ExcelVBA～ファイルをBase64エンコード・デコードする方法

　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　

★エンコードデコードサンプルダウンロード
（base64エンコードとデコード、quoted-printableデコード、URL＝パーセントデコード、Yahoo知恵袋インデント変換、のコードが入っています。）
　　

https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q10298915845

「ファイルをBase64エンコード・デコードするVBAマクロ」
https://www.ka-net.org/blog/?p=4479
を少し加工。

Web検索してみたら、
「ファイルをBase64エンコード・デコードするVBAマクロ」
https://www.ka-net.org/blog/?p=4479
というのがありました。

Base64エンコードとは？
https://wa3.i-3-i.info/word11338.html

当方でFunctionをPrivate からPublicに変更後にテストしてみましたら、
xlsxもPDFも、
エンコードした結果をグローバル変数にいったん入れて、
そののち、そのグローバル変数の値をもとにデコードしたら、
xlsx、PDF、ともに、正常に？復元されました・・・・。
すべてのxlsxやPDFを完璧にエンコード、デコード、できるのかは
自分にはわかりませんが・・・。

セルにエンコードした値を入れたら、１セルだけでは足りませんで、
デコードが正常に行えませんでした。
セルに保存するなら、1行1セル、のように複数行が必要のようです。

あるいは、エンコードは、
テキストファイルやクリップボードに書き出すとか、
大量のテキストを書き出せるものに書き出したほうがいいかも？です。

==============

以下のコードで、エンコード結果をクリップボードに送っても、
そのクリップボードの内容から、
xlsx、PDF、ともに、正常に？復元されました・・・・。

クリップボードのデータを、いったんテキストファイルに貼り付け、
それをすべて選択してから、コピー、を実行し、その後、
DecodeBase64 を実行してもＯＫでした。

これもすべてのxlsxやPDFを完璧にエンコード、デコード、できるのかは
自分にはわかりませんが・・・。

以下は、クリップボードのデータをゲットしたり、送ったりのコードです。

＝＝＝＝

'クリップボードにデータを送る。
Function Sendcb(s_FPath As String)

Dim o_cpb As Object
Set o_cpb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'↑「Microsoft Forms 2.0 Object Library」と書くとエラーになるので
' 「new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}」と書く。

With o_cpb
.SetText s_FPath '変数のデータをDataObjectに格納
.PutInClipboard 'DataObjectのデータをクリップボードに格納
End With

End Function

'クリップボードの値をゲットする。
Function Getcbdata() As String

On Error Resume Next
With o_cpb
.GetFromClipboard
Getcbdata = .GetText
End With

End Function

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

考え違いしてたらごめんなさい。

=============================================================================================
以上、知恵袋回答
=============================================================================================
=============================================================================================
=============================================================================================
=============================================================================================
=============================================================================================
以下、全体のコード。
=============================================================================================

'
'


Option Explicit

Dim s_TempTxt01 As String 'エンコード結果を入れるためのテスト用のグローバル変数。クリップボードの代わりにこれを使ってもいい。


'指定したファイルをBase64エンコードして、その結果のテキスト内容をクリップボードに送る。
Public Sub SendcbEncodeTest01()
  Call Sendcb(EncodeBase64("D:\1\decord03.pdf"))
End Sub


'Base64エンコードされたクリップボードに保持されたテキスト内容から、デコードしてファイルを復元する。
'クリップボードのその内容を、いったんテキストファイルにコピペし、
'その後、そのテキストファイルの内容を切り取りやコピーをしても、ファイルを復元できます。
Public Sub GetcbdataDEcodeTest01()
  Call DecodeBase64(Getcbdata, "D:\1\decord04.pdf")
End Sub

'「Base64エンコードされた文字の羅列が記録されたテキストファイル」の内容から、
'それをデコードしてファイルを復元する。

Public Sub DecordFromTxtBodyTest01()

    Dim s_TxtBody01 As String
    'テキストファイルの本文内容を一発格納するための変数。
    
    Let s_TxtBody01 = TxtAllBundleRead01("d:\1\decord06.txt")
    '「Base64エンコードされた文字の羅列が記録されたテキストファイル」から
    'その内容を一括読み。
    
    Call DecodeBase64(s_TxtBody01, "D:\1\decord06.xlsx")
    'その内容から、ファイル復元。
    '拡張子なしで実行して、あとから、色々に拡張子を試してもOKです。
    
