m_Base64模块：
Option Explicit
'除以2的一次方是右移一位
'乘以2的一次方是左移一位
'(bytInText(i) And &HFC) (2 ^ 2)
'第一个字节的内容And运算0xFC(11111100)(取左边6位)，再除以2的二次方(右移2位)
'(bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0) (2 ^ 4)
'第一个字节的内容And运算0x03(00000011)(取右边2位)，再乘以2的四次方(左移4位)
'第二个字节的内容And运算0xF0(11110000)(取左边4位)，再除以2的四次方(右移4位)
'两个结果再Or运算
'(bytInText(i + 1) And &HF) * (2 ^ 2) + (bytInText(i + 2) And &HC0) (2 ^ 6)
'第二个字节的内容And运算0x0F(00001111)(取右边4位)，再乘以2的二次方(左移2位)
'第三个字节的内容And运算0xC0(11000000)(取左边2位)，再除以2的六次方(右移6位)
'两个结果再Or运算
'bytInText(i + 2) And &H3F
'第三个字节的内容And运算0x3F(00111111)(取右边6位)
'Base64编码函数
Public Function Base64_Encode(bytInText() As Byte) As Byte()
Dim Base64EncodeTable() As Byte
Dim lngInTextLen As Long, lngMod As Long, i As Long
Dim bytEncode() As Byte, lngEncodeLen As Long
Base64_Encode = Chr(0) '初始化函数返回值
Base64EncodeTable() = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" '初始化Base64编码表
Base64EncodeTable() = StrConv(Base64EncodeTable(), vbFromUnicode) '转换为ANSI编码
If LBound(bytInText) <> 0 Then Exit Function 'bytInText数组下标不从零开始则出错返回
lngInTextLen = UBound(bytInText) - LBound(bytInText) + 1 '计算bytInText数组长度
lngMod = lngInTextLen Mod 3 '取模3后的余数(结果只有0、1、2三种情况)
If lngMod = 0 Then
lngEncodeLen = lngInTextLen / 3 * 4 '求编码后的长度
lngInTextLen = lngInTextLen / 3 * 3 '取3的整数倍
ElseIf lngMod = 1 Then
lngEncodeLen = (lngInTextLen + 2) / 3 * 4 '求编码后的长度
lngInTextLen = ((lngInTextLen + 2) / 3 - 1) * 3 '取3的整数倍
ElseIf lngMod = 2 Then
lngEncodeLen = (lngInTextLen + 1) / 3 * 4 '求编码后的长度
lngInTextLen = ((lngInTextLen + 1) / 3 - 1) * 3 '取3的整数倍
End If
'MsgBox "编码后的长度为" & lngEncodeLen & "字节！"
'MsgBox "3的整数倍为" & lngInTextLen
ReDim bytEncode(0 To lngEncodeLen - 1) '重新定义编码缓冲区
lngEncodeLen = 0 '初始化编码长度计数
For i = 0 To lngInTextLen - 1 Step 3
bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC) (2 ^ 2))
bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0) (2 ^ 4))
bytEncode(lngEncodeLen + 2) = Base64EncodeTable((bytInText(i + 1) And &HF) * (2 ^ 2) Or (bytInText(i + 2) And &HC0) (2 ^ 6))
bytEncode(lngEncodeLen + 3) = Base64EncodeTable(bytInText(i + 2) And &H3F)
lngEncodeLen = lngEncodeLen + 4
Next
i = lngInTextLen - 1 + 1
If lngMod = 1 Then '对剩余字节进行填充
bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC) (2 ^ 2))
bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4))
bytEncode(lngEncodeLen + 2) = Base64EncodeTable(64) '填充=
bytEncode(lngEncodeLen + 3) = Base64EncodeTable(64) '填充=
lngEncodeLen = lngEncodeLen + 4
ElseIf lngMod = 2 Then
bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC) (2 ^ 2))
bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0) (2 ^ 4))
bytEncode(lngEncodeLen + 2) = Base64EncodeTable((bytInText(i + 1) And &HF) * (2 ^ 2))
bytEncode(lngEncodeLen + 3) = Base64EncodeTable(64) '填充=
lngEncodeLen = lngEncodeLen + 4
End If
Base64_Encode = bytEncode()
End Function
'Base64解码函数
Public Function Base64_Decode(bytInText() As Byte) As Byte()
Dim Base64DecodeTable(1 To 122) As Byte
Dim lngInTextLen As Long, i As Long
Dim bytDecode() As Byte, lngDecodeLen As Long
Base64_Decode = Chr(0) '初始化函数返回值
If LBound(bytInText) <> 0 Then Exit Function 'bytInText数组下标不从零开始则出错返回
lngInTextLen = UBound(bytInText) - LBound(bytInText) + 1 '计算bytInText数组长度
If lngInTextLen Mod 4 <> 0 Then Exit Function '输入编码不是4的倍数则出错返回
For i = 1 To 122 '初始化Base64解码表
Select Case i
Case 43 '+
Base64DecodeTable(i) = 62
Case 47 '/
Base64DecodeTable(i) = 63
Case 48 To 57 '0 - 9
Base64DecodeTable(i) = 52 + (i - 48)
Case 65 To 90 'A - Z
Base64DecodeTable(i) = 0 + (i - 65)
Case 97 To 122 'a - z
Base64DecodeTable(i) = 26 + (i - 97)
Case Else
Base64DecodeTable(i) = 255
End Select
Next
lngDecodeLen = lngInTextLen / 4 * 3 '求解码后的最大长度
ReDim bytDecode(0 To lngDecodeLen - 1) '重新定义解码缓冲区
'MsgBox "解码后的最大长度为：" & lngDecodeLen
lngDecodeLen = 0 '初始化解码长度
For i = 0 To lngInTextLen - 1 Step 4
bytDecode(lngDecodeLen) = (Base64DecodeTable(bytInText(i)) * (2 ^ 2)) Or ((Base64DecodeTable(bytInText(i + 1)) And &H30) (2 ^ 4))
bytDecode(lngDecodeLen + 1) = ((Base64DecodeTable(bytInText(i + 1)) And &HF) * (2 ^ 4)) Or ((Base64DecodeTable(bytInText(i + 2)) And &H3C) (2 ^ 2))
bytDecode(lngDecodeLen + 2) = ((Base64DecodeTable(bytInText(i + 2)) And &H3) * (2 ^ 6)) Or Base64DecodeTable(bytInText(i + 3))
lngDecodeLen = lngDecodeLen + 3
Next
If bytInText(lngInTextLen - 1) = &H3D Then '判断最后两个字节的情况,求解码后的实际长度
If bytInText(lngInTextLen - 2) = &H3D Then
lngDecodeLen = lngDecodeLen - 2 '最后两个字节为"="
Else
lngDecodeLen = lngDecodeLen - 1 '最后一个字节为"="
End If
bytDecode(lngDecodeLen) = 0 '在实际长度的后一个字节放个结束符
End If
'MsgBox "解码后的实际长度为：" & lngDecodeLen
Base64_Decode = bytDecode()
End Function
frmLogin.frm窗体
Option Explicit
Private Sub cmdAdd_Click() '添加按钮
frmSet.Show 1 '模态显示设置对话框
Call QQ_DB_UpdataUserList(lvListView)
End Sub
Private Sub cmdDel_Click() '删除按钮
Dim i As Integer, blnSelect As Boolean
For i = 1 To lvListView.ListItems.Count
If lvListView.ListItems(i).Checked = True Then
blnSelect = True
If MsgBox("你确定要删除QQ号码为:" & lvListView.ListItems(i).Text & "的记录吗？", vbInformation + vbOKCancel, "QQ自动登录器") = vbOK Then
Call QQ_DB_Del(lvListView.ListItems(i).Text)
End If
End If
Next
Call QQ_DB_UpdataUserList(lvListView)
If blnSelect = False Then
MsgBox "请先选择一个QQ号码！", vbInformation + vbOKOnly, "QQ自动登录器"
End If
End Sub
Private Sub cmdExit_Click() '退出按钮
End
End Sub
Private Sub cmdLogin_Click() '登录按钮
Dim i As Integer, strNum As String, intLoginMode As Integer, blnSelect As Boolean
If chkLoginMode.Value = 1 Then '选中隐身登录复选框
intLoginMode = 40
Else
intLoginMode = 41
End If
For i = 1 To lvListView.ListItems.Count
If lvListView.ListItems(i).Checked = True Then
blnSelect = True
strNum = lvListView.ListItems(i).Text
Call QQ_AutoLogin(strNum, intLoginMode) '自动登录QQ
End If
Next
If blnSelect = False Then
MsgBox "请先选择一个QQ号码！", vbInformation + vbOKOnly, "QQ自动登录器"
End If
End Sub
Private Sub cmdModify_Click() '修改按钮
Dim i As Integer, blnSelect As Boolean
For i = 1 To lvListView.ListItems.Count
If lvListView.ListItems(i).Checked = True Then
blnSelect = True
frmSet.g_strNum = lvListView.ListItems(i).Text
frmSet.Show 1
End If
Next
If blnSelect = False Then
MsgBox "请先选择一个QQ号码！", vbInformation + vbOKOnly, "QQ自动登录器"
End If
End Sub
Private Sub Form_Load()
If QQ_DB_Connect = False Then '连接数据库
End
End If
lvListView.SmallIcons = ilImageList
Call QQ_DB_UpdataUserList(lvListView)
End Sub
Private Sub lvListView_ItemClick(ByVal Item As MSComctlLib.ListItem)
lvListView.SelectedItem.Checked = Not lvListView.SelectedItem.Checked
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call QQ_DB_Deconnetion '断开与数据库的连接
End Sub
frmSet.frm窗体：
Option Explicit
Public g_strNum As String '保存主窗口传递过来的QQ号码变量
Private Sub cmdCancel_Click() '取消按钮
Unload frmSet
End Sub
Private Sub cmdOK_Click() '确定按钮
Dim strNum As String, strPwd As String, lngRet As Long
If Trim(txtNumber.Text) = "" Or Trim(txtPassword.Text) = "" Or Trim(txtPassword2.Text) = "" Then
MsgBox "请输入完整的信息！", vbInformation Or vbOKOnly, "QQ自动登录器"
txtNumber.SetFocus
Exit Sub
End If
If Trim(txtPassword.Text) <> Trim(txtPassword2.Text) Then
MsgBox "两次输入的密码不一致，请重新输入！", vbInformation Or vbOKOnly, "QQ自动登录器"
txtPassword.Text = ""
txtPassword2.Text = ""
txtPassword.SetFocus
Exit Sub
End If
strNum = Trim(txtNumber.Text)
strPwd = Trim(txtPassword.Text)
If g_strNum <> "" Then '修改密码信息
Call QQ_DB_Edit(strNum, strPwd)
MsgBox "修改成功！", vbInformation Or vbOKOnly, "QQ自动登录器"
Unload frmSet
Else '添加密码信息
If QQ_DB_Find(strNum) Then
If MsgBox("您所输入的QQ号码信息已存在数据库中，是否改变密码信息？", vbInformation Or vbYesNo, "QQ自动登录器") = vbYes Then
Call QQ_DB_Edit(strNum, strPwd)
MsgBox "修改成功！", vbInformation Or vbOKOnly, "QQ自动登录器"
Unload frmSet
Else
Exit Sub
End If
Else
Call QQ_DB_Add(strNum, strPwd)
MsgBox "记录成功！", vbInformation Or vbOKOnly, "QQ自动登录器"
Unload frmSet
End If
End If
End Sub
Private Sub Form_Load()
If g_strNum <> "" Then
txtNumber.Text = g_strNum
txtNumber.Enabled = False
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
g_strNum = ""
End Sub
Private Sub txtNumber_KeyPress(KeyAscii As Integer)
If KeyAscii >= Asc(0) And KeyAscii <= Asc(9) Or KeyAscii = 8 Or KeyAscii = 13 Then
Else
KeyAscii = 0
End If
End Sub
该程序用ACCESS保存QQ的密码信息，可以实现批量登录。当你有多个QQ号码需要登录的时候就不用一个个去按QQ输密码了。程序还有一个需要改进的地方，就是保存密码的时候保存的是明文，虽然数据库加了密码，但现在ACCESS数据库好像不是很安全，网上经常看到有破解ACCESS数据库密码之类的文章。所以建议大家在保存密码的时候最好再加个自己的加密的方法。(直接保存密码的MD5也是不安全的喔，别人知道了MD5一样是可以登录你QQ的)
