Excel VBA質問箱 IV

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

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


1273 / 13644 ツリー ←次へ | 前へ→

【75310】数値配列からビットマップ画像を出力する方法 www 14/2/11(火) 10:34 質問[未読]
【75323】Re:数値配列からビットマップ画像を出力す... ちび坊主 14/2/12(水) 15:24 回答[未読]

【75310】数値配列からビットマップ画像を出力する...
質問  www  - 14/2/11(火) 10:34 -

引用なし
パスワード
   例えば、
dim a(255,255)
で作成した二次元配列があり、それぞれの中に0〜255の数値が格納されているとします。
この画像からグレースケールあるいは任意の配色で
256x256の解像度のbmp画像を出力するプログラムを
VBAで作りたいのですがどのようにすれば良いですか?


検索して調べたのですが
www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=54343;id=excel
akadamashy.blog68.fc2.com/blog-entry-915.html


のサイトにビットマップ画像を出力するための
プログラムが記載されていました。

しかしながら、ここに記載されているのは全てバイトで記述された配列から
画像を出力するものとなっており、数値データから出力するにはどうしたら良いか分かりません。


どなたか教えてください。

【75323】Re:数値配列からビットマップ画像を出力...
回答  ちび坊主  - 14/2/12(水) 15:24 -

引用なし
パスワード
   こんにちは。

見直したら、おかしなところがいろいろあったので、消しました。

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

1273 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free