(Excel VBA)SHIFT‐JISでエンコードされたバイナリデータファイルを作成するコードについて - tsukimisoba/Blog GitHub Wiki

2025/06/20

SHIFT-JISでエンコードされたバイナリデータファイルを作成するコードについて

' PersonDataを表現する構造体
Public Type PersonData
    Name As String
    Age As Long
End Type

' バイナリファイル処理用のモジュール
Public Module BinaryFileHandler

    ' 定数定義
    Private Const NAME_SIZE As Integer = 10
    Private Const AGE_SIZE As Integer = 4
    Private Const RECORD_SIZE As Integer = NAME_SIZE + AGE_SIZE

    ' Excel VBAでのバイナリファイル書き込み
    Public Sub WritePersonsToFile(filePath As String, persons() As PersonData)
        Dim fileNum As Integer
        Dim i As Integer
        
        ' ファイル番号を取得
        fileNum = FreeFile
        
        ' バイナリモードでファイルを開く
        Open filePath For Binary Access Write As #fileNum
        
        ' 各レコードを書き込み
        For i = LBound(persons) To UBound(persons)
            Call WritePersonRecord(fileNum, persons(i))
        Next i
        
        ' ファイルを閉じる
        Close #fileNum
    End Sub
    
    ' バイナリファイルから読み込み
    Public Function ReadPersonsFromFile(filePath As String) As PersonData()
        Dim fileNum As Integer
        Dim fileSize As Long
        Dim recordCount As Long
        Dim persons() As PersonData
        Dim i As Long
        
        ' ファイル番号を取得
        fileNum = FreeFile
        
        ' バイナリモードでファイルを開く
        Open filePath For Binary Access Read As #fileNum
        
        ' ファイルサイズを取得
        fileSize = LOF(fileNum)
        
        ' レコード数を計算
        recordCount = fileSize / RECORD_SIZE
        
        ' 配列を初期化
        If recordCount > 0 Then
            ReDim persons(1 To recordCount)
            
            ' 各レコードを読み込み
            For i = 1 To recordCount
                persons(i) = ReadPersonRecord(fileNum)
            Next i
        Else
            ReDim persons(1 To 0) ' 空の配列
        End If
        
        ' ファイルを閉じる
        Close #fileNum
        
        ReadPersonsFromFile = persons
    End Function
    
    ' 1レコード分のデータを書き込み
    Private Sub WritePersonRecord(fileNum As Integer, person As PersonData)
        Dim nameBytes() As Byte
        Dim ageBytes() As Byte
        
        ' 氏名を固定長バイト配列に変換
        nameBytes = GetFixedLengthNameBytes(person.Name)
        
        ' 年齢をバイト配列に変換（リトルエンディアン）
        ageBytes = LongToBytes(person.Age)
        
        ' バイナリデータを書き込み
        Put #fileNum, , nameBytes
        Put #fileNum, , ageBytes
    End Sub
    
    ' 1レコード分のデータを読み込み
    Private Function ReadPersonRecord(fileNum As Integer) As PersonData
        Dim person As PersonData
        Dim nameBytes(1 To NAME_SIZE) As Byte
        Dim ageBytes(1 To AGE_SIZE) As Byte
        
        ' 氏名部分を読み込み
        Get #fileNum, , nameBytes
        person.Name = GetStringFromBytes(nameBytes)
        
        ' 年齢部分を読み込み
        Get #fileNum, , ageBytes
        person.Age = BytesToLong(ageBytes)
        
        ReadPersonRecord = person
    End Function
    
    ' 文字列を固定長SHIFT-JISバイト配列に変換
    Private Function GetFixedLengthNameBytes(text As String) As Byte()
        Dim result(1 To NAME_SIZE) As Byte
        Dim textBytes() As Byte
        Dim i As Integer
        Dim copyLength As Integer
        
        ' 配列を0で初期化
        For i = 1 To NAME_SIZE
            result(i) = 0
        Next i
        
        If Len(text) > 0 Then
            ' SHIFT-JISバイト配列に変換
            textBytes = StrConv(text, vbFromUnicode)
            
            ' コピーする長さを決定（最大NAME_SIZE）
            copyLength = UBound(textBytes) - LBound(textBytes) + 1
            If copyLength > NAME_SIZE Then
                copyLength = NAME_SIZE
            End If
            
            ' バイトをコピー
            For i = 1 To copyLength
                result(i) = textBytes(i - 1 + LBound(textBytes))
            Next i
        End If
        
        GetFixedLengthNameBytes = result
    End Function
    
    ' SHIFT-JISバイト配列から文字列に変換
    Private Function GetStringFromBytes(bytes() As Byte) As String
        Dim i As Integer
        Dim endPos As Integer
        Dim validBytes() As Byte
        
        ' 0バイトまでの位置を検索
        endPos = 0
        For i = LBound(bytes) To UBound(bytes)
            If bytes(i) = 0 Then
                Exit For
            End If
            endPos = endPos + 1
        Next i
        
        If endPos = 0 Then
            GetStringFromBytes = ""
            Exit Function
        End If
        
        ' 有効なバイト部分だけを抽出
        ReDim validBytes(0 To endPos - 1)
        For i = 0 To endPos - 1
            validBytes(i) = bytes(i + LBound(bytes))
        Next i
        
        ' SHIFT-JISからUnicodeに変換
        GetStringFromBytes = StrConv(validBytes, vbUnicode)
    End Function
    
    ' Long値をバイト配列に変換（リトルエンディアン）
    Private Function LongToBytes(value As Long) As Byte()
        Dim result(1 To 4) As Byte
        
        result(1) = value And &HFF
        result(2) = (value \ &H100) And &HFF
        result(3) = (value \ &H10000) And &HFF
        result(4) = (value \ &H1000000) And &HFF
        
        LongToBytes = result
    End Function
    
    ' バイト配列をLong値に変換（リトルエンディアン）
    Private Function BytesToLong(bytes() As Byte) As Long
        Dim result As Long
        
        result = bytes(LBound(bytes)) + _
                 bytes(LBound(bytes) + 1) * &H100& + _
                 bytes(LBound(bytes) + 2) * &H10000 + _
                 bytes(LBound(bytes) + 3) * &H1000000
        
        BytesToLong = result
    End Function

