プログラムソースコード「エクセル画forBMP」

ExcelＶＢＡ＝エクセルマクロで作成されたゲームやフリーソフトのプログラムソースコードを公開しています。

Option Explicit
Option Base 1
Public FileOpenFlag As Boolean 'ファイルを開く処理中フラグ
Private MakeFlag As Boolean    'ファイルが指定されているフラグ
Private FileName As String   '対象ファイルのパス
Private DataBuf() As Byte    'ファイルのバイナリー収容配列
Private TrimRange1 As Range  'トリムパターン指定反映セル
Private TrimRange2 As Range  'トリムパターン結果反映セル
Public TrimFlagRange As Range
Private XpRange As Range     '
Private YpRange As Range     '
Private StartXpRange As Range
Private LastXpRange As Range
Private StartYpRange As Range
Private LastYpRange As Range
Private TrimXpRange As Range
Private TrimYpRange As Range

Private TrimFlagX As Boolean  'トリムXの必要フラッグ
Private TrimFlagY As Boolean  'トリムYの必要フラッグ
Private XP As Long           '画像の横ピクセル
Private Yp As Long           '画像の縦ピクセル
Private StartXp As Long      'トリム用座標
Private LastXp As Long
Private StartYp As Long
Private LastYp As Long
Private R() As Byte
Private G() As Byte
Private B() As Byte

Sub SetRange()
    Set TrimRange1 = Range("p11")
    Set TrimRange2 = Range("p12")
    Set TrimFlagRange = Range("G13")
    Set XpRange = Range("g10")
    Set YpRange = Range("g11")
    Set StartXpRange = Range("g17")
    Set LastXpRange = Range("i17")
    Set StartYpRange = Range("g18")
    Set LastYpRange = Range("i18")
    Set TrimXpRange = Range("m17")
    Set TrimYpRange = Range("m18")

End Sub
Sub ImageTrim()

    'トリムの計算
    TrimFlagX = (XP > 255)
    TrimFlagY = (Yp > 255)

    If TrimFlagX = True Or TrimFlagY = True Then
        TrimFlagRange.Value = "あり"
        ActiveSheet.Image1.PictureAlignment = TrimRange1.Value - 1
    Else
        TrimFlagRange.Value = "なし"
        ActiveSheet.Image1.PictureAlignment = 2
        TrimRange1.Value = 3
    End If

    If TrimFlagX = True Then
        Select Case TrimRange1.Value
            Case 1  '左上
                StartXp = 1
                LastXp = 255
            Case 2  '右上
                StartXp = XP - 255 + 1
                LastXp = XP
            Case 3  '中央
                StartXp = Int((XP - 255) / 2)
                LastXp = StartXp + 254
            Case 4  '左下
                StartXp = 1
                LastXp = 255
            Case 5  '右下
                StartXp = XP - 255 + 1
                LastXp = XP
        End Select
    Else
        StartXp = 1
        LastXp = XP
    End If

    If TrimFlagY = True Then
        Select Case TrimRange1.Value
            Case 1  '左上
                StartYp = 1
                LastYp = 255
            Case 2  '右上
                StartYp = 1
                LastYp = 255
            Case 3  '中央
                StartYp = Int((Yp - 255) / 2)
                LastYp = StartYp + 254
            Case 4  '左下
                StartYp = Yp - 255 + 1
                LastYp = Yp
            Case 5  '右下
                StartYp = Yp - 255 + 1
                LastYp = Yp
        End Select
    Else
        StartYp = 1
        LastYp = Yp
    End If
    StartXpRange.Value = StartXp
    LastXpRange.Value = LastXp
    StartYpRange.Value = StartYp
    LastYpRange.Value = LastYp
    TrimXpRange.Value = LastXp - StartXp + 1
    TrimYpRange.Value = LastYp - StartYp + 1

End Sub
Sub FileOpen()
'BMPデータ構造
'　19　横画数下位バイト
'　20　横画数上位バイト
'　23　縦画数下位バイト
'　24　縦画数上位バイト

'55 色データ開始
'55　Ｒ
'56　Ｇ
'57　Ｂ
'１ラインの終わりには4の倍数に合わせ００が入る」
'データは左下→右下
'　　　　左上→右上
    On Error GoTo ErrHnd

    Dim x As Long
    Dim y As Long

    Dim DWcount As Byte
    Dim count As Long
    Dim count2 As Long

    SetRange
    FileOpenFlag = True

    FileName = Application.GetOpenFilename("ビットマップファイル (*.bmp), *.bmp")
    'If FileName = False Then
    '    Exit Sub
    If FileLen(FileName) > 0 Then
        ReDim DataBuf(1 To FileLen(FileName)) As Byte
    End If

    MakeFlag = True

    Open FileName For Binary As #1
        Get #1, , DataBuf
    Close #1

    If DataBuf(29) <> 24 Then
        MsgBox "24bitのBMPのみ対応です"
        Exit Sub
    End If

    '画像横画数
    XP = DataBuf(20) * 256 + DataBuf(19)
    Yp = DataBuf(24) * 256 + DataBuf(23)
    XpRange.Value = XP
    YpRange.Value = Yp
        'MsgBox x & "×" & y
    If XP > 255 Then
        MsgBox "縦横255dotまで有効です"
    End If

    Select Case ((XP * 3) Mod 4)
        Case 0
            DWcount = 0
        Case 1
            DWcount = 3
        Case 2
            DWcount = 2
        Case 3
            DWcount = 1
    End Select

    ReDim R(1 To Yp, 1 To XP) As Byte
    ReDim G(1 To Yp, 1 To XP) As Byte
    ReDim B(1 To Yp, 1 To XP) As Byte

    For y = Yp To 1 Step -1
        For x = 1 To XP
            count = (y - 1) * (XP * 3 + DWcount)
            count2 = (x - 1) * 3 + 54
            B(Yp + 1 - y, x) = DataBuf(count + count2 + 1)
            G(Yp + 1 - y, x) = DataBuf(count + count2 + 2)
            R(Yp + 1 - y, x) = DataBuf(count + count2 + 3)
        Next x
    Next y
    ImageTrim
    ActiveSheet.Image1.Picture = LoadPicture(FileName)

    FileOpenFlag = False

ErrHnd:
    Exit Sub
End Sub
Sub MakeSheet()

    If MakeFlag = False Then
        MsgBox "24bitのBMPファイルを選択して下さい。"
        Exit Sub
    End If

    Dim x As Long
    Dim y As Long

    Workbooks.Add
    Range(Cells(1, 1), Cells(LastYp - StartYp + 1, LastXp - StartXp + 1)).Select
    Selection.ColumnWidth = 1.63
    Selection.RowHeight = 13.5

    Application.ScreenUpdating = False
    ActiveWindow.Zoom = True
    Application.ScreenUpdating = False

    Range("A1").Select
    For y = StartYp To LastYp
        For x = StartXp To LastXp
            Cells(y - StartYp + 1, x - StartXp + 1).Interior.Color = RGB(R(y, x), G(y, x), B(y, x))
        Next x
        Application.ScreenUpdating = True
        Application.ScreenUpdating = False
    Next y

    MsgBox "エクセル画が完成しました"

End Sub

Sub Clear()

End Sub

プログラムソースコード館＞実用ソフト＞エクセル画forBMP