ExcelVBAによるBMP生成テスト

Option Explicit

Private Type BITMAPINFOHEADER '40バイト
biSize As Long 'イメージ バッファのバイト数
biWidth As Long '幅
biHeight As Long '高さ
biPlanes As Integer '常に1
biBitCount As Integer '1ピクセルあたりのカラービット数
biCompression As Long '圧縮方法
biSizeImage As Long 'ピクセルデータの全バイト数
biXPelsPerMeter As Long '0または水平解像度
biYPelsPerMeter As Long '0または垂直解像度
biClrUsed As Long 'ビットマップを表示するための色数(0)
biClrImportant As Long 'ビットマップを表示するための重要な色数(0)
End Type

Private Type RGBQUAD
rgbBlue As Byte '青の輝度
rgbGreen As Byte '緑の輝度
rgbRed As Byte '赤の輝度
rgbReserved As Byte '予約(常に0)
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Private Type COLORREF
COLORREF As Long
End Type


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 CreateCompatibleBitmap Lib "Gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Integer, _
ByVal nHeight As Integer) As Long

Private Declare Function CreateCompatibleDC Lib "Gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long

Private Declare Function GetDC Lib "user32" _
(ByVal hWnd As Long) As Long

Private Declare Function LineTo Lib "Gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, _
ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "Gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function SelectObject Lib "Gdi32" _
(hdc As Long, _
hgdiobj As Long) As Long

Private Declare Function BitBlt Lib "Gdi32" _
(ByVal hdcDest As Long, _
ByVal nXDest As Integer, _
ByVal nYDest As Integer, _
ByVal nWidth As Integer, _
ByVal nHeight As Integer, _
ByVal hdcSrc As Long, _
ByVal nXSrc As Integer, _
ByVal nYSrc As Integer, _
ByVal dwRop As Long) As Long

Private Declare Function SetPixel Lib "Gdi32" _
(ByVal hdc As Long, _
ByVal x As Integer, _
ByVal y As Integer) As Long





Public Function CreateBitmap_Test()

Dim i As Integer
Dim j As Integer

'## ビットマップ構造体
Dim myBitmap As BITMAPINFO

'## ビットマップのハンドル
Dim Hundle_myBitmap As Long

'## メモリデバイスコンテキストのハンドル
Dim Hundle_myDC As Long


'## 作製する画像のメモリポインタ
Dim Pointer_myBitmap As Long

'## 対象ウインドウ のハンドル
Dim hTargetWin As Long

'## デバイスコンテキストへのハンドル
Dim hTargetDC As Long

'## 返り値の一時格納変数
Dim re As String

'## color構造体
Dim myColor As COLORREF


hTargetDC = GetDC(0)

Hundle_myBitmap = CreateCompatibleBitmap(hTargetDC, 256, 256)


Hundle_myDC = CreateCompatibleDC(hTargetDC)

re = SelectObject(Hundle_myDC, Hundle_myBitmap)

Call DeleteObject(Hundle_myBitmap)
Call ReleaseDC(hTargetWin, hTargetDC)


Dim hImageDisplayWin As Long
Dim hImageDisplayDC As Long


hImageDisplayWin = WindowFromPoint(300, 300)

hImageDisplayDC = GetDC(hImageDisplayWin)

If hImageDisplayDC = 0 Then

MsgBox ("失敗しました。")

Else


myColor.COLORREF = &H443344

Call BitBlt(hImageDisplayDC, 100, 100, 256, 256, Hundle_myBitmap, 0, 0, 0)

Call DeleteObject(hTargetWin)
Call DeleteObject(hImageDisplayWin)
Call DeleteObject(Hundle_myBitmap)


For i = 0 To 255
For j = 0 To 63
setpixel(hundle_mybitmap, i,j, )
Next
Next
x00bbggrr


Call ReleaseDC(hTargetWin, hTargetDC)
Call ReleaseDC(hImageDisplayWin, hImageDisplayDC)
Call ReleaseDC(Hundle_myBitmap, Hundle_myDC)

End If

End Function

この記事へのコメント

この記事へのトラックバック