フォームにline関数などで描画したものを白黒ビットマップで保存するには？ (ID:124120)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

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

'BMPファイルのヘッダー−ファイル情報
Private Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End Type
'BMPファイルのヘッダー−ビットマップの情報
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
Sub SaveMonoImage(FN As String, picBox As PictureBox)

Dim BFH As BITMAPFILEHEADER 'ヘッダーその１
Dim BInf As BITMAPINFO 'ヘッダーその２
Dim BMByte() As Byte '実際のバイト
Dim BMX As Integer, BMY As Integer '縦横のサイズ
Dim srcDC As Long 'デバイスコンテキスト
Dim Fno As Long

'高速化のためにPoint関数でなくGetPixelを使っています。
'そのためAutoRedrawプロパティがTrueでないとうまく動作しません。

'ビットマップファイルの各ラインのバイト数計算
BMX = picBox.ScaleWidth
BMY = picBox.ScaleHeight

ReDim BMByte((BMX * BMY \ 8) - 1)'イメージのサイズ

'ヘッダー初期化
With BFH
    .bfType = &H4D42 '保存時に「BM」となる
    .bfOffBits = 62 'BFHが14バイト、BIFが40バイト、パレットが8バイト
    .bfSize = Len(BFH) + Len(BInf) + (BMX * BMY \ 8)
End With

With BInf.bmiHeader
    .biSize = Len(BInf.bmiHeader)  'BIFは40バイト
    .biWidth = BMX '幅
    .biHeight = BMY '高さ
    .biPlanes = 1 '常に１
    .biBitCount = 1 '2色なので1ビット
    .biSizeImage = BFH.bfSize - Len(BInf)
End With

With BInf.bmiColors(1)
.rgbBlue = 255: .rgbRed = 255: .rgbGreen = 255 'rgbReservedは0なのでそのまま
'Pal(1)は黒だが、すべて0でいいのでそのまま
End With

GetDIBits picBox.hDC, picBox.Image, 0&, BInf.bmiHeader.biHeight,BMByte(0), BInf, 0&

Fno = FreeFile
Open FN For Binary As #Fno
Put #Fno, , BFH
Put #Fno, , BInf
Put #Fno, , BMByte()
Close #Fno
End Sub

適当に変えてみました。
あとは手直ししてくださいね。

←解決時は質問者本人がここをチェックしてください。

戻る