1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
| Option Explicit
Sub test()
Dim Base As String
Base = Base64
MsgBox Base
Base64 = Base
End Sub
Property Get Base64() As String
Dim inputFile As Variant
inputFile = Application.GetOpenFilename("All Files (*.*), *.*", , "Select a file to convert to Base64")
If inputFile <> False Then Base64 = FileToBase64(inputFile)
End Property
Property Let Base64(Value As String)
Dim outputFile As Variant
outputFile = Application.GetSaveAsFilename(FileFilter:="All Files (*.*), *.*", Title:="Save as")
If outputFile <> False Then Base64ToFile Value, outputFile
End Property
Function FileToBase64(ByVal filePath As String) As String
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1 ' adTypeBinary
stream.Open
stream.LoadFromFile filePath
Dim arrData() As Byte: arrData() = stream.Read
FileToBase64 = EncodeBase64(arrData)
stream.Close
Set stream = Nothing
End Function
Sub Base64ToFile(ByVal base64Text As String, ByVal filePath As String)
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1
stream.Open
stream.Write DecodeBase64(base64Text)
stream.SaveToFile filePath, 2 ' adSaveCreateOverWrite
stream.Close
Set stream = Nothing
End Sub
Function EncodeBase64(arrData() As Byte) As String
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function
Function DecodeBase64(ByVal base64Text As String) As Byte()
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.Text = base64Text
DecodeBase64 = objNode.nodeTypedValue
Set objNode = Nothing
Set objXML = Nothing
End Function |
Partager