最終更新日：1999/08/10
ＢＡＳＥ６４のサンプルコード
Visual Basic V4で書いた，BASE64のENCODE/DECODEのサンプルプログラムです。
思いつきで，このコードを元にBASE64のEncode/Decodeを行うActiveX DLLを作ってみました。
詳細は，こちらをご覧下さい。
ＩＮＤＥＸ
利用方法
ＢＡＳＥ６４サンプルコード
注意書き
このサンプルコードの使い方
このサンプルコードは，BASE64のENCODE/DECODEを行います。
それぞれのコード変換を行うＴＯＰ関数は，base64encode／base64decodeになります。
受信したメールの変換を行う場合には，Base64Get／Base64Putのような前処理が必要になるでしょう。
- Sub base64encode(Bstr() As Byte, Blen As Long, B64str As String)
- 与えられたデータ列(Bstr())とデータ長(Blen)を，base64の規約に従って６ｂｉｔのASCII文字列(B64str)に変換します。
- Sub base64decode(B64str As String, Bstr() As Byte, BCnt As Long)
- base64の規約に従って変換された６ｂｉｔのASCII文字列(B64str)を復元して，データ列(Bstr())とデータ長(BCnt)を返します。
- Function Base64Get(Fname As String, inMailData As String, MailBody As Object) As Boolean
- 指定されたファイル名(Fname)を添付ファイル(Base64形式)として送信可能な形式にして，メールの本体のテキスト(inMailData)に付加してメール送信用のバッファオブジェクト(MailBody)のテキストプロパティに格納する。
メール送信用のバッファオブジェクトは，RichTextObjectとすること。
この関数の実行結果は，True（データ作成成功）/False（失敗）で返されます。
- Function Base64Put(Cmd1 As String, AnswerBody As Object, DirPos As String, Fname As String, Times As String, OptionDir As String) As Boolean
- メールとして受信した受信文字列(Cmd1)の添付ファイルを，指定したディレクトリ(OptionDir)に展開する。
展開された結果は，RichTextObjectのTextプロパティ(AnswerBody.Text)として得られます。
この関数の実行結果は，True（ファイル作成成功）/False（失敗）で返されます。
ＢＡＳＥ６４サンプルコード（'lib_base64.bas'）
ＩＣＰのテスト用に作成したＢＡＳＥ６４用のENCODE/DECODEライブラリです。
Attribute VB_Name = "lib_base64"
'-----------------------------------------------------
'Base64 for MIME [1996/10/06]
' 1996 (c) by H.Yokomizo
'-----------------------------------------------------
'
'-----------------------------------------------------
'ここはコメントを外して使って下さい。
'Const MailVersion = "TestMailer Ver0.1 By H.Y."
'Const MIMEbound = "-@-@-@- " & MailVersion & " -@-@-@-"
'
'Public POPContentType As String ' MIME Contents Type
'Dim DQ As String '(") コード:Chr(34)
'
'Const InpSize = 32767 ' Input$ Input Max Size
'-----------------------------------------------------
Option Explicit
Sub base64encode(Bstr() As Byte, Blen As Long, B64str As String)
'----------------------------------------------------------------
' BASE64 ENCODER [1996/04/27]
' 8bit Binary -> 6bit ASCII (A-Z,a-z,0-9,+,/,[=])
' + Bstr : 8bit Binary Data
' + Blen : Bstr Data Length
' - B64str : Base64 ASCII Code Data
'----------------------------------------------------------------
'Base64の符号化は，３バイト(24bit)のバイナリデータを6bit単位の
'４つのデータに分割して，それを0-63(A-Z,a-z,0-9,+,/,[=])を表現
'する文字列に割り付けることで行う。
' 15 B1 0 15 B2 0 15 B3 0
' |----|----| |----|----| |----|----|Binary 8Bit * 3
' Case0 Case1 Case2 Case3 (Bmode)
' |------|-- ----|---- --|------|Base64 6Bit * 4
'データの最終端には"="を付けることがある。
'これはデータが24bitの途中で終わったことを示し，
'（8bit:2，16bit:1，24bit:0）の"="を付加する。
'変換されたデータは，１行最大76byteの文字列となる。
'Base64の符号化は，元データから約３３％大きくなる。
'Base64についての詳細は，MIME,RFC1521,September 1993
'"http://www.cis.ohio-state.edu/htbin/rfc/rfc1521.html"
'を参照のこと。
'----------------------------------------------------------------
Dim Bmode As Integer 'バイナリデータの区切りモード(0-3)
Dim Cnt As Long 'バイナリデータのポインタ
Dim B1 As Byte '符号化するバイナリデータ
Dim RetVal As Integer
Dim Str1 As String
Dim m As Integer
Dim Pos As Integer
B64str = ""
Cnt = 0
Bmode = 0
Do Until Blen <= Cnt
' オペレーティング システムに制御を渡します。
If Fix(Cnt Mod 100) = 0 Then RetVal = DoEvents()
' Ｂｉｔデータの整形
B1 = Bstr(Cnt)
Select Case Bmode
Case 0
B1 = (&HFC And B1) \ 4 '上位6Bit
Case 1
B1 = (&H3 And B1) * 16 '下位2Bit
Cnt = Cnt + 1 ' +
If Blen > Cnt Then
B1 = B1 + (&HF0 And Bstr(Cnt)) \ 16 '上位4Bit
End If
Case 2
B1 = (&HF And B1) * 4 '下位4Bit
Cnt = Cnt + 1 ' +
If Blen > Cnt Then
B1 = B1 + (&HC0 And Bstr(Cnt)) \ 64 '上位2Bit
End If
Case 3
B1 = &H3F And B1 '下位6Bit
Cnt = Cnt + 1
End Select
'Base64文字列作成（符号化）
B64str = B64str & BinToB64(B1)
Bmode = Bmode + 1
If Bmode > 3 Then Bmode = 0
Loop
'終端記号"="の付加
Select Case Bmode
Case 0 '何も付け加えない?
B64str = B64str
Case 1, 2 '"=="
B64str = B64str & "=="
Case 3 '"="
B64str = B64str & "="
End Select
'改行による76バイトの整形[1996/10/09]
Str1 = ""
m = 0
Do Until Len(B64str) <= m * 76
Pos = m * 76 + 1
If Len(B64str) - Pos > 76 Then
Str1 = Str1 & Mid$(B64str, Pos, 76) & vbCrLf
Else
Str1 = Str1 & Mid$(B64str, Pos, Len(B64str) - m * 76) & vbCrLf
End If
m = m + 1
Loop
B64str = Str1
Debug.Print "Base64 Last Encode Mode = "; Bmode
End Sub
Sub base64decode(B64str As String, Bstr() As Byte, BCnt As Long)
'----------------------------------------------------------------
' BASE64 DECODER [1996/04/27]
' 6bit ASCII -> 8bit Binary
' in B64str : Base64 ASCII Code Data
' out Bstr : 8bit Binary Data
' out BCnt : Bstr Data Length
'----------------------------------------------------------------
'Base64のASCII文字列(A-Z,a-z,0-9,+,/,[=])をバイナリデータに戻す。
'変換を行うために必要な配列を確保すること。
'変換文字列の後に，Base64のASCII文字を入れないこと
'???大量のデータを扱う場合には，適切なコード分割を行うこと???
'???分割する場合には，文字列の最後に"="を付加すること???
'----------------------------------------------------------------
Dim Bmode As Integer 'バイナリデータの区切りモード(0-3)
Dim ACnt As Long 'ASCIIデータのポインタ
Dim B1 As Byte '作成されたバイナリデータ
Dim RetVal As Integer
ACnt = 0
BCnt = 0
Bmode = 0
Do Until (Mid$(B64str, ACnt + 1, 1) = "=" Or Len(B64str) <= ACnt)
' オペレーティング システムに制御を渡します。
If Fix(ACnt Mod 100) = 0 Then RetVal = DoEvents()
'ASCIIデータの数値化(0-63)
B1 = B64ToBin(Mid$(B64str, ACnt + 1, 1))
If B1 >= 0 And B1 <= 63 Then
'Base64バイナリ変換
Select Case Bmode
Case 0
Bstr(BCnt) = B1 * 4 '上位6Bit
Case 1
Bstr(BCnt) = Bstr(BCnt) + (B1 \ 16) '下位2Bit
BCnt = BCnt + 1 ' +
Bstr(BCnt) = (&HF And B1) * 16 '上位4Bit
Case 2
Bstr(BCnt) = Bstr(BCnt) + (B1 \ 4) '下位4Bit
BCnt = BCnt + 1 ' +
Bstr(BCnt) = (&H3 And B1) * 64 '上位2Bit
Case 3
Bstr(BCnt) = Bstr(BCnt) + B1 '上位6Bit
BCnt = BCnt + 1
End Select
Bmode = Bmode + 1
If Bmode > 3 Then Bmode = 0
End If
ACnt = ACnt + 1
Loop
End Sub
Function Base64Get(Fname As String, inMailData As String, MailBody As Object) As Boolean
'-----------------------------------------------------
' 添付ファイルの作成
'指定されたファイルを添付ファイル(Base64形式)として
'送信可能な形式に格納する。
' + Fname : パス付きのファイル名
' + inMailData : テキスト部の格納データ
' - MailBody : 送信用データを格納するバッファオブジェクト
' (警告:RichTextObjectにすること)
' Ret : True/False
'-----------------------------------------------------
Dim Flen As Long
Dim Rsize As Long
Dim FNum As Integer
Dim Bstr() As Byte
Dim Astr As String
Dim B64str As String
Dim Ftitle As String
Dim n As Integer
On Error GoTo ChkError
'ファイルの存在確認
Flen = FileLen(Fname)
If Flen <= 0 Then
MailBody.Text = Fname & ":File Access Error" & vbCrLf
Debug.Print MailBody.Text
Base64Get = False
Exit Function
End If
ReDim Bstr(Flen)
FNum = FreeFile '未使用のファイル番号を取得します。
Open Fname For Binary Access Read As #FNum 'ファイルを開きます。
' Input$での制限(32,767Byte)付きREAD
If Flen >= InpSize Then
n = 0
Astr = ""
B64str = ""
Do
Bstr = InputB$(InpSize - 1, #FNum)
base64encode Bstr, InpSize - 1, Astr
B64str = B64str & Astr
n = n + 1
Loop Until (Flen - n * (InpSize - 1)) < InpSize
Bstr = InputB$(Flen - n * (InpSize - 1), #FNum)
base64encode Bstr, Flen - n * (InpSize - 1), Astr
B64str = B64str & Astr
Else
Bstr = InputB$(Flen, #FNum)
base64encode Bstr, Flen, B64str
End If
Close #FNum ' ファイルを閉じます。
' Set a FileTitle
Ftitle = Fname
Do Until Len(Ftitle) <= 0
Debug.Print Ftitle
n = InStr(Ftitle, "\")
If n = 0 Then Exit Do
Ftitle = Mid(Ftitle, n + 1)
Loop
' Set Plain Text Part
MailBody.Text = _
vbCrLf & "--" & MIMEbound & vbCrLf & _
"Content-Type: Text/Plain; Charset=iso-2022-jp" & vbCrLf & _
vbCrLf & vbCrLf & inMailData & vbCrLf & vbCrLf
' Set Multi Part of base64
MailBody.Text = MailBody.Text & "--" & MIMEbound & vbCrLf
MailBody.Text = MailBody.Text & "Content-Type: application/octet-stream; name=" & _
DQ & Ftitle & DQ & vbCrLf
MailBody.Text = MailBody.Text & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf
MailBody.Text = MailBody.Text & B64str & vbCrLf & vbCrLf
MailBody.Text = MailBody.Text & "--" & MIMEbound & "--" & vbCrLf
Base64Get = True
Exit Function
ChkError:
MailBody.Text = Fname & ":" & Error$(Err) & vbCrLf
Debug.Print MailBody.Text
Base64Get = False
End Function
Function Base64Put(Cmd1 As String, _
AnswerBody As Object, _
DirPos As String, _
Fname As String, _
Times As String, _
OptionDir As String) As Boolean
'-----------------------------------------------------
'添付ファイルの展開[1996/10/06]
'指定されたディレクトリに添付ファイルを展開する
' + Cmd1 : 受信データ(2GBまで受信可)
' 32KB以上のデータ受信時のチェック要！
' - AnswerBody : Reply-Mail Body Object(RichTextObject)
' .Text = 実行結果メッセージ（Create or Error)
' - DirPos : Write Position
' - Fname : Base64 File Name
' - Times : Option Time
' + OptionDir : ""ならばメールのディレクトリを使う。それ以外
' なら，ここで指定したディレクトリを使う。
' Ret : True（ファイル作成成功）/False（失敗）
'-----------------------------------------------------
'注意書き
' 複数の添付ファイルには対応していません！。
' 一応AnswerBodyのTextプロパティがCmd1と同じでも大丈夫なはず！。
'-----------------------------------------------------
Dim Boundary As String
Dim Content1 As String
Dim Content2 As String
Dim Ftitle As String
Dim Str1 As String
Dim Str2 As String
Dim B64str As String
Dim Bstr() As Byte
Dim Blen As Long
Dim FNum As Integer
On Error GoTo ChkError
DirPos = ""
' MIME boundary Get
If InStr(POPContentType, "multipart/mixed;") > 0 Then
Str2 = SpritAString(POPContentType, DQ, Str1)
Str1 = SpritAString(Str2, DQ, Boundary)
If Len(Boundary) <= 0 Then
AnswerBody.Text = POPContentType & ";Error" & vbCrLf
Base64Put = False
Exit Function
End If
Else
AnswerBody.Text = POPContentType & ";Error" & vbCrLf
Base64Put = False
Exit Function
End If
' Content Analyze(Boundaryで２つに分ける)
Str1 = SpritAString(Cmd1, Boundary, Content1)
Content2 = SpritAString(Str1, Boundary, Content1)
' Command Check(Content1=メール本体部分)
'ディレクトリ設定オプション(OptionDir)の確認[1996/10/06]
If OptionDir <> "" Then
'指定があれば(<>"")指定されたディレクトリに展開
DirPos = OptionDir
Else
'指定がなければメール本体のディレクトリを利用
Do Until Len(Content1) <= 0
Content1 = SpritAString(Content1, vbCrLf, Str1)
If Len(Str1) > 0 Then
If InStr(Str1, "Content-") = 0 And InStr(Str1, "content-") = 0 Then
DirPos = Str1
TakeALine Content1, Times, Str1
Debug.Print "FILE PUT:" & DirPos & vbCrLf
Exit Do
End If
End If
Loop
End If
'ディレクトリの存在チェック
If DirExists(DirPos) = False Then
AnswerBody.Text = "Base64Put:Dir Error=" & DirPos & vbCrLf
Base64Put = False
Exit Function
End If
'対象ディレクトリに移動
ChDrive DirPos
ChDir DirPos
' Include File Check
Str1 = SpritAString(Content2, Boundary, Content1)
If Len(Str1) <= 0 Then
AnswerBody.Text = "Base64Put:Include Error" & vbCrLf
Base64Put = False
Exit Function
End If
' Base64 Content Check
Do Until Len(Content1) <= 0
Content1 = SpritAString(Content1, vbCrLf, Str1)
'ファイル名取得
If InStr(Str1, "application/octet-stream; name=") > 0 Then
Str1 = SpritAString(Str1, "name=", Str2)
Str2 = SpritAString(Str1, DQ, Fname)
If Str2 <> "" Then
Str1 = SpritAString(Str2, DQ, Fname)
End If
End If
' Base64変換Check
If InStr(Str1, "Base64") > 0 Or _
InStr(Str1, "BASE64") > 0 Or _
InStr(Str1, "base64") > 0 Then
Exit Do
End If
Loop
If Len(Content1) <= 0 Then
AnswerBody.Text = "Base64Put:Include Error" & vbCrLf
Base64Put = False
Exit Function
End If
'ファイル名設定
Ftitle = DirPos & "\" & Fname
Debug.Print "FILE = " & Ftitle & vbCrLf
'Base64変換文字列取得
Str1 = "?"
Do Until (Len(Str1) = 0)
If TakeALine(Content1, Str1, Content1) = False Then
AnswerBody.Text = "Base64Put:Base64 Strings Not Found." & vbCrLf
Base64Put = False
Exit Function
End If
Loop
Str1 = SpritAString(Content1, Boundary, B64str)
'Str1 = TakeAFirst(Content1, vbCrLf, B64str)
Debug.Print "Base64-Data:" & B64str & vbCrLf
If Len(B64str) <= 0 Then
AnswerBody.Text = "Base64Put:Base64 Strings Not Found!" & vbCrLf
Base64Put = False
Exit Function
End If
'Base64変換
ReDim Bstr(Len(B64str) * 2) As Byte
base64decode B64str, Bstr(), Blen
Debug.Print "Decode Size ="; Blen
ReDim Preserve Bstr(Blen - 1) As Byte
' Include File Write
FNum = FreeFile ' 未使用のファイル番号を取得します。
'Open Ftitle For Binary Access Write As #Fnum Len = Blen '---Lenの最大は32,767
Open Ftitle For Binary Access Write As #FNum 'BinaryAccessのためLenを削除[96/10/02]
Put #FNum, 1, Bstr
Close #FNum ' ファイルを閉じます。
AnswerBody.Text = Ftitle & ":Created" & vbCrLf
Base64Put = True
Exit Function
ChkError:
AnswerBody.Text = "Base64Put(" & DirPos & "):Error" & vbCrLf
Debug.Print AnswerBody.Text
Base64Put = False
End Function
Function BinToB64(B1 As Byte) As String
'----------------------------------------------------------------
' バイナリデータをBase64のASCIIデータへ変換する
' in B1 : Base64 Binary (0-63)
' return : Base64 Ascii Code
'----------------------------------------------------------------
Dim A1 As String
If B1 <= 25 Then A1 = Chr(Asc("A") + B1)
If B1 > 25 And B1 <= 51 Then A1 = Chr(Asc("a") + B1 - 26)
If B1 > 51 And B1 <= 61 Then A1 = Chr(Asc("0") + B1 - 52)
If B1 = 62 Then A1 = "+"
If B1 = 63 Then A1 = "/"
BinToB64 = A1
'Debug.Print B1; A1
End Function
Function B64ToBin(A1 As String) As Byte
'----------------------------------------------------------------
' Base64のASCIIデータをバイナリデータに変換する
' in A1 : Base64 Ascii Char(1Byte)
' return : Base64 Binary (0-63)
'文字列長が1でないときは255を返す。
'Base64対象文字以外は255を返す。
'----------------------------------------------------------------
Dim B1 As Byte
If Len(A1) <> 1 Then
B64ToBin = 255
Exit Function
End If
B1 = 255
If Asc(A1) >= Asc("A") And Asc(A1) <= Asc("Z") Then B1 = Asc(A1) - Asc("A") + 0
If Asc(A1) >= Asc("a") And Asc(A1) <= Asc("z") Then B1 = Asc(A1) - Asc("a") + 26
If Asc(A1) >= Asc("0") And Asc(A1) <= Asc("9") Then B1 = Asc(A1) - Asc("0") + 52
If A1 = "+" Then B1 = 62
If A1 = "/" Then B1 = 63
B64ToBin = B1
End Function
Function TakeALine(Str1 As String, Str2 As String, Str3 As String) As Boolean
'-------------------------------------------------
'文字列を改行コードで分けて返す。
' Str1 : 元の文字列
' Str2 : 最初の行（CRLFは含まない）
' Str3 : 残りの行
' 戻り値 : False=改行コード無,True=分割成功
'改行のみの場合，Str2は長さ0の文字列となる。
'-------------------------------------------------
'Calling:
' Ret = TakeALine(Text, First, Others)
' or
' Ret = TakeALine(ALL,First,ALL)
'-------------------------------------------------
Dim Pos As Integer
Pos = InStr(Str1, vbCrLf)
If Pos > 0 Then
TakeALine = True
Str2 = Left(Str1, Pos - 1)
Str3 = Mid(Str1, Pos + Len(vbCrLf), Len(Str1) - Pos - Len(vbCrLf) + 1)
Else
TakeALine = False
Str2 = ""
Str3 = ""
End If
End Function
Function SpritAString(ByVal Str1 As String, Str2 As String, Str3 As String) As String
'----------------------------------------------------------
'文字列を特定文字(vbCrLf,",",etc)で分けて返す。
' Str1 : 元の文字列
' Str2 : 特定文字(Ex,TAB,","," ",etc)
' Str3 : 最初の文字列（特定文字は含まない）
' 戻り値 : 残りの文字列（特定文字列が無いときは""を返す）
'----------------------------------------------------------
' Calling:
' Others = SpritAString(Source,SpritString,First)
'----------------------------------------------------------
Dim Pos As Integer
Pos = InStr(Str1, Str2)
If Pos > 0 Then
' 特定文字列が含まれていると，その文字列の前と後に文字列を分けて返す
Str3 = Left(Str1, Pos - 1)
SpritAString = Mid(Str1, Pos + Len(Str2), Len(Str1) - Pos - Len(Str2) + 1)
Else
' 特定文字列が含まれない時は元の文字列を最初の文字列としてそのまま返す
Str3 = Str1
SpritAString = ""
End If
End Function
注意書き
ＶＢを使う上での一般常識の無さはご勘弁下さい（なにせ日曜プログラマなもので）。
苦情も受け付けていますが，できれば「こうしたら上達するよっ」といった点を指摘していただけるとありがたいです。
バグリポートについては，この場に掲載させていただくことをご了承下さい。
サンプルコードへの反映については，将来的に対応するかもしれません，ということにさせて下さい。
とにかくＶＢ４で大容量の文字処理を行うことは実行時間上無理があることを実感したので，特にバージョンアップ等は考えていません。
このコードを用いて，WinBiffおよび電信８号との添付ファイルの送受信テストは，特に問題ありませんでした。
但し以下の項目については，若干から非常に．．．の間で怪しい場合があります。
- ３２ＫＢを越える添付ファイルのENCODE/DECODE
- ASCII"8.3"形式以外を添付ファイル名とした場合
- とにかく異常処理全般
サンプルコードの関数のコメント内に"+","-"とあるのは，引数がその関数に対してIN("+")あるいはOUT("-")のデータを持つことを示します。
（もちろん関数の戻り値(Return)はOUT("-")になります）
本来ならByRef，ByVal等を付けた方が良かったと思いますが，昔からのクセで使ってますのでご了解下さい。
戻る
技術的なメモのＩＮＤＥＸへ
(c) 1996 H.Yokomizo All Right Reserved.
