VBA bmp

Option Explicit

Public Type RGBTRIPLE
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
End Type

Private Type BITMAPFILEHEADER
    bfType As String * 2
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bjOffBits As Long
End Type
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImaze As Long
    biXPixPerMeter As Long
    biYPixPerMeter As Long
    biClrUsed As Long
    biClrImporant As Long
End Type

Public bjHeader As BITMAPFILEHEADER
Public biHeader As BitmapInfoHeader

Public Function ReadBitmap(strFileName As String) As RGBTRIPLE()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim intFileNumber As Integer
    Dim lngColors As Long
    Dim rgbData() As RGBTRIPLE
    Dim rgbTemp As RGBTRIPLE
    Dim bytTemp As Byte
    
    intFileNumber = FreeFile()
    Open strFileName For Binary As intFileNumber
        Get intFileNumber, , bjHeader
        Get intFileNumber, , biHeader
        
        ReDim rgbData(0 To biHeader.biHeight - 1, 0 To biHeader.biWidth - 1) As RGBTRIPLE
        n = (4 - (-(Int(-biHeader.biWidth * (biHeader.biBitCount / 8))) Mod 4)) Mod 4
        lngColors = IIf(biHeader.biClrUsed = 0, 2 ^ biHeader.biBitCount, biHeader.biClrUsed)
        
        
        For i = UBound(rgbData, 1) To 0 Step -1
            For j = 0 To UBound(rgbData, 2)
                Get intFileNumber, , rgbData(i, j)
            Next
            For j = 1 To n
                Get intFileNumber, , bytTemp
            Next
        Next
    Close
    
    ReadBitmap = rgbData
End Function
Public Sub WriteBitmapTurn90(strFileName As String, rgbData() As RGBTRIPLE)
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim intFileNumber As Integer
    Dim bytTemp As Byte
    
    lngHeight = UBound(rgbData, 1) + 1
    lngWidth = UBound(rgbData, 2) + 1
    n = (4 - (lngHeight * 3 Mod 4)) Mod 4
    
    With bjHeader
        .bfSize = Len(bjHeader) + Len(biHeader) + 3 * lngHeight * lngWidth + n * lngWidth
        .bjOffBits = Len(bjHeader) + Len(biHeader)
    End With
    With biHeader
        .biWidth = lngHeight
        .biHeight = lngWidth
        .biSizeImaze = bjHeader.bfSize - Len(bjHeader) - Len(biHeader)
    End With
    
    If Len(Dir(strFileName)) Then
        Kill strFileName
    End If
    
    intFileNumber = FreeFile()
    Open strFileName For Binary As intFileNumber
        Put intFileNumber, , bjHeader
        Put intFileNumber, , biHeader
        
        For i = lngWidth - 1 To 0 Step -1
            For j = 0 To lngHeight - 1
                Put intFileNumber, , rgbData(j, i)
            Next
            For j = 1 To n
                Put intFileNumber, , bytTemp
            Next
        Next
    Close
End Sub

-----------------------------------------------------------

Sub Main()
    'ファイル選択ダイアログでファイルを指定
    Dim vFilePath As Variant
    Dim fileName As String
    Dim rgbData() As RGBTRIPLE
    
    vFilePath = Application.GetOpenFilename
    If vFilePath = False Then
        End
    End If
 
    'ファイルサイズが０バイトの場合は処理終了
    Dim nFileLen As Long
    nFileLen = FileLen(vFilePath)
    If nFileLen = 0 Then
        End
    End If
        
    fileName = vFilePath
    rgbData = ReadBitmap(fileName)
    Call WriteBitmapTurn90("2.bmp", rgbData)
 
End Sub

Private Sub CommandButton1_Click()
  Call Main
End Sub