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

名前

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

本文

過去に書いた0なら白1なら黒というようにならんでいる形式
で保存すると何故か24Bitになってしまいました
せっかく
ガッ様  ねろ様・・・  すいませんが
元の話に戻らせていただきます（勝手ながら）
通ってみた様の教えていただいたものですと
（コードです長々とすいません）'色取得用
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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

Sub SaveMonoImage(FN As String, picBox As PictureBox)

Dim BFH As BITMAPFILEHEADER 'ヘッダーその１
Dim BIH As BITMAPINFOHEADER 'ヘッダーその２
Dim Pal(1) As RGBQUAD 'パレット２色分
Dim BMByte() As Byte '実際のバイト
Dim BMX As Integer, BMY As Integer '縦横のサイズ
Dim BMXByte As Integer '1ラインあたりのバイト数
Dim Temp As Integer, Temp2 As Integer, Temp3 As Long, Temp4 As Long '作業用変数
Dim Tcol As Byte '作業用変数
Dim srcDC As Long 'デバイスコンテキスト

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

'ビットマップファイルの各ラインのバイト数計算
BMX = picBox.ScaleWidth
BMY = picBox.ScaleHeight
BMXByte = (BMX - 1) \ 8 + 1 'バイト数計算
Temp = ((BMXByte - 1) \ 4 + 1) * 4 - 1 'バイト境界を4バイトにそろえている
ReDim BMByte(Temp, BMY - 1)

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

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

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

srcDC = picBox.hdc

For Temp = BMY - 1 To 0 Step -1 '1ラインずつ下から作成
    For Temp2 = 0 To BMXByte - 1 '1バイトずつ作成
        Tcol = 0
        For Temp3 = 0 To 7 '1バイトは8ビット
            Temp4 = GetPixel(srcDC, Temp2 * 8 + Temp3, Temp)
            If Temp4 = 0 Then Tcol = Tcol + 2 ^ (7 - Temp3) '黒の場合
        Next
        BMByte(Temp2, BMY - 1 - Temp) = Tcol
    Next
Next

Open FN For Binary As 1
Put 1, , BFH
Put 1, , BIH
Put 1, , Pal()
Put 1, , BMByte()
Close
なんですが・・・

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

戻る