Access交流网
  • 设为首页|收藏本站|繁体中文|手机版
  •     
  • Access培训-Access开发平台-Access行业开发

  • 首页
  • 资讯
  • 技巧
  • 源码
  • 行业
  • 资源
  • 活动
  • 关于

技巧

ACCESS数据库

启动/设置/选项/背景

修复/压缩

安全/加密/解密

快捷键

版本升级/其它等

数据表

命名方式/设计规范

表设计

查询

Sql语言基础

选择查询

更新查询

删除查询

追加查询

生成表查询

交叉表查询

SQL特定查询

查询参数

查询综合应用

界面/窗体/控件

标签

文本框

命令按钮

组合框/列表框

选项组/复选框/选项按钮

选项卡

子窗体

窗体本身/综合应用

其它

报表打印

报表设计

高级报表

模块/函数/VBA/API/系统

VBA基础

内置函数

调试/跟踪/Debug

模块/类模块

API/COM/系统相关

字符数字日期

网络通信游戏

加密解密安全

文件处理

经典算法

宏/菜单/工具栏/功能区

宏/脚本

菜单/工具栏

功能区/Ribbon

图表/图形/图像/多媒体

图表

图形/图像

音频

视频/动画

DAO/链接表/ADO/ADP

DAO/链接表/ODBC

ADO/RDO

ADP

ActiveX/第三方控件/插件

Treeview树控件

ListView列表控件

Toolbar工具栏控件

微软其它控件

Dbi-Tech

CodeJock

Grid++Report

FastReport

ComponentOne

加载项/插件/Addin

OFFICE集成/导入导出/交互

Excel导入导出/交互

Word导入导出/交互

PPT交互

Outlook控制/邮件

Text文本文件/INI/CSV

PDF/SWF/XML格式

CAD格式

Sharepoint/其它Office

SqlServer/其它数据库

表

视图

存储过程/触发器

函数

用户/权限/安全

调试/维护

SqlServer其它/综合

发布/打包/文档/帮助

开发版/运行时

打包/发布/部署

开发文档/帮助制作

Access完整行业系统

采购管理系统

销售管理系统

仓库管理系统

人力资源管理HRM

CRM管理系统

MRP/ERP管理系统

BRP/流程优化

其它管理系统

心得/经验/绝招
其它/杂项
Excel技巧

Excel应用与操作

Excel开发编程

Word技巧

Word应用与操作

Word开发编程

Outlook技巧

Outlook应用与操作

Outlook开发编程

热门文章

  • 修改工作组用户密码
  • 提供一种数据备份的方法
  • base64编码、解码函数
  • Access限制软件30天..
  • Access VBA可用的..
  • 找回忘了的密码的原理

最新文章

  • 获取字符的Unicode编..
  • Access对数据表进行加..
  • Access 下Base6..
  • Access VBA可用的..
  • 获取电脑的网卡物理地址
  • 在 Access 2010..

联系方式

Access交流网(免费Access交流)

QQ:18449932 

网  址:www.access-cn.com

当前位置:首页 > 技巧 > 模块/函数/VBA/API/系统 > 加密解密安全
加密解密安全

Access VBA可用的Base64编码/解码模块

Base64编码/解码模块

使用方法,将以下模块代码 复制到Access中的模块中。然后在窗体或其它地方调用即可


Option Explicit

'名称:          Base64编码/解码模块

'Name:          Base64 Encode & Decode Module


'作者:          KiteGirl [中国]

'programmer:    KiteGirl [China]


Private priBitMoveTable() As Byte                          '移位缓冲表

Private priBitMoveTable_CellReady() As Boolean             '移位缓冲表标志表

Private priBitMoveTable_Create As Boolean                  '移位缓冲表创建标志


Private priEncodeTable() As Byte                           '编码表(素码转Base64)

Private priEncodeTable_Create As Boolean


Private priDecodeTable() As Byte                           '解码表(Base64转素码)

Private priDecodeTable_Create As Boolean


Private Declare Sub Base64_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDestination As Any, ByRef pSource As Any, ByVal pLength As Long)


Private Const conBase64_CodeTableStrng As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Private Const conBase64_PatchCode As Byte = 61


Private Type tpBase64_Dollop2438                '24Bit(8Bit*3Byte)数据块

    btBytes(0 To 2) As Byte

End Type


Private Type tpBase64_Dollop2446                '24Bit(6Bit*4Byte)数据块

    btBytes(0 To 3) As Byte

End Type



'解码

Public Sub Base64_Decode(ByRef tOutBytes() As Byte, ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode)

'Base64Decode函数

'语法:[tOutBytes()] = Base64Decode(pBytes(), [pPatchCode])

'功能:将Byte数组表示的Base64编码Ascii字节数组解码为Byte字节数组,并返回。

'参数:byte pBytes()                  '必要参数。Byte数组表示的Base64编码数据。

'      byte pPatchCode                '可选参数。冗余字节追加码。默认为61("="的Ascii码)

'返回:byte tOutBytes()               'Byte数组。

'示例:

'      Dim tSurString As String

'      Dim tSurBytes() As Byte

'      tSurString = "S2l0ZUdpcmzKx7j2usO6otfT"

'      tSurBytes() = StrConv(tSurString, vbFromUnicode)

'      Dim tDesString As String

'      Dim tDesBytes() As Byte

'      tDesBytes() = Base64Decode(tSurBytes())

'      tDesString = StrConv(tDesBytes(), vbUnicode) 'tDesString返回"KiteGirl是个好孩子"


    Dim tOutBytes_Length As Long


    Dim tBytes_Length As Long


    Dim tBytes2446() As Byte


    Dim tSurBytes_Length As Long

    Dim tDesBytes_Length As Long


    Err.Clear

    On Error Resume Next


    tBytes_Length = UBound(pBytes())



    If CBool(Err.Number) Then Exit Sub


    tBytes2446() = BytesPrimeDecode(pBytes())

    tOutBytes() = Bytes2438GetBy2446(tBytes2446())


    Dim tPatchNumber As Long


    Dim tIndex As Long

    Dim tBytesIndex As Long


    For tIndex = 0 To 1

        tBytesIndex = tBytes_Length - tIndex

        tPatchNumber = tPatchNumber + ((pBytes(tIndex) = pPatchCode) And 1)

    Next


    tSurBytes_Length = tBytes_Length - tPatchNumber

    tDesBytes_Length = (tSurBytes_Length * 3) / 4


    ReDim Preserve tOutBytes(tDesBytes_Length)


End Sub


'编码

Public Sub Base64_Encode(ByRef tOutBytes() As Byte, ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode)

'Base64Encode函数

'语法:[tOutBytes()] = Base64Encode(pBytes(), [pPatchCode])

'功能:将Byte数组编码为Base64编码的Ascii字节数组,并返回。

'参数:byte pBytes()                  '必要参数。Byte数组表示的数据。

'      byte pPatchCode                '可选参数。冗余字节追加码。默认为61("="的Ascii码)

'返回:byte tOutBytes()               'Base64编码表示的Ascii代码数组。

'注意:如果你想在VB里以字符串表示该函数的返回值,需要用StrConv转换为Unicode。

'示例:

'      Dim tSurString As String

'      Dim tSurBytes() As Byte

'      tSurString = "KiteGirl是个好孩子"

'      tSurBytes() = StrConv(tSurString, vbFromUnicode)

'      Dim tDesString As String

'      Dim tDesBytes() As Byte

'      tDesBytes() = Base64Encode(tSurBytes())

'      tDesString = StrConv(tDesBytes(), vbUnicode) 'tDesString返回"S2l0ZUdpcmzKx7j2usO6otfT"


    Dim tOutBytes_Length As Long


    Dim tBytes2446() As Byte


    Dim tSurBytes_Length As Long

    Dim tDesBytes_Length As Long


    Err.Clear

    On Error Resume Next


    tSurBytes_Length = UBound(pBytes())


    If CBool(Err.Number) Then Exit Sub


    tBytes2446() = Bytes2438PutTo2446(pBytes())

    tOutBytes() = BytesPrimeEncode(tBytes2446())


    tOutBytes_Length = UBound(tOutBytes())


    Dim tPatchNumber As Long


    tDesBytes_Length = (tSurBytes_Length * 4 + 3) / 3

    tPatchNumber = tOutBytes_Length - tDesBytes_Length


    Dim tIndex As Long

    Dim tBytesIndex As Long


    For tIndex = 1 To tPatchNumber

        tBytesIndex = tOutBytes_Length - tIndex + 1

        tOutBytes(tBytesIndex) = pPatchCode

    Next

End Sub


Private Function BytesPrimeDecode(ByRef pBytes() As Byte) As Byte()

'功能:将Base64数组解码为素码数组


    Dim tOutBytes() As Byte


    Dim tBytes_Length As Long


    Err.Clear

    On Error Resume Next


    tBytes_Length = UBound(pBytes())


    If CBool(Err.Number) Then Exit Function


    ReDim tOutBytes(tBytes_Length)


    If Not priDecodeTable_Create Then Base64CodeTableCreate


    Dim tIndex As Long


    For tIndex = 0 To tBytes_Length

        tOutBytes(tIndex) = priDecodeTable(pBytes(tIndex))

    Next


    BytesPrimeDecode = tOutBytes()

End Function


Private Function BytesPrimeEncode(ByRef pBytes() As Byte) As Byte()

'功能:将素码数组编码为Base64数组


    Dim tOutBytes() As Byte


    Dim tBytes_Length As Long


    Err.Clear

    On Error Resume Next


    tBytes_Length = UBound(pBytes())


    If CBool(Err.Number) Then Exit Function


    ReDim tOutBytes(tBytes_Length)


    If Not priEncodeTable_Create Then Base64CodeTableCreate


    Dim tIndex As Long


    For tIndex = 0 To tBytes_Length

        tOutBytes(tIndex) = priEncodeTable(pBytes(tIndex))

    Next


    BytesPrimeEncode = tOutBytes()

End Function


Private Sub Base64CodeTableCreate(Optional ByVal pString As String = conBase64_CodeTableStrng)

'功能:根据字符串提供的代码初始化Base64解码/编码码表。


    Dim tBytes() As Byte

    Dim tBytes_Length As Long


    tBytes() = pString

    tBytes_Length = UBound(tBytes())


    If Not tBytes_Length = 127 Then

'        MsgBox "编码/解码表初始化失败", , "错误"

        Exit Sub

    End If


    Dim tIndex As Byte


    ReDim priEncodeTable(0 To 255)

    ReDim priDecodeTable(0 To 255)


    Dim tTableIndex As Byte

    Dim tByteValue As Byte


    For tIndex = 0 To tBytes_Length Step 2

        tTableIndex = tIndex / 2

        tByteValue = tBytes(tIndex)

        priEncodeTable(tTableIndex) = tByteValue

        priDecodeTable(tByteValue) = tTableIndex

    Next


    priEncodeTable_Create = True

    priDecodeTable_Create = True

End Sub


Private Function Bytes2438GetBy2446(ByRef pBytes() As Byte) As Byte()

'功能:将素码转换为字节。

    Dim tOutBytes() As Byte


    Dim tDollops2438() As tpBase64_Dollop2438

    Dim tDollops2446() As tpBase64_Dollop2446


    tDollops2446() = BytesPutTo2446(pBytes())

    tDollops2438() = Dollops2438GetBy2446(tDollops2446())

    tOutBytes() = BytesGetBy2438(tDollops2438())


    Bytes2438GetBy2446 = tOutBytes()

End Function


Private Function Bytes2438PutTo2446(ByRef pBytes() As Byte) As Byte()

'功能:将字节转换为素码。

    Dim tOutBytes() As Byte


    Dim tDollops2438() As tpBase64_Dollop2438

    Dim tDollops2446() As tpBase64_Dollop2446


    tDollops2438() = BytesPutTo2438(pBytes())

    tDollops2446() = Dollops2438PutTo2446(tDollops2438())

    tOutBytes() = BytesGetBy2446(tDollops2446())


    Bytes2438PutTo2446 = tOutBytes()

End Function


Private Function BytesGetBy2446(ByRef p2446() As tpBase64_Dollop2446) As Byte()

'功能:2446数组转换为字节数组


    Dim tOutBytes() As Byte

    Dim tOutBytes_Length As Long


    Dim t2446Length As Long


    Err.Clear

    On Error Resume Next


    t2446Length = UBound(p2446())


    If CBool(Err.Number) Then Exit Function


    tOutBytes_Length = t2446Length * 4 + 3


    ReDim tOutBytes(0 To tOutBytes_Length)


    Dim tCopyLength As Long


    tCopyLength = tOutBytes_Length + 1


    Base64_CopyMemory tOutBytes(0), p2446(0), tCopyLength


    BytesGetBy2446 = tOutBytes()

End Function


Private Function BytesPutTo2446(ByRef pBytes() As Byte) As tpBase64_Dollop2446()

'功能:字节数组转换为2446数组

    Dim tOut2446() As tpBase64_Dollop2446

    Dim tOut2446_Length As Long


    Dim tBytesLength As Long


    Err.Clear

    On Error Resume Next


    tBytesLength = UBound(pBytes())


    If CBool(Err.Number) Then Exit Function


    tOut2446_Length = tBytesLength / 4


    ReDim tOut2446(0 To tOut2446_Length)


    Dim tCopyLength As Long


    tCopyLength = tBytesLength + 1


    Base64_CopyMemory tOut2446(0), pBytes(0), tCopyLength


    BytesPutTo2446 = tOut2446()

End Function


Private Function BytesGetBy2438(ByRef p2438() As tpBase64_Dollop2438) As Byte()

'功能:2438数组转换为字节数组

    Dim tOutBytes() As Byte

    Dim tOutBytes_Length As Long


    Dim t2438Length As Long


    Err.Clear

    On Error Resume Next


    t2438Length = UBound(p2438())


    If CBool(Err.Number) Then Exit Function


    tOutBytes_Length = t2438Length * 3 + 2


    ReDim tOutBytes(0 To tOutBytes_Length)


    Dim tCopyLength As Long


    tCopyLength = tOutBytes_Length + 1


    Base64_CopyMemory tOutBytes(0), p2438(0), tCopyLength


    BytesGetBy2438 = tOutBytes()

End Function


Private Function BytesPutTo2438(ByRef pBytes() As Byte) As tpBase64_Dollop2438()

'功能:字节数组转换为2438数组

    Dim tOut2438() As tpBase64_Dollop2438

    Dim tOut2438_Length As Long


    Dim tBytesLength As Long


    Err.Clear

    On Error Resume Next


    tBytesLength = UBound(pBytes())


    If CBool(Err.Number) Then Exit Function


    tOut2438_Length = tBytesLength / 3


    ReDim tOut2438(0 To tOut2438_Length)


    Dim tCopyLength As Long


    tCopyLength = tBytesLength + 1


    Base64_CopyMemory tOut2438(0), pBytes(0), tCopyLength


    BytesPutTo2438 = tOut2438()

End Function


Private Function Dollops2438GetBy2446(ByRef p2446() As tpBase64_Dollop2446) As tpBase64_Dollop2438()

'功能:2446块数组转换为2438块数组

    Dim tOut2438() As tpBase64_Dollop2438

    Dim tOut2438_Length As Long


    Dim t2446_Length As Long


    Err.Clear

    On Error Resume Next


    If CBool(Err.Number) Then Exit Function


    t2446_Length = UBound(p2446())

    tOut2438_Length = t2446_Length


    ReDim tOut2438(tOut2438_Length)


    Dim tIndex As Long


    For tIndex = 0 To t2446_Length

        tOut2438(tIndex) = Dollop2438GetBy2446(p2446(tIndex))

    Next


    Dollops2438GetBy2446 = tOut2438()

End Function


Private Function Dollops2438PutTo2446(ByRef p2438() As tpBase64_Dollop2438) As tpBase64_Dollop2446()

'功能:2438块数组转换为2446块数组


    Dim tOut2446() As tpBase64_Dollop2446

    Dim tOut2446_Length As Long


    Dim t2438_Length As Long


    Err.Clear

    On Error Resume Next


    If CBool(Err.Number) Then Exit Function


    t2438_Length = UBound(p2438())

    tOut2446_Length = t2438_Length


    ReDim tOut2446(tOut2446_Length)


    Dim tIndex As Long


    For tIndex = 0 To t2438_Length

        tOut2446(tIndex) = Dollop2438PutTo2446(p2438(tIndex))

    Next


    Dollops2438PutTo2446 = tOut2446()

End Function


Private Function Dollop2438GetBy2446(ByRef p2446 As tpBase64_Dollop2446) As tpBase64_Dollop2438

'功能:2446块转换为2438块

    Dim tOut2438 As tpBase64_Dollop2438


    With tOut2438

        .btBytes(0) = ByteBitMove(p2446.btBytes(0), 2) + ByteBitMove(p2446.btBytes(1), -4)

        .btBytes(1) = ByteBitMove(p2446.btBytes(1), 4) + ByteBitMove(p2446.btBytes(2), -2)

        .btBytes(2) = ByteBitMove(p2446.btBytes(2), 6) + ByteBitMove(p2446.btBytes(3), 0)

    End With


    Dollop2438GetBy2446 = tOut2438

End Function


Private Function Dollop2438PutTo2446(ByRef p2438 As tpBase64_Dollop2438) As tpBase64_Dollop2446

'功能:2438块转换为2446块

    Dim tOut2446 As tpBase64_Dollop2446


    With tOut2446

        .btBytes(0) = ByteBitMove(p2438.btBytes(0), -2, 63)

        .btBytes(1) = ByteBitMove(p2438.btBytes(0), 4, 63) + ByteBitMove(p2438.btBytes(1), -4, 63)

        .btBytes(2) = ByteBitMove(p2438.btBytes(1), 2, 63) + ByteBitMove(p2438.btBytes(2), -6, 63)

        .btBytes(3) = ByteBitMove(p2438.btBytes(2), 0, 63)

    End With


    Dollop2438PutTo2446 = tOut2446

End Function


Private Function ByteBitMove(ByVal pByte As Byte, ByVal pMove As Integer, Optional ByVal pConCode As Byte = &HFF) As Byte

'功能:对Byte进行移位(带饱和缓冲功能)。

    Dim tOutByte As Byte


    If Not priBitMoveTable_Create Then


        ReDim priBitMoveTable(0 To 255, -8 To 8)

        ReDim priBitMoveTable_CellReady(0 To 255, -8 To 8)


        priBitMoveTable_Create = True


    End If


    If Not priBitMoveTable_CellReady(pByte, pMove) Then


        priBitMoveTable(pByte, pMove) = ByteBitMove_Operation(pByte, pMove)

        priBitMoveTable_CellReady(pByte, pMove) = True


    End If


    tOutByte = priBitMoveTable(pByte, pMove) And pConCode


    ByteBitMove = tOutByte

End Function


Private Function ByteBitMove_Operation(ByVal pByte As Byte, ByVal pMove As Integer) As Byte

'功能:对Byte进行算术移位。

    Dim tOutByte As Byte


    Dim tMoveLeft As Boolean

    Dim tMoveRight As Boolean

    Dim tMoveCount As Integer


    tMoveLeft = pMove > 0

    tMoveRight = pMove < 0


    tMoveCount = Abs(pMove)


    If tMoveLeft Then

        tOutByte = (pByte Mod (2 ^ (8 - tMoveCount))) * (2 ^ tMoveCount)

    ElseIf tMoveRight Then

        tOutByte = pByte / 2 ^ tMoveCount

    Else

        tOutByte = pByte

    End If


    ByteBitMove_Operation = tOutByte

End Function



其它加解密

Public   keyCode   As   String         '密钥   

  Private   keySingle   As   String   '单引号   

  Private   keyDouble   As   String   '双引号   

  '对外公开的加密函数,过滤掉单引号和双引号   

  Public   Function   Encrypt(ByVal   strValue   As   String)   As   String   

          Dim   strKeyCode   As   String   

    

          strKeyCode   =   Trim(keyCode)   

          If   Len(strKeyCode)   >   10   Then   

                  Encrypt   =   "密钥最长10位"   

                  Exit   Function   

          End   If   

          '处理密钥,特意不对称   

          '[FS+KC]   [/FS-KC]   

          '此处假定文本中永远不会同时出现[FS+KC]与[/FS-KC]   

          If   Len(strKeyCode)   Then   

                  strKeyCode   =   "[FS+KC]"   &   strKeyCode   &   "[/FS-KC]"   

          Else   

                  strKeyCode   =   ""   

          End   If   

          '释放掉   

          keyCode   =   ""   

          Encrypt   =   myEncrypt(strValue   &   strKeyCode)   

  End   Function   

    

  '对外公开的解密函数   

  Public   Function   UnEncrypt(ByVal   strValue   As   String)   As   String   

          Dim   strKeyCode   As   String   

          Dim   strInKeyCode   As   String   

          Dim   strReturn   As   String   

          Dim   blnUsedKeyCode   As   Boolean   

          Dim   lKeyStart   As   Long   

          Dim   lKeyEnd   As   String   

            

          strKeyCode   =   Trim(keyCode)   

          If   Len(strKeyCode)   >   10   Then   

                  UnEncrypt   =   "-3"   

                  Exit   Function   

          End   If   

            

          '首先进行解密   

          strReturn   =   myUnEncrypt(strValue)   

            

          '判断是否使用了密钥   

          '取最后一个位置的标记   

          If   InStrRev(strReturn,   "[FS+KC]")   >   0   And   Right(strReturn,   8)   =   "[/FS-KC]"   Then   

                  blnUsedKeyCode   =   True   

          End   If   

  ''         '处理异常空格,其实不是真正的空格,而是255的不可见字符   

          Dim   i   As   Long   

          Dim   strReturn2   As   String   

          Dim   strChar   As   String   

          For   i   =   1   To   Len(strReturn)   

                  strChar   =   Mid(strReturn,   i,   1)   

                  If   Asc(strChar)   <>   255   Then   

                          strReturn2   =   strReturn2   &   strChar   

                  End   If   

          Next   

          strReturn   =   strReturn2   

          '如果使用了密钥   

          If   blnUsedKeyCode   Then   

                  '如果未输入密钥   

                  If   strKeyCode   =   ""   Then   

                          UnEncrypt   =   "-2"   

                  '判断密钥   

                  Else   

                          '取出密钥文本   

                          lKeyStart   =   InStrRev(strReturn,   "[FS+KC]")   +   Len("[FS+KC]")   

                          lKeyEnd   =   InStrRev(strReturn,   "[/FS-KC]")   

                          strInKeyCode   =   Mid(strReturn,   lKeyStart,   lKeyEnd   -   lKeyStart)   

                          If   strKeyCode   <>   strInKeyCode   Then   

                                  '密钥错误   

                                  UnEncrypt   =   "-1"   

                                  Exit   Function   

                          Else   

                                  '返回准确文本   

                                  strReturn   =   Left(strReturn,   Len(strReturn)   -   Len("[FS+KC]"   &   strKeyCode   &   "[/FS-KC]"))   

                                  UnEncrypt   =   strReturn   

                                  Exit   Function   

                          End   If   

                  End   If   

          Else   

                  UnEncrypt   =   strReturn   

          End   If   

  End   Function   

    

    

  '加密函数   

  Private   Function   myEncrypt(ByVal   strValue   As   String)   As   String   

          Randomize   

          Dim   ll   As   Long   

          Dim   AscNumber   As   Long   

          Dim   i   As   Long   

          Dim   HH   As   String   

          Dim   ss   As   String   

          Dim   mm   As   String   

          Dim   J   As   Long   

          Dim   Temp   As   String   

          Dim   Temp2   As   String   

          Dim   Temp1   As   String   

          Dim   temp3   As   String   

          Dim   temp4   As   String   

            

    

            

          ll   =   Len(strValue)     '加密字符长度   

          If   ll   =   0   Then   

                  myEncrypt   =   ""   

          Else   

          '**************************************   

                  i   =   1   

                  For   i   =   1   To   ll   

                          AscNumber   =   Asc(Mid(strValue,   i,   1))       '取ASC码   

                          HH   =   Hex(AscNumber)   '换成16进制码   

                          If   Len(HH)   <   2   Then   '不够二位的补0   

                                  HH   =   "0"   &   HH   

                          End   If   

                          '拆开(可能任意多位)   

                          For   J   =   1   To   Len(HH)   

                                  ss   =   Mid(HH,   J,   1)   

                                  Select   Case   ss   

                                  Case   "0"   

                                          mm   =   "0000"   

                                  Case   "1"   

                                          mm   =   "0001"   

                                  Case   "2"   

                                          mm   =   "0010"   

                                  Case   "3"   

                                          mm   =   "0011"   

                                  Case   "4"   

                                          mm   =   "0100"   

                                  Case   "5"   

                                          mm   =   "0101"   

                                  Case   "6"   

                                          mm   =   "0110"   

                                  Case   "7"   

                                          mm   =   "0111"   

                                  Case   "8"   

                                          mm   =   "1000"   

                                  Case   "9"   

                                          mm   =   "1001"   

                                  Case   "A"   

                                          mm   =   "1010"   

                                  Case   "B"   

                                          mm   =   "1011"   

                                  Case   "C"   

                                          mm   =   "1100"   

                                  Case   "D"   

                                          mm   =   "1101"   

                                  Case   "E"   

                                          mm   =   "1110"   

                                  Case   "F"   

                                          mm   =   "1111"   

                                  End   Select   

                                  Temp   =   Temp   &   mm   

                          Next   J   

                  Next   i   

                  '**************************************   

                  '     Debug.Print   "G",   temp   

                  Temp2   =   ""   

                  temp3   =   ""   

                  i   =   1   

                  'Len(Temp)必定为偶数   

                  For   i   =   1   To   Len(Temp)   

                          '拆偶数位   

                          If   i   /   2   =   Int(i   /   2)   Then   

                                  Temp2   =   Temp2   &   Mid(Temp,   i,   1)   

                          '拆奇数位   

                          Else   

                                  temp3   =   temp3   &   Mid(Temp,   i,   1)   

                          End   If   

                  Next   

                  Temp   =   Temp2   &   temp3   

                  '**************************************   

                  '把最右面7位移到前面   

                  Temp1   =   Right(Temp,   7)   

                  Temp   =   Temp1   &   Left(Temp,   Len(Temp)   -   7)   

                  '左右各半互换   

                  Temp1   =   Left(Temp,   Len(Temp)   /   2)   

                  Temp   =   Right(Temp,   Len(Temp)   /   2)   &   Temp1   

                  '取从中间位置开始往后取2位   

                  Temp1   =   Mid(Temp,   Len(Temp)   /   2,   2)   

                  '组合在字串的前后,因为仍然保持了4的偶数倍,所以仍然能错位返回成字符   

                  Temp   =   Temp1   &   Temp   &   Temp1   

                  '**************************************   

                  Temp1   =   ""   

                  ss   =   ""   

                  mm   =   ""   

                  J   =   1   

                  '将二进制还原成字母   

                  For   J   =   1   To   Len(Temp)   Step   4   

                          ss   =   Mid(Temp,   J,   4)   

                          Select   Case   ss   

                          Case   "0000"   

                                  mm   =   "F"   

                          Case   "0001"   

                                  mm   =   "b"   

                          Case   "0010"   

                                  mm   =   "2"   

                          Case   "0011"   

                                  mm   =   "P"   

                          Case   "0100"   

                                  mm   =   "V"   

                          Case   "0101"   

                                  mm   =   "j"   

                          Case   "0110"   

                                  mm   =   "W"   

                          Case   "0111"   

                                  mm   =   "N"   

                          Case   "1000"   

                                  mm   =   "q"   

                          Case   "1001"   

                                  mm   =   "m"   

                          Case   "1010"   

                                  mm   =   "7"   

                          Case   "1011"   

                                  mm   =   "i"   

                          Case   "1100"   

                                  mm   =   "d"   

                          Case   "1101"   

                                  mm   =   "c"   

                          Case   "1110"   

                                  mm   =   "L"   

                          Case   "1111"   

                                  mm   =   "z"   

                          End   Select   

                          Temp1   =   Temp1   &   mm   

                  Next   J   

                  Temp   =   Temp1   

                  '**************************************   

                  i   =   1   

                  Temp1   =   ""   

                  For   i   =   1   To   Len(Temp)   

                          Temp1   =   Temp1   &   Chr(Asc(Mid(Temp,   i,   1))   Xor   17)   

                  Next   i   

                  Temp   =   Temp1   

                  '**************************************   

                  i   =   1   

                  Temp1   =   ""   

                  For   i   =   1   To   Len(Temp)   

                          Temp2   =   Chr(Int(Rnd   *   25))   

                          temp3   =   Chr(Asc(Mid(Temp,   i,   1))   Xor   Asc(Temp2))   

                          Temp1   =   Temp1   &   temp3   &   Chr(Asc(Temp2)   +   65)   

                  Next   i   

                  '**************************************   

                  Temp   =   Temp1   

                  '处理单引号和双引号   

                  Temp   =   Replace(Temp,   Chr(39),   "Tr]3[9")   

                  Temp   =   Replace(Temp,   Chr(34),   "HPr{3")   

                  myEncrypt   =   Temp   

                    

          End   If   

            

  End   Function


发布人:zstmtony  
分享到:
点击次数:  更新时间:2017-06-21 14:27:56  【打印此页】  【关闭】
上一条:Access引用窗体值Form_ 与 Forms! 的区别  下一条:Access类模块与模块的异同



相关文章

  • • 获取字符的Unicode编码、Ascii码、及各种编码转换加密解密
  • • Access对数据表进行加密解密
  • • Access 下Base64位加密解密类模块(支持中文加解密和特殊符号)
  • • 获取电脑的网卡物理地址
  • • 在 Access 2010 中设置或更改 Access 2003 用户级安全机制
  • • ACCESS安全机制中的工作组管理员文件如果防止被替换
  • • ACCESS丢失MDW,还能还原用户与用户组及权限相关信息吗

热门文章

  • [2003-12-12] 禁止使用SHIFT键打开MDB/MDE文件access数据库
  • [2013-12-06] ACCESS安全机制中的工作组管理员文件如果防止被替换access数据库
  • [2003-12-10] Access 2003 进行数字签名的全过程access数据库
  • [2004-08-18] Access限制数据库的试用天数access数据库
  • [2003-12-12] 如何不通过设置工程密码锁定VBA代码?access数据库
  • [2008-11-07] 如何能通过窗体访问表,但不能直接读取表?access数据库

热门产品

公司动态|在线留言|在线反馈|友情链接|会员中心|站内搜索|网站地图

Access交流网 版权所有 1999-2018 粤ICP备10043721号

QQ:18449932

Access应用 Access培训 Access开发 Access平台

access|数据库|access下载|access教程|access视频|access软件

Powered by MetInfo 5.3.12 ©2008-2023  www.metinfo.cn