Win32の初心者です。教えてください。
画像処理プログラムを書いているのですが・・・
LoadImageを使って画像をLoadし、BitBltを使って描写させるまではできたのですが、
そのメモリー上のBMPをどうやってもSaveできません
hFile = CreateFile("filename.bmp", GENERIC_WRITE, 0, ByVal 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
WriteFile (hFile, 「欲しいポインタ」, 230454(Byte数は固定なので力ずく）, VarPtr(dwAccessByte), ByVal 0)
とやれば、File生成、書き込みができると思い、あとはBMPのBufferのポインタを指定してあげればいけると思ったのですが（？）、ポインタを獲得する手法がわかりません
どうやったらbufferのポインタが得られるのか、どなたか教えてください
よろしくお願いいたします
BMPをSaveする
-
ゲスト
'--------------------------------------
' Win32API Graphic Functions
' ABのグラフィック命令の代替関数
'--------------------------------------
'/////////////////////////
'//ABのPSet命令の代替関数
'/////////////////////////
Sub PSetAPI(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, Col As Long)
Dim hDC As Long
hDC = GetDC(hWnd)
SetPixel(hDC, x, y, Col)
ReleaseDC(hWnd, hDC)
End Sub
'/////////////////////////
'//ABのLine命令の代替関数
'/////////////////////////
Sub LineAPI(ByVal hWnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal flag As Integer, ByVal Col As Long)
Dim hDC As Long, lpRect As RECT, hPen As Long, hBrush As Long, hOld As Long
hDC = GetDC(hWnd)
hPen = CreatePen(PS_SOLID, 0, Col)
hBrush = CreateSolidBrush(Col)
Select Case(flag)
Case 1
hOld = SelectObject(hDC, hPen)
MoveToEx(hDC, x1, y1, ByVal NULL)
LineTo(hDC, x2, y1)
LineTo(hDC, x2, y2)
LineTo(hDC, x1, y2)
LineTo(hDC, x1, y1)
SelectObject(hDC, hOld)
Case 2
lpRect.left = x1
lpRect.right = x2
lpRect.top = y1
lpRect.bottom = y2
hOld = SelectObject(hDC, hBrush)
FillRect(hDC, lpRect, hBrush)
SelectObject(hDC, hOld)
Case Else
hOld = SelectObject(hDC, hPen)
MoveToEx(hDC, x1, y1, ByVal NULL)
LineTo(hDC, x2, y2)
SelectObject(hDC, hOld)
End Select
DeleteObject(hPen)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'///////////////////////////
'//ABのCircle命令の代替関数
'///////////////////////////
Sub CircleAPI(ByVal hWnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal flag As Integer, ByVal Col As Long)
Dim hDC As Long, brs As LOGBRUSH, hPen As Long, hBrush As Long, hOldPen As Long, hOldBrush As Long
hDC = GetDC(hWnd)
hPen = CreatePen(PS_SOLID, 0, Col)
hOldPen = SelectObject(hDC, hPen)
brs.lbColor = Col
brs.lbHatch = NULL 'lbStyleがBS_SOLID、BS_NULL(BS_HOLLOW)の場合無視される
Select Case(flag)
Case 1 'TRUEで塗りつぶし
brs.lbStyle = BS_SOLID
hBrush = CreateBrushIndirect(brs)
hOldBrush = SelectObject(hDC, hBrush)
Ellipse(hDC, x1, y1, x2, y2)
SelectObject(hDC, hOldBrush)
Case Else 'FALSEで塗りつぶしなし
brs.lbStyle = BS_NULL
hBrush = CreateBrushIndirect(brs)
hOldBrush = SelectObject(hDC, hBrush)
Ellipse(hDC, x1, y1, x2, y2)
SelectObject(hDC, hOldBrush)
End Select
SelectObject(hDC, hOldPen)
DeleteObject(hPen)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'//////////////////////////
'//ABのPaint命令の代替関数
'//////////////////////////
Sub PaintAPI(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, Col As Long)
Dim hDC As Long, hBrush As Long, hOldBrush As Long, sfCol As Long
hDC = GetDC(hWnd)
hBrush = CreateSolidBrush(Col)
hOldBrush = SelectObject(hDC, hBrush)
sfCol = GetPixel(hDC, x, y)
ExtFloodFill(hDC, x, y, sfCol, FLOODFILLSURFACE)
SelectObject(hDC, hOldBrush)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'--------------------------------------
' BitmapUty.sbp
' Bitmap関連ユーティリティライブラリー
'--------------------------------------
'//////////////////
'//Bitmap用追加DLL
'//////////////////
Declare Function IsClipboardFormatAvailable Lib "user32" Alias "IsClipboardFormatAvailable" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function GetClipboardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
'////////////////
'//追加DLL用定数
'////////////////
Const CF_BITMAP = 2
'/////////////
'//追加構造体
'/////////////
'BITMAPFILEHEADER構造体宣言 － 14バイト長
Type BITMAPFILEHEADER
Dim bfType As WORD 'B', 'M' - ひっくり返っているが
Dim bfSize As DWORD 'ファイルサイズ
Dim bfReserved1 As WORD
Dim bfReserved2 As WORD
Dim bfOffBits DWORD 'ファイル先頭からビットパターンまでのオフセット(54byte＋パレットデータ)
End Type
'ICONDIR構造体宣言 － 6バイト長
Type ICONDIR
idReserved As WORD '常に0
idType As WORD 'Iconの場合1、Cursorの場合2
idCount As WORD 'エントリーの数
End Type
'ICONDIRENTRY構造体宣言 － 16バイト長
Type ICONDIRENTRY
bWidth As BYTE 'アイコンの幅
bHeight As BYTE 'アイコンの高さ
bColorCount As BYTE '色数 - 0 (256色), 2, 16でそれぞれwBitCountの8、1、4に対応
bReserved As BYTE '0
wPlanes As WORD 'プレーン数
wBitCount As WORD 'ビットカウント
dwBytesInRes As DWORD 'リソースのサイズ
dwImageOffset As DWORD '画像データまでのオフセット
End Type
'-----------------------------------------------------------------------------
' ビットマップファイルの書込関数
' Bsave(ビットマップハンドル, ファイル名, 色数*)
' *色数は1－モノクロ, 4－16色, 8－256色, 16, 24, 32はTrueカラーでRGBQUADがない
' 戻り値：成功＝TRUE、失敗＝FALSE
'-----------------------------------------------------------------------------
Function Bsave(ByVal hBmp As Long, pszFile As String, ByVal CBit As Integer) As Integer
Dim hDC As Long, hMem As Long 'デスクトップDCとコンパチビットマップDC
Dim BMPSize As DWORD 'ビットマップサイズ計算用
Dim Bmp As BITMAP '基本情報取得用
Dim Bmf As BITMAPFILEHEADER 'BITMAPFILEHEADER構造体変数
Dim Bmi As BITMAPINFO 'BITMAPINFO構造体変数（ABの場合、既に256個のRGBQUADがついている）
Dim lpBits As String 'ビットパターンへのメモリーポインター
Dim hFile As Long '書込みファイルハンドル
Dim dwTotal As DWORD '総バイト数
Dim dwTmp As Long 'WriteFile()関数の書込バイト数用
Dim nSuccess As Integer 'GetDIBits関数の成功判定フラグ
'デスティネーションのビットマップ情報構造体を初期化
GetObject(hBmp, Len(Bmp), Bmp)
If(CBit = 0) Then 'CBitが0の場合はDDBのカラービットとする
CBit = Bmp.bmBitsPixel
End If
'CBitのチェック
Select Case(CBit)
Case 1
Case 4
Case 8
Case 16
Case 24
Case 32
Case Else '上記以外は受け付けられない
Bsave = FALSE
Exit Function
End Select
'BITMAPINFOの準備
Bmi.bmiHeader.biSize = 40 'sizeof(BITMAPINFOHEADER)
Bmi.bmiHeader.biWidth = Bmp.bmWidth
Bmi.bmiHeader.biHeight = Bmp.bmHeight
Bmi.bmiHeader.biPlanes = 1
Bmi.bmiHeader.biBitCount = CBit
Bmi.bmiHeader.biCompression = BI_RGB '0x0
Bmi.bmiHeader.biSizeImage = 0 '圧縮時以外は0
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'ビットマップデータサイズを算出（4の倍数でなければならない）
BMPSize = ((CBit * Bmi.bmiHeader.biWidth + 31) \ 32) * 4 * Abs(Bmi.bmiHeader.biHeight)
'BITMAPFILEHEADERの準備
Bmf.bfType = &H4D42 '"BM" - ひっくり返っているが
Bmf.bfReserved1 = 0
Bmf.bfReserved2 = 0
If(CBit <= 8) Then 'BITMAPFILEHEADER + BITMAPINFOHEADER + RGBQUAD
Bmf.bfOffBits = 54 + (4 * (2 ^ CBit))
Else 'BITMAPFILEHEADER + BITMAPINFOHEADER
Bmf.bfOffBits = 54
End If
Bmf.bfSize = BMPSize + Bmf.bfOffBits 'ファイルサイズ
'ビットパターンデータの準備
lpBits = String$(BMPSize, Chr$(0)) 'メモリーサイズ確保（ABでは文字列を使用している）
'ここで色数を変更
hDC = GetDC(0) 'デスクトップのデバイスコンテキスト
hMem = CreateCompatibleDC(hDC) 'そのコンパチDC
SelectObject(hMem, hBmp) 'ビットマップを読ませる
'ビット配列をGetDIBits関数でlpBitsに取り出す
nSuccess = GetDIBits(hMem, hBmp, 0, Bmp.bmHeight, lpBits, Bmi, DIB_RGB_COLORS)
DeleteDC(hMem) 'コンパチDCを削除
ReleaseDC(0, hDC) 'デスクトップのデバイスコンテキストを開放
If(nSuccess = 0) Then '色数変更失敗
MessageBox(NULL, "色数変更に失敗しました", "エラー", MB_OK Or MB_ICONSTOP)
Bsave = FALSE
Exit Function
End If
'--------------
' ファイル作成
'--------------
'書き込み用ファイルを開く
hFile = CreateFile(pszFile, _
GENERIC_WRITE, _
0, _
ByVal NULL, _
CREATE_ALWAYS, _
FILE_ATTRIBUTE_NORMAL, _
NULL)
If(hFile = INVALID_HANDLE_VALUE) Then
MessageBox(NULL, "ファイルを開くことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
Bsave = FALSE
Exit Function
End If
'各ヘッダーの書きこみ
'BITMAPFILEHEADERをファイルへ書き込む
If(WriteFile(hFile, Bmf, 14, dwTmp, ByVal NULL) = 0) Then 'sizeof(BITMAPFILEHEADER) = 14
MessageBox(NULL, "ビットマップファイルヘッダーを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'BITMAPINFOHEADERとRGBQUADをファイルへ書き込む
If(WriteFile(hFile, Bmi, Bmf.bfOffBits - 14, dwTmp, ByVal NULL) = 0) Then 'BITMAPINFOHEADER + RGBQUAD
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'ビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, lpBits, BMPSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'x.BMPファイルをクローズする
If(CloseHandle(hFile)) = 0 Then
MessageBox(NULL, "ファイルをクローズできませんでした", "エラー", MB_OK Or MB_ICONSTOP)
End If
Bsave = TRUE
End Function
'--------------------------------------------------------------------------------
' ビットマップをアイコンとして書込む関数
' SaveAsIcon(ウィンドウハンドル、ビットマップハンドル, ファイル名, サイズ, 色数*)
' *色数は1－モノクロ, 4－16色, 8－256色, 16, 24, 32はTrueカラーでRGBQUADがない
' 戻り値：成功＝TRUE、失敗＝FALSE
'--------------------------------------------------------------------------------
Function SaveAsIcon(ByVal hBmp As Long, pszFile As String, ByVal CBit As Integer) As Integer
Dim hDC As Long, hMem As Long 'デスクトップDCとコンパチビットマップDC
Dim BMPSize As DWORD 'Colorビットマップサイズ計算用
Dim MASKSize As DWORD 'Maskビットマップサイズ計算用
Dim Bmp As BITMAP '基本情報取得用
Dim Bmi As BITMAPINFO 'BITMAPINFO構造体変数（ABの場合、既に256個のRGBQUADがついている）
Dim lpBits As String 'Colorビットパターンへのメモリーポインター
Dim mskBits As String 'Maskビットパターンへのメモリーポインター
Dim BkCol As Integer '背景色パレット番号
Dim IconDir As ICONDIR 'ICONDIR構造体
Dim IconEntry As ICONDIRENTRY 'ICONDIRENTRY構造体
Dim hFile As Long '書込みファイルハンドル
Dim dwTotal As DWORD '総バイト数
Dim dwTmp As Long 'WriteFile()関数の書込バイト数用
Dim nSuccess As Integer 'GetDIBits関数の成功判定フラグ
'デスティネーションのビットマップ情報構造体を初期化
GetObject(hBmp, Len(Bmp), Bmp)
If(Bmp.bmWidth <> 16 And Bmp.bmWidth <>32) Then '16 x 16と32 x 32しか受け付けない
SaveAsIcon = FALSE
Exit Function
End If
'CBitのチェック
If(CBit <> 1 And CBit <> 4 And CBit <> 8) Then '左記以外は受け付けられない
SaveAsIcon = FALSE
Exit Function
End If
'ビットマップデータサイズを算出（4の倍数で無ければならない）
BMPSize = ((CBit * Bmp.bmWidth + 31) \ 32) * 4 * Abs(Bmp.bmHeight)
'マスクビットのサイズを算出（（4の倍数で無ければならない・16 x 16、32 x 32のみ）
MASKSize = ((Bmp.bmWidth + 31) \ 32) * 4 * Abs(Bmp.bmHeight)
'BITMAPINFOの準備
Bmi.bmiHeader.biSize = 40 'sizeof(BITMAPINFOHEADER)
Bmi.bmiHeader.biWidth = Bmp.bmWidth
Bmi.bmiHeader.biHeight = Bmp.bmHeight
Bmi.bmiHeader.biPlanes = 1
Bmi.bmiHeader.biBitCount = CBit
Bmi.bmiHeader.biCompression = BI_RGB '0x0
Bmi.bmiHeader.biSizeImage = 0 '圧縮時以外は0
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'ビットパターンデータの準備
lpBits = String$(BMPSize, Chr$(0)) 'Colorビットメモリー確保（ABでは文字列を使用している）
'ここで色数を変更
hDC = GetDC(0) 'デスクトップのデバイスコンテキスト
hMem = CreateCompatibleDC(hDC) 'そのコンパチDC
SelectObject(hMem, hBmp) 'ビットマップを読ませる
'ビット配列をGetDIBits関数でlpBitsに取り出す
nSuccess = GetDIBits(hMem, hBmp, 0, Bmp.bmHeight, lpBits, Bmi, DIB_RGB_COLORS)
DeleteDC(hMem) 'コンパチDCを削除
ReleaseDC(0, hDC) 'デスクトップのデバイスコンテキストを開放
If(nSuccess = 0) Then '色数変更失敗
MessageBox(NULL, "色数変更に失敗しました", "エラー", MB_OK Or MB_ICONSTOP)
SaveAsIcon = FALSE
Exit Function
End If
'イメージ最左上端ピクセルの色を背景色とする為に先ず1バイトを取り出す
If(Bmi.bmiHeader.biHeight > 0) Then 'ボトムアップ
BkCol = Asc(Mid$(lpBits, 1 + ((CBit * Bmp.bmWidth + 31) \ 32) * 4 * (Abs(Bmp.bmHeight) - 1), 1))
Else 'ボトムダウン
BkCol = Asc(Mid$(lpBits, 1, 1))
End If
Select Case(CBit)
Case 1 'モノクロの場合は第7ビットが値
BkCol = BkCol \ 128
Case 4 '16色の場合は上位4ビットが値
BkCol = BkCol \ 16
End Select
'マスクビットパターンを作成
mskBits = String$(MASKSize, Chr$(0)) 'Maskビットメモリー確保（ABでは文字列を使用しいる）
Dim i As Integer, j As Integer, Dat As Integer, Bit As Byte
For i = 1 to MASKSize
Bit = 0
For j = 7 to 0 Step -1
Select Case(CBit)
Case 1
If((Asc(Mid$(lpBits, i, 1)) And (2 ^ j)) = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
Case 4
If(j Mod 2 = 1) Then
Dat = Asc(Mid$(lpBits, (i - 1) * 4 + (7 - j) \ 2 + 1, 1)) \ 16
Else
Dat = Asc(Mid$(lpBits, (i - 1) * 4 + (7 - j) \ 2 + 1, 1)) Mod 16
End If
If(Dat = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
Case 8
If(Asc(Mid$(lpBits, (i - 1) * 8 + 8 - j, 1)) = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
End Select
Next j
Mid(mskBits, i, 1) = Chr$(Bit)
Next i
'幅が16の時には2バイト分の0が続くので修正する
' 現状のデーターの状態 実データ 余分な0
' 00000000 00000000 00000000 00000000 11111111 11111111 00000000 00000000
' 00000000 00000000 00000000 00000000 －－＞ 10000000 00000001 00000000 00000000
' 10000000 00000001 11111111 11111111 －－＞ 10000000 00000001 00000000 00000000
' 11111111 11111111 10000000 00000001 11111111 11111111 00000000 00000000
If(Bmp.bmWidth = 16) Then
Dim temp As String
temp = ""
For i = 1 to MASKSize \ 2 Step 2
temp = temp + Mid$(mskBits, i, 2)
temp = temp + Chr$(0) + Chr$(0)
Next i
mskBits = temp
End If
'ICONDIR構造体の準備
IconDir.idReserved = 0 '必ず0
IconDir.idType = 1 'Iconの場合1
IconDir.idCount = 1 'エントリーの数
'ICONDIRENTRY構造体の準備
IconEntry.bWidth = Bmp.bmWidth 'アイコンの幅
IconEntry.bHeight = Bmp.bmHeight 'アイコンの高さ
Select Case(CBit) '色数 - 0 (256色), 2, 16でそれぞれwBitCountの8、1、4に対応
Case 1
IconEntry.bColorCount = 2
Case 4
IconEntry.bColorCount = 16
Case 8
IconEntry.bColorCount = 0
EndSelect
IconEntry.bReserved = 0 '必ず0
IconEntry.wPlanes = 1 'プレーン数
IconEntry.wBitCount = CBit 'ビットカウント
IconEntry.dwBytesInRes = 40 + 4 * (2 ^ CBit) + BMPSize + MASKSize 'BITMAPINFO(40) + Color Pallette + BMPSize + MaskBit size
IconEntry.dwImageOffset = Len(IconDir) + Len(IconEntry) '画像データまでのオフセットICONDIR = 6 + ICONDIRENTRY = 16
'BITMAPINFO構造体の修正
Bmi.bmiHeader.biHeight = Bmp.bmHeight * 2 'ここが通常のビットマップと異なる
Bmi.bmiHeader.biCompression = 0 'ここは常に0
Bmi.bmiHeader.biSizeImage = BMPSize + MASKSize '表示データ部とマスクデータ部の合計サイズ
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'--------------
' ファイル作成
'--------------
'書き込み用ファイルを開く
hFile = CreateFile(pszFile, _
GENERIC_WRITE, _
0, _
ByVal NULL, _
CREATE_ALWAYS, _
FILE_ATTRIBUTE_NORMAL, _
NULL)
If(hFile = INVALID_HANDLE_VALUE) Then
MessageBox(NULL, "ファイルを開くことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
SaveAsIcon = FALSE
Exit Function
End If
'ICONDIR構造体をファイルへ書き込む
If(WriteFile(hFile, IconDir, 6, dwTmp, ByVal NULL) = 0) Then 'sizeof(IconDir) = 6
MessageBox(NULL, "ビットマップファイルヘッダーを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'ICONDIRENTRY構造体をファイルへ書き込む
If(WriteFile(hFile, IconEntry, 16, dwTmp, ByVal NULL) = 0) Then 'sizeof(IconEntry) = 16
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'BITMAPINFO構造体をファイルへ書き込む
If(WriteFile(hFile, Bmi, 40 + 4 * (2 ^ CBit), dwTmp, ByVal NULL) = 0) Then 'BITMAPINFO + RGBQUAD x 2 ^ CBit
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'Colorビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, lpBits, BMPSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'Maskビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, mskBits, MASKSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'x.icoファイルをクローズする
If(CloseHandle(hFile)) = 0 Then
MessageBox(NULL, "ファイルをクローズできませんでした", "エラー", MB_OK Or MB_ICONSTOP)
End If
SaveAsIcon = TRUE
End Function
'-------------------------------------------------------------
' GetBmpFromWnd()関数でビットマップをウィンドウから取る
' GetBmpFromWnd(ウィンドウウハンドル, x座標, y座標, 幅, 高さ)
' 戻り値：取得したビットマップのハンドル
' ☆必ず後でDeleteObjectを使用してビットマップを廃棄すること
'-------------------------------------------------------------
Function GetBmpFromWnd(ByVal hWnd As Long, ByVal x As Integer, ByVal y As Integer, ByVal w As Integer, ByVal h As Integer) As Long
Dim hDC As Long, hMem As Long, hBmp As Long
hDC = GetDC(hWnd)
hMem = CreateCompatibleDC(hDC)
hBmp = CreateCompatibleBitmap(hDC, w, h)
SelectObject(hMem, hBmp)
StretchBlt(hMem, 0, 0, w, h, hDC, x, y, w, h, SRCCOPY)
GetBmpFromWnd = hBmp
DeleteDC(hMem)
ReleaseDC(hWnd, hDC)
End Function
'----------------------------------------------------------------------------------
' ShowBmpInWnd()関数でビットマップをウィンドウに表示
' ShowBmpInWnd(ウィンドウウハンドル, ビットマップハンドル, x座標, y座標, 幅, 高さ)
' 幅、高さに0を入れると元々のサイズで表示
' 戻り値：なし
'----------------------------------------------------------------------------------
Function ShowBmpInWnd(ByVal hWnd As Long, ByVal hBmp As Long, ByVal x As Long, ByVal y As Long, ByVal w As Long, ByVal h As LOng)
Dim hDC As Long, hMem As Long, bmp As BITMAP
GetObject(hBmp, Len(bmp), bmp)
hDC = GetDC(hWnd)
hMem = CreateCompatibleDC(hDC)
SelectObject(hMem, hBmp)
If(w * h = 0) Then
w = bmp.bmWidth
h = bmp.bmHeight
End If
StretchBlt(hDC, x, y, w, h, hMem, 0, 0, bmp.bmWidth, bmp.bmHeight, SRCCOPY)
DeleteDC(hMem)
ReleaseDC(hWnd, hDC)
End Function
'------------------------------------------------
' クリップボードからビットマップハンドルを取得
' LoadFromClipboard(ビットマップハンドル(参照）)
' 戻り値：成功＝TRUE、失敗FLASE
'------------------------------------------------
Function LoadFromClipboard(hBmp As Long) As Integer
Dim temp As Long
If(IsClipboardFormatAvailable(CF_BITMAP)) Then
OpenClipboard(NULL)
temp = GetClipboardData(CF_BITMAP)
CloseClipboard()
If(temp <> 0) Then
'現在のビットマップは破棄する
If(hBmp <> 0) Then
DeleteObject(hBmp)
End If
'DIBSECTIONを作成してハンドルを渡す
hBmp = CopyImage(temp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG Or LR_COPYDELETEORG)
If(hBmp) Then
LoadFromClipboard = TRUE
Else
LoadFromClipboard = FALSE
End If
Else
LoadFromClipboard = FALSE
End If
Else
LoadFromClipboard = FALSE
End If
End Function
'------------------------------------------------
' ビットマップをクリップボードにコピー
' SaveToClipboard(ビットマップハンドル(参照）)
' 戻り値：成功＝TRUE、失敗FLASE
'------------------------------------------------
Function SaveToClipboard(hBmp As Long) As Integer
If(hBmp) Then
If(OpenClipboard(NULL) = 0) Then
SaveToClipboard = FALSE
Exit Function
Else
If(EmptyClipboard() = 0) Then
SaveToClipboard = FALSE
Exit Function
End If
End If
SetClipboardData(CF_BITMAP, CopyImage(hBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG))
CloseClipboard()
End If
SaveToClipboard = TRUE
End Function
' Win32API Graphic Functions
' ABのグラフィック命令の代替関数
'--------------------------------------
'/////////////////////////
'//ABのPSet命令の代替関数
'/////////////////////////
Sub PSetAPI(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, Col As Long)
Dim hDC As Long
hDC = GetDC(hWnd)
SetPixel(hDC, x, y, Col)
ReleaseDC(hWnd, hDC)
End Sub
'/////////////////////////
'//ABのLine命令の代替関数
'/////////////////////////
Sub LineAPI(ByVal hWnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal flag As Integer, ByVal Col As Long)
Dim hDC As Long, lpRect As RECT, hPen As Long, hBrush As Long, hOld As Long
hDC = GetDC(hWnd)
hPen = CreatePen(PS_SOLID, 0, Col)
hBrush = CreateSolidBrush(Col)
Select Case(flag)
Case 1
hOld = SelectObject(hDC, hPen)
MoveToEx(hDC, x1, y1, ByVal NULL)
LineTo(hDC, x2, y1)
LineTo(hDC, x2, y2)
LineTo(hDC, x1, y2)
LineTo(hDC, x1, y1)
SelectObject(hDC, hOld)
Case 2
lpRect.left = x1
lpRect.right = x2
lpRect.top = y1
lpRect.bottom = y2
hOld = SelectObject(hDC, hBrush)
FillRect(hDC, lpRect, hBrush)
SelectObject(hDC, hOld)
Case Else
hOld = SelectObject(hDC, hPen)
MoveToEx(hDC, x1, y1, ByVal NULL)
LineTo(hDC, x2, y2)
SelectObject(hDC, hOld)
End Select
DeleteObject(hPen)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'///////////////////////////
'//ABのCircle命令の代替関数
'///////////////////////////
Sub CircleAPI(ByVal hWnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal flag As Integer, ByVal Col As Long)
Dim hDC As Long, brs As LOGBRUSH, hPen As Long, hBrush As Long, hOldPen As Long, hOldBrush As Long
hDC = GetDC(hWnd)
hPen = CreatePen(PS_SOLID, 0, Col)
hOldPen = SelectObject(hDC, hPen)
brs.lbColor = Col
brs.lbHatch = NULL 'lbStyleがBS_SOLID、BS_NULL(BS_HOLLOW)の場合無視される
Select Case(flag)
Case 1 'TRUEで塗りつぶし
brs.lbStyle = BS_SOLID
hBrush = CreateBrushIndirect(brs)
hOldBrush = SelectObject(hDC, hBrush)
Ellipse(hDC, x1, y1, x2, y2)
SelectObject(hDC, hOldBrush)
Case Else 'FALSEで塗りつぶしなし
brs.lbStyle = BS_NULL
hBrush = CreateBrushIndirect(brs)
hOldBrush = SelectObject(hDC, hBrush)
Ellipse(hDC, x1, y1, x2, y2)
SelectObject(hDC, hOldBrush)
End Select
SelectObject(hDC, hOldPen)
DeleteObject(hPen)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'//////////////////////////
'//ABのPaint命令の代替関数
'//////////////////////////
Sub PaintAPI(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, Col As Long)
Dim hDC As Long, hBrush As Long, hOldBrush As Long, sfCol As Long
hDC = GetDC(hWnd)
hBrush = CreateSolidBrush(Col)
hOldBrush = SelectObject(hDC, hBrush)
sfCol = GetPixel(hDC, x, y)
ExtFloodFill(hDC, x, y, sfCol, FLOODFILLSURFACE)
SelectObject(hDC, hOldBrush)
DeleteObject(hBrush)
ReleaseDC(hWnd, hDC)
End Sub
'--------------------------------------
' BitmapUty.sbp
' Bitmap関連ユーティリティライブラリー
'--------------------------------------
'//////////////////
'//Bitmap用追加DLL
'//////////////////
Declare Function IsClipboardFormatAvailable Lib "user32" Alias "IsClipboardFormatAvailable" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function GetClipboardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
'////////////////
'//追加DLL用定数
'////////////////
Const CF_BITMAP = 2
'/////////////
'//追加構造体
'/////////////
'BITMAPFILEHEADER構造体宣言 － 14バイト長
Type BITMAPFILEHEADER
Dim bfType As WORD 'B', 'M' - ひっくり返っているが
Dim bfSize As DWORD 'ファイルサイズ
Dim bfReserved1 As WORD
Dim bfReserved2 As WORD
Dim bfOffBits DWORD 'ファイル先頭からビットパターンまでのオフセット(54byte＋パレットデータ)
End Type
'ICONDIR構造体宣言 － 6バイト長
Type ICONDIR
idReserved As WORD '常に0
idType As WORD 'Iconの場合1、Cursorの場合2
idCount As WORD 'エントリーの数
End Type
'ICONDIRENTRY構造体宣言 － 16バイト長
Type ICONDIRENTRY
bWidth As BYTE 'アイコンの幅
bHeight As BYTE 'アイコンの高さ
bColorCount As BYTE '色数 - 0 (256色), 2, 16でそれぞれwBitCountの8、1、4に対応
bReserved As BYTE '0
wPlanes As WORD 'プレーン数
wBitCount As WORD 'ビットカウント
dwBytesInRes As DWORD 'リソースのサイズ
dwImageOffset As DWORD '画像データまでのオフセット
End Type
'-----------------------------------------------------------------------------
' ビットマップファイルの書込関数
' Bsave(ビットマップハンドル, ファイル名, 色数*)
' *色数は1－モノクロ, 4－16色, 8－256色, 16, 24, 32はTrueカラーでRGBQUADがない
' 戻り値：成功＝TRUE、失敗＝FALSE
'-----------------------------------------------------------------------------
Function Bsave(ByVal hBmp As Long, pszFile As String, ByVal CBit As Integer) As Integer
Dim hDC As Long, hMem As Long 'デスクトップDCとコンパチビットマップDC
Dim BMPSize As DWORD 'ビットマップサイズ計算用
Dim Bmp As BITMAP '基本情報取得用
Dim Bmf As BITMAPFILEHEADER 'BITMAPFILEHEADER構造体変数
Dim Bmi As BITMAPINFO 'BITMAPINFO構造体変数（ABの場合、既に256個のRGBQUADがついている）
Dim lpBits As String 'ビットパターンへのメモリーポインター
Dim hFile As Long '書込みファイルハンドル
Dim dwTotal As DWORD '総バイト数
Dim dwTmp As Long 'WriteFile()関数の書込バイト数用
Dim nSuccess As Integer 'GetDIBits関数の成功判定フラグ
'デスティネーションのビットマップ情報構造体を初期化
GetObject(hBmp, Len(Bmp), Bmp)
If(CBit = 0) Then 'CBitが0の場合はDDBのカラービットとする
CBit = Bmp.bmBitsPixel
End If
'CBitのチェック
Select Case(CBit)
Case 1
Case 4
Case 8
Case 16
Case 24
Case 32
Case Else '上記以外は受け付けられない
Bsave = FALSE
Exit Function
End Select
'BITMAPINFOの準備
Bmi.bmiHeader.biSize = 40 'sizeof(BITMAPINFOHEADER)
Bmi.bmiHeader.biWidth = Bmp.bmWidth
Bmi.bmiHeader.biHeight = Bmp.bmHeight
Bmi.bmiHeader.biPlanes = 1
Bmi.bmiHeader.biBitCount = CBit
Bmi.bmiHeader.biCompression = BI_RGB '0x0
Bmi.bmiHeader.biSizeImage = 0 '圧縮時以外は0
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'ビットマップデータサイズを算出（4の倍数でなければならない）
BMPSize = ((CBit * Bmi.bmiHeader.biWidth + 31) \ 32) * 4 * Abs(Bmi.bmiHeader.biHeight)
'BITMAPFILEHEADERの準備
Bmf.bfType = &H4D42 '"BM" - ひっくり返っているが
Bmf.bfReserved1 = 0
Bmf.bfReserved2 = 0
If(CBit <= 8) Then 'BITMAPFILEHEADER + BITMAPINFOHEADER + RGBQUAD
Bmf.bfOffBits = 54 + (4 * (2 ^ CBit))
Else 'BITMAPFILEHEADER + BITMAPINFOHEADER
Bmf.bfOffBits = 54
End If
Bmf.bfSize = BMPSize + Bmf.bfOffBits 'ファイルサイズ
'ビットパターンデータの準備
lpBits = String$(BMPSize, Chr$(0)) 'メモリーサイズ確保（ABでは文字列を使用している）
'ここで色数を変更
hDC = GetDC(0) 'デスクトップのデバイスコンテキスト
hMem = CreateCompatibleDC(hDC) 'そのコンパチDC
SelectObject(hMem, hBmp) 'ビットマップを読ませる
'ビット配列をGetDIBits関数でlpBitsに取り出す
nSuccess = GetDIBits(hMem, hBmp, 0, Bmp.bmHeight, lpBits, Bmi, DIB_RGB_COLORS)
DeleteDC(hMem) 'コンパチDCを削除
ReleaseDC(0, hDC) 'デスクトップのデバイスコンテキストを開放
If(nSuccess = 0) Then '色数変更失敗
MessageBox(NULL, "色数変更に失敗しました", "エラー", MB_OK Or MB_ICONSTOP)
Bsave = FALSE
Exit Function
End If
'--------------
' ファイル作成
'--------------
'書き込み用ファイルを開く
hFile = CreateFile(pszFile, _
GENERIC_WRITE, _
0, _
ByVal NULL, _
CREATE_ALWAYS, _
FILE_ATTRIBUTE_NORMAL, _
NULL)
If(hFile = INVALID_HANDLE_VALUE) Then
MessageBox(NULL, "ファイルを開くことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
Bsave = FALSE
Exit Function
End If
'各ヘッダーの書きこみ
'BITMAPFILEHEADERをファイルへ書き込む
If(WriteFile(hFile, Bmf, 14, dwTmp, ByVal NULL) = 0) Then 'sizeof(BITMAPFILEHEADER) = 14
MessageBox(NULL, "ビットマップファイルヘッダーを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'BITMAPINFOHEADERとRGBQUADをファイルへ書き込む
If(WriteFile(hFile, Bmi, Bmf.bfOffBits - 14, dwTmp, ByVal NULL) = 0) Then 'BITMAPINFOHEADER + RGBQUAD
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'ビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, lpBits, BMPSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
Bsave = FALSE
Exit Function
End If
'x.BMPファイルをクローズする
If(CloseHandle(hFile)) = 0 Then
MessageBox(NULL, "ファイルをクローズできませんでした", "エラー", MB_OK Or MB_ICONSTOP)
End If
Bsave = TRUE
End Function
'--------------------------------------------------------------------------------
' ビットマップをアイコンとして書込む関数
' SaveAsIcon(ウィンドウハンドル、ビットマップハンドル, ファイル名, サイズ, 色数*)
' *色数は1－モノクロ, 4－16色, 8－256色, 16, 24, 32はTrueカラーでRGBQUADがない
' 戻り値：成功＝TRUE、失敗＝FALSE
'--------------------------------------------------------------------------------
Function SaveAsIcon(ByVal hBmp As Long, pszFile As String, ByVal CBit As Integer) As Integer
Dim hDC As Long, hMem As Long 'デスクトップDCとコンパチビットマップDC
Dim BMPSize As DWORD 'Colorビットマップサイズ計算用
Dim MASKSize As DWORD 'Maskビットマップサイズ計算用
Dim Bmp As BITMAP '基本情報取得用
Dim Bmi As BITMAPINFO 'BITMAPINFO構造体変数（ABの場合、既に256個のRGBQUADがついている）
Dim lpBits As String 'Colorビットパターンへのメモリーポインター
Dim mskBits As String 'Maskビットパターンへのメモリーポインター
Dim BkCol As Integer '背景色パレット番号
Dim IconDir As ICONDIR 'ICONDIR構造体
Dim IconEntry As ICONDIRENTRY 'ICONDIRENTRY構造体
Dim hFile As Long '書込みファイルハンドル
Dim dwTotal As DWORD '総バイト数
Dim dwTmp As Long 'WriteFile()関数の書込バイト数用
Dim nSuccess As Integer 'GetDIBits関数の成功判定フラグ
'デスティネーションのビットマップ情報構造体を初期化
GetObject(hBmp, Len(Bmp), Bmp)
If(Bmp.bmWidth <> 16 And Bmp.bmWidth <>32) Then '16 x 16と32 x 32しか受け付けない
SaveAsIcon = FALSE
Exit Function
End If
'CBitのチェック
If(CBit <> 1 And CBit <> 4 And CBit <> 8) Then '左記以外は受け付けられない
SaveAsIcon = FALSE
Exit Function
End If
'ビットマップデータサイズを算出（4の倍数で無ければならない）
BMPSize = ((CBit * Bmp.bmWidth + 31) \ 32) * 4 * Abs(Bmp.bmHeight)
'マスクビットのサイズを算出（（4の倍数で無ければならない・16 x 16、32 x 32のみ）
MASKSize = ((Bmp.bmWidth + 31) \ 32) * 4 * Abs(Bmp.bmHeight)
'BITMAPINFOの準備
Bmi.bmiHeader.biSize = 40 'sizeof(BITMAPINFOHEADER)
Bmi.bmiHeader.biWidth = Bmp.bmWidth
Bmi.bmiHeader.biHeight = Bmp.bmHeight
Bmi.bmiHeader.biPlanes = 1
Bmi.bmiHeader.biBitCount = CBit
Bmi.bmiHeader.biCompression = BI_RGB '0x0
Bmi.bmiHeader.biSizeImage = 0 '圧縮時以外は0
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'ビットパターンデータの準備
lpBits = String$(BMPSize, Chr$(0)) 'Colorビットメモリー確保（ABでは文字列を使用している）
'ここで色数を変更
hDC = GetDC(0) 'デスクトップのデバイスコンテキスト
hMem = CreateCompatibleDC(hDC) 'そのコンパチDC
SelectObject(hMem, hBmp) 'ビットマップを読ませる
'ビット配列をGetDIBits関数でlpBitsに取り出す
nSuccess = GetDIBits(hMem, hBmp, 0, Bmp.bmHeight, lpBits, Bmi, DIB_RGB_COLORS)
DeleteDC(hMem) 'コンパチDCを削除
ReleaseDC(0, hDC) 'デスクトップのデバイスコンテキストを開放
If(nSuccess = 0) Then '色数変更失敗
MessageBox(NULL, "色数変更に失敗しました", "エラー", MB_OK Or MB_ICONSTOP)
SaveAsIcon = FALSE
Exit Function
End If
'イメージ最左上端ピクセルの色を背景色とする為に先ず1バイトを取り出す
If(Bmi.bmiHeader.biHeight > 0) Then 'ボトムアップ
BkCol = Asc(Mid$(lpBits, 1 + ((CBit * Bmp.bmWidth + 31) \ 32) * 4 * (Abs(Bmp.bmHeight) - 1), 1))
Else 'ボトムダウン
BkCol = Asc(Mid$(lpBits, 1, 1))
End If
Select Case(CBit)
Case 1 'モノクロの場合は第7ビットが値
BkCol = BkCol \ 128
Case 4 '16色の場合は上位4ビットが値
BkCol = BkCol \ 16
End Select
'マスクビットパターンを作成
mskBits = String$(MASKSize, Chr$(0)) 'Maskビットメモリー確保（ABでは文字列を使用しいる）
Dim i As Integer, j As Integer, Dat As Integer, Bit As Byte
For i = 1 to MASKSize
Bit = 0
For j = 7 to 0 Step -1
Select Case(CBit)
Case 1
If((Asc(Mid$(lpBits, i, 1)) And (2 ^ j)) = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
Case 4
If(j Mod 2 = 1) Then
Dat = Asc(Mid$(lpBits, (i - 1) * 4 + (7 - j) \ 2 + 1, 1)) \ 16
Else
Dat = Asc(Mid$(lpBits, (i - 1) * 4 + (7 - j) \ 2 + 1, 1)) Mod 16
End If
If(Dat = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
Case 8
If(Asc(Mid$(lpBits, (i - 1) * 8 + 8 - j, 1)) = BkCol) Then
Bit = Bit Or (2 ^ j)
End If
End Select
Next j
Mid(mskBits, i, 1) = Chr$(Bit)
Next i
'幅が16の時には2バイト分の0が続くので修正する
' 現状のデーターの状態 実データ 余分な0
' 00000000 00000000 00000000 00000000 11111111 11111111 00000000 00000000
' 00000000 00000000 00000000 00000000 －－＞ 10000000 00000001 00000000 00000000
' 10000000 00000001 11111111 11111111 －－＞ 10000000 00000001 00000000 00000000
' 11111111 11111111 10000000 00000001 11111111 11111111 00000000 00000000
If(Bmp.bmWidth = 16) Then
Dim temp As String
temp = ""
For i = 1 to MASKSize \ 2 Step 2
temp = temp + Mid$(mskBits, i, 2)
temp = temp + Chr$(0) + Chr$(0)
Next i
mskBits = temp
End If
'ICONDIR構造体の準備
IconDir.idReserved = 0 '必ず0
IconDir.idType = 1 'Iconの場合1
IconDir.idCount = 1 'エントリーの数
'ICONDIRENTRY構造体の準備
IconEntry.bWidth = Bmp.bmWidth 'アイコンの幅
IconEntry.bHeight = Bmp.bmHeight 'アイコンの高さ
Select Case(CBit) '色数 - 0 (256色), 2, 16でそれぞれwBitCountの8、1、4に対応
Case 1
IconEntry.bColorCount = 2
Case 4
IconEntry.bColorCount = 16
Case 8
IconEntry.bColorCount = 0
EndSelect
IconEntry.bReserved = 0 '必ず0
IconEntry.wPlanes = 1 'プレーン数
IconEntry.wBitCount = CBit 'ビットカウント
IconEntry.dwBytesInRes = 40 + 4 * (2 ^ CBit) + BMPSize + MASKSize 'BITMAPINFO(40) + Color Pallette + BMPSize + MaskBit size
IconEntry.dwImageOffset = Len(IconDir) + Len(IconEntry) '画像データまでのオフセットICONDIR = 6 + ICONDIRENTRY = 16
'BITMAPINFO構造体の修正
Bmi.bmiHeader.biHeight = Bmp.bmHeight * 2 'ここが通常のビットマップと異なる
Bmi.bmiHeader.biCompression = 0 'ここは常に0
Bmi.bmiHeader.biSizeImage = BMPSize + MASKSize '表示データ部とマスクデータ部の合計サイズ
Bmi.bmiHeader.biXPelsPerMeter = 0
Bmi.bmiHeader.biYPelsPerMeter = 0
Bmi.bmiHeader.biClrUsed = 0
Bmi.bmiHeader.biClrImportant = 0
'--------------
' ファイル作成
'--------------
'書き込み用ファイルを開く
hFile = CreateFile(pszFile, _
GENERIC_WRITE, _
0, _
ByVal NULL, _
CREATE_ALWAYS, _
FILE_ATTRIBUTE_NORMAL, _
NULL)
If(hFile = INVALID_HANDLE_VALUE) Then
MessageBox(NULL, "ファイルを開くことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
SaveAsIcon = FALSE
Exit Function
End If
'ICONDIR構造体をファイルへ書き込む
If(WriteFile(hFile, IconDir, 6, dwTmp, ByVal NULL) = 0) Then 'sizeof(IconDir) = 6
MessageBox(NULL, "ビットマップファイルヘッダーを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'ICONDIRENTRY構造体をファイルへ書き込む
If(WriteFile(hFile, IconEntry, 16, dwTmp, ByVal NULL) = 0) Then 'sizeof(IconEntry) = 16
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'BITMAPINFO構造体をファイルへ書き込む
If(WriteFile(hFile, Bmi, 40 + 4 * (2 ^ CBit), dwTmp, ByVal NULL) = 0) Then 'BITMAPINFO + RGBQUAD x 2 ^ CBit
MessageBox(NULL, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'Colorビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, lpBits, BMPSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'Maskビットマップビット配列をファイルへ書き込む
If(WriteFile(hFile, mskBits, MASKSize, dwTmp, ByVal NULL) = 0) Then
MessageBox(NULL, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP)
CloseHandle(hFile)
SaveAsIcon = FALSE
Exit Function
End If
'x.icoファイルをクローズする
If(CloseHandle(hFile)) = 0 Then
MessageBox(NULL, "ファイルをクローズできませんでした", "エラー", MB_OK Or MB_ICONSTOP)
End If
SaveAsIcon = TRUE
End Function
'-------------------------------------------------------------
' GetBmpFromWnd()関数でビットマップをウィンドウから取る
' GetBmpFromWnd(ウィンドウウハンドル, x座標, y座標, 幅, 高さ)
' 戻り値：取得したビットマップのハンドル
' ☆必ず後でDeleteObjectを使用してビットマップを廃棄すること
'-------------------------------------------------------------
Function GetBmpFromWnd(ByVal hWnd As Long, ByVal x As Integer, ByVal y As Integer, ByVal w As Integer, ByVal h As Integer) As Long
Dim hDC As Long, hMem As Long, hBmp As Long
hDC = GetDC(hWnd)
hMem = CreateCompatibleDC(hDC)
hBmp = CreateCompatibleBitmap(hDC, w, h)
SelectObject(hMem, hBmp)
StretchBlt(hMem, 0, 0, w, h, hDC, x, y, w, h, SRCCOPY)
GetBmpFromWnd = hBmp
DeleteDC(hMem)
ReleaseDC(hWnd, hDC)
End Function
'----------------------------------------------------------------------------------
' ShowBmpInWnd()関数でビットマップをウィンドウに表示
' ShowBmpInWnd(ウィンドウウハンドル, ビットマップハンドル, x座標, y座標, 幅, 高さ)
' 幅、高さに0を入れると元々のサイズで表示
' 戻り値：なし
'----------------------------------------------------------------------------------
Function ShowBmpInWnd(ByVal hWnd As Long, ByVal hBmp As Long, ByVal x As Long, ByVal y As Long, ByVal w As Long, ByVal h As LOng)
Dim hDC As Long, hMem As Long, bmp As BITMAP
GetObject(hBmp, Len(bmp), bmp)
hDC = GetDC(hWnd)
hMem = CreateCompatibleDC(hDC)
SelectObject(hMem, hBmp)
If(w * h = 0) Then
w = bmp.bmWidth
h = bmp.bmHeight
End If
StretchBlt(hDC, x, y, w, h, hMem, 0, 0, bmp.bmWidth, bmp.bmHeight, SRCCOPY)
DeleteDC(hMem)
ReleaseDC(hWnd, hDC)
End Function
'------------------------------------------------
' クリップボードからビットマップハンドルを取得
' LoadFromClipboard(ビットマップハンドル(参照）)
' 戻り値：成功＝TRUE、失敗FLASE
'------------------------------------------------
Function LoadFromClipboard(hBmp As Long) As Integer
Dim temp As Long
If(IsClipboardFormatAvailable(CF_BITMAP)) Then
OpenClipboard(NULL)
temp = GetClipboardData(CF_BITMAP)
CloseClipboard()
If(temp <> 0) Then
'現在のビットマップは破棄する
If(hBmp <> 0) Then
DeleteObject(hBmp)
End If
'DIBSECTIONを作成してハンドルを渡す
hBmp = CopyImage(temp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG Or LR_COPYDELETEORG)
If(hBmp) Then
LoadFromClipboard = TRUE
Else
LoadFromClipboard = FALSE
End If
Else
LoadFromClipboard = FALSE
End If
Else
LoadFromClipboard = FALSE
End If
End Function
'------------------------------------------------
' ビットマップをクリップボードにコピー
' SaveToClipboard(ビットマップハンドル(参照）)
' 戻り値：成功＝TRUE、失敗FLASE
'------------------------------------------------
Function SaveToClipboard(hBmp As Long) As Integer
If(hBmp) Then
If(OpenClipboard(NULL) = 0) Then
SaveToClipboard = FALSE
Exit Function
Else
If(EmptyClipboard() = 0) Then
SaveToClipboard = FALSE
Exit Function
End If
End If
SetClipboardData(CF_BITMAP, CopyImage(hBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG))
CloseClipboard()
End If
SaveToClipboard = TRUE
End Function
-
ひで
ありがとうございます！
C言語のど素人なので、ポインタに関しての記述知識がありませんでした。
これって基本の基本ですね。
ありがとうございます
これからもっと勉強していきたいと思います
これって基本の基本ですね。
ありがとうございます
これからもっと勉強していきたいと思います
-
ひで
WriteFileで「アクセス違反」が発生してしまいます
やってみたのですが、WriteFileを実行すると、「アクセス違反」が発生してしまいます
いろいろといじってみたのですが、何をやってもここでアクセス違反が発生してしまい、身動き取れなくなってしまいました
情報をお持ちの方、よろしくお願いいたします
いろいろといじってみたのですが、何をやってもここでアクセス違反が発生してしまい、身動き取れなくなってしまいました
情報をお持ちの方、よろしくお願いいたします