VBAでBitmap画像をつくって何か描いてみる(AccessでもExcelでもWordでも)

戻る

並べるのはボタン4つにイメージコントロール1つ(つくるのが面倒だったらサンプルはこちら)
コードはWEB上での拾いものを適当に加工しただけで、中身の多くは自分でも理解できてません。

API関数の引数用Constは使った分のみ記述(本当はすごくいっぱいある。こちらに隔離しておきます)

あと色指定の書き方。
ここでは、RGB(r, g, b)でやってますが、vbRed, vbGreenみたいな書き方でも、整数値一発でもいけるはずです。

とりあえずOfficeVBAでも出来ないわけじゃないんだなと、これは単なる確認作業。
さらに深く突っ込むのは自分には無理(VBAからWindowsAPIフルに使ってまともな画像加工ソフトつくる人がいたら、皮肉でもなんでもなく本気で拍手ものだと思います)
Option Compare Database '←Excel, Wordでは不要
Option Explicit

Private Type BITMAPFILEHEADER
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    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
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
End Type
'↑の3つのTypeは必須


'↓線を描くときに使用
Private Type POINTAPI
    x As Long
    y As Long
End Type

'↓ここでは文字入れに使用。他にもいろいろ使い道はありそう
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


'以下API関数。Bitmapファイルを作る以上、最初の7つは何があろうと必須
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pbmi As BITMAPINFO, _
                                                    ByVal iUsage As Long, ByVal ppvBits As Long, _
                                                    ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, _
                                                ByVal nStartScan As Long, ByVal nNumScans As Long, _
                                                lpBits As Any, lpBI As BITMAPINFO, _
                                                ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long


'↓線や図形を描くのに必要
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle As Long, ByVal nWidth As Long, _
                                                    ByVal crColor As Long) As Integer

'↓塗りつぶしに必要
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long


'↓四角形描画
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, _
                                                ByVal X1 As Long, ByVal Y1 As Long, _
                                                ByVal X2 As Long, ByVal Y2 As Long) As Long

'↓楕円形描画
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal hdc As Long, _
                                                ByVal nLeftRect As Long, ByVal nTopRect As Long, _
                                                ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
'↓以下2つは線を引くのに必要
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, _
                                            ByVal x As Long, ByVal y As Long, _
                                            ByRef lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, _
                                                ByVal nXEnd As Long, ByVal nYEnd As Long) As Integer

'↓以下4つは文字入れに必要
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, _
                                                                    ByVal nWidth As Long, _
                                                                    ByVal nEscapement As Long, _
                                                                    ByVal nOrientation As Long, _
                                                                    ByVal fnWeight As Long, _
                                                                    ByVal IfdwItalic As Long, _
                                                                    ByVal fdwUnderline As Long, _
                                                                    ByVal fdwStrikeOut As Long, _
                                                                    ByVal fdwCharSet As Long, _
                                                                    ByVal fdwOutputPrecision As Long, _
                                                                    ByVal fdwClipPrecision As Long, _
                                                                    ByVal fdwQuality As Long, _
                                                                    ByVal fdwPitchAndFamily As Long, _
                                                                    ByVal lpszFace As String) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _
                                                                ByVal lpStr As String, _
                                                                ByVal nCount As Long, _
                                                                lpRect As RECT, _
                                                                ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Integer



'以下、定数。とりあえずここで使うものだけ(実際にはうんざりするほど沢山ある)

'↓線の種類
Private Const PS_SOLID = 0
'PS_DASH = 1 とか PS_DOT = 2 とか色々あるんだけど、やってみても全然効かない。
'もう面倒だからこんな定数使わずに引数決め打ちゼロでもいいと思う。

'↓塗りつぶし方
Private Const WHITE_BRUSH = 0
Private Const GRAY_BRUSH = 2
Private Const BLACK_BRUSH = 4

'↓文字入れに関していろいろ
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_SCRIPT = 64
Private Const DT_CENTER = &H1
Private Const DT_SINGLELINE = &H20


'↓てきとうに決めたBitmapのサイズ
Private Const CWIDTH = 320
Private Const CHEIGHT = 240

Private Sub DeleteTmpBMP(strFile As String) 'これは必要ないかも(ざっと見たところ、残したままでも上書きしてる)

    Dim MyFSO As Variant '実はVariantじゃなくObjectなんじゃないかと最近気づいた(どっちでも動く。As以下省略でも動く)

    
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    If MyFSO.FileExists(strFile) = True Then
        MyFSO.DeleteFile strFile
    End If
    Set MyFSO = Nothing
End Sub

