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

ぼう人間 2005-08-15 01:35:57 No: 124103

早速ですが
フォームにline関数などで描画したものを白黒ビットマップで保存するには
どうすればいいでしょうか
フツーにSavePictureを使えは２４ビットのものになってしまいます
またフォームですから実行した環境の解像度のファイルになってしまいます
どうすればいいでしょうか
よろしくお願いします

ぼう人間 2005-08-15 02:12:05 No: 124104

忘れていましたが
WinXPでVB6です
どうぞよろしくお願いします

特攻隊長まるるう 2005-08-19 18:47:19 No: 124105

とりあえずピクチャの全ての点で色を調べて白か黒に
置き換えれば2色に変換はできるよね？その後の保存
ファイルの形式を指定できるのか？…はそれらしい
情報に行き着きませんでした。SavePicture ステー
トメントでビットマップを扱った場合は元のファイルと
同じ形式で保管されるとヘルプに書いてあります。
API を使ってビットマップの加工を…したりするの
かなぁ？その辺りを調べてみて下さい。

ぼう人間 2005-08-23 02:38:07 No: 124106

うーーーーーーん
やっぱりAPIですか・・・
確かにAPIを使えば出来そうなきもするんですが・・・
どうなんでしょう

K.J.K. 2005-08-23 04:56:23 No: 124107

別に直接API関数を使う必要は無いでしょう。
2色化できていれば、ビットマップのフォーマットを調べて、
それをバイナリーとしてファイルに書き込むだけですよね。

通ってみた 2005-08-23 18:37:44 No: 124108

http://kone.vis.ne.jp/program/

ここにそれっぽいサンプルがありますが、どうでしょう？

通り巣鴨 2005-08-24 01:39:22 No: 124109

2色化されてない場合はCreateBitmapで2色にできますよ。
CreateCompatibleBitmapじゃないので間違えないように
後は

BITMAPFILEHEADER
BITMAPINFO（BITMAPINFOHEADER、RGBQUAD）
を正しく設定して
GetDIBitsでピクセルデータを取得し
BITMAPFILEHEADER
BITMAPINFO（BITMAPINFOHEADER、RGBQUAD）
ピクセルデータの順でバイナリで書き込めば完成です。

モノクロはパレット（RGBQUAD）って必要？？失念しました。

通り巣鴨 2005-08-24 01:41:49 No: 124110

CreateBitmapはいらないかもしれませんね。
ちょいと実験がてらサンプルでも作ってみます。

通り巣鴨 2005-08-24 02:27:12 No: 124111

サンプル作成途中でVBが落ちたので作成するのやめました。
CreateBitmapはいらないですね。
モノクロもパレットは必要でした。
RGBQUAD(1)ですね。

ぼう人間 2005-08-25 02:09:36 No: 124112

皆さん回答ありがとうございます
話がずれてしまいますが
独自の形式で保存する
（といっても0なら白1なら黒というようにならんでいるファイルです）
なら
for  X=0 to ピクチャーの横
  DoEvents
  for  Y=0  to ピクチャーの横
    DoEvents
    if(point(x,y)=白の数）then
     alldata=alldata & 0
    else
     alldata=alldata & 1
    end if
  next Y
next X
ALLDATAと書き出す
とすると
膨大な時間(処理に)がかかりますね
それならどうするべきでしょうか？？
当初の質問とは違ってきましたが
よろしくお願いします

ぼう人間 2005-08-25 02:11:02 No: 124113

すいません訂正します
ALLDATAと書き出す
は
ALLDATAを書き出す
の間違いです
すいません

ガッ 2005-08-25 02:22:53 No: 124114

最近ビットマップ触ってないけど、
１  GetDIBits()で2値のビットマップデータを受け取り、
２  そのビットマップを減色して、
３  BITMAPFILEHEADERを作り、
４  BITMAPFILEHEADERとBITMAPINFOとBITMAPINFOHEADERをファイルに書きこむ
だけ…のはず。

> 通り巣鴨さん
> RGBQUAD(1)ですね。
そうですね、RGBQUAD(1 to 2)としたほうが分かりやすい&安全かもしれません。

> ぼう人間さん
時間がかかるのは、ピクチャーの横:W、とピクチャーの縦：Hを捜査している間に
(W+2)*(H+1)回(?)DoEventsを挟み、
VB標準のメソッドPoint()を使っていて、
ALLDATAに文字列としてInteger型を強引に連結しているせいだと思います。
高速化したいならDIB(Device Independent Bitmap)について勉強してください。
ファイルにALLDATAを書くのは早いのでは？

通り巣鴨 2005-08-25 02:38:09 No: 124115

たしか256色のビットマップが1ピクセル1バイトです。
パレットの0に白1に黒を割り当ててビットマップ作れば
多分、できます

ねろ 2005-08-25 02:43:45 No: 124116

文字列の足し算は1000文字を超えると急激に遅くなります。
    For  Y = 0  To ピクチャーの横
        If(point(x,y)=白の数）then
            s = s & 0
        Else
            s = s & 1
        End If
        i = i + 1
        If i = 1000 Then
            alldata = alldata + s
            s = ""
            i = 0
        End if
    Next n
こんなことをすれば速くなります。

ねろ 2005-08-25 03:06:48 No: 124117

あ！
Nextの後に alldata = alldata + s を入れて下さい。

ガッ 2005-08-25 05:24:13 No: 124118

サイズが決定されている文字列操作ならやっぱりMID$()ステートメントが一番かと。
それかByte()→Stringを使うことかな…

-VB6-
dim s as string
s="1234"
mid$(s,1,2)="ab"

ぼう人間 2005-08-27 01:52:49 No: 124119

過去に書いた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
なんですが・・・

通り巣鴨 2005-08-27 02:48:17 No: 124120

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

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