tagCANDY CGI VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
[ツリー表示へ]  [ワード検索]  [Home]

タイトル Re^7: GetDIbitsの使用方法について
投稿日: 2014/03/21(Fri) 18:48
投稿者還暦手習い
魔界の仮面弁士様

 随分時間がかかってしまいましたが、結果は得られました。
 プログラムの記述は突っ込みどころ満載だとは思いますが期待通りの結果は
  得られました。
 手間隙のかかる、ど素人の初老に本当に親切に丁寧なご指導、心から感謝し
  ます。
 ありがとうございました。

 以下、私同様素人の方にも、何かのお役にたてば(お役に立たず誤った情報
  となるやも?)と思い全文記載させていただきます。

 ただ、記載中の★と★★の箇所が納得いかず、あつかましくも再々再度、質
  問させていただきます。
 よしくお願いいたします。

'==========================================================================
'PCの画面の指定した場所で指定した幅・高さの画像をフォームにコピーして
'その画像のピクセル単位の色情報を配列変数の形で取得する。

'◆Formモジュール ========================================================
'   Form と コマンドボタン1個

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
        ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32"  _
        (ByVal hObject As Long) As Long

Private Const SRCCOPY = &HCC0020

Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, _
        ByVal nXDest As Long, ByVal nYDest As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hDCSrc As Long, _
        ByVal nXSrc As Long, ByVal nYSrc As Long, _
        ByVal dwRop As Long) As Long
        
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

Private Type BITMAPINFO
        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 Declare Function CreateCompatibleBitmap Lib "gdi32"  _
        (ByVal hdc As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long) As Long
                        
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
        ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32"  _
        (ByVal hdc As Long) As Long

Private pixel()          As Long

'###############################
Private Sub Command1_Click()
'###############################
Dim ScreenhDC       As Long
Dim bmpinfo         As BITMAPINFO
Dim hBmp            As Long
Dim hMemDC          As Long
Dim hOld            As Long
Dim B               As Long
Dim G               As Long
Dim R               As Long
Dim XX              As Long
Dim YY              As Long

    'スクリーン全体ののDCハンドル
    ScreenhDC = GetDC(0)
    
  '----------------------------------------------------------------
  '処理の概要:
  '
    'デスクトップのX座標150 Y座標150のポイントから80×80(ピクセル)の
    '領域をFormにコピーX=150 Y=150 幅*高 80×80 は他の処理で
    '任意の指定できるものとします。
    '
  '実際には、X,Yはフォーム外のクリックを検知してその場所のデスク
    'トップ上の座標を得ます。
  'また幅*高さはフォーム上のテキストボックスから任意に指定してお
    'くものとします。
  '何れも処理は完成しておりますが、本件の件名とは無関係であります
    'ので記載は省略させていただきます。
    '----------------------------------------------------------------
    BitBlt Me.hdc, 0, 0, 80, 80, ScreenhDC, 150, 150, SRCCOPY
    '----------------------------------------------------------------
    
    '初期化
    bmpinfo.biBitCount = 32
    bmpinfo.biCompression = 0
    bmpinfo.biHeight = 80
    bmpinfo.biPlanes = 1
    bmpinfo.biSize = 40
    bmpinfo.biWidth = 80
    
    'ビットマップ作成
    hBmp = CreateCompatibleBitmap(Me.hdc, 80, 80)
  
    'メモリデバイスコンテキストを作成
    hMemDC = CreateCompatibleDC(Me.hdc)
    
    'メモリデバイスコンテキストに適切なhBmpを選択し直す
    hOld = SelectObject(hMemDC, hBmp)
    
    'hMemDCに描画処理を行う
    BitBlt hMemDC, 0, 0, 80, 80, Me.hdc, 0, 0, SRCCOPY
    
    '★bmpinfoが設定済みなので不要?コメント行にしても結果は同じでした。
    GetDIBits hMemDC, hBmp, 0, bmpinfo.biHeight, ByVal 0&, bmpinfo, 0

    '配列の宣言
    ReDim pixel(80 - 1, 80 - 1) As Long
    
    '★★高さを−にするとビットマップが逆転する?
    bmpinfo.biHeight = -bmpinfo.biHeight
        '★★↑次STEPにAbsで絶対値を代入しているので不要のはずなのに
        'この行が無い場合は結果が違う(無い場合、画像上下が逆)
    
    '色を取得,Pixel配列には画像の色が入る
    GetDIBits hMemDC, hBmp, 0, Abs(bmpinfo.biHeight), pixel(0, 0), bmpinfo, 0
    
    'DCの解放
    ReleaseDC 0, ScreenhDC
    SelectObject hMemDC, hOld
    DeleteObject hBmp
    DeleteObject hMemDC
    
    '***************** 結果検証のためファイルに保存 ****************
    'かなりドロ臭い方法ですがあらためてファイルをExcelVBAで読んで
    'セル(横幅0.5程度)に色づけして画像確認を行うためファイル保
    '存します。取得したpixel(*,*)が正しいかを検証しました。
    
    Open "C:\TEST.CSV" For Output As #1
        For YY = 0 To 79
            For XX = 0 To 79
                B = CByte(pixel(XX, YY) And &HFF&)
                G = CByte((pixel(XX, YY) \ &H100&) And &HFF&)
                R = CByte((pixel(XX, YY) \ &H10000) And &HFF&)
                    Print #1, Str(XX) & "," & Str(YY) & "," & _
                    Str(B) & "," & Str(G) & "," & Str(R)
            Next XX
        Next YY
    Close #1
    End Sub
    
    '■■ここからはVBAで動作させて画像を検証するプログラム■■
    'Sub TEST()
    'Dim FILE_DATA     As String
    'Dim PIX_DATA()    As String
    '=========================================
    'テスト環境はExcel2013(フルカラー)で実施
    '=========================================
    'セルの設定
    'Rows(1).ColumnWidth = 0.5
    'Columns(1).RowHeight = 5
    
    'セルに描画
    'Open "C:\TEST.CSV" For Input As #1
    '    Do Until EOF(1) = True
    '        Line Input #1, FILE_DATA
    '        PIX_DATA = Split(FILE_DATA, ",")
    '
    '            Cells(Val(PIX_DATA(1)) + 1, _
    '                  Val(PIX_DATA(0)) + 1).Interior.Color = _
    '            RGB(Val(PIX_DATA(4)), Val(PIX_DATA(3)), Val(PIX_DATA(2)))
    '    Loop
    'Close #1
    'End Sub

- 関連一覧ツリー をクリックするとツリー全体を一括表示します)

古いスレッドにレスはつけられません。