End Sub


'=============
'=============

'クリップボードにデータを送る（だけ）のプログラム。
Function Sendcb(s_FPath As String)

    Dim o_cpb As Object
    Set o_cpb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    '↑CreateObject関数のクラス名の指定で「MSForms.DataObject」と書くとエラーになるので
    '  「new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}」と書く。
    
    With o_cpb
        .SetText s_FPath    '変数のデータをDataObjectに格納
        .PutInClipboard     'DataObjectのデータをクリップボードに格納
    End With
    
End Function


'クリップボードの値をゲットする（だけ）のプログラム。
Function Getcbdata() As String

    Dim o_cpb As Object
    Set o_cpb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    '↑同じく、CreateObject関数のクラス名の指定で「MSForms.DataObject」と書くとエラーになるので
    '  「new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}」と書く。
    
    On Error Resume Next
    With o_cpb
        .GetFromClipboard
        Getcbdata = .GetText
    End With

End Function


'指定したテキストファイルから、ループを使わずに一発で内容を読み込む
'https://vbanobuhinko.com/%E3%83%86%E3%82%AD%E3%82%B9%E3%83%88%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E4%B8%80%E6%8B%AC%E8%AA%AD%E3%81%BF%E8%BE%BC%E3%81%BF%E3%81%99%E3%82%8B/

Function TxtAllBundleRead01(s_Path As String) As String
    
    Dim bhTxt As String
    
    'FSOの宣言
    Dim bhFSO As Object
    Dim bhFSOT As Object
    
    Set bhFSO = CreateObject("Scripting.FileSystemObject")
    '指定テキストファイルを開く
'    Set bhFSOT = bhFSO.OpenTextFile("指定テキストファイルの絶対パス")
    Set bhFSOT = bhFSO.OpenTextFile(s_Path)
    
    '開いたテキストを1つのデータに一括読み込み

    Let bhTxt = bhFSOT.ReadAll
    
    Let TxtAllBundleRead01 = bhTxt
    
    'FSOの解放
    Set bhFSOT = Nothing
    Set bhFSO = Nothing

End Function

'=============
'=============

'Base64でエンコードする（＝ファイルを文字化する）
Function EncodeBase64(ByVal FilePath As String) As String
'ファイルをBase64エンコード
  Dim elm As Object
  Dim ret As String
  Const adTypeBinary = 1
  Const adReadAll = -1
   
  ret = "" '初期化
  On Error Resume Next
  Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
  With CreateObject("ADODB.Stream")
    .Type = adTypeBinary
    .Open
    .LoadFromFile FilePath
    elm.DataType = "bin.base64"
    elm.nodeTypedValue = .Read(adReadAll)
    ret = elm.Text
    .Close
  End With
  On Error GoTo 0
  EncodeBase64 = ret
End Function
 


'Base64でデコードする（＝エンコードで文字化されたものからファイルに復元する）
Function DecodeBase64(ByVal Base64Str As String, ByVal FilePath As String) As Long
'ファイルをBase64デコード
  Dim elm As Object
  Dim ret As Long
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
   
  ret = -1 '初期化
  On Error Resume Next
  Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
  elm.DataType = "bin.base64"
  elm.Text = Base64Str
  With CreateObject("ADODB.Stream")
    .Type = adTypeBinary
    .Open
    .Write elm.nodeTypedValue
    .SaveToFile FilePath, adSaveCreateOverWrite
    .Close
  End With
  If Err.Number <> 0 Then ret = 0
  On Error GoTo 0
  DecodeBase64 = ret
End Function


'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

Option Explicit

Dim s_TempTxt01 As String 'エンコード結果を入れるためのテスト用のグローバル変数。クリップボードの代わりにこれを使ってもいい。

'指定したファイルをBase64エンコードして、その結果のテキスト内容をクリップボードに送る。

Public Sub SendcbEncodeTest01()

Call Sendcb(EncodeBase64("D:\1\decord03.pdf"))

End Sub

'Base64エンコードされたクリップボードに保持されたテキスト内容から、デコードしてファイルを復元する。

'クリップボードのその内容を、いったんテキストファイルにコピペし、

'その後、そのテキストファイルの内容を切り取りやコピーをしても、ファイルを復元できます。

Public Sub GetcbdataDEcodeTest01()

Call DecodeBase64(Getcbdata, "D:\1\decord04.pdf")

