【VB】VB写的Base64编码、解码工具
Base64的编码方式很简单，每3个8-bit字节转换为4个6-bit字节来存储，而每个6 bit字节都转换为64个可打印字符。字符表如下。值字符值字符值字符值字符
0A17R34i51z
1B18S35j520
2C19T36k531
3D20U37l542
4E21V38m553
5F22W39n564
6G23X40o575
7H24Y41p586
8I25Z42q597
9J26a43r608
10K27b44s619
11L28c45t62+
12M29d46u63/
13N30e47v
14O31f48w
15P32g49x
16Q33h50y
Base64的存在，能使信息可以通过可打印ASCII码的方式存储，避免了各种冲突问题。比如我有一堆“回车”（CR LF）要通过电子邮件发送，为了避免服务器误解我的请求，我可以把它编码为Base64。
牺牲了体积，但是换来了灵活性。
VERSION 5.00
Begin VB.Form frmMain
Caption = "Base64"
ClientHeight = 5190
ClientLeft = 120
ClientTop = 450
ClientWidth = 8340
LinkTopic = "Form1"
ScaleHeight = 346
ScaleMode = 3'Pixel
ScaleWidth = 556
StartUpPosition = 3'窗口缺省
Begin VB.PictureBox picCenterBar
Align = 3'Align Left
BorderStyle = 0'None
Height = 5190
Left = 3135
MousePointer = 9'Size W E
ScaleHeight = 346
ScaleMode = 3'Pixel
ScaleWidth = 8
TabIndex = 4
Top = 0
Width = 120
End
Begin VB.PictureBox picBase64
Align = 3'Align Left
BorderStyle = 0'None
Height = 5190
Left = 3255
ScaleHeight = 346
ScaleMode = 3'Pixel
ScaleWidth = 232
TabIndex = 2
Top = 0
Width = 3480
Begin VB.TextBox txtBase64
Height = 2775
Left = 0
MultiLine = -1'True
ScrollBars = 2'Vertical
TabIndex = 6
Top = 240
Width = 2655
End
Begin VB.Label lblBase64
AutoSize = -1'True
Caption = "Base64编码："
Height = 180
Left = 0
TabIndex = 3
Top = 0
Width = 1080
End
End
Begin VB.PictureBox picSrc
Align = 3'Align Left
BorderStyle = 0'None
Height = 5190
Left = 0
ScaleHeight = 346
ScaleMode = 3'Pixel
ScaleWidth = 209
TabIndex = 0
Top = 0
Width = 3135
Begin VB.TextBox txtSrc
Height = 2895
Left = 0
MultiLine = -1'True
ScrollBars = 2'Vertical
TabIndex = 5
Top = 240
Width = 3135
End
Begin VB.Label lblSrc
AutoSize = -1'True
Caption = "原始信息："
Height = 180
Left = 0
TabIndex = 1
Top = 0
Width = 900
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'字符串用UTF-8编码
Private Const CP_UTF8 = 65001
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, lpDefaultChar As Any, ByVal lpUsedDefaultChar As Long) As Long
Dim SW!, SH! '窗口宽度和高度
Dim IsManagedChange As Boolean '确定是不是程序自身修改了文本框。防止循环修改。
'将字符串转换为UTF-8编码的字节数组
Sub StringToUTF8Bytes(Src As String, UTF8Bytes() As Byte)
'先计算需求字节数
Dim BytesRequired As Long
BytesRequired = WideCharToMultiByte(CP_UTF8, 0, ByVal StrPtr(Src), Len(Src), ByVal 0, 0, ByVal 0, ByVal 0)
'然后转换
ReDim UTF8Bytes(BytesRequired - 1)
WideCharToMultiByte CP_UTF8, 0, ByVal StrPtr(Src), Len(Src), UTF8Bytes(0), BytesRequired, ByVal 0, ByVal 0
End Sub
'将UTF-8编码的字节数组转换为字符串
Function UTF8BytesToString(UTF8Bytes() As Byte) As String
'先计算需求字节数
Dim BytesRequired As Long
BytesRequired = MultiByteToWideChar(CP_UTF8, 0, UTF8Bytes(0), UBound(UTF8Bytes) + 1, ByVal 0, 0)
'然后转换
UTF8BytesToString = String(BytesRequired, 0)
MultiByteToWideChar CP_UTF8, 0, UTF8Bytes(0), UBound(UTF8Bytes) + 1, ByVal StrPtr(UTF8BytesToString), BytesRequired
End Function
'将6-bit字节转换为Base64字符
Function EncBase64Char(ByVal Value As Byte) As Byte
If Value < 26 Then '26个大写英文字母
EncBase64Char = Value + &H41
ElseIf Value < 52 Then '26个小写英文字母
EncBase64Char = Value + &H61 - 26
ElseIf Value < 62 Then '10个数字
EncBase64Char = Value + &H30 - 52
ElseIf Value = 62 Then
EncBase64Char = &H2B '+
Else
EncBase64Char = &H2F '/
End If
End Function
'将Base64字符转换为6 bit字节
Function DecBase64Char(ByVal Value As Byte) As Byte
If Value >= &H41 And Value <= &H5A Then
DecBase64Char = Value - &H41
ElseIf Value >= &H61 And Value <= &H7A Then
DecBase64Char = Value - &H61 + 26
ElseIf Value >= &H30 And Value <= &H39 Then
DecBase64Char = Value - &H30 + 52
ElseIf Value = &H2B Then
DecBase64Char = 62
ElseIf Value = &H2F Then
DecBase64Char = 63
End If
End Function
'进行Base64编码，返回Base64的字符串
Function Encode(Src As String) As String
On Error GoTo ErrHandler
If Len(Src) = 0 Then Exit Function
'原始内容
Dim SrcBytes() As Byte, SrcLen As Long
StringToUTF8Bytes Src, SrcBytes '先将原文以UTF-8的方式编码
SrcLen = UBound(SrcBytes) + 1
'编码后的内容
Dim DestBytes() As Byte, DestLen As Long
DestLen = SrcLen + ((SrcLen - 1) \ 3 + 1)
ReDim DestBytes(DestLen - 1)
'将8-bit字节数组转换为6-bit字节数组
Dim I&, J&, Bit&
For I = 0 To SrcLen - 1
If Bit = 0 Then 'DestBytes(J)未被写入
DestBytes(J) = (SrcBytes(I) And &HFC) \ &H4
J = J + 1
DestBytes(J) = (SrcBytes(I) And &H3) * &H10
Bit = 2
'234567
'NNNN01 'N:Next byte
ElseIf Bit = 2 Then 'DestBytes(J)已被写入两位
DestBytes(J) = DestBytes(J) Or ((SrcBytes(I) And &HF0) \ &H10)
J = J + 1
DestBytes(J) = (SrcBytes(I) And &HF) * &H4
Bit = 4
'4567PP 'P:Prev byte
'NN0123 'N:Next byte
ElseIf Bit = 4 Then 'DestBytes(J)已被写入四位
DestBytes(J) = DestBytes(J) Or ((SrcBytes(I) And &HC0) / &H40)
J = J + 1
DestBytes(J) = SrcBytes(I) And &H3F
J = J + 1
Bit = 0
'67PPPP 'P:Prev byte
'012345
End If
Next
For I = 0 To DestLen - 1
DestBytes(I) = EncBase64Char(DestBytes(I)) '转换为Base64字符
Next
Encode = StrConv(DestBytes, vbUnicode) & String(2 - (SrcLen - 1) Mod 3, "=") '原文剩余内容不足3个字节需要补齐
Exit Function
'出错返回错误描述。
ErrHandler:
Encode = Err.Description
End Function
'将Base64的字符串解码为原文。
Function Decode(Src As String) As String
On Error GoTo ErrHandler
If Len(Src) = 0 Then Exit Function
'编码后的内容
Dim SrcBytes() As Byte, SrcLen As Long
SrcBytes = StrConv(Src, vbFromUnicode)
SrcLen = UBound(SrcBytes) + 1
'原始内容
Dim DestBytes() As Byte, DestLen As Long
DestLen = SrcLen - SrcLen \ 4
ReDim DestBytes(DestLen - 1)
Dim I&, J&, Bit&
For J = 0 To SrcLen - 1
SrcBytes(J) = DecBase64Char(SrcBytes(J)) '从Base64字符转换为6-bit字节
Next
'将6-bit字节数组转换为8-bit字节数组
For J = 0 To DestLen - 1
If Bit = 0 Then 'DestBytes(J)未被写入
DestBytes(J) = SrcBytes(I) * &H4
I = I + 1
If I > UBound(SrcBytes) Then Exit For
DestBytes(J) = DestBytes(J) Or ((SrcBytes(I) And &H30) \ &H10)
Bit = 2
ElseIf Bit = 2 Then 'DestBytes(J)已被写入两字节
DestBytes(J) = (SrcBytes(I) And &HF) * &H10
I = I + 1
If I > UBound(SrcBytes) Then Exit For
DestBytes(J) = DestBytes(J) Or ((SrcBytes(I) And &H3C) \ &H4)
Bit = 4
ElseIf Bit = 4 Then 'DestBytes(J)已被写入四字节
DestBytes(J) = (SrcBytes(I) And &H3) * &H40
I = I + 1
If I > UBound(SrcBytes) Then Exit For
DestBytes(J) = DestBytes(J) Or SrcBytes(I)
I = I + 1
If I > UBound(SrcBytes) Then Exit For
Bit = 0
End If
Next
'最后将转换得到的UTF-8字符串转换为VB支持的Unicode字符串以便于显示。
Decode = UTF8BytesToString(DestBytes)
Exit Function
ErrHandler:
Decode = Err.Description
End Function
Private Sub Form_Load()
Form_Resize
End Sub
'窗口大小更改时，左右两个文本框的宽度比例保持不变。
Private Sub Form_Resize()
On Error Resume Next
SW = ScaleWidth
SH = ScaleHeight
Dim LWidth!, RWidth!, MWidth!
LWidth = picSrc.Width
RWidth = picBase64.Width
MWidth = picCenterBar.Width
picSrc.Width = (SW - MWidth) * LWidth / (LWidth + RWidth)
picBase64.Width = (SW - MWidth) * RWidth / (LWidth + RWidth)
End Sub
'容器大小修改时，里面的文本框适应容器的尺寸。
Private Sub picSrc_Resize()
On Error Resume Next
txtSrc.Move 0, txtSrc.Top, picSrc.ScaleWidth, picSrc.ScaleHeight - txtSrc.Top
End Sub
Private Sub picBase64_Resize()
On Error Resume Next
txtBase64.Move 0, txtBase64.Top, picBase64.ScaleWidth, picBase64.ScaleHeight - txtBase64.Top
End Sub
'中间的分隔，可以用鼠标拖动。鼠标按下时变暗。
Private Sub picCenterBar_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
picCenterBar.BackColor = vbButtonShadow
End Sub
Private Sub picCenterBar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Static DragX!
If Button And 1 Then '是否鼠标左键按下。
Dim NewWidth!, MWidth!
MWidth = picCenterBar.Width
NewWidth = picSrc.Width + (X - DragX)
'限制拖动的范围。
If NewWidth < 1 Then NewWidth = 1
If NewWidth > SW - MWidth - 1 Then NewWidth = SW - MWidth - 1
'调整UI尺寸
picSrc.Width = NewWidth
picBase64.Width = SW - MWidth - NewWidth
Else
DragX = X
End If
End Sub
'拖动停止时变回原来的颜色。
Private Sub picCenterBar_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
picCenterBar.BackColor = vbButtonFace
End Sub
'修改文本框的时候。进行编码工作
Private Sub txtSrc_Change()
If IsManagedChange Then
IsManagedChange = False '防止循环修改
Else
IsManagedChange = True
txtBase64.Text = ""
IsManagedChange = True
txtBase64.SelText = Encode(txtSrc.Text)
IsManagedChange = False
End If
End Sub
'修改文本框的时候。进行解码工作
Private Sub txtBase64_Change()
If IsManagedChange Then
IsManagedChange = False '防止循环修改
Else
IsManagedChange = True
txtSrc.Text = ""
IsManagedChange = True
txtSrc.SelText = Decode(txtBase64.Text)
IsManagedChange = False
End If
End SubBIN:
SRC:
参考资料： :o居然让我坐了沙发？ 凌寒 发表于 2016-10-2 20:57
居然让我坐了沙发？
噗。。 支持 ！！ 支持 ！！ 本帖最后由 china_shy_wzb 于 2020-7-20 13:30 编辑
我来支持一下 ！！ 感谢分享。。。
页:
[1]