• 締切済み

Excel2003VBAでクリップボードにあるビットマップの操作について

Excel2003VBAにおいてクリップボードにあるビットマップの画像の任意の1pxの色を、 ペイントのスポイトツールのように取得するマクロを作成したいのですが GetPixelという関数で画像の任意1pxの色を取得できる所までは調べられたのですが、 それをクリップボードの画像で使用することができませんでした。 以下は、GetPixel関数を試してみた時のソースになります。 '------------------------------------------------------------------ Option Explicit Declare Function GetDesktopWindow Lib "user32" () As Long Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long Sub ピクセル色獲得() Dim hwnd As Long Dim hdc As Long hwnd = GetDesktopWindow() hdc = GetWindowDC(hwnd) Debug.Print Hex(GetPixel(hdc, 100, 200)) End Sub '------------------------------------------------------------------ 上記ソースで任意1pxの色を取得できたため クリップボードの画像の色を取得するマクロを下記のように作成しました。 '--------------------------------------------------------------- Option Explicit Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long Sub クリップボードピクセル色獲得() Dim CB As Variant Dim i As Long CB = Application.ClipboardFormats Debug.Print Hex(GetPixel(CB, 100, 200)) End Sub '--------------------------------------------------------------- 型が一致しません と言われ動きません。 以上です、よろしくお願いいたします。

みんなの回答

  • zawax
  • ベストアンサー率50% (3/6)
回答No.5

まちがい、、で終わらせては申し訳ないのでちょっと検証。 当初のクリップボードから直接取る回答にはなっていませんが、 UserFormを作って、そこから値を取得する方法です。 シェイプのhwnd,hdcをとるのは難しそうだったので。 これならなんとかなるか。。 UserFormにイメージを貼り付けるロジックは別途必要です。 Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Declare Function GetActiveWindow Lib "user32" () As Long Private Sub UserForm_Click() Dim hwnd As Long Dim hdc As Long hwnd = GetActiveWindow hdc = GetDC(hwnd) Debug.Print Hex(GetPixel(hdc, 100, 200)) End Sub

  • zawax
  • ベストアンサー率50% (3/6)
回答No.4

>KenKen_SPさん、 hdc、たしかにコンテキストですね。 まちがいでした。

  • KenKen_SP
  • ベストアンサー率62% (785/1258)
回答No.3

こんばんは。 GetPixel の第一引数は hDc という変数名が示すとおり、デバイス コンテキストのハンドルです。これは、Win32Api、GDI ともにそう。 ウインドウハンドルではありませんよ。

  • okormazd
  • ベストアンサー率50% (1224/2412)
回答No.2

>型が一致しません GetPixel(CB, 100, 200) CBが配列になっています。 ここはlongじゃないとだめでしょう。

  • zawax
  • ベストアンサー率50% (3/6)
回答No.1

マニアックなことやってますね。好きですこう言うの。 CBをVariantで宣言してクリップボードの中身を入れていますが、 GetPixelではウィンドウハンドルを要求していますので、 たぶんダメだろう、というのはソースを見てわかります。 (ウィンドウハンドルとは表示領域のIDだとおもっていただければ。。) なので、イメージが乗っている表示領域を作成し、そのウィンドウハンドルを取得できれば、 GelPixelが使えるということになります。 Excel内で画像を表示できる、制御しやすい表示領域はシェイプ系ですが、 シェイプのウィンドウハンドルを取ってこれるか、、が鍵でしょうね。 試したわけではありませんし、明確な答えではないので参考意見です。。

