ab.com コミュニティ https://www.activebasic.com/forum/ |
|
[AB4]ビットマップを簡単に扱うクラス https://www.activebasic.com/forum/viewtopic.php?t=672 |
ページ 1 / 1 |
作成者: | 淡幻星 [ 2006年1月27日(金) 03:56 ] |
記事の件名: | [AB4]ビットマップを簡単に扱うクラス |
ビットマップを簡単に扱うクラスです。 AB4に、Put@・Get@・Bload(BMP開く)・Bsave(BMP保存)のような 記述を持ち込もうってコンセプトです。 以前に投稿した[AB3]AB2/N88ライクなBLoad/Put@/Get@/Point/Psetを クラスにまとめて、ちょっと機能追加してみました。 クラスの定義はここをクリックしてください。 [ここをクリックすると内容が表示されます]
#N88BASIC環境下でも、それ以外(ノーマルウィンドウベースとか)の環境でも使えます。コード: '定数の定義 Const PSet_BASIC = SRCCOPY Const OR_BASIC = SRCPAINT Const XOR_BASIC = SRCINVERT Const AND_BASIC = SRCAND 'ビットマップを簡単に扱うためのクラス。 Class WsEasyBmp hHeapEB As HANDLE hBmpEB As HBITMAP dwPixelBits As DWordPtr '複数スレッドから呼び出される。下のfPixelBitsで管理。 fPixelBits As Long '複数スレッドから呼び出される。 hTargetWnd As HWND hBasicMemDC As HDC fBasic As Long cs As CRITICAL_SECTION hSecondThread As VoidPtr tID As DWord hAnyThreadParam As DWord 'スレッド間の値渡し。必ず時間差で呼び出されるので排他処理は不要。 nCpuSleepLevel As Long 'ピクセル取得時のCpu抑制率をミリ秒で指定。マイナスをしてすると、DWordキャストされるので2147483648以上を指定したことを意味し、つまりほぼ停止。 'スレッド間の値渡しのための関数。 Function GetAnyThreadParam() As DWord GetAnyThreadParam = hAnyThreadParam End Function Function SetAnyThreadParam( dwAny As DWord ) As DWord hAnyThreadParam = dwAny End Function 'ピクセルデータの配列の有効無効 Function IsPixelBits() As Long EnterCriticalSection( cs ) IsPixelBits = fPixelBits LeaveCriticalSection( cs ) EndFunction Sub SetPixelBits( fFlag As Long ) EnterCriticalSection( cs ) fPixelBits = fFlag LeaveCriticalSection( cs ) EndSub 'Bmpファイルからピクセル情報を得て、配列に格納しておく '別スレッドを呼び出して、そちらで読み込む。 Sub GetPixelBits( hBmpEB As HBITMAP ) Dim hDC As HDC Dim hMemDC As HDC Dim hMemDC2 As HDC Dim hBmp2 As HBITMAP Dim w As Long Dim h As Long '前回のスレッドの終了を待つ。 If( hSecondThread<>NULL )Then If( WAIT_TIMEOUT=WaitForSingleObject(hSecondThread, 0) )Then '念のためスレッド動作中かを確認。 TerminateThread( hSecondThread, 1 ) End If CloseHandle( hSecondThread ) hSecondThread = NULL EndIf 'スレッド用にビットマップを複製。hBmpEB→hBmp2 /* 「1つのビットマップオブジェクトを同時に複数の デバイスコンテキストで選択することはできない.」 http://ls-al.jp/blog/archives/2006/03/post_288.html */ w = GetWidth() h = GetHeight() hDC = GetDC( hTargetWnd ) hMemDC = CreateCompatibleDC( hDC ) hMemDC2 = CreateCompatibleDC( hDC ) hBmp2 = CreateCompatibleBitmap( hDC, w, h ) If( NULL=SelectObject( hMemDC, hBmpEB ) )Then '結合に失敗。 MessageBox(hTargetWnd, "ピクセル情報の取得に失敗。与えられたHBITMAPが新規DCに結合できない。", "エラー", MB_OK Or MB_ICONSTOP) /* そのまま抜けるか、一応最後まで走らせるか・・・。迷うところ。ピクセル有無の無限待機関数の存在を考慮。 DeleteDC( hMemDC ) DeleteDC( hMemDC2 ) ReleaseDC( hTargetWnd ,hDC ) ExitSub */ End If SelectObject( hMemDC2, hBmp2 ) BitBlt( hMemDC2, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY ) DeleteDC( hMemDC ) DeleteDC( hMemDC2 ) ReleaseDC( hTargetWnd ,hDC ) '複製したビットマップからピクセル情報を得る@別スレッドGetPixelBitsA()を作成。 '※複製したビットマップhBmp2はスレッド側で終了時に破棄される。 SetAnyThreadParam( hBmp2 As DWord ) hSecondThread = CreateThread( ByVal NULL, NULL, AddressOf(WsEasyBmp_Static_GetPixelBitsA), VarPtr(This), NULL, VarPtr(tID) ) EndSub 'コールバック関数の類であるスレッドをメンバに持たせるために、 '途中中継を行う静的メソッド。 Sub WsEasyBmp_Static_GetPixelBitsA( vdParam As VoidPtr ) Dim lpWsEasyBmp As *WsEasyBmp lpWsEasyBmp = vdParam As *WsEasyBmp lpWsEasyBmp->GetPixelBitsA() End Sub Public 'Bmpファイルからピクセル情報を得て、配列に格納しておく:本体。 '※別スレッドとして呼び出される。 ' 本当はプライベート・メンバにしたいが、そうすると静的メンバから呼び出せない・・・。 ' これって仕様だっけ? Sub GetPixelBitsA() Dim nSize As Long Dim x As Long Dim y As Long Dim w As Long Dim h As Long Dim hDC As HDC Dim hMemDC As HDC Dim hBmpCpy As HBITMAP '対象となるビットマップハンドルを得る。 '※スレッド間の衝突を考慮 hBmpCpy = GetAnyThreadParam() As HBITMAP If( dwPixelBits<>NULL )Then HeapFree( hHeapEB, NULL, dwPixelBits ) dwPixelBits = NULL EndIf w = GetWidth() h = GetHeight() nSize = w*h dwPixelBits = HeapAlloc( hHeapEB, HEAP_ZERO_MEMORY, nSize*4 ) 'RGB=24bit ≒ DWord = 4Byte = 32Bit hDC = GetDC( hTargetWnd ) hMemDC = CreateCompatibleDC( hDC ) SelectObject( hMemDC, hBmpCpy ) For y=0 To h-1 For x=0 To w-1 dwPixelBits[ y*w + x ] = GetPixel( hMemDC, x, y ) Next Sleep( nCpuSleepLevel As DWord ) Next DeleteDC( hMemDC ) ReleaseDC( hTargetWnd ,hDC ) '利用したビットマップ(複製)を破棄する。 DeleteObject( hBmpCpy ) 'ピクセル情報を取得したことを通知する。 SetPixelBits( TRUE ) ExitThread( 0 ) EndSub Private 'ビットマップを保存する '※ysama様のログからコピペ Function BsaveA(hBmp As Long, pszFile As BytePtr, CBit As Integer) As Integer '----------------------------------------------------------------------------- ' ビットマップファイルの書込関数 ' BsaveA(ビットマップハンドル, ファイル名, 色数*) ' *色数は1-モノクロ, 4-16色, 8-256色, 16, 24, 32はTrueカラーでRGBQUADがない ' 戻り値:成功=TRUE、失敗=FALSE '----------------------------------------------------------------------------- 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 BytePtr 'ビットパターンへのメモリーポインター 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 '上記以外は受け付けられない BsaveA = 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 * (1 << CBit)) Else 'BITMAPFILEHEADER + BITMAPINFOHEADER Bmf.bfOffBits = 54 End If Bmf.bfSize = BMPSize + Bmf.bfOffBits 'ファイルサイズ 'ビットパターンデータの準備 lpBits = GlobalAlloc(GPTR, BMPSize) 'ビットパターン用メモリー確保 If(lpBits = 0) Then MessageBox(hTargetWnd, "メモリ確保に失敗しました", "エラー", MB_OK Or MB_ICONSTOP) BsaveA = FALSE Exit Function End If 'ここで色数を変更 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(hTargetWnd, "色数変更に失敗しました", "エラー", MB_OK Or MB_ICONSTOP) GlobalFree(lpBits) '確保したメモリーを解放 BsaveA = 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(hTargetWnd, "ファイルを開くことができませんでした", "エラー", MB_OK Or MB_ICONSTOP) GlobalFree(lpBits) '確保したメモリーを解放 BsaveA = FALSE Exit Function End If '各ヘッダーの書きこみ 'BITMAPFILEHEADERをファイルへ書き込む If(WriteFile(hFile, VarPtr(Bmf), 14, VarPtr(dwTmp), ByVal NULL) = 0) Then 'sizeof(BITMAPFILEHEADER) = 14 MessageBox(hTargetWnd, "ビットマップファイルヘッダーを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP) GlobalFree(lpBits) '確保したメモリーを解放 CloseHandle(hFile) BsaveA = FALSE Exit Function End If 'BITMAPINFOHEADERとRGBQUADをファイルへ書き込む If(WriteFile(hFile, VarPtr(Bmi), Bmf.bfOffBits - 14, VarPtr(dwTmp), ByVal NULL) = 0) Then 'BITMAPINFOHEADER + RGBQUAD MessageBox(hTargetWnd, "ビットマップ情報とカラーテーブルを書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP) GlobalFree(lpBits) '確保したメモリーを解放 CloseHandle(hFile) BsaveA = FALSE Exit Function End If 'ビットマップビット配列をファイルへ書き込む If(WriteFile(hFile, lpBits, BMPSize, VarPtr(dwTmp), ByVal NULL) = 0) Then MessageBox(hTargetWnd, "ビット配列を書き込むことができませんでした", "エラー", MB_OK Or MB_ICONSTOP) CloseHandle(hFile) GlobalFree(lpBits) '確保したメモリーを解放 BsaveA = FALSE Exit Function End If 'x.BMPファイルをクローズする If(CloseHandle(hFile)) = 0 Then MessageBox(hTargetWnd, "ファイルをクローズできませんでした", "エラー", MB_OK Or MB_ICONSTOP) End If GlobalFree(lpBits) '確保したメモリーを解放 BsaveA = TRUE End Function 'ビットマップと逸れに付随するピクセル情報(あれば)を破棄する Sub WsDeleteEasyBmp() 'ピクセル情報の破棄 SetPixelBits( FALSE ) If( hSecondThread<>NULL )Then 'スレッドが動作中のときは、強制終了する。 TerminateThread( hSecondThread, 1 ) CloseHandle( hSecondThread ) hSecondThread = NULL EndIf HeapFree( hHeapEB, NULL, dwPixelBits ) dwPixelBits = NULL 'ビットマップハンドルの破棄 DeleteObject( hBmpEB ) hBmpEB = NULL EndSub Public '-------------------------------------------------------------------- Sub WsEasyBmp() InitializeCriticalSection( cs ) hHeapEB = HeapCreate( NULL, 0, 0 ) hBmpEB = NULL hSecondThread = NULL dwPixelBits = NULL fPixelBits = FALSE hTargetWnd = NULL hBasicMemDC = NULL fBasic = FALSE nCpuSleepLevel = 0 End Sub Sub ~WsEasyBmp() If( hSecondThread<>NULL )Then 'スレッド処理が動作中なら強制終了する。 TerminateThread( hSecondThread, 1 ) WaitForSingleObject( hSecondThread, INFINITE ) '念のため、終了を待機。 CloseHandle( hSecondThread ) hSecondThread = NULL EndIf If( hBmpEB<>NULL )Then WsDeleteEasyBmp() EndIf HeapDestroy( hHeapEB ) DeleteCriticalSection( cs ) End Sub 'ターゲットとなる窓のセット Sub SetTargetWindow( hWnd As HWND ) hTargetWnd = hWnd fBasic = FALSE End Sub 'ターゲットになっている窓を返す。 Function GetTargetWindow() As HWND GetTargetWindow = hTargetWnd End Function 'コマンドプロンプト用の設定(N88Basicライク)。 Sub SetBasic() hTargetWnd = _PromptSys_hWnd hBasicMemDC = _PromptSys_hMemDC fBasic = TRUE End Sub 'ビットマップをファイルからロード Function Bload( pBmpFile As BytePtr ) As Long If( hBmpEB<>NULL )Then WsDeleteEasyBmp() EndIf hBmpEB = LoadImage( GetWindowLong(hTargetWnd, GWL_HINSTANCE) As HINSTANCE, pBmpFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE ) If( hBmpEB=NULL )Then Bload = FALSE Else Bload = TRUE 'ピクセル情報を得ておく。 GetPixelBits( hBmpEB ) EndIf End Function 'ビットマップをファイルへ保存する。 Function Bsave( pBmpFile As BytePtr ) As Long Bsave = BsaveA( hBmpEB, pBmpFile, 32 ) End Function 'ビットマップを伸縮しつつ描画 Function PutBmpStretch( x As Long, y As Long, w As Long, h As Long, dwRop As Long ) As Long PutBmpStretch = PutBmpStretchEx( x, y, w, h, dwRop, NULL ) As Long End Function '上記において、hDCが指定されている場合用Exメソッド(RADのPaintイベントとかで必要になる)。 Function PutBmpStretchEx( x As Long, y As Long, w As Long, h As Long, dwRop As Long, hPaintDC As HDC ) As Long Dim hDC As HDC 'デバイスコンテキスト Dim BitmapReport As BITMAP 'ビットマップ情報を格納するための構造体 Dim hMemDC As HDC 'メモリ・デバイスコンテキスト Dim dCNumber As Double '描画すべきものが無いとき If( hBmpEB=NULL )Then PutBmpStretchEx = FALSE ExitFunction Else PutBmpStretchEx = TRUE EndIf 'ラスタオペレーション省略時の補整 If( dwRop=NULL )Then dwRop = SRCCOPY EndIf '縦横サイズ省略時の補整 GetObject( hBmpEB, Len(BitmapReport), BitmapReport )'ビットマップのサイズを取得 If( (w=0)and(h=0) )Then w = BitmapReport.bmWidth h = BitmapReport.bmHeight Else If( h<=0 )Then dCNumber = BitmapReport.bmHeight / BitmapReport.bmWidth h = ( w*dCNumber ) As Long End If If( w<=0 )Then dCNumber = BitmapReport.bmWidth / BitmapReport.bmHeight w = ( h*dCNumber ) As Long End If End If 'デバイスコンテキストを得る If( hPaintDC=NULL )Then hDC = GetDC( hTargetWnd ) Else hDC = hPaintDC End If 'ビットマップの描画準備 hMemDC = CreateCompatibleDC( hDC ) 'メモリ・デバイスコンテキストを作成する SelectObject( hMemDC, hBmpEB ) 'ビットマップを選択 'ビットマップを描画 SetStretchBltMode( hDC, COLORONCOLOR ) '伸縮モードを単純ピクセル削除で指定。 StretchBlt( hDC, x, y, w, h, hMemDC, 0, 0, BitmapReport.bmWidth, BitmapReport.bmHeight, dwRop ) If( fBasic=TRUE )Then 'N88BASICモードのとき(再描画対策) SetStretchBltMode( hBasicMemDC, COLORONCOLOR ) StretchBlt( hBasicMemDC, x, y, w, h, hMemDC, 0, 0, BitmapReport.bmWidth, BitmapReport.bmHeight, dwRop ) EndIf '使ったオブジェクトの開放 DeleteDC( hMemDC ) If( hPaintDC=NULL )Then ReleaseDC( hTargetWnd ,hDC ) End If EndFunction 'ビットマップを伸縮せずに描画 Function PutBmp( x As Long, y As Long, dwRop As Long ) As Long PutBmp = PutBmpStretch( x, y, 0, 0, dwRop ) EndFunction 'ビットマップを画面(窓)から得る Function GetBmp( x As Long, y As Long, w As Long, h As Long ) As Long Dim hDC As HDC Dim hMemDC As HDC If( hBmpEB<>NULL )Then WsDeleteEasyBmp() EndIf hDC = GetDC( hTargetWnd ) hMemDC = CreateCompatibleDC( hDC ) hBmpEB = CreateCompatibleBitmap( hDC, w, h ) SelectObject( hMemDC, hBmpEB ) If( fBasic=TRUE )Then StretchBlt( hMemDC, 0, 0, w, h, hBasicMemDC, x, y, w, h, SRCCOPY ) Else StretchBlt( hMemDC, 0, 0, w, h, hDC, x, y, w, h, SRCCOPY ) EndIf DeleteDC( hMemDC ) ReleaseDC( hTargetWnd ,hDC ) GetBmp = TRUE 'ピクセル情報を得ておく。 GetPixelBits( hBmpEB ) EndFunction 'ビットマップの指定された位置のピクセル情報を返す。 Function GetBmpPixel( x As Long, y As Long ) As DWord Dim nWidth As Long Dim nHeight As Long Dim nRed As Long Dim nGreen As Long Dim nBlue As Long Dim nArry As Long If( IsPixelBits()=TRUE )Then nHeight = GetHeight() If( y < nHeight )Then nWidth = GetWidth() If( x < nWidth )Then GetBmpPixel = dwPixelBits[ y*nWidth + x ] Else GetBmpPixel = 0 EndIf Else GetBmpPixel = 0 EndIf Else GetBmpPixel = 0 EndIf EndFunction 'ビットマップの縦横の長さを返す。 Function GetWidth() As Long Dim lp As BITMAP GetObject( hBmpEB, Len(lp), lp ) GetWidth = lp.bmWidth EndFunction Function GetHeight() As Long Dim lp As BITMAP GetObject( hBmpEB, Len(lp), lp ) GetHeight = lp.bmHeight EndFunction 'ピクセルを描く Sub Pset( x As Long, y As Long, crColor As DWord ) Dim hDC As HDC 'デバイスコンテキスト hDC = GetDC( hTargetWnd ) SetPixel( hDC, x, y, crColor ) If( fBasic=TRUE )Then 'N88BASICモードのとき(再描画対策) SetPixel( hBasicMemDC, x, y, crColor ) EndIf ReleaseDC( hTargetWnd ,hDC ) EndSub '関数GetBmpPixel()の有効無効 Function IsGetBmpPixel() As Long IsGetBmpPixel = IsPixelBits() EndFunction '関数GetBmpPixel()の有効になるまで待機する Sub IsGetBmpPixel_INFINITE() While( FALSE=IsPixelBits() ) Sleep( 1000 ) Wend EndSub '窓の指定された位置のピクセル情報を返す。 Function Point( x As Long, y As Long ) As Long Dim hDC As HDC 'デバイスコンテキスト hDC = GetDC( hTargetWnd ) Point = GetPixel( hDC, x, y ) If( fBasic=TRUE )Then 'N88BASICモードのとき(再描画対策) Point = GetPixel( hBasicMemDC, x, y ) EndIf ReleaseDC( hTargetWnd ,hDC ) EndFunction 'ビットマップハンドルを得る(外部の操作用)。 Function GetHandleBmp() As HBITMAP GetHandleBmp = hBmpEB End Function 'ビットマップハンドルを外部からセット Sub SetHandleBmp( hNewBmp As HBITMAP ) As Long If( hBmpEB<>NULL )Then WsDeleteEasyBmp() EndIf hBmpEB = hNewBmp 'ピクセル情報を得ておく。 GetPixelBits( hBmpEB ) End Sub 'ビットマップのピクセルデータの入った配列の先頭ポインタを返す。 Function GetPixelArray() As DWordPtr If( IsPixelBits()=TRUE )Then GetPixelArray = dwPixelBits Else GetPixelArray = NULL EndIf End Function 'ビットマップのピクセルデータの入った配列のサイズを返す。 Function GetPixelArraySize() As Long GetPixelArraySize = GetWidth()*GetHeight()*SizeOf(DWord) 'たぶんSizeOf()=4 理由→ DWord = 4Byte = 32Bit End Function 'ピクセル取得時のCpu抑制率をミリ秒で指定する。 '取得中は変更不可。 'マイナスを指定すると、取得を行わない(実際には、非常に鈍く行う。サイクル辺り590時間)。 Function SetCpuSleepLevel( nMiliSec As Long ) As Long If( WAIT_TIMEOUT=WaitForSingleObject(hSecondThread, 0) )Then SetCpuSleepLevel = FALSE Else nCpuSleepLevel = nMiliSec SetCpuSleepLevel = TRUE End If End Function End Class ・N88BASIC環境下(N88プロンプトベース)で使う場合は、 Sub SetBasic() を最初に実行してください。 ・それ以外で実行する場合は、ビットマップを貼り付ける窓を Sub SetTargetWindow( hWnd As HWND ) で指定してください。 ・ビットマップをファイルから読み込む Function Bload( pBmpFile As BytePtr ) As Long pBmpFile ビットマップデータが入ったファイル名を指定します。 ・ビットマップをファイルへ保存する。 Function Bsave( pBmpFile As BytePtr ) As Long pBmpFile 保存ファイル名を指定します。 ・ビットマップを窓、もしくはN88プロンプトへ描画 Function PutBmp( x As Long, y As Long, dwRop As Long ) As Long x,y ビットマップの左上の座標を指定します。 dwRop ラスタオペレーションを指定します。 PSet_BASIC … ビットマップをそのまま画面にコピーします。 OR_BASIC … ビットマップの色と画面の色をOR演算した結果を表示します。 XOR_BASIC … ビットマップの色と画面の色をXOR演算した結果を表示します。 AND_BASIC … ビットマップの色と画面の色をAND演算した結果を表示します。 ※省略(0を指定)するとPSet_BASICとして扱われます。 ・伸縮機能付きのPutBmp()(伸縮モードはCOLORONCOLOR) Function PutBmpStretch( x As Long, y As Long, w As Long, h As Long, dwRop As Long ) As Long 動作はPutBmp()に準ず。 w,h が伸縮後の縦横になる。 ( w,h )=( 0,0 )を指定すると、伸縮せずに描画。 ( w,h )の一方のみに-1を指定すると、縦横比を維持して伸縮描画。 ・デバイスコンテキストを指定できるPutBmpStretch() Function PutBmpStretchEx( x As Long, y As Long, w As Long, h As Long, dwRop As Long, hPaintDC As HDC ) As Long 動作はPutBmpStretch()に準ず。 hPaintDCにNULLを指定すると、SetTargetWindow()メソッドで指定してある 窓のデバイスコンテキストに対して描画される。 ・BMPを窓/プロンプト画面から読み込む Function GetBmp( x As Long, y As Long, w As Long, h As Long ) As Long x,y 選択する長方形の開始点の座標を指定します。 w,h 選択する長方形の終始点の座標を指定します。 ・窓/プロンプト画面へ、指定したドットを描画する Sub Pset( x As Long, y As Long, crColor As DWord ) x,y 座標を指定します crColor RGB(24ビットデータ)を指定します。 ・窓/プロンプト画面の、指定した座標の色を取得する Function Point( x As Long, y As Long ) As Long x,y 座標を指定します 取得した色が、24ビットデータで返ります。 ・ビットマップの、指定された位置のピクセル情報(RGB)を返す。 Function GetBmpPixel( x As Long, y As Long ) As DWord x,y ビットマップの左上を(0,0)とした座標を指定します 取得した色が、24ビットデータで返ります。 ※読み込んだ直後は取得に失敗することがあります。 IsGetBmpPixel()の返り値がTRUEになるまでお待ちください。 ・メソッドGetBmpPixel()が有効かどうかを返す。 Function IsGetBmpPixel() As Long 有効(取得可能)であればTRUEを、そうでなければFALSEを返します。 ・ビットマップの幅を返す。 Function GetWidth() As Long ・ビットマップの高さを返す。 Function GetHeight() As Long ・ビットマップのピクセルデータ(RGB)の入った配列の先頭ポインタを返す。 Function GetPixelArray() As DWordPtr 配列要素番号は、『縦の位置×幅+横の位置』となります。 ・ビットマップのピクセルデータの入った配列のサイズを返す。 Function GetPixelArraySize() As Long 配列要素をコピーするのに必要なサイズがByteで返ります。 ・ビットマップハンドルを得る。 Function GetHandleBmp() As HBITMAP このクラスが保持しているビットマップのハンドルを返します。 外部操作用です。 このメンバで得たビットマップハンドルは削除しないで下さい。 また、別のビットマップをもとのクラスオブジェクトに読み込んだときは、 以前に得たビットマップハンドルは無効になります。 ・ビットマップハンドルを外部からセットする。 Sub SetHandleBmp( hNewBmp As HBITMAP ) As Long 別途に作製したビットマップのハンドルを、このクラスに保持させます。 これにより、上記の操作(保存や色の取得)が出来るようになります。 (Jpegなどを別途読み込んで、逸れに対しての操作とか。) このメンバにセットしたビットマップハンドルは削除する必要は ありません。クラスオブジェクト内で必要に応じて自動的に削除します。 (※別のビットマップをクラスオブジェクトに読み込んだ時点で削除) ※とくに断りが無い場合、返り値は成功時はTRUE、失敗時はFALSEになります。 例:N88BASIC コード: #N88BASIC Dim lp As WsEasyBmp Dim w As Long Dim h As Long Dim x As Long Dim y As Long lp.SetBasic() 'N88BASIC環境をセット lp.Bload( "hoge.bmp" ) 'ビットマップの読み込み lp.PutBmp( 0, 0, 0 ) 'とりあえず出力 'ピクセル情報取得可能になるまで待機。 While( lp.IsGetBmpPixel()=FALSE ) Print "*" Sleep( 100 ) Wend '1ピクセルごとに描画してみる。 w = lp.GetWidth() h = lp.GetHeight() For x=0 To w-1 For y=0 To h-1 lp.Pset( x, h+20+y, lp.GetBmpPixel(x,y) ) Next Next 'プロンプト画面のピクセル情報を取得し、別の場所に吐き出してみる。 For x=w-32 To w+32 For y=16 To 64 lp.Pset( x+w+64, y, lp.Point(x,y) ) If( lp.Point(x,y)=0 )Then lp.Pset( x+w+64, y, RGB( 255, 255, 255 ) ) End If Next Next 'プロンプト画面の一部を読み込み、ファイルに保存する。 lp.GetBmp( 0, 0, 64, h*2 ) lp.Bsave( "test.bmp" ) 例:ノーマルウィンドウ コード: ' TODO: この位置にグローバルな変数、構造体、定数、関数を定義します。 Dim lp As WsEasyBmp '----------------------------------------------------------------------------- ' ここから下は、イベントプロシージャを記述するための領域になります。 Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT) lp.SetWnd( hMainWnd ) '入出力を行う窓を設定。 lp.Bload( "hoge.bmp" ) 'ビットマップの読み込み End Sub Sub MainWnd_Paint(hDC As HDC) lp.PutBmp( 16, 16, NULL ) '保持しているビットマップを描画。 End Sub以上。 ※2006.01.28の22時の時点で、修正しています。 N88BASICモードで、Endを書かなかった場合にアクセス違反が出るバグを修正。 ※2006.02.1の1時半過ぎの時点で、修正しています。 スレッドの管理を修正(連続でBloadメンバを呼び出したときの対策)。 ※2006.06.15の11時過ぎの時点で、修正しています。 主にスレッド管理にいくつかバグ発見し、それを修正。 GetPixelArraySize()が致命的におかしいことに気づき修正。 メソッドに、PutBmpStretchEx(),PutBmpStretch()を追加。 (他にもこっそり追加しているメソッドがあったり?) いつものように蛇足。 GetBmpPixel()が、読み込んだ直後は取得失敗する理由は、 読み込んだBMPを一度メモリデバイスコンテキストに描画し、 そのピクセルデータをGetPixel()を使って読み取って2次元配列に保存し、 GetBmpPixel()ではその配列から値を返しているため。 大きなBMP(1000×1000くらい?)だと数秒くらい掛かるのかな? なお、その間の制御は返してますので、フリーズしたりはしないです。 本当はBMPファイルから直に読み取りたかったのですが・・・ 上手く読み取れない。横にデータが広がってしまうのです。 BMP構造の理解がいまいち足りないみたいなので、今回はこの辺で妥協。 GetBmp()で読み込んだときにどーせ同じことするわけだし。 ちなみに。 わざわざ配列に一度読み込んで・・・なんて組み方をしたのは、 GetPixelArray()で配列を外に取り出して好きな処理をすることを見据えているから。 ある閾値より暗いところはRGB(0,0,0)に変えるとか、 逆にある閾値より明るいところはRGB(255,255,255)で真っ白にするとか。 そういうRGBを直に操作するような画像加工ソフトを作りたいな~と。 そのためのこのクラスですね。 Jpeg→Gifとかの変換で綺麗にサイズを減らしたりするんじゃないかとw 後は星の写真の背景の処理とか。 ・・・インターフェースを組むのが面倒なので、しばらく放置の予感^^; |
作成者: | 淡幻星 [ 2006年1月28日(土) 02:54 ] |
記事の件名: | [AB4]ビットマップのRGBに補整曲線を適用する |
ビットマップのピクセル要素RGBに対して補整曲線を適用するクラスです。 例えば、 ・&H444444以下のピクセルは&H000000に変更。 ・&Haaaaaa以上のピクセルは&Hffffffに変更。 ・y = tanh(x) のようにして、一部の輝度変化を拡大 などのように画像を編集できます。 上記のWsEasyBmpクラスを基底クラスに利用しています。 クラスの定義はここをクリック。 [ここをクリックすると内容が表示されます] (※動作確認 AB Ver. 4.10.02)コード: 'BMPに輝度補整曲線を適用するクラス。 TypeDef PFuncBrightnessEffectCuve = *Function( dwCor As DWord ) As DWord Class WsBmpGamma Inherits WsEasyBmp Public Sub WsBmpGamma() End Sub Sub ~WsBmpGamma() End Sub Function BrightnessEff( funcCor As PFuncBrightnessEffectCuve ) As Long Dim w As Long Dim h As Long Dim x As Long Dim y As Long Dim dwCor As DWord Dim hWnd As HWND Dim hDC As HDC Dim hMemDC As HDC Dim hBmp As HBITMAP If( IsGetBmpPixel()=FALSE )Then BrightnessEff = FALSE Exit Function Else BrightnessEff = TRUE End If w = GetWidth() h = GetHeight() hWnd = GetTargetWindow() hDC = GetDC( hWnd ) hMemDC = CreateCompatibleDC( hDC ) hBmp = CreateCompatibleBitmap( hDC, w, h ) SelectObject( hMemDC, hBmp ) For y=0 To h-1 For x=0 To w-1 dwCor = GetBmpPixel( x, y ) SetPixel( hMemDC, x, y, funcCor( dwCor ) ) Next Next SetHandleBmp( hBmp ) DeleteDC( hMemDC ) ReleaseDC( hWnd, hDC ) End Function End Class 【使い方】 1、画像補整曲線を以下の関数形で定義します。 Function funcName( dwCor As DWord ) As DWord ※引数はDWord型で、返り値もDWord型です。 コード: '例:赤の輝度が<&Haaならば、青と緑の輝度を無視する(赤のみにする)。 Function HogeBraight( dwCor As DWord ) As DWord Dim b As Byte b = (dwCor And &Hff) As Byte If( b<&Haa )Then HogeBraight = b As DWord Else HogeBraight = dwCor End If End Function2、Bload()メソッドなどでビットマップを読みます。 3、メソッド Function BrightnessEff( funcCor As PFuncBrightnessEffectCuve ) As Long を呼び出し、引数には補整曲線の関数(の開始ポインタ)を渡します。 この例であれば lp.BrightnessEff( AddressOf(HogeBraight) ) となります。 なお、処理中が終わってから制御を返します。 処理が成功するとTRUEが、失敗するとFALSEが返ります。 (別スレッド化は・・・気が向いたらまた後日に^^:) 以上。 |
作成者: | 淡幻星 [ 2006年6月15日(木) 11:18 ] |
記事の件名: | [AB4]ビットマップにモザイクフィルターを適用する |
指定したピクセル幅(正方形)でモザイクを掛けます。 実際には、指定ピクセル幅の正方形でRGBを平均化する操作になります。 上記のWsEasyBmpクラスを基底クラスに利用しています。 定義はこちらです。 [ここをクリックすると内容が表示されます]
(※動作確認 AB Ver. 4.24.00) コード: Class WsPicsMosaic Inherits WsEasyBmp Public Sub WsPicsMosaic() WsEasyBmp() End Sub Sub ~WsPicsMosaic() End Sub 'モザイクフィルターを適用する。ただし、ピクセル取得が終わっていないと失敗する。 Function MosaicEff( nPixel As Long ) As Long Dim w As Long Dim h As Long Dim x As Long Dim y As Long Dim i As Long Dim j As Long Dim dwCor As DWord Dim hWnd As HWND Dim hDC As HDC Dim hMemDC As HDC Dim hBmp As HBITMAP Dim dwR As DWord Dim dwG As DWord Dim dwB As DWord If( IsGetBmpPixel()=FALSE )Then MosaicEff = FALSE Exit Function Else MosaicEff = TRUE End If w = GetWidth() h = GetHeight() hWnd = GetTargetWindow() hDC = GetDC( hWnd ) hMemDC = CreateCompatibleDC( hDC ) hBmp = CreateCompatibleBitmap( hDC, w, h ) SelectObject( hMemDC, hBmp ) For y=0 To h-1 Step nPixel For x=0 To w-1 Step nPixel dwR = 0 dwG = 0 dwB = 0 For j=0 To nPixel-1 For i=0 To nPixel-1 dwCor = GetBmpPixel( x+i, y+j ) dwR += ( &hff and dwCor ) dwG += ( (&hff00 and dwCor) >> 8 ) dwB += ( (&hff0000 and dwCor) >> 16 ) Next Next dwR = dwR \ ( nPixel*nPixel ) dwG = dwG \ ( nPixel*nPixel ) dwB = dwB \ ( nPixel*nPixel ) DeleteObject( SelectObject( hMemDC, CreateSolidBrush( RGB(dwR,dwG,dwB) ) ) ) DeleteObject( SelectObject( hMemDC, CreatePen( PS_SOLID, 1, RGB(dwR,dwG,dwB) ) ) ) Rectangle( hMemDC, x, y, x+i, y+j ) Next Next DeleteObject( SelectObject( hMemDC, GetStockObject( WHITE_BRUSH ) ) ) DeleteObject( SelectObject( hMemDC, GetStockObject( WHITE_PEN ) ) ) DeleteDC( hMemDC ) ReleaseDC( hWnd, hDC ) SetHandleBmp( hBmp ) End Function 'モザイクフィルターを適用する。ただし、ピクセル取得が終わっていなければ、終わるまで待機する。 Sub MosaicEff_INFINITE( nPixel As Long ) Dim r As Long While( IsGetBmpPixel()=FALSE ) 'ピクセル取得が終わるまで待機 Sleep( 500 ) Wend r = MosaicEff( nPixel ) EndSub End Class メソッドの説明。 Function MosaicEff( nPixel As Long ) As Long nPixelにモザイクの幅を指定してください。 ※メソッドIsGetBmpPixel()の返り値がTRUEになってから実行してください。 利用例。 コード: #N88BASIC Dim objEff As WsPicsMosaic objEff.SetBasic() objEff.BloadPics( "Picture.bmp" ) objEff.IsGetBmpPixel_INFINITE() objEff.PutBmp( 0, 0, NULL ) '読み込んだ画像を描画。 objEff.MosaicEff_INFINITE( 6 ) '6x6のサイズでモザイク加工。 'objEff.IsGetBmpPixel_INFINITE() 'ピクセル取得が終わるまで待機(PutBmpに対しては必須ではない) objEff.PutBmp( 0, 0, NULL ) '加工の終わった画像を描画。 Sleep( 5000 ) End ちなみに、基底クラスのWsEasyBmpも先ほど修正版と差し替えました。 |
ページ 1 / 1 | 全ての表示時間は UTC+09:00 です |
Powered by phpBB® Forum Software © phpBB Limited https://www.phpbb.com/ |