Excel VBA質問箱 IV

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

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


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

【54343】bitmapで計算結果を出力 けにち 08/3/9(日) 3:24 質問[未読]
【54345】Re:bitmapで計算結果を出力 VBWASURETA 08/3/9(日) 5:32 発言[未読]
【54357】Re:bitmapで計算結果を出力 VBWASURETA 08/3/10(月) 11:06 発言[未読]
【54355】Re:bitmapで計算結果を出力 Yuki 08/3/10(月) 10:04 発言[未読]
【54356】Re:bitmapで計算結果を出力 VBWASURETA 08/3/10(月) 10:21 発言[未読]
【54402】Re:bitmapで計算結果を出力 でれすけ 08/3/11(火) 19:52 回答[未読]

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

引用なし
パスワード
   質問:Excel VBAで画像を構成してBitmap形式などでファイルに書き出すことはできるでしょうか?

なぜ必要か?:Excel VBAである計算処理をして、その結果が大きな2次元の配列に格納されています。その全体的な様子を観察したいのですが、ワークシートに数値を書き出してグラフ化するには配列が大きすぎるので。

具体的には、
 Dim p(5000,5000) as Integer
で定義された配列に処理結果が格納されていて、p(i,j)の値が正か負かで色分けした画像を作りたいと思っています。Bitmap上の、左からi 番目上からj 番目の点が、p(i,j)が正なら白、負なら黒となるようなものです。

ちょっと調べるとSavePictureというものは見つかったのですが、ボタンなどの画像を保存する方法しかわかりませんでした。

【54345】Re:bitmapで計算結果を出力
発言  VBWASURETA  - 08/3/9(日) 5:32 -

引用なし
パスワード
   ▼けにち さん:
こんばんは。

配列のサイズから見てビットマップにしたとしても
かなり大きくなりますよ?
画面サイズが1280 * 800だとしても表示しきれません。
1本ラインで縮小にすると見えなくなりそうですし。

シートを分けるなりしてやる方が無難かもしれませんね。

どうしてもやってみたい場合は過去の取得方法ですが参考になるかと。
.netだと簡単なのですがvbaだと色々書かないとダメみたいですね。
www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=19971;id=excel

【54355】Re:bitmapで計算結果を出力
発言  Yuki  - 08/3/10(月) 10:04 -

引用なし
パスワード
   ▼けにち さん:
>質問:Excel VBAで画像を構成してBitmap形式などでファイルに書き出すことはできるでしょうか?
>

>ちょっと調べるとSavePictureというものは見つかったのですが、ボタンなどの画像を保存する方法しかわかりませんでした。

試してみて下さい。
Option Explicit

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal wFormat As Long) As Long
Private Declare Function CopyImage Lib "user32" _
        (ByVal handle As Long, _
         ByVal un1 As Long, ByVal n1 As Long, _
         ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
        (PicDesc As PicBmp, _
         RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
         IPic As IPictureDisp) As Long

Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4


Sub TEST() ' 此処を実行
  Dim strFileName As String
  strFileName = "D:\hogehogeBitMap.bmp"
  
  ActiveSheet.Range("範囲").CopyPicture xlScreen, xlBitmap
  SavePicture GetBitMap(), strFileName
End Sub

Function GetBitMap() As IPictureDisp
 Dim iid As GUID
 Dim Pic As PicBmp
 Dim ObjPic As IPictureDisp
 Dim hBitmap As Long
 Dim CopyBitmap As Long

 With iid
  .Data1 = &H20400
  .Data4(0) = &HC0
  .Data4(7) = &H46
 End With
 
 OpenClipboard 0
 hBitmap = GetClipboardData(CF_BITMAP)
 If hBitmap = 0 Then
  CloseClipboard
  Exit Function
 End If
 
 CopyBitmap = CopyImage(hBitmap, _
             IMAGE_BITMAP, 0, 0, _
             LR_COPYRETURNORG)
 CloseClipboard
 
 With Pic
  .Size = Len(Pic)
  .Type = PICTYPE_BITMAP
  .hBmp = CopyBitmap
 End With
 
 OleCreatePictureIndirect Pic, iid, 1, ObjPic
 Set GetBitMap = ObjPic
End Function

【54356】Re:bitmapで計算結果を出力
発言  VBWASURETA  - 08/3/10(月) 10:21 -

引用なし
パスワード
   ▼Yuki さん:
おはようございます。

すみませんこの方法どこかの掲示板に書かれてましたが、
CopyやCopyPictureメソッドだとシートそのもののイメージを
ビットマップ形式にされた内容のようです。
なので、配列で送るようにちょっと手を
加えてやって見ました。(ただ配列をクリップボードに送るだけですが)

> OpenClipboard 0
> hBitmap = GetClipboardData(CF_BITMAP)
> If hBitmap = 0 Then
>  CloseClipboard
>  Exit Function
> End If

この部分でビットマップ形式に変換ができないようで
戻り値が0になります。やり方次第なのかもしれませんが、
少し検討する時間が必要になりそうです。

単純に配列をバイナリデータに変換してクリップボードへ
送れば行ける気もしますが。

【54357】Re:bitmapで計算結果を出力
発言  VBWASURETA  - 08/3/10(月) 11:06 -

引用なし
パスワード
   ▼VBWASURETA さん:

一応、1000 * 1のビットマップのデータをバイナリデータ(16進)で
表現してみました。
すみませんコピぺすると掲示板の文字数オーバーするようで
貼り付けれませんでした^^;

試してもらっても良いですが、ペイントで1本のラインを縦に繋げて
100ドットぐらいだったら試しですぐできると思います。
で、見てもらえばわかりますが。1本のラインなので殆ど見えません。
提案ですが、プラスならプラスのカウントで、マイナスはマイナスのカウントで
まとめるのはダメでしょうか?
ファイル圧縮の原理のような感じで。
列はシートをわけないとダメそうですが。

【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

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