関連するQ&A

  • VBAでSetTextColorがうまくいかない

    EXCELのVBAでユーザーフォームを使ったグラフィック表示のプログラムを 作っているのですが、SetTextColorでテキスト色の設定をしようと してもうまくいきません。何故か設定しようとする色の値が無視されて 「1304008」が設定されてしまいます。(GetTextColorで確認) そしてそれ以降何を設定してもこの状態のままです。 何か考えられることがありますでしょうか。 下にそのプログラムを示します。 ちなみにSetBKColorやAngleArcなど他のグラフィック命令は問題なく 動いていてSetTextColorだけがうまくいってない状態です。 '------------------------------------------------- ' ユーザーフォーム用プログラム '------------------------------------------------- Private Declare Function GetActiveWindow Lib "user32" () As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _ ByVal hwndParent As Long, _ ByVal hwndChildAfter As Long, _ ByVal lpszClass As String, _ ByVal lpszWindow As String) As Long Private Declare Function GetDC Lib "user32" ( _ ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" ( _ ByVal hWnd As Long, _ ByVal hdc As Long) As Long Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, crColor As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _ (ByVal hdc&, ByVal x&, _ ByVal y&, ByVal lpString$, ByVal nCount&) As Long Dim hWnd As Long Dim hdc As Long Public Sub UserForm_Activate() DoEvents hWnd = FindWindowEx(GetActiveWindow, 0, "F3 Server 60000000", "") hdc = GetDC(hWnd) ret = SetTextColor(hdc, RGB(255, 0, 0)) ret = TextOut(hdc, 0, 0, "abc", 3) Call ReleaseDC(hWnd, hdc) End Sub '-------------------------------------------------

  • 他のアプリケーションの hDC を取得したい

     APIの初歩的なことですみません 他のアプリケーションの hDC を取得して GetPixel() API等 を使用したいのですが どうもうまくいきません hDC や hWnd あたりがよくわからないのが 原因だと思いますが、分かる方教えてください  ソースは以下の様な感じです Private Declare Function FindWindowA Lib "user32" (ByVal cnm As String, ByVal cap As String) As Long Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long lhWnd = FindWindowA(vbNullString, "ExpApp") lColor = GetPixel(lhWnd, ix, iy)

  • マウスのある個所の色

    お世話になります よろしくお願いします Pictureboxをクリックされたときに そのPictureboxがクリックされた箇所の色を16進数で取得したいのですが うまくいきません どこが間違っているのか教えてもらえないでしょうか? ソースは Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Type POINTAPI x As Long y As Long End Type Private Sub Picture1_Click() Dim Poi As POINTAPI Dim iro As Long GetCursorPos Poi iro = GetPixel(Me.Picture1.hdc, Poi.x, Poi.y) Me.Label2.Caption = Poi.x Me.Label3.Caption = Poi.y Me.Label1.Caption = iro CloseHandle (Me.Picture1.hdc) End Sub GetPixcelの引数に-1しか入りません あと、もし数値で取れたとして それを16進数にする方法を教えてください よろしくお願いします

  • windows7のエクスプローラをVBAで操作-1

    アドバイスをお願いします。 Excel-VBAで起動しているエクスプローラに対してハンドルを取得してクリックしたり、テキストボックスに文字をセットするプログラムを作って動かしています。 WindowsXPのときはできていたのですが、Windows7になったら正しく動作しなくなりました。 下のコードはエクスプローラの現在のフォルダパスが表示されるところに(添付ファイル参照)文字を入れるものです。 最後のSendMessageAnyで1が返ってしまいます。何が考えられますでしょうか。どう対策したらいいでしょうか。 なおハンドルの値はSDKのInspect Objectsで確認していますので、正しく取得できていると思っています。 よろしくお願いします。 Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _ ByVal hwndParent As Long, _ ByVal hwndChildAfter As Long, _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Declare Function SendMessageAny Lib "user32.dll" _ Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal MSG As Long, _ ByVal wParam As Long, _ ByVal lParam As Any) As Long Const WM_SETTEXT = &HC Private hwnd As Long Private FOLDER As String Sub Put_folder_name1() hwnd = FindWindow("CabinetWClass", vbNullString) hwnd = FindWindowEx(hwnd, 0, "WorkerW", vbNullString) hwnd = FindWindowEx(hwnd, 0, "ReBarWindow32", vbNullString) hwnd = FindWindowEx(hwnd, 0, "Address Band Root", vbNullString) hwnd = FindWindowEx(hwnd, 0, "msctls_progress32", vbNullString) hwnd = FindWindowEx(hwnd, 0, "ComboBoxEx32", vbNullString) hwnd = FindWindowEx(hwnd, 0, "ComboBox", vbNullString) hwnd = FindWindowEx(hwnd, 0, "Edit", vbNullString) FOLDER = "\\xx.xx.xx.xx\test" RC = SendMessageAny(hwnd, WM_SETTEXT, 0, ByVal FOLDER) end sub

  • windows7のエクスプローラをVBAで操作-2

    アドバイスをお願いします。 Excel-VBAで起動しているエクスプローラに対してハンドルを取得してクリックしたり、テキストボックスに文字をセットするプログラムを作って動かしています。 WindowsXPのときはできていたのですが、Windows7になったら正しく動作しなくなりました。 下のコードはエクスプローラのフォルダパスの右のボタン(添付ファイル参照)をクリックすべく、コーディングしたものです。 最後のSendMessage(hwnd, BM_CLICK, 0, 0) でクリックしたいのですが、その前にボタンのハンドルが取得できません。SDKのInspect Objectsで調べると、このボタンはClass="ToolbarWindow32"でName="前の場所"ですが、NativeWindowHandleが表示されず、Legacy.IAccessible.ChildID=1となっています。 このようなウィンドゥは別のやり方(IAccessible?)でないとクリックできないように感じていますが如何せん知識がありません。 どうしたらできるか、アドバイスよろしくお願いします。 Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _ ByVal hwndParent As Long, _ ByVal hwndChildAfter As Long, _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, lParam As Any) As Long Const BM_CLICK = &HF5 Private hwnd As Long Sub Click_button() hwnd = FindWindow("CabinetWClass", vbNullString) hwnd = FindWindowEx(hwnd, 0, "WorkerW", vbNullString) hwnd = FindWindowEx(hwnd, 0, "ReBarWindow32", vbNullString) hwnd = FindWindowEx(hwnd, 0, "Address Band Root", vbNullString) hwnd = FindWindowEx(hwnd, 0, "msctls_progress32", vbNullString) hwnd = FindWindowEx(hwnd, 0, "ToolbarWindow32", vbNullString) ' この次が分からない。 RC = SendMessage(hwnd, BM_CLICK, 0, 0) end sub

  • API関数 GetPixel

    質問ですが、Visual Basicで Option Explicit Private Declare Function Getpixel Lib "gdi32" (_ ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ) As Long というソース部分があるのですが、これをVC++で書き直すとしたらどのようになるのでしょうか。また、VC++のAPI関数にはGetPixelはないのでしょうか。なにとぞよろしくお願いいたします。

  • VBA ウィンドウの列挙 Win32 API

    http://d.hatena.ne.jp/cartooh/20090618 上記のページに記載されているVBAです。 動作は確認できたのですが、どのような処理の流れとなっているのかがわかりません。 どなたかコメントを付けていただけないでしょうか。 よろしくお願いいたします。 Option Explicit Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal cnm As String, ByVal cap As String) As Long Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _ ByVal cch As Long) As Long Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, _ ByVal lParam As Long) As Long Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long Const INDENT_KEY = "INDENT" Public Function EnumChildWindowsProc(ByVal hWnd As Long, ByVal lParam As Object) As Long EnumChildWindowsProc = EnumWindowsProc(hWnd, lParam) End Function Public Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Object) As Long EnumWindowsProc = True If IsWindowVisible(hWnd) = 0 Then Exit Function End If Dim strClassName As String ' * 255 Dim strCaption As String ' * 255 strClassName = String(255, vbNullChar) strCaption = String(255, vbNullChar) GetWindowText hWnd, strCaption, Len(strCaption) GetClassName hWnd, strClassName, Len(strClassName) strCaption = RTrim(left(strCaption, InStr(1, strCaption, vbNullChar) - 1)) strClassName = RTrim(left(strClassName, InStr(1, strClassName, vbNullChar) - 1)) ActiveCell.Cells(1, 1).Value = Hex(hWnd) ActiveCell.Cells(1, 2).Value = IsWindowVisible(hWnd) ActiveCell.Cells(1, 3).Value = strCaption ActiveCell.Cells(1, 4).Value = strClassName ActiveCell.Cells(2, 2).Activate Dim c As Collection Set c = lParam Dim indent As Long indent = c(INDENT_KEY) c.Add String(indent * 2, " ") & Hex(hWnd) & " " & strCaption & " " & strClassName, before:=c.Count indent = indent + 1 c.Remove INDENT_KEY c.Add indent, INDENT_KEY Call EnumChildWindows(hWnd, AddressOf EnumChildWindowsProc, ObjPtr(c)) indent = c(INDENT_KEY) - 1 c.Remove INDENT_KEY c.Add indent, INDENT_KEY ActiveCell.Cells(1, 0).Activate End Function Sub hoge() Application.ScreenUpdating = False Dim sht As Worksheet Set sht = ThisWorkbook.Worksheets(1) sht.UsedRange.Clear sht.Activate sht.Range("A1").Activate Dim c As Collection Set c = New Collection c.Add 0, INDENT_KEY Dim ret As Long ret = EnumWindows(AddressOf EnumWindowsProc, ObjPtr(c)) c.Remove INDENT_KEY Set sht = ThisWorkbook.Worksheets(2) sht.UsedRange.Clear sht.Activate sht.Range("A1").Activate Dim o As Variant For Each o In c ActiveCell.Value = o ActiveCell.Cells(2, 1).Activate Next Application.ScreenUpdating = True End Sub

  • Formを動かせるようにしたい

    お世話になります。 OS XP PRO  VB6(SP5)で開発しています。 ディスプレイのサイズによりFormを動かせたり固定させたりしたいのですが、 規定値は固定にしたいのでFormプロパティのMoveableはFalseにしてあります。 下記のようにプログラミングしたのですが固定されたままです。 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function GetSystemMenu Lib "user32" (ByVal _ hwnd As Long _ , ByVal bRevert As Long) As Long Private Declare Function RemoveMenu Lib "user32" ( _ ByVal hMenu As Long, ByVal nPosition As Long, _ ByVal wFlags As Long) As Long Private Declare Function DrawMenuBar Lib "user32" ( _ ByVal hwnd As Long) As Long Private Const MF_BYCOMMAND = &H0 Private Const SC_MOVE = &HF010 Private Sub Form_Load() Dim kk As Long kk = GetSystemMenu(.hwnd, bb) Call RemoveMenu(kk, SC_MOVE, MF_BYCOMMAND) Call DrawMenuBar(.hwnd) End Sub アドバイス頂きたくよろしくお願いします。 以上です。

  • VBA内でのGetPixelを使用した時のRGB値取得の方法

    初めまして、 現在、ExcelVBAを勉強中です。 表題の通りですが、LoadPicture関数でbmpを読み込み、ピクセルのRGB値を取得しようとしているのですがうまくいきません。色々と検索して回ったのですが、探し方が悪いのか見つかりませんでした。 以下はソースになります。 Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Sub Sample(bmpfile as String) bmpdata = LoadPicture(bmpfile) 'デバッグ用表示 MsgBox (Hex(GetPixel(bmpdata, 1, 1))) End Sub サンプルで使用した画像データは10x10のすべて黒(#000000)で塗りつぶしたデータですが、デバッグ表示で見てみると何故かFFFFFFFFと表示されます。ほかの色も試しましたがデバッグ表示結果は同じでした。 どなたか詳しい方、原因などを教えて頂けますでしょうか。 よろしくお願いいたします。

  • VBでShell○なのにShellExecute×

    http://support.microsoft.com/kb/170918/ja 等を参考に、コンソールアプリからHTMLファイルを呼び出すだけのEXEをVB(Visual Basic 2008 Express Edition)で作ったところ、 Shell関数ではHTMLがIEで起動されるのに対し、ShellExecute関数ではダメでした。 HTMLへのファイルパスが正しいことはMsgBoxで確認しました。 また、ほぼ同じソースをbasにしてExcelから起動すると、ShellExecuteでも起動しました。 以下がソース(抜粋)になりますが、原因が分かる方がおられましたら、ヒントだけでも、ご教示いただけると幸いです。 よろしくお願いいたします。 - - - - - - - - - - - - - - - - - - - - - - Option Explicit On Module Module1 Private Declare Function ShellExecute Lib "shell32.dll" Alias _ "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _ String, ByVal lpszFile As String, ByVal lpszParams As String, _ ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long 'エラーコード宣言略 Function StartDoc(ByVal DocName As String) As Long Dim Scr_hDC As Long Scr_hDC = GetDesktopWindow() 'こちらだと成功 StartDoc = Shell("explorer.exe" & " " & DocName, vbNormalFocus) StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _ "", "C:\", SW_SHOWNORMAL) End Function Sub Main() Dim r As Long, msg As String r = StartDoc(CurDir() & "\target.html") 'エラーハンドリング省略 End Sub End Module

専門家に質問してみよう