これは何がうれしいかというとEXCELのマクロブックとかをメールに添付して送りたくない場合に使う手法です。
①マクロブックをB64変換を行う
②メールでマクロを送りたい人にB64テキストファイルを添付して送る
③メールを受け取った側はB64復元でB64テキストをマクロブックに戻す。
一連の処理コードを以下に添付します。
Option Explicit
'=============================================================
' ＜参考＞
' ファイルをBase64エンコード・デコードするVBAマクロ
' https://www.ka-net.org/blog/?p=4479
'=============================================================
'-----------------------------------------------------------------
' Sub ■B64変換()
' 概要：指定のファイルをＢ６４形式のファイルへ返還する
'-----------------------------------------------------------------
' Sub ■B64復元()
' 概要：Ｂ６４形式のファイルを元のファイルへ返還する
'-----------------------------------------------------------------
Sub ■B64変換()
Dim Start
Start = Timer
On Error GoTo Catch
Dim WS0 As Worksheet
Set WS0 = ActiveSheet
Dim 開始 As String
開始 = Format(Now, "yyyy/mm/dd hh:mm:ss")
WS0.Cells(1, "B") = "開始：" & Format(Now, "yyyy/mm/dd hh:mm:ss")
Dim strFiles As String
Dim i As Long, j As Long, k As Long, m As Long
Dim QMSG As String, MSG As String
Dim RC
QMSG = "Ｂ６４変換対象ファイルを指定して下さい？"
RC = MsgBox(QMSG, vbYesNo, "■変換対象ファイルの選択")
Select Case RC
Case vbYes
Case Else
MsgBox "処理を中止します。", vbCritical
End
End Select
'１．返還前のファイルを指定する
strFiles = ファイル選択処理
If strFiles = "" Then
MsgBox "処理を終了します！" & vbLf & vbLf & "もう一度起動ボタンクリックから実行願います。"
Exit Sub
End If
Dim sFiles
Dim eRow As Long
sFiles = Split(strFiles, vbLf)
Dim fullPath As String
Dim folderPath As String
Dim sFile As String
j = 1
fullPath = sFiles(j) 'ファイル名は配列の添え字１からセットされる
folderPath = Left(fullPath, InStrRev(fullPath, "\"))
sFile = Mid(fullPath, InStrRev(fullPath, "\") + 1)
WS0.Cells(3, "A") = sFile
WS0.Cells(3, "B") = fullPath
'２．返還後のファイルをファイル名の最後に「_B64.txt」付与する。
WS0.Cells(3, "C") = sFile & "_B64.txt"
WS0.Cells(3, "D") = folderPath & sFile & "_B64.txt"
B64変換処理:
Dim TTL As String
fullPath = WS0.Cells(3, "B")
TTL = EncodeBase64FromFile(fullPath)
'テキスト変換してファイルにする
Open WS0.Cells(3, "D") For Output As #1
Print #1, TTL;
Close #1
'---------------------------------------------------------------------------
'別途、サイズが73*13000=949000以上ならば10000行で区切ってファイル分割を行う。
'理由：メールの添付ファイルサイズが１Ｍ以内の制約がある場合を想定・・・
'---------------------------------------------------------------------------
Dim 分割サイズ As Long
Dim 分割ファイル行数 As Long
Dim 分割行数 As Long
Select Case True
Case WS0.Cells(3, "E") = ""
分割ファイル行数 = 13000
Case IsNumeric(WS0.Cells(3, "E"))
分割ファイル行数 = CLng(WS0.Cells(3, "E"))
Case Else
分割ファイル行数 = 13000
End Select
分割サイズ = 分割ファイル行数 * 73
Select Case True
Case WS0.Cells(3, "F") = ""
分割行数 = 10000
Case IsNumeric(WS0.Cells(3, "F"))
分割行数 = CLng(WS0.Cells(3, "F"))
Case Else
分割行数 = 10000
End Select
If Len(TTL) > 分割サイズ Then
Call B64ファイル分割2(TTL, WS0.Cells(3, "D"), 分割行数)
MSG = "Ｂ６４ファイルのサイズが " & Format(分割サイズ, "#,##0") & " を超えたため"
MSG = MSG & vbLf & "分割ファイルを作成しています。"
Else
MSG = ""
End If
Dim 終了 As String
終了 = Format(Now, "yyyy/mm/dd hh:mm:ss")
Dim 開始終了 As String
開始終了 = WS0.Cells(1, "B")
開始終了 = 開始終了 & vbLf & "終了：" & Format(Now, "yyyy/mm/dd hh:mm:ss")
開始終了 = 開始終了 & vbLf & "処理：" & Format(CDate(終了) - CDate(開始), "hh:mm:ss ") & Format(Timer - Start, "00.0秒")
WS0.Cells(1, "B") = 開始終了
MsgBox "B64変換処理が終了しました！" & vbLf & vbLf & MSG
Finally:
Exit Sub
Catch:
Debug.Print Err.Number, Err.Description
Stop
Resume
End Sub
Sub ■B64復元()
'１．Ｂ６４変換後のファイルを指定する
'２．変換後ファイルの"_B64.txt"を取り除いたファイルを復元ファイル名とする
'３．変換後ファイル名が"_B64_001.txt"の場合はそのほかの分割ファイルをマージして
' 変換後ファイル"_B64.txt"を作成する
Dim Start
Start = Timer
On Error GoTo Catch
'1. ファイル選択ダイアログでファイルを選択してシートの所定のカラムにセットする
Dim WS0 As Worksheet: Set WS0 = ActiveSheet
Dim 開始 As String: 開始 = Format(Now, "yyyy/mm/dd hh:mm:ss")
WS0.Cells(5, "B") = "開始：" & Format(Now, "yy/mm/dd hh:mm:ss")
Dim i As Long, j As Long, k As Long, m As Long
Dim strFiles As String
Dim QMSG As String, MSG As String
Dim RC
QMSG = "変換後Ｂ６４ファイルを指定して下さい？"
RC = MsgBox(QMSG, vbYesNo, "■変換後ファイルの選択")
Select Case RC
Case vbYes
Case Else
MsgBox "処理を中止します。", vbCritical
Exit Sub
End Select
strFiles = ファイル選択処理
If strFiles = "" Then
MsgBox "処理を終了します！" & vbLf & vbLf & "もう一度起動ボタンクリックから実行願います。"
Exit Sub
End If
Dim sFiles
Dim eRow As Long
sFiles = Split(strFiles, vbLf)
Dim fullPath As String
Dim folderPath As String
Dim sFile As String
j = 1
fullPath = sFiles(j)
folderPath = Left(fullPath, InStrRev(fullPath, "\"))
sFile = Mid(fullPath, InStrRev(fullPath, "\") + 1)
'「_B64_001.txt」は分割ファイルの最初のファイルを表す
If Right(sFile, 12) = "_B64_001.txt" Then
'① FSOにてファイルリストの中からＬＩＫＥ演算子を使い分割ファイル名を探し
'② ファイル一覧をソートしてソート順にファイルのマージ処理を行う
Dim sCombineFileName As String
Dim seqFile As String
sCombineFileName = Left(sFile, Len(sFile) - 8) & ".txt"
seqFile = Left(sFile, Len(sFile) - 7) & "*" & ".txt"
Call combineFiles1(folderPath, seqFile, sCombineFileName)
Else
sCombineFileName = sFile
End If
WS0.Cells(7, "A") = sCombineFileName
WS0.Cells(7, "B") = folderPath & sCombineFileName
WS0.Cells(7, "C") = Left(sCombineFileName, Len(sCombineFileName) - 8)
WS0.Cells(7, "D") = folderPath & Left(sCombineFileName, Len(sCombineFileName) - 8)
B64復元処理:
'Ｂ６４変換後ファイルを読み込む
Dim L1 As String
Dim TTL As String
i = 0
Dim text_path As String
text_path = WS0.Cells(7, "B")
''テキストファイルを開く
'Open text_path For Input As #1
'
''最終行までループ
'Do Until EOF(1)
' Line Input #1, L1 '毎回1行読み込み
' i = i + 1
' TTL = TTL & L1 'Ｂ６４文字列を連結
'Loop
'
'Close #1
Dim FSO
Dim oFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'ファイルを開く
Dim oTS As Object
Set oTS = FSO.OpenTextFile(text_path, ForReading)
'データを全て新規ファイルに書き込み
Dim sRead As String
sRead = oTS.ReadAll
TTL = Replace(sRead, vbLf, "")
Dim TB As Object
'Set TB = WS0.Shapes("テキスト ボックス 1").TextFrame
If Len(TTL) >= (10 * 1000000) Then
'サイズが大きいと処理が完了しなくなる。
'10Mバイトごとにバイナリー変換してできれば連結していけるようにする
End If
fullPath = WS0.Cells(7, "D")
Dim IMSG As String
If DecodeBase64ToFile(TTL, fullPath) = 0 Then
IMSG = "B64復元処理に失敗しました！(SIZE=" & Len(TTL)
Else
IMSG = "B64復元処理が成功しました！"
End If
Dim 終了 As String
終了 = Format(Now, "yyyy/mm/dd hh:mm:ss")
Dim 開始終了 As String
開始終了 = WS0.Cells(1, "B")
開始終了 = 開始終了 & vbLf & "終了：" & Format(Now, "yyyy/mm/dd hh:mm:ss")
開始終了 = 開始終了 & vbLf & "処理：" & Format(CDate(終了) - CDate(開始), "hh:mm:ss ") & Format(Timer - Start, "00.0秒")
WS0.Cells(5, "B") = 開始終了
MsgBox IMSG, vbInformation
Finally:
Exit Sub
Catch:
Debug.Print Err.Number, Err.Description
Stop
Resume
End Sub
''新規に出力ファイルを作成する。
'intFileNumber = FreeFile 'ファイルの空き番号を得る
''バイナリファイルを作成
'Open strSaveFileName For Binary As intFileNumber
'Seek #intFileNumber, LOF(intFileNumber) + 1&
'
''バッファの内容をファイルに書き込む
'Put #intFileNumber, , bytSaveText
''ファイルを閉じる
'Close #intFileNumber
'【エクセルVBA】TextFrameオブジェクトとCharactersオブジェクトでテキストボックスを操作してみよう！
'https://tonari-it.com/excel-vba-textframe-charcters/
'
'Sub Text_Box_Change()
' With ActiveSheet.Shapes("テキスト ボックス 1").TextFrame
' .Characters.text = "テキスト更新！"
' .HorizontalAlignment = xlHAlignRight
' .VerticalAlignment = xlVAlignCenter
' End With
'
'End Sub
'
'
Function ファイル選択処理() As String
Dim strFiles As String
Dim i As Long
ファイル選択処理 = ""
With Application.FileDialog(msoFileDialogFilePicker)
'ファイルの複数選択を可能にする
.AllowMultiSelect = False
'ファイルフィルタのクリア
.Filters.Clear
'ファイルフィルタの追加
.Filters.Add "ZIP,TEXT,PDF,その他", "*.txt; *.*"
.Filters.Add "エクセルブック他", "*.xls*; *.doc*"
'初期表示フォルダの設定
.InitialFileName = ThisWorkbook.Path & "\"
If .Show = -1 Then 'ファイルダイアログ表示
' [ OK ] ボタンが押された場合
For i = 1 To .SelectedItems.Count
strFiles = strFiles & vbLf & .SelectedItems(i)
Next i
'MsgBox "以下のファイルが選択されました。" & _
vbLf & strFiles, vbInformation
Else
' [ キャンセル ] ボタンが押された場合
MsgBox "ファイル選択がキャンセルされました。", vbExclamation
ファイル選択処理 = ""
Exit Function
End If
End With
ファイル選択処理 = strFiles
Finally:
Exit Function
Catch:
Debug.Print Err.Number, Err.Description
Stop
Resume
End Function
Private Function EncodeBase64FromFile(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
EncodeBase64FromFile = ret
End Function
Private Function DecodeBase64ToFile(ByVal Base64Str As String, ByVal FilePath As String) As Long
'読み込んで追加書きを刷る場合
'objStream.Position = objStream.size
'ファイルを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
'Dim i As Long, j As Long, k As Long
'Dim sz As Long
'Dim NTB() As Byte
'
'ReDim NTB(Len(Base64Str))
'
'For i = 1 To Len(Base64Str) Step 4
' elm.text = Mid(Base64Str, i, 4)
' For j = 0 To 2
' NTB(k) = elm.nodeTypedValue(j)
' k = k + 1
' Next
'Next
'1 2 4 8 16 32
'ReDim Preserve NTB(k)
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
DecodeBase64ToFile = ret
End Function
'-----------------------------------------------------------------
' Sub B64ファイル分割(Read_File, Save_File, 分割行数 As Long)
'-----------------------------------------------------------------
' メモ：2022/12/07 今回はファイルから読み込んでファイル分割する方法は採用しなかった。
'-----------------------------------------------------------------
Sub B64ファイル分割(Read_File, Save_File, 分割行数 As Long)
'Dim Read_File As String, Save_File As String
'Dim Rec As Integer
Dim buf() As Variant
Dim i As Long, j As Long
'Read_File = "C:\sample.csv" '←適当に変えてください(フルパス）
'Save_File = "C:\sample_" '←適当に変えてください（連番の手前まで）
'Rec = 2 '分割するときのヘッダを除いたレコード数
ReDim buf(1 To 分割行数)
i = 1
Open Read_File For Input As #1
Dim 連番付与ファイル名 As String
Dim wPath As String
wPath = Left(Save_File, Len(Save_File) - Len(".txt"))
Do Until EOF(1) = True '終端に達するまでループ
連番付与ファイル名 = wPath & "_" & Right("00" & i, 3) & ".txt"
Open 連番付与ファイル名 For Output As #2
For j = 1 To 分割行数 'データ読み込み
Line Input #1, buf(j)
If EOF(1) = True Then Exit For
Next j
For j = 1 To 分割行数 'データ書き込み
Write #2, buf(j)
Next
For j = 1 To 分割行数 'データ初期化
buf(j) = ""
Next
Close #2
i = i + 1
Loop
Close #1
End Sub
'「テキスト」は７２文字のあとvblfが１文字くっついている
Sub B64ファイル分割2(テキスト As String, Save_File As String, 分割行数 As Long)
On Error GoTo Catch
Dim buf As String
Dim i As Long, j As Long
Dim 連番付与ファイル名 As String
Dim wPath As String
wPath = Left(Save_File, Len(Save_File) - Len(".txt"))
j = 1
For i = 1 To Len(テキスト) Step 分割行数 * 73
Select Case True
Case i = 1
連番付与ファイル名 = wPath & "_001" & ".txt"
Open 連番付与ファイル名 For Output As #1
buf = Mid(テキスト, 1, 分割行数 * 73)
Case i Mod 分割行数 * 73 = 1
Close #1
j = j + 1
連番付与ファイル名 = wPath & "_" & Right("00" & j, 3) & ".txt"
Open 連番付与ファイル名 For Output As #1
buf = Mid(テキスト, i, 分割行数 * 73)
End Select
Print #1, buf;
Next
Close #1
Finally:
Exit Sub
Catch:
Debug.Print Err.Number, Err.Description
Stop
Resume
End Sub
'==================================================================================
' 機能概要： 特定のファイル（単一、複数）を指定したファイルに追加書きする
'----------------------------------------------------------------------------------
' 処理名称： Sub combineFiles1(sFolder As String,sFile as string, sCombineFileName As String)
' 引数説明： sFolder 任意のフォルダパス
' ： sFile ファイル名（*,?で対象ファイル名を絞り込むことが可能）
' ： sCombineFileName まとめる1ファイルのファイル名｡パスは不要｡
'==================================================================================
Sub combineFiles1(sFolder As String, sFile As String, sCombineFileName As String)
Dim FSO As Object
Dim oTS As TextStream '// TextStreamクラス
Dim oFolder As Folder '// フォルダ
Dim oFile As File '// ファイル
Dim iCharCode As Integer '// ファイル終端の文字コード
Dim oTsCombine As TextStream '// 書き込みファイル用のTextStreamクラス
Dim sRead As String '// 読み込みデータ
Dim sExtension As String '// 拡張子文字列
' フォルダがない場合
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(sFolder) Then
Else
' 以降を処理せず抜ける
Exit Sub
End If
' 指定フォルダをFolderオブジェクトとして取得
Set oFolder = FSO.GetFolder(sFolder)
' まとめるファイルを新規ファイルとして作成
Set oTsCombine = FSO.CreateTextFile(oFolder.Path & "\" & sCombineFileName, True, False)
' カレントフォルダ内の全ファイルを１ファイルずつ取得
For Each oFile In oFolder.Files
' 作成するファイルの場合
If oFile.Name = sCombineFileName Then
' 読み込み対象からは除外する
GoTo Continue
End If
If oFile.Name Like sFile Then
Else
' 読み込み対象からは除外する
GoTo Continue
End If
' ファイルを開く
Set oTS = FSO.OpenTextFile(oFile.Path, ForReading)
' データを全て新規ファイルに書き込み
sRead = oTS.ReadAll
Call oTsCombine.Write(sRead)
' ファイルにデータがある場合
If oFile.size > 0 Then
' 終端文字の文字コードを取得（終端が全角文字の考慮でAscWを利用）
iCharCode = AscW(Right(sRead, 1))
Else
iCharCode = -1
End If
Call oTS.Close
' ファイル終端が改行コード（CR(13)、LF(10)）ではない場合
If (iCharCode <> 13 And iCharCode <> 10) Then
' 改行コードを書き込む
Call oTsCombine.Write(vbCrLf)
End If
Continue:
Next
Call oTsCombine.Close
End Sub
'==================================================================================
' 機能概要： 複数のファイルを指定したファイルに追加書きする
'----------------------------------------------------------------------------------
' 処理名称： Sub combineFiles(sFolder As String, sCombineFileName As String)
' 引数説明： sFolder 任意のフォルダパス
' ： sCombineFileName まとめる1ファイルのファイル名｡パスは不要｡
'==================================================================================
Sub combineFiles(sFolder As String, sCombineFileName As String)
Dim oFSO As Object
Dim oTS As TextStream '// TextStreamクラス
Dim oFolder As Folder '// フォルダ
Dim oFile As File '// ファイル
Dim iCharCode As Integer '// ファイル終端の文字コード
Dim oTsCombine As TextStream '// 書き込みファイル用のTextStreamクラス
Dim sRead As String '// 読み込みデータ
Dim sExtension As String '// 拡張子文字列
' フォルダがない場合
Set oFSO = CreateObject("Scripting.FileSystemObject")
If (oFSO.FolderExists(sFolder) = False) Then
' 以降を処理せず抜ける
Exit Sub
End If
' 指定フォルダをFolderオブジェクトとして取得
Set oFolder = oFSO.GetFolder(sFolder)
' まとめるファイルを新規ファイルとして作成
'fso.CreateTextFile(FileName [, Overwrite] [, Unicode])
'folder.CreateTextFile(FileName [, Overwrite] [, Unicode])
Set oTsCombine = oFSO.CreateTextFile(oFolder.Path & "\" & sCombineFileName, True, False)
' カレントフォルダ内の全ファイルを１ファイルずつ取得
For Each oFile In oFolder.Files
' 作成するファイルの場合
If oFile.Name = sCombineFileName Then
' 読み込み対象からは除外する
GoTo Continue
End If
' ファイルを開く
Set oTS = oFSO.OpenTextFile(oFile.Path, ForReading)
' データを全て新規ファイルに書き込み
sRead = oTS.ReadAll
Call oTsCombine.Write(sRead)
' ファイルにデータがある場合
If oFile.size > 0 Then
' 終端文字の文字コードを取得（終端が全角文字の考慮でAscWを利用）
iCharCode = AscW(Right(sRead, 1))
Else
iCharCode = -1
End If
Call oTS.Close
' ファイル終端が改行コード（CR(13)、LF(10)）ではない場合
If (iCharCode <> 13 And iCharCode <> 10) Then
' 改行コードを書き込む
Call oTsCombine.Write(vbCrLf)
End If
Continue:
Next
Call oTsCombine.Close
End Sub