Private Sub CommandButton0_Click() 'とりあえずまっさらのBitmapをつくってみる(生まれたては真っ黒)
    Dim MyStrFile As String
    Dim MyDC0, MyDC1 As Long
    Dim MyBMP As Long
    Dim MyBMPInf As BITMAPINFO
    Dim MyBMPFLHdr As BITMAPFILEHEADER
    Dim MyBMPBits() As Byte
    Dim MyFNUM As Long
    
    MyStrFile = ThisWorkbook.Path & "\tmp00.bmp" 'Excelの場合
    MyStrFile = ActiveDocument.Path & "\tmp00.bmp" 'Wordの場合
    MyStrFile = CurrentProject.Path & "\tmp00.bmp" 'Accessの場合

    Call DeleteTmpBMP(MyStrFile) '←この1行はたぶん省略可
    MyDC0 = GetDC(0&)
    MyDC1 = CreateCompatibleDC(MyDC0)
    With MyBMPInf.bmiHeader
        .biSize = 40 '←意味不明(書かないと怒られる)
        .biWidth = CWIDTH
        .biHeight = CHEIGHT
        .biPlanes = 1
        .biBitCount = 24 '32でも24でも8でも4でも好きなように(8だと256色、4だと16色しか使えないけど)
    End With
    MyBMP = CreateDIBSection(MyDC1, MyBMPInf, 0, 0, 0, 0)
    Call SelectObject(MyDC1, MyBMP)
    
    '↓
    
    'いろいろ描きたいときは、ここに処理を書く
    
    '↑
        
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)
    ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
    MyFNUM = FreeFile
    Open MyStrFile For Binary As #MyFNUM
    With MyBMPFLHdr
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(MyBMPFLHdr) + Len(MyBMPInf) + UBound(MyBMPBits) + 1
        .bfOffBits = Len(MyBMPFLHdr) + Len(MyBMPInf)
    End With
    Put #MyFNUM, , MyBMPFLHdr
    Put #MyFNUM, , MyBMPInf
    Put #MyFNUM, , MyBMPBits
    Close #MyFNUM

    Call DeleteObject(MyBMP)
    Call DeleteObject(MyDC1)
    Call ReleaseDC(0&, MyDC0)
    
    Image1.Picture = LoadPicture(MyStrFile) 'Excel, Wordの場合
    Image1.Picture = MyStrFile 'Accessの場合
End Sub

Private Sub CommandButton1_Click() '真っ黒のままでは描画しにくいので真っ白に染めてみる
    Dim MyStrFile As String
    Dim MyDC0, MyDC1 As Long
    Dim MyBMP As Long
    Dim MyPen As Long
    Dim MyBrush As Long
    Dim MyBMPInf As BITMAPINFO
    Dim MyBMPFLHdr As BITMAPFILEHEADER
    Dim MyBMPBits() As Byte
    Dim MyFNUM As Long
    
    MyStrFile = ThisWorkbook.Path & "\tmp00.bmp" 'Excelの場合
    MyStrFile = ActiveDocument.Path & "\tmp00.bmp" 'Wordの場合
    MyStrFile = CurrentProject.Path & "\tmp00.bmp" 'Accessの場合

    Call DeleteTmpBMP(MyStrFile)
    MyDC0 = GetDC(0&)
    MyDC1 = CreateCompatibleDC(MyDC0)
    With MyBMPInf.bmiHeader
        .biSize = 40
        .biWidth = CWIDTH
        .biHeight = CHEIGHT
        .biPlanes = 1
        .biBitCount = 24
    End With
    MyBMP = CreateDIBSection(MyDC1, MyBMPInf, 0, 0, 0, 0)
    Call SelectObject(MyDC1, MyBMP)
    '↑ここまでの処理は共通
    
    
    MyPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255)) 'ペンを決めて(白)
    Call SelectObject(MyDC1, MyPen)
    MyBrush = GetStockObject(WHITE_BRUSH) '塗りつぶし方を決めて(白)
    Call SelectObject(MyDC1, MyBrush)
    Call Rectangle(MyDC1, 0, 0, CWIDTH, CHEIGHT) 'Bitmapと同じ大きさの四角形を描く(とうぜん真っ白になる)
    
    '用済みになったペンとブラシを破棄
    Call DeleteObject(MyPen)
    Call DeleteObject(MyBrush)
    
        
    '↓ここからの処理は共通
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)
    ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
    MyFNUM = FreeFile
    Open MyStrFile For Binary As #MyFNUM
    With MyBMPFLHdr
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(MyBMPFLHdr) + Len(MyBMPInf) + UBound(MyBMPBits) + 1
        .bfOffBits = Len(MyBMPFLHdr) + Len(MyBMPInf)
    End With
    Put #MyFNUM, , MyBMPFLHdr
    Put #MyFNUM, , MyBMPInf
    Put #MyFNUM, , MyBMPBits
    Close #MyFNUM

    Call DeleteObject(MyBMP)
    Call DeleteObject(MyDC1)
    Call ReleaseDC(0&, MyDC0)
    
    Image1.Picture = LoadPicture(MyStrFile) 'Excel, Wordの場合
    Image1.Picture = MyStrFile 'Accessの場合
End Sub

Private Sub CommandButton2_Click() '図形や線を描いてみる
    Dim MyStrFile As String
    Dim MyDC0, MyDC1 As Long
    Dim MyBMP As Long
    Dim MyPen As Long
    Dim MyBrush As Long
    Dim MyPnt As POINTAPI
    Dim MyBMPInf As BITMAPINFO
    Dim MyBMPFLHdr As BITMAPFILEHEADER
    Dim MyBMPBits() As Byte
    Dim MyFNUM As Long
    
    MyStrFile = ThisWorkbook.Path & "\tmp00.bmp" 'Excelの場合
    MyStrFile = ActiveDocument.Path & "\tmp00.bmp" 'Wordの場合
    MyStrFile = CurrentProject.Path & "\tmp00.bmp" 'Accessの場合

    Call DeleteTmpBMP(MyStrFile)
    MyDC0 = GetDC(0&)
    MyDC1 = CreateCompatibleDC(MyDC0)
    With MyBMPInf.bmiHeader
        .biSize = 40
        .biWidth = CWIDTH
        .biHeight = CHEIGHT
        .biPlanes = 1
        .biBitCount = 24
    End With
    MyBMP = CreateDIBSection(MyDC1, MyBMPInf, 0, 0, 0, 0)
    Call SelectObject(MyDC1, MyBMP)
    '↑ここまでの処理は共通
    
    
    
     'まずは真っ白に塗りつぶし
    MyPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))
    Call SelectObject(MyDC1, MyPen)
    MyBrush = GetStockObject(WHITE_BRUSH)
    Call SelectObject(MyDC1, MyBrush)
    Call Rectangle(MyDC1, 0, 0, CWIDTH, CHEIGHT)
    Call DeleteObject(MyPen) '次に描こうとしているものは違う色の線だったり、違う色の塗りつぶし方だったりするので
    Call DeleteObject(MyBrush) 'とりあえずペンとブラシを破棄
    
    
    'あらためてペンとブラシを用意して円形描画
    MyPen = CreatePen(PS_SOLID, 6, RGB(255, 0, 0))
    Call SelectObject(MyDC1, MyPen)
    MyBrush = GetStockObject(BLACK_BRUSH)
    Call SelectObject(MyDC1, MyBrush)
    Call Ellipse(MyDC1, 100, 110, 200, 210)
    Call DeleteObject(MyPen) 'ペンとブラシ破棄
    Call DeleteObject(MyBrush)
    
    
    'あらためてペンとブラシを用意して四角形描画
    MyPen = CreatePen(PS_SOLID, 10, RGB(0, 0, 255))
    Call SelectObject(MyDC1, MyPen)
    MyBrush = GetStockObject(GRAY_BRUSH)
    Call SelectObject(MyDC1, MyBrush)
    Call Rectangle(MyDC1, 10, 50, 60, 100)
    Call DeleteObject(MyPen) 'ペンとブラシ破棄
    Call DeleteObject(MyBrush)
    
    'あらためてペンを用意して直線引き
    MyPen = CreatePen(PS_SOLID, 2, RGB(0, 255, 0))
    Call SelectObject(MyDC1, MyPen)
    Call MoveToEx(MyDC1, 150, 50, MyPnt) 'スタート地点を決めて
    Call LineTo(MyDC1, 300, 50) 'ここまで線を引く
    Call DeleteObject(MyPen) 'ペンを破棄
    
        
    '↓ここからの処理は共通
    '正直いって何やってるのかさっぱりわからない
    '何となく、空中に浮かんだキャンバスから虚無のビットマップファイルに絵柄をうつしている感じ
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)
    ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
    MyFNUM = FreeFile
    Open MyStrFile For Binary As #MyFNUM
    With MyBMPFLHdr
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(MyBMPFLHdr) + Len(MyBMPInf) + UBound(MyBMPBits) + 1
        .bfOffBits = Len(MyBMPFLHdr) + Len(MyBMPInf)
    End With
    Put #MyFNUM, , MyBMPFLHdr
    Put #MyFNUM, , MyBMPInf
    Put #MyFNUM, , MyBMPBits
    Close #MyFNUM

    '何やってるかわからなくてもとにかく用済みになったものは破棄するのがこの世界の掟
    Call DeleteObject(MyBMP)
    Call DeleteObject(MyDC1)
    Call ReleaseDC(0&, MyDC0)
    
    Image1.Picture = LoadPicture(MyStrFile) 'Excel, Wordの場合
    Image1.Picture = MyStrFile 'Accessの場合
End Sub

Private Sub CommandButton3_Click() '文字を入れてみる
    Dim MyStrFile As String
    Dim MyDC0, MyDC1 As Long
    Dim MyBMP As Long
    Dim MyPen As Long
    Dim MyBrush As Long
    Dim MyFont As Long
    Dim MyFntFamily As String
    Dim MyRct As RECT
    Dim MyBMPInf As BITMAPINFO
    Dim MyBMPFLHdr As BITMAPFILEHEADER
    Dim MyBMPBits() As Byte
    Dim MyFNUM As Long
    
    MyStrFile = ThisWorkbook.Path & "\tmp00.bmp" 'Excelの場合
    MyStrFile = ActiveDocument.Path & "\tmp00.bmp" 'Wordの場合
    MyStrFile = CurrentProject.Path & "\tmp00.bmp" 'Accessの場合

    Call DeleteTmpBMP(MyStrFile)
    MyDC0 = GetDC(0&)
    MyDC1 = CreateCompatibleDC(MyDC0)
    With MyBMPInf.bmiHeader
        .biSize = 40
        .biWidth = CWIDTH
        .biHeight = CHEIGHT
        .biPlanes = 1
        .biBitCount = 24
    End With
    MyBMP = CreateDIBSection(MyDC1, MyBMPInf, 0, 0, 0, 0)
    Call SelectObject(MyDC1, MyBMP)
    '↑ここまでの処理は共通
    
    
    'まずは真っ白に塗りつぶし
    MyPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))
    Call SelectObject(MyDC1, MyPen)
    MyBrush = GetStockObject(WHITE_BRUSH)
    Call SelectObject(MyDC1, MyBrush)
    Call Rectangle(MyDC1, 0, 0, CWIDTH, CHEIGHT)
    Call DeleteObject(MyPen) 'ペンとブラシ破棄
    Call DeleteObject(MyBrush)
    
    

    '以下、文字入れ。
    '文字を入れるだけならペンはいらない。
    '用意するのはフォント
    MyFont = CreateFont(18, 0, 0, 0, FW_NORMAL, _
            0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, _
            CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
            DEFAULT_PITCH Or FF_SCRIPT, MyFntFamily)
    Call SelectObject(MyDC1, MyFont)
    
    MyRct.Left = 10 '限界ワクを決めて
    MyRct.Top = 50
    MyRct.Right = 310
    MyRct.Bottom = 75
    Call SetTextColor(MyDC1, RGB(255, 0, 0)) '文字色を決めて
    Call SetBkColor(MyDC1, RGB(0, 0, 0)) '背景色を決めて
    Call DrawText(MyDC1, "あいうえおかきくけこ", -1, MyRct, DT_CENTER Or DT_SINGLELINE)
    
    MyRct.Top = 70
    MyRct.Bottom = 95
    Call SetTextColor(MyDC1, RGB(255, 255, 255))
    Call SetBkColor(MyDC1, RGB(0, 255, 0))
    Call DrawText(MyDC1, "さしすせそたちつてとなにぬねの", -1, MyRct, DT_CENTER Or DT_SINGLELINE)
    
    
    '次に入れようとしている文字は、違うサイズ、違うデザインなので、とりあえず用済みになったフォントを破棄
    Call DeleteObject(MyFont)
    
    
    'あらためてフォントを用意
    MyFont = CreateFont(24, 0, 0, 0, FW_BOLD, _
            0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, _
            CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
            DEFAULT_PITCH Or FF_SCRIPT, MyFntFamily)
    Call SelectObject(MyDC1, MyFont)
    
    MyRct.Top = 90
    MyRct.Bottom = 115
    Call SetTextColor(MyDC1, RGB(0, 0, 255))
    Call SetBkColor(MyDC1, RGB(255, 0, 0))
    Call DrawText(MyDC1, "はひふへほ", -1, MyRct, DT_CENTER Or DT_SINGLELINE)
    
    Call DeleteObject(MyFont) 'フォントを破棄
    
        
        
    '↓ここからの処理は共通
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)
    ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
    MyFNUM = FreeFile
    Open MyStrFile For Binary As #MyFNUM
    With MyBMPFLHdr
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(MyBMPFLHdr) + Len(MyBMPInf) + UBound(MyBMPBits) + 1
        .bfOffBits = Len(MyBMPFLHdr) + Len(MyBMPInf)
    End With
    Put #MyFNUM, , MyBMPFLHdr
    Put #MyFNUM, , MyBMPInf
    Put #MyFNUM, , MyBMPBits
    Close #MyFNUM

    Call DeleteObject(MyBMP)
    Call DeleteObject(MyDC1)
    Call ReleaseDC(0&, MyDC0)
    
    Image1.Picture = LoadPicture(MyStrFile) 'Excel, Wordの場合
    Image1.Picture = MyStrFile 'Accessの場合
End Sub