| |
こんにちは
ひさしぶりに回答してみるテスト
Bitmap形式のフォーマットはわかっているので、
検索してみると丁寧に解説してくれているサイトもあります
こういうありがたい情報を参考にして
力づくでガシガシとビットマップを作るというのも方法としてはあります。
Type tagBITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Type tagBITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPixPerMeter As Long
biYPixPerMeter As Long
biClrUsed As Long
biClrImporant As Long
End Type
Type tagRGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Sub sample()
Dim p(1 To 500, 1 To 500) As Integer
For i = 1 To 500
For j = 1 To 500
r = (i - 250) ^ 2 + (j - 250) ^ 2
If 40000 < r Then
p(i, j) = 1
End If
If i = 250 Or j = 250 Then
If p(i, j) = 1 Then p(i, j) = 0 Else p(i, j) = 1
End If
Next
Next
Call Array2Bitmap(p(), "D:\test.bmp")
End Sub
Sub Array2Bitmap(p() As Integer, bmpFilename As String)
Dim BITMAPFILEHEADER As tagBITMAPFILEHEADER
Dim BITMAPINFOHEADER As tagBITMAPINFOHEADER
Dim RGBQUAD(0 To 1) As tagRGBQUAD
Dim buf() As Byte
Dim Nx As Long, Ny As Long
Nx = UBound(p, 1)
Ny = UBound(p, 2)
If Nx Mod 8 = 0 Then bDx = Nx \ 8 Else bDx = (Nx \ 8) + 1
If bDx Mod 4 > 0 Then bDx = ((bDx \ 4) + 1) * 4
bDy = Ny
ReDim buf(1 To bDx, 1 To bDy) As Byte
With BITMAPINFOHEADER
.biSize = 40
.biWidth = Nx
.biHeight = Ny
.biPlanes = 1
.biBitCount = 1
.biCompression = 0
.biSizeImage = bDx * bDy
.biSizeImage = 0
.biXPixPerMeter = 3936
.biYPixPerMeter = 3936
.biClrUsed = 2
.biClrImporant = 1
End With
With RGBQUAD(0)
.rgbRed = 200
.rgbGreen = 255
.rgbBlue = 255
End With
With RGBQUAD(1)
.rgbRed = 200
.rgbGreen = 200
.rgbBlue = 100
End With
With BITMAPFILEHEADER
.bfType = &H4D42
.bfReserved1 = 0
.bfReserved2 = 0
.bfOffBits = Len(BITMAPFILEHEADER) _
+ Len(BITMAPINFOHEADER) _
+ Len(RGBQUAD(0)) _
+ Len(RGBQUAD(1))
.bfSize = .bfOffBits + BITMAPINFOHEADER.biSizeImage
End With
For j = 1 To Ny
For i = 1 To (Nx \ 8) * 8 Step 8
l = i \ 8 + 1
For k = 0 To 7
buf(l, j) = buf(l, j) + p(i + k, j) * 2 ^ (7 - k)
Next
Next
If (Nx \ 8) * 8 < Nx Then
l = i \ 8 + 1
For k = 0 To Nx - (Nx \ 8) * 8 - 1
buf(l, j) = buf(l, j) + p(i + k, j) * 2 ^ (7 - k)
Next
End If
Next
fn = FreeFile
Open bmpFilename For Binary As fn
Put fn, , BITMAPFILEHEADER
Put fn, , BITMAPINFOHEADER
Put fn, , RGBQUAD(0)
Put fn, , RGBQUAD(1)
Put fn, , buf
Close fn
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
