by 刈谷 真 » 2005年7月05日(火) 20:56
> こちらでは正常に動作してますが・・・どのバージョンのABでしょうか?
私もAB4.02.01を使っております。他のコードがいけないのでしょうか?
かなり目茶目茶ですが、指摘してください。お願いします。
-------------------------------------------------
Function MakeSolidBmp(ByRef pColor As RGBQUAD, ByVal dwWidth As DWord, ByVal dwHeight As DWord, ByRef lpFileData As BytePtr) As DWord
' 変数の宣言
Dim pBmpFileHeader As BITMAPFILEHEADER ' BITMAPFILEHEADER構造体
Dim pBmpInfoHeader As BITMAPINFOHEADER ' BITMAPINFOHEADER構造体
Dim dwLineLen As DWord ' 1走査線のサイズ
Dim lpLineData As BytePtr ' 1走査線の画像データ
Dim i As Long
' 1走査線のサイズを求める
dwLineLen = Raise(dwWidth * 3 / 4) * 4
' 1走査線の画像データの生成
lpLineData = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, dwLineLen)
For i = 0 To dwWidth - 1
memcpy(lpLineData + i * 3, VarPtr(pColor), 3)
Next
' BITMAPFILEHEADER構造体の設定
FillMemory(VarPtr(pBmpFileHeader), Len(pBmpFileHeader), 0) ' 構造体の初期化
With pBmpFileHeader
memcpy(VarPtr(.bfType), "BM", 2) ' ファイルタイプ
.bfSize = dwLineLen * dwHeight + &H36 ' ファイルサイズ
.bfOffBits = &H36 ' 画像データまでのオフセット
End With
' BITMAPINFOHEADER構造体の設定
FillMemory(VarPtr(pBmpInfoHeader), Len(pBmpInfoHeader), 0) ' 構造体の初期化
With pBmpInfoHeader
.biSize = 1 ' ヘッダサイズ
.biWidth = dwWidth ' BMPの幅
.biHeight = dwHeight ' BMPの高さ
.biPlanes = 1 ' プレーン数
.biBitCount = 24 ' ビット数
.biCompression = BI_RGB ' 圧縮の種類
.biSizeImage = dwLineLen * dwHeight ' 画像データ部のサイズ
End With
' ファイルヘッダのコピー
lpFileData = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, pBmpFileHeader.bfSize) ' ヒープ領域の確保
memcpy(lpFileData, VarPtr(pBmpFileHeader), 14) ' BITMAPFILEHEADER構造体のデータをコピー
memcpy(lpFileData + 14, VarPtr(pBmpInfoHeader), 40) ' BITMAPINFOHEADER構造体のデータをコピー
' 画像データの生成
For i = 0 To dwHeight - 1
memcpy(lpFileData + 54 + i * dwLineLen, lpLineData, dwLineLen)
Next
Dim x As Long
Dim y As Long
Dim Color As RGBQUAD
x = -1
y = 0
Dim Buf As String
Dim tmp As String
Dim io As Long
Open "a.txt" For Input As 1
Field #1,Lof(1) 'ファイル内のデータをすべて読み込む
Get #1,1,Buf
Close 1
For io=1 to Len(Buf)
tmp = Mid$(Buf,io,1) '読み込んだデータから一文字ずつ取り出す
Select Case tmp
Case "a"
With Color
.rgbBlue = 0 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 255 'RED
End With
Case "b"
With Color
.rgbBlue = 0 ' BLUE
.rgbGreen = 255 ' GREEN
.rgbRed = 0 'RED
End With
Case "c"
With Color
.rgbBlue = 255 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 0 'RED
End With
End Select
x = x + 1 ' 色を変えたい部分のx座標
y = y ' 色を変えたい部分のy座標
If x = 100 Then
y = y + 1
x = 0
End If
memcpy(lpFileData + 54 + dwLineLen * (dwHeight - y - 1) + x * 3, VarPtr(Color), 3)
' ヒープ領域の解放
HeapFree(GetProcessHeap(), 0, lpLineData)
' 戻り値
MakeSolidBmp = pBmpFileHeader.bfSize
Next
End Function
' 切り上げ関数
'
' 【引数】
' dbNum: 切り上げする数値
' 【戻り値】
' 切り上げされた数値
Function Raise(ByVal dbNum As Double) As Long
If Fix(dbNum) = dbNum or dbNum < 0 Then
Raise = Fix(dbNum)
Else
Raise = Fix(dbNum) + 1
End If
End Function
' 使用 (100×100のBMPの保存)
' 変数の宣言
Dim pColor As RGBQUAD
Dim lpFileData As BytePtr ' ファイルデータ
Dim dwFileSize As DWord ' BMPファイルのサイズ
Dim hFile As DWord ' ファイルハンドル
Dim lpNumberOfBytesWritten As DWord ' 書き込まれたファイルサイズ
' 色の設定
With pColor
.rgbBlue = 0 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 0 'RED
End With
' BMPの生成
dwFileSize = MakeSolidBmp(pColor, 100, 100, lpFileData)
' ファイルの保存(同フォルダの"test.bmp"に保存)
hFile = CreateFile("test.bmp", GENERIC_WRITE, 0, ByVal NULL, CREATE_ALWAYS, FILE_FLAG_RANDOM_ACCESS, 0) ' ファイルの作成
WriteFile(hFile, lpFileData, dwFileSize, VarPtr(lpNumberOfBytesWritten), ByVal NULL) ' ファイル書き込み
SetEndOfFile(hFile) ' ファイルサイズの調整
CloseHandle(hFile) ' ファイルハンドルを閉じる
' ヒープ領域を開放
HeapFree(GetProcessHeap(), 0, lpFileData)
Close #1
' プログラムの終了
End
> こちらでは正常に動作してますが・・・どのバージョンのABでしょうか?
私もAB4.02.01を使っております。他のコードがいけないのでしょうか?
かなり目茶目茶ですが、指摘してください。お願いします。
-------------------------------------------------
Function MakeSolidBmp(ByRef pColor As RGBQUAD, ByVal dwWidth As DWord, ByVal dwHeight As DWord, ByRef lpFileData As BytePtr) As DWord
' 変数の宣言
Dim pBmpFileHeader As BITMAPFILEHEADER ' BITMAPFILEHEADER構造体
Dim pBmpInfoHeader As BITMAPINFOHEADER ' BITMAPINFOHEADER構造体
Dim dwLineLen As DWord ' 1走査線のサイズ
Dim lpLineData As BytePtr ' 1走査線の画像データ
Dim i As Long
' 1走査線のサイズを求める
dwLineLen = Raise(dwWidth * 3 / 4) * 4
' 1走査線の画像データの生成
lpLineData = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, dwLineLen)
For i = 0 To dwWidth - 1
memcpy(lpLineData + i * 3, VarPtr(pColor), 3)
Next
' BITMAPFILEHEADER構造体の設定
FillMemory(VarPtr(pBmpFileHeader), Len(pBmpFileHeader), 0) ' 構造体の初期化
With pBmpFileHeader
memcpy(VarPtr(.bfType), "BM", 2) ' ファイルタイプ
.bfSize = dwLineLen * dwHeight + &H36 ' ファイルサイズ
.bfOffBits = &H36 ' 画像データまでのオフセット
End With
' BITMAPINFOHEADER構造体の設定
FillMemory(VarPtr(pBmpInfoHeader), Len(pBmpInfoHeader), 0) ' 構造体の初期化
With pBmpInfoHeader
.biSize = 1 ' ヘッダサイズ
.biWidth = dwWidth ' BMPの幅
.biHeight = dwHeight ' BMPの高さ
.biPlanes = 1 ' プレーン数
.biBitCount = 24 ' ビット数
.biCompression = BI_RGB ' 圧縮の種類
.biSizeImage = dwLineLen * dwHeight ' 画像データ部のサイズ
End With
' ファイルヘッダのコピー
lpFileData = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, pBmpFileHeader.bfSize) ' ヒープ領域の確保
memcpy(lpFileData, VarPtr(pBmpFileHeader), 14) ' BITMAPFILEHEADER構造体のデータをコピー
memcpy(lpFileData + 14, VarPtr(pBmpInfoHeader), 40) ' BITMAPINFOHEADER構造体のデータをコピー
' 画像データの生成
For i = 0 To dwHeight - 1
memcpy(lpFileData + 54 + i * dwLineLen, lpLineData, dwLineLen)
Next
Dim x As Long
Dim y As Long
Dim Color As RGBQUAD
x = -1
y = 0
Dim Buf As String
Dim tmp As String
Dim io As Long
Open "a.txt" For Input As 1
Field #1,Lof(1) 'ファイル内のデータをすべて読み込む
Get #1,1,Buf
Close 1
For io=1 to Len(Buf)
tmp = Mid$(Buf,io,1) '読み込んだデータから一文字ずつ取り出す
Select Case tmp
Case "a"
With Color
.rgbBlue = 0 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 255 'RED
End With
Case "b"
With Color
.rgbBlue = 0 ' BLUE
.rgbGreen = 255 ' GREEN
.rgbRed = 0 'RED
End With
Case "c"
With Color
.rgbBlue = 255 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 0 'RED
End With
End Select
x = x + 1 ' 色を変えたい部分のx座標
y = y ' 色を変えたい部分のy座標
If x = 100 Then
y = y + 1
x = 0
End If
memcpy(lpFileData + 54 + dwLineLen * (dwHeight - y - 1) + x * 3, VarPtr(Color), 3)
' ヒープ領域の解放
HeapFree(GetProcessHeap(), 0, lpLineData)
' 戻り値
MakeSolidBmp = pBmpFileHeader.bfSize
Next
End Function
' 切り上げ関数
'
' 【引数】
' dbNum: 切り上げする数値
' 【戻り値】
' 切り上げされた数値
Function Raise(ByVal dbNum As Double) As Long
If Fix(dbNum) = dbNum or dbNum < 0 Then
Raise = Fix(dbNum)
Else
Raise = Fix(dbNum) + 1
End If
End Function
' 使用 (100×100のBMPの保存)
' 変数の宣言
Dim pColor As RGBQUAD
Dim lpFileData As BytePtr ' ファイルデータ
Dim dwFileSize As DWord ' BMPファイルのサイズ
Dim hFile As DWord ' ファイルハンドル
Dim lpNumberOfBytesWritten As DWord ' 書き込まれたファイルサイズ
' 色の設定
With pColor
.rgbBlue = 0 ' BLUE
.rgbGreen = 0 ' GREEN
.rgbRed = 0 'RED
End With
' BMPの生成
dwFileSize = MakeSolidBmp(pColor, 100, 100, lpFileData)
' ファイルの保存(同フォルダの"test.bmp"に保存)
hFile = CreateFile("test.bmp", GENERIC_WRITE, 0, ByVal NULL, CREATE_ALWAYS, FILE_FLAG_RANDOM_ACCESS, 0) ' ファイルの作成
WriteFile(hFile, lpFileData, dwFileSize, VarPtr(lpNumberOfBytesWritten), ByVal NULL) ' ファイル書き込み
SetEndOfFile(hFile) ' ファイルサイズの調整
CloseHandle(hFile) ' ファイルハンドルを閉じる
' ヒープ領域を開放
HeapFree(GetProcessHeap(), 0, lpFileData)
Close #1
' プログラムの終了
End