Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

27647 / 76732

←次へ　｜　前へ→


	【54402】Re:bitmapで計算結果を出力

でれすけ - 08/3/11(火) 19:52 -


	引用なし

	パスワード

こんにちは
ひさしぶりに回答してみるテスト

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

2 hits

▼

【54343】bitmapで計算結果を出力 けにち 08/3/9(日) 3:24