End Sub

'「Base64エンコードされた文字の羅列が記録されたテキストファイル」の内容から、

'それをデコードしてファイルを復元する。

Public Sub DecordFromTxtBodyTest01()

Dim s_TxtBody01 As String

'テキストファイルの本文内容を一発格納するための変数。

Let s_TxtBody01 = TxtAllBundleRead01("d:\1\decord06.txt")

'「Base64エンコードされた文字の羅列が記録されたテキストファイル」から

'その内容を一括読み。

Call DecodeBase64(s_TxtBody01, "D:\1\decord06.xlsx")

'その内容から、ファイル復元。

'拡張子なしで実行して、あとから、色々に拡張子を試してもOKです。

End Sub

'=============

'クリップボードにデータを送る（だけ）のプログラム。

Function Sendcb(s_FPath As String)

Dim o_cpb As Object

Set o_cpb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

'↑CreateObject関数のクラス名の指定で「MSForms.DataObject」と書くとエラーになるので

' 「new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}」と書く。

With o_cpb

.SetText s_FPath '変数のデータをDataObjectに格納

.PutInClipboard 'DataObjectのデータをクリップボードに格納

End With

End Function

'クリップボードの値をゲットする（だけ）のプログラム。

Function Getcbdata() As String

Dim o_cpb As Object

Set o_cpb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

'↑同じく、CreateObject関数のクラス名の指定で「MSForms.DataObject」と書くとエラーになるので

' 「new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}」と書く。

On Error Resume Next

With o_cpb

.GetFromClipboard

Getcbdata = .GetText

End With

End Function

'指定したテキストファイルから、ループを使わずに一発で内容を読み込む

'https://vbanobuhinko.com/%E3%83%86%E3%82%AD%E3%82%B9%E3%83%88%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E4%B8%80%E6%8B%AC%E8%AA%AD%E3%81%BF%E8%BE%BC%E3%81%BF%E3%81%99%E3%82%8B/

Function TxtAllBundleRead01(s_Path As String) As String

Dim bhTxt As String

'FSOの宣言

Dim bhFSO As Object

Dim bhFSOT As Object

Set bhFSO = CreateObject("Scripting.FileSystemObject")

'指定テキストファイルを開く

' Set bhFSOT = bhFSO.OpenTextFile("指定テキストファイルの絶対パス")

Set bhFSOT = bhFSO.OpenTextFile(s_Path)

'開いたテキストを1つのデータに一括読み込み

Let bhTxt = bhFSOT.ReadAll

Let TxtAllBundleRead01 = bhTxt

'FSOの解放

Set bhFSOT = Nothing

Set bhFSO = Nothing

End Function

'=============

'Base64でエンコードする（＝ファイルを文字化する）

Function EncodeBase64(ByVal FilePath As String) As String

'ファイルをBase64エンコード

Dim elm As Object

Dim ret As String

Const adTypeBinary = 1

Const adReadAll = -1

ret = "" '初期化

On Error Resume Next

Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")

With CreateObject("ADODB.Stream")

.Type = adTypeBinary

.Open

.LoadFromFile FilePath

elm.DataType = "bin.base64"

elm.nodeTypedValue = .Read(adReadAll)

ret = elm.Text

.Close

End With

On Error GoTo 0

EncodeBase64 = ret

End Function

'Base64でデコードする（＝エンコードで文字化されたものからファイルに復元する）

Function DecodeBase64(ByVal Base64Str As String, ByVal FilePath As String) As Long

'ファイルをBase64デコード

Dim elm As Object

Dim ret As Long

Const adTypeBinary = 1

Const adSaveCreateOverWrite = 2

ret = -1 '初期化

On Error Resume Next

Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")

elm.DataType = "bin.base64"

elm.Text = Base64Str

With CreateObject("ADODB.Stream")

.Type = adTypeBinary

.Open

.Write elm.nodeTypedValue

.SaveToFile FilePath, adSaveCreateOverWrite

.Close

End With

If Err.Number <> 0 Then ret = 0

On Error GoTo 0

DecodeBase64 = ret

End Function

投稿タグ: エンコード, デコード, ビジネスパソコンの基礎, ビジネス一般常識, フリーウェア

MENU

関連記事

最近の投稿

カテゴリー

MENU

ExcelVBA～ファイルをBase64エンコード・デコードする方法

関連記事

最近の投稿

カテゴリー

タグ