| |
こんにちは。
見直したら、おかしなところがいろいろあったので、消しました。
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
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 Sub CreateBmpFile(PixData(), BmpPath As String)
Dim bmH As BITMAPFILEHEADER
Dim BmI As BITMAPINFOHEADER
Dim buf() As Byte
Dim lBmpByteWidth As Long
Dim lBMPWidth As Long
Dim lBMPHeight As Long
Dim i As Long, j As Long, k As Long
Dim fio As Integer
lBMPWidth = UBound(PixData, 1) - LBound(PixData, 1) + 1
lBMPHeight = UBound(PixData, 2) - LBound(PixData, 2) + 1
lBmpByteWidth = 3 * lBMPWidth + ((4 - (3 * lBMPWidth Mod 4)) * _
Sgn(3 * lBMPWidth Mod 4))
ReDim buf(0 To lBmpByteWidth - 1, 0 To lBMPHeight - 1)
For i = 0 To lBmpByteWidth - 3 Step 3
k = 0
For j = lBMPHeight To 1 Step -1
buf(i, k) = PixData(i \ 3, j - 1) 'B
buf(i + 1, k) = PixData(i \ 3, j - 1) 'G
buf(i + 2, k) = PixData(i \ 3, j - 1) 'R
k = k + 1
Next
Next
With bmH
.bfType = CInt("&H" & VBA.Hex(Asc("M")) & VBA.Hex(Asc("B")))
.bfOffBits = Len(bmH) + Len(BmI)
.bfSize = lBMPHeight * lBmpByteWidth + .bfOffBits
End With
With BmI
.biSize = Len(BmI)
.biWidth = lBMPWidth
.biHeight = lBMPHeight
.biPlanes = 1
.biBitCount = 24
.biSizeImage = lBmpByteWidth
End With
fio = FreeFile()
Open BmpPath For Binary As fio
Put fio, , bmH
Put fio, , BmI
Put fio, , buf()
Close fio
End Sub
Sub Sample02()
Dim i As Long, j As Long
Dim colorb()
ReDim colorb(0 To 200, 0 To 99)
For i = LBound(colorb, 1) To UBound(colorb, 1)
For j = LBound(colorb, 2) To UBound(colorb, 2)
colorb(i, j) = i
Next
Next
CreateBmpFile colorb, "D:\temp\test01.bmp"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
