サンプル投稿用掲示板 VB2005 〜 用トップページ VB6.0 用 トップページ
- 日時： 2007/07/16 13:57
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[描画・画像][アルゴリズム][] *
* キーワード：グラフィック,画像の２値化,減色,,, *
***********************************************************************************
元質問：白黒ビットマップ形式でpictureを保存する.. - のぶ 2003/02/07-07:26 No.2628
-----------------------------------------------------------------------------------
Re^4: 白黒ビットマップ形式でpictureを保.. - k.k 203/02/11-10:19 No.2690
-----------------------------------------------------------------------------------
とりあえずサンプルを書いてみました。
ピクチャーボックスとコマンドボタンをひとつずつおいて、ピクチャーボックスのAutoRedrawをTrueにScaleModeをピクセルにしてください。
GetDibits関数を使って白黒ビットマップを取得します。
つまり、BITMAPINFOHEADER構造体のbiBitcountメンバでビット数を1にし、BITMAPINFO構造体でbmiColorsメンバをbmiColors(1)（要素数が２つ）にすればモノクロビットマップを取得することができます。
GetDibits関数を使用すれば、２５６色ビットマップ、１６ビットカラービットマップなどのビットマップにも変換することができます。
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
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 Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD '白黒ビットマップとして取得するため配列を２つにする
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Sub Command1_Click()
Dim rc As Long
Dim BmpInfo As BITMAPINFO
Dim PicData() As Byte
Dim BmpFileHeader As BITMAPFILEHEADER
With BmpInfo.bmiHeader
.biSize = 40
.biWidth = Picture1.ScaleWidth
.biHeight = Picture1.ScaleHeight
.biPlanes = 1
.biBitCount = 1 'ここでビット数（色数）を設定する。白黒なのでここでは１を設定。
End With
'まず、５番目の引数(lpBits)に0を設定して、GetDiBitsを実行するとバッファに必要なバイト数が戻ってくる
rc = GetDIBits(Picture1.hdc, Picture1.Picture, 0, Picture1.ScaleHeight - 1, ByVal 0&, BmpInfo, DIB_RGB_COLORS)
'バッファを確保する
ReDim PicData(BmpInfo.bmiHeader.biSizeImage - 1)
'再度改めて、５番目に確保したバッファを設定して、GetDibitsを実行して白黒ビットマップのデータを取得
rc = GetDIBits(Picture1.hdc, Picture1.Picture, 0, Picture1.ScaleHeight, PicData(0), BmpInfo, DIB_RGB_COLORS)
'パレットを設定
'黒 (すべて0なので省略してもかまわない)
With BmpInfo.bmiColors(0)
.rgbBlue = 0
.rgbGreen = 0
.rgbRed = 0
.rgbReserved = 0
End With
'白
With BmpInfo.bmiColors(1)
.rgbBlue = &HFF
.rgbGreen = &HFF
.rgbRed = &HFF
.rgbReserved = 0
End With
'確認のため描画する
rc = SetDIBits(Picture1.hdc, Picture1.Picture, 0, Picture1.ScaleHeight, PicData(0), BmpInfo, DIB_RGB_COLORS)
'リフレッシュして表示する
Picture1.Refresh
'ファイルヘッダーを設定
With BmpFileHeader
.bfType = &H4D42 '"BM"
.bfSize = Len(BmpFileHeader) + Len(BmpInfo) + BmpInfo.bmiHeader.biSizeImage
.bfOffBits = Len(BmpFileHeader) + Len(BmpInfo)
End With
'ファイルを開く（新規作成）
Open "c:\mono.bmp" For Binary As #1
'ファイルヘッダーを書き込む
Put #1, , BmpFileHeader
'ヘッダーを書き込み
Put #1, , BmpInfo
'画像データを書き込む
Put #1, , PicData
Close #1
End Sub
でも、この減色ほうほうだと、簡単なアルゴリズムを使用しているため、あまりきれいではありません。
 |