End Module

' 使用例とテスト用のサブルーチン
Sub TestBinaryFileHandling()
    Dim persons(1 To 3) As PersonData
    Dim readPersons() As PersonData
    Dim filePath As String
    Dim i As Integer
    
    ' テストデータを作成
    persons(1).Name = "田中太郎"
    persons(1).Age = 25
    
    persons(2).Name = "佐藤花子"
    persons(2).Age = 30
    
    persons(3).Name = "山田次郎"
    persons(3).Age = 35
    
    ' ファイルパスを設定（Excelファイルと同じフォルダ）
    filePath = ThisWorkbook.Path & "\persons.dat"
    
    ' ファイルに書き込み
    Debug.Print "データをファイルに書き込み中..."
    Call WritePersonsToFile(filePath, persons)
    Debug.Print "書き込み完了"
    
    ' ファイルから読み込み
    Debug.Print "ファイルからデータを読み込み中..."
    readPersons = ReadPersonsFromFile(filePath)
    Debug.Print "読み込み完了"
    
    ' 読み込んだデータを表示
    Debug.Print "読み込んだデータ:"
    For i = LBound(readPersons) To UBound(readPersons)
        Debug.Print "氏名: " & readPersons(i).Name & ", 年齢: " & readPersons(i).Age
    Next i
    
    ' ワークシートにも出力
    Call OutputToWorksheet(readPersons)
End Sub

' ワークシートにデータを出力
Sub OutputToWorksheet(persons() As PersonData)
    Dim ws As Worksheet
    Dim i As Integer
    
    ' アクティブなワークシートを取得
    Set ws = ActiveSheet
    
    ' ヘッダーを設定
    ws.Cells(1, 1).Value = "氏名"
    ws.Cells(1, 2).Value = "年齢"
    
    ' データを出力
    For i = LBound(persons) To UBound(persons)
        ws.Cells(i - LBound(persons) + 2, 1).Value = persons(i).Name
        ws.Cells(i - LBound(persons) + 2, 2).Value = persons(i).Age
    Next i
End Sub