VB6怎么给文件加密？

用加密算法
简单的是异或算法,解密同理
Private Function Encrypt(ByVal strSource As String, ByVal Key1 As Byte, _
ByVal Key2 As Integer) As String
Dim bLowData As Byte
Dim bHigData As Byte
Dim i As Integer
Dim strEncrypt As String
Dim strChar As String
For i = 1 To Len(strSource) 　‘从待加（解）密字符串中取出一个字符　strChar = Mid(strSource, i, 1) 　‘取字符的低字节和Key1进行异或运算　bLowData = AscB(MidB(strChar, 1, 1)) Xor Key1 　‘取字符的高字节和K2进行异或运算　bHigData = AscB(MidB(strChar, 2, 1)) Xor Key2 　‘将运算后的数据合成新的字符　strEncrypt = strEncrypt & ChrB(bLowData) & ChrB(bHigData) Next
Encrypt = strEncrypt
End Function

不是已经有现成的了吗？
再给你一个吧。调用一下就行了，一个是加密函数，一个是解密函数
'******************************************************
' 功  能：Base64 编码
' 返回值：编码后的字符串，失败返回空串
' 参  数：bytSrcArr() 存储待编码的数据的字节数组(并不改变其值)
'         bytBufArr() 必须传入可变字节数组，以返回编码
'******************************************************
Public Function EnBase64(ByRef bytSrcArr() As Byte, ByRef bytBufArr() As Byte) As Boolean
On Error GoTo ER
Static bytTabArr(64) As Byte, lpbytTab As Long  ' 分配 ANSI 码表存储空间
Dim lpbytBuf As Long, lpbytBufHead As Long      ' 编码缓冲区的首地址
Dim i As Long, lngMod As Long
    ' 初始化 ANSI 码表，取得首地址
    If lpbytTab = 0 Then lpbytTab = str2byt(VarPtr(bytTabArr(0)), BASE64_TABLE)
    ' 计算以 3 字节分组后的剩余字节数
    lngMod = (UBound(bytSrcArr) - LBound(bytSrcArr) + 1) Mod 3
    ' 分配和初始化缓冲区
    i = ((UBound(bytSrcArr) - LBound(bytSrcArr) + 1) \ 3) * 4 + IIf(lngMod = 0, 0, 4)
    ReDim bytBufArr(i + (i \ 76) * 2 - 1) ' 格式化编码输出时，每76字符一行，故加上 CrLf 的占位
    FillMemory VarPtr(bytBufArr(UBound(bytBufArr) - 1)), 2, Asc("=") ' 编码字符串的结尾最多会出现两个“=”
    ' 取得缓冲区首地址
    lpbytBuf = VarPtr(bytBufArr(0)): lpbytBufHead = lpbytBuf
    ' 进行编码，即用码表中对应的字节填充缓冲区，每加入一组（4字节）后判断一次分割
    For i = LBound(bytSrcArr) To UBound(bytSrcArr) - lngMod Step 3
        CopyMemory lpbytBuf, lpbytTab + bytSrcArr(i) \ 4, 1
        CopyMemory lpbytBuf + 1, lpbytTab + (bytSrcArr(i) Mod 4) * 16 + bytSrcArr(i + 1) \ 16, 1
        CopyMemory lpbytBuf + 2, lpbytTab + (bytSrcArr(i + 1) Mod 16) * 4 + bytSrcArr(i + 2) \ 64, 1
        CopyMemory lpbytBuf + 3, lpbytTab + bytSrcArr(i + 2) Mod 64, 1
        lpbytBuf = lpbytBuf + 4
        ' 每76字符一行，考虑到已加入的 CrLf，判断条件为当前位置加上 CrLf 后的偏移值是否为78的整数倍
        If (lpbytBuf + 2 - lpbytBufHead) Mod 78 = 0 Then
            FillMemory lpbytBuf, 1, 13: FillMemory lpbytBuf + 1, 1, 10
            lpbytBuf = lpbytBuf + 2
        End If
    Next i
    ' 处理以 3 字节分割后的剩余字节（1-2个），因为至少有4字节空余，这里应该不需要换行
    If lngMod <> 0 Then
        CopyMemory lpbytBuf, lpbytTab + bytSrcArr(i) \ 4, 1
        If lngMod < 2 Then ' 1字节
            CopyMemory lpbytBuf + 1, lpbytTab + (bytSrcArr(i) Mod 4) * 16, 1
        Else ' 2字节
            CopyMemory lpbytBuf + 1, _
                       lpbytTab + (bytSrcArr(i) Mod 4) * 16 + _
                       bytSrcArr(i + 1) \ 16, 1
            CopyMemory lpbytBuf + 2, lpbytTab + (bytSrcArr(i + 1) Mod 16) * 4, 1
        End If
    End If
    EnBase64 = True
ER:
    If Err.Number <> 0 Then Err.Raise Err.Number, , Err.Description & vbCrLf & "编码失败。"
End Function'******************************************************
' 功  能：Base64 解码
' 返回值：成功返回 True，失败返回 False
' 参  数：strSrc 必须为 Base64 编码的字节数组，且不能以回车结尾，
'                否则可能得到错误 600，或“下标越界”的错误
'         bytBuf() 必须传入可变字节数组，以返回解码数据
'******************************************************
Public Function DeBase64(ByRef strSrc() As Byte, ByRef bytBuf() As Byte) As Boolean
On Error GoTo ER
Dim lngTmp As Long       ' 用来重组数据的 4 字节缓存
Dim i As Long, j As Long ' 目标和源数组的下标控制
    ' 分配足够的存储空间，来保存解码后的数据
    ReDim bytBuf(UBound(strSrc))
    ' 查表解码
    For i = 0 To UBound(strSrc) Step 4
        lngTmp = MatchTable(strSrc, i) * &H40000     ' 按照编码时的分组分割结构重新组合
        lngTmp = lngTmp + MatchTable(strSrc, i + 1) * &H1000&
        lngTmp = lngTmp + MatchTable(strSrc, i + 2) * &H40&
        lngTmp = lngTmp + MatchTable(strSrc, i + 3)
        CopyMemory VarPtr(bytBuf(j)), VarPtr(lngTmp), 3 ' 提取 Long 中组合而成的字节
        bytBuf(j) = bytBuf(j) Xor bytBuf(j + 2)         ' 颠倒顺序，以符合编码前的字节高低存储顺序
        bytBuf(j + 2) = bytBuf(j) Xor bytBuf(j + 2)
        bytBuf(j) = bytBuf(j) Xor bytBuf(j + 2)
        j = j + 3 ' 切换到下一个待值的缓存偏移值
    Next i
    ' 清除结尾的多余数据（根据编码字符串结尾的“=”数目0、1或2判断）
    ReDim Preserve bytBuf(j - 1 - IIf(strSrc(UBound(strSrc)) = Asc("="), _
                                      IIf(strSrc(UBound(strSrc) - 1) = Asc("="), 2, 1), 0))
    DeBase64 = True
ER:
    If Err.Number <> 0 Then Err.Raise Err.Number, , Err.Description & vbCrLf & "可能这不是 Base64 编码。"
End Function
'******************************************************
' 功  能：根据编码字符的 ASCII 码查询对应的码表索引
' 返回值：编码对应的码表索引（0-Based）
' 参  数：bytCode 编码存储区
'         lngOffSet 编码在存储区中的当前偏移值，即处理进度
'******************************************************
Private Function MatchTable(ByRef bytCode() As Byte, ByRef lngOffSet As Long) As Long
RETRY:
    Select Case bytCode(lngOffSet)
    Case &H41 To &H5B ' "A"-"Z"
        MatchTable = bytCode(lngOffSet) - &H41&
    Case &H61 To &H7B ' "a"-"z"
        MatchTable = bytCode(lngOffSet) - &H47&
    Case &H30 To &H39 ' "0"-"9"
        MatchTable = bytCode(lngOffSet) + 4&
    Case &H2B         ' "+"
        MatchTable = 62&
    Case &H2F         ' "/"
        MatchTable = 63&
    Case &H3D         ' "="
        ' 如果“=”不是出现在结尾，本程序也未做错误处理
        ' 此时得到的结果可能是错误的（未解决）
    Case &HD          ' CrLf，跳过回车重试下一编码
        lngOffSet = lngOffSet + 2
        ' 重试时可能会在编码末端产生下标越界的错误
        GoTo RETRY
    Case Else         ' 非法字符
        MatchTable = -1&
        Err.Raise 600, , "非 Base64 编码"
    End Select
End Function'******************************************************
' 功  能：编码、解码测试
' 参  数：strInput 待编码的文件名
'         strOutput 编码输出文件名
'******************************************************
Public Sub EncodeTest(ByVal strInput As String, ByVal strOutput As String)
On Error GoTo ER
Err.Clear
Dim bytBufArr() As Byte, bytSrcArr() As Byte, lngFileNo As Long, strTmp As String
Dim sngEncodeTime As Single ' 编码耗费的时间    If Len(Dir(strInput)) = 0 Then MsgBox "找不到指定的原始文件！": Exit Sub
    If FileLen(strInput) = 0 Then
        Open strOutput For Output As FreeFile
        Close
        Exit Sub
    End If
    lngFileNo = FreeFile
    Open strInput For Binary As lngFileNo
        ReDim bytSrcArr(LOF(lngFileNo) - 1)
        Get #lngFileNo, , bytSrcArr ' InputB 慢很多
    Close

    sngEncodeTime = Timer ' 计时开始
    If EnBase64(bytSrcArr, bytBufArr) Then
        sngEncodeTime = Timer - sngEncodeTime ' 计时结束

        lngFileNo = FreeFile
        Open strOutput For Binary As lngFileNo
                Put #lngFileNo, , bytBufArr
        Close

        MsgBox "编码完成。" & vbCrLf & _
               "编码耗时约 " & Format(sngEncodeTime, "0.000") & " 秒。" & vbCrLf & _
               "(不计磁盘访问时间)"

    End If

    Erase bytBufArr, bytSrcArr
ER:
    If Err.Number <> 0 Then MsgBox Err.Description
End Sub

http://www.csdn.net/Develop/list_article.asp?author=jlum99经典加密算法在VB中的实现（4）- DES （jlum99收藏）  Visual Basic 2267 2001-6-17

经典加密算法在VB中的实现（3）- RC4 （jlum99收藏）  Visual Basic 1638 2001-6-17

经典加密算法在VB中的实现（2）- MD5 （jlum99收藏）  Visual Basic 1978 2001-6-17

经典加密算法在VB中的实现（1）- Base64 （jlum99收藏）

经典加密算法在VB中的实现（3）- RC4     public sub main()
dim key as string
for i = 1 to 16
    randomize
    key = key & chr(rnd * 255)
next i
msgbox rc4(rc4("welcome to plindge studio!", key), key)
end sub
public function rc4(inp as string, key as string) as string
dim s(0 to 255) as byte, k(0 to 255) as byte, i as long
dim j as long, temp as byte, y as byte, t as long, x as long
dim outp as string for i = 0 to 255
    s(i) = i
next j = 1
for i = 0 to 255
    if j > len(key) then j = 1
    k(i) = asc(mid(key, j, 1))
    j = j + 1
next i j = 0
for i = 0 to 255
    j = (j + s(i) + k(i)) mod 256
    temp = s(i)
    s(i) = s(j)
    s(j) = temp
next i i = 0
j = 0
for x = 1 to len(inp)
    i = (i + 1) mod 256
    j = (j + s(i)) mod 256
    temp = s(i)
    s(i) = s(j)
    s(j) = temp
    t = (s(i) + (s(j) mod 256)) mod 256
    y = s(t)

    outp = outp & chr(asc(mid(inp, x, 1)) xor y)
next
rc4 = outp
end function
一个简单实用的 vb 加密/解密算法  Function UserCode(password As String) As String
'用户口令加密
    Dim il_bit, il_x, il_y, il_z, il_len, i As Long
    Dim is_out As String
    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len
        il_bit = AscW(Mid(password, i, 1))    'W系列支持unicode

        il_y = (il_bit * 13 Mod 256) + il_x
        is_out = is_out & ChrW(Fix(il_y))  '取整 int和fix区别: fix修正负数
        il_x = il_bit * 13 / 256
    Next
    is_out = is_out & ChrW(Fix(il_x))

    password = is_out
    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len
        il_bit = AscW(Mid(password, i, 1))
        '取前4位值
        il_y = il_bit / 16 + 64
        is_out = is_out & ChrW(Fix(il_y))
        '取后4位值
        il_y = (il_bit Mod 16) + 64
        is_out = is_out & ChrW(Fix(il_y))
    Next
    UserCode = is_out
End Function
Function UserDeCode(password As String) As String
'口令解密
    Dim is_out As String
    Dim il_x, il_y, il_len, i, il_bit As Long    il_len = Len(password)
    il_x = 0
    il_y = 0
    is_out = ""
    For i = 1 To il_len Step 2
        il_bit = AscW(Mid(password, i, 1))
        '取前4位值
        il_y = (il_bit - 64) * 16
        '取后4位值
        'dd = AscW(Mid(password, i + 1, 1)) - 64
        il_y = il_y + AscW(Mid(password, i + 1, 1)) - 64
        is_out = is_out & ChrW(il_y)
    Next    il_x = 0
    il_y = 0
    password = is_out
    is_out = ""    il_len = Len(password)
    il_x = AscW(Mid(password, il_len, 1))       For i = (il_len - 1) To 1 Step -1
        il_y = il_x * 256 + AscW(Mid(password, i, 1))
        il_x = il_y Mod 13
        is_out = ChrW(Fix(il_y / 13)) & is_out
    Next
    UserDeCode = is_out
End Function

调试易

VB6怎么给文件加密？

解决方案 »