VBAでSetTextColorがうまくいかない

このQ&Aのポイント
  • EXCELのVBAでユーザーフォームを使ったグラフィック表示のプログラムを作っているのですが、SetTextColorでテキスト色の設定をしようとしてもうまくいきません。
  • 何故か設定しようとする色の値が無視されて「1304008」が設定されてしまいます。(GetTextColorで確認) そしてそれ以降何を設定してもこの状態のままです。
  • SetBKColorやAngleArcなど他のグラフィック命令は問題なく動いていてSetTextColorだけがうまくいってない状態です。
回答を見る
  • ベストアンサー

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 '-------------------------------------------------

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

crColorが値渡し(ByVal)になっていないのが原因だと思います。 Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, crColor As Long) As Long   ↓ Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, ByVal crColor As Long) As Long このようにAPI宣言を書き換えて試してみてください。

brave33
質問者

お礼

うおおおおおおおお! 回答を見た瞬間唸ってしまいました。 この一文はどこかからコピペってきたのですが、 それが間違えてるとは・・・さんざんプログラム(あくまで本文のみ) を見直してあらゆることを試してもわからず1日潰してしまいました。 プログラマの「合ってるはずだ」は厳禁なのに、無意識にやって しまってたんですね。 ありがとうございました!

関連するQ&A

  • 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

  • VBA ユーザーフォームの×ボタン制御の不具合

    PowerPoint VBAで複数のユーザーフォームからなるVBAマクロを作成しました。 フォーム内の「次へ」「前へ」ボタンでのみ、マクロの実行制御をしているので、途中で右上の×を押されると、想定外エラーが発生します。 そこで、一番下に貼りつけたようなコードを全てのフォームに挿入することで、右上の×が表示されないようにしました。 あくまでフォームにしかコードは埋め込んでいません。 (標準モジュール、クラスには入ってません) ですが、極稀に、「フォームの右上×」ではなく、「PowerPointの右上×」が非表示になってしまう現象が発生します。 いろいろやるうちに再現はするのですが、厳密な再現手順がよくわかりません。 状況と下記ソースから、どこらへんに原因がありそうかアドバイス頂けないでしょうか? 全コードは出せない部分が多いのですが、アドバイスにあたり必要なコードがあれば、別途貼らせて頂きます。 Private Const GWL_STYLE = (-16) Private Const WS_SYSMENU = &H80000 ' ウィンドウに関する情報を返す Private Declare Function GetWindowLong Lib "USER32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long ' ウィンドウの属性を変更 Private Declare Function SetWindowLong Lib "USER32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long ' Activeなウィンドウのハンドルを取得 Private Declare Function GetActiveWindow Lib "USER32.dll" () As Long ' メニューバーを再描画 Private Declare Function DrawMenuBar Lib "USER32.dll" (ByVal hWnd As Long) As Long ' フォームアクティブ時処理 Private Sub UserForm_Activate() Dim hWnd As Long Dim Wnd_STYLE As Long hWnd = GetActiveWindow() Wnd_STYLE = GetWindowLong(hWnd, GWL_STYLE) Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU) SetWindowLong hWnd, GWL_STYLE, Wnd_STYLE DrawMenuBar hWnd 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)

  • 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でIEの「ファイルのダウンロード」ダイアログを制御

    VBではなくVBAにて、IEの「ファイルのダウンロード」ダイアログを制御したいと思い、過去の同様の質問等を参考に下記のソースを作成して動かしてみましたが、「ファイルのダウンロード」画面で、「保存(S)」ボタンのハンドルを取得するところまではできましたが、sendMessageでクリックができず、次に進むことが出来ませんでした。 手動で「保存(S)」ボタンを押下して、強制的に「名前を付けて保存」画面に遷移させた後プログラムを再開すると、同画面の「保存(S)」ボタンのクリックはできました。 同じロジックで「名前を付けて保存」画面の「保存(S)」は動くのに、「ファイルのダウンロード」画面の「保存(S)」が動かないのはなぜでしょうか。 どなたかおわかりになる方がいらっしゃいましたら、ご回答をお願いします。 ***使用環境*** OS: XP pro IE: 6 OFFICE:2002 ***以下作成したソース(エラー制御は省略)*** Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetDlgCtrlID Lib "user32" (ByVal hwnd As Long) As Long Private Sub Test() Dim ret1 As Long Dim ret2 As Long Const WM_COMMAND As Long = &H111 ret1 = FindWindow("#32770", "ファイルのダウンロード") ret2 = FindWindowEx(ret1, 0, "Button", "保存(&S)") Call SendMessage(ret1, WM_COMMAND, GetDlgCtrlID(ret2), ByVal ret2) ret1 = FindWindow("#32770", "名前を付けて保存") ret2 = FindWindowEx(ret1, 0, "Button", "保存(&S)") Call SendMessage(ret1, WM_COMMAND, GetDlgCtrlID(ret2), ByVal ret2) End Sub ***以上ソース終わり***

  • WinAPIで電卓をクリック

    現在、WinAPIを勉強しており、練習としてVBAを用いて、電卓アプリのボタンをクリックしようとしています。 キーを送るのではなく、クリックで行いたいたいと 考えています。 ボタンのハンドルを取得するところまではできましたが、sendMessageでクリックできず、EditBoxに数字が 入りません。 どのようにすればよいのかご教授ください。 よろしくお願い致します。 環境: WinXP home、 Excel2002、Win付属アプリの電卓v5.1 ---作成したプログラム---- '標準モジュールの中身 Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Sub Main() Dim lngWindWnd As Long 'ウィンドウハンドル Dim ret As Long Dim hCalc As Long 'アプリケーションタイトルより、ウィンドウハンドルを得ます lngWindWnd = FindWindow(vbNullString, "電卓") '8ボタンのハンドル(確実に取れていることを確認 hCalc = FindWindowEx(lngWindWnd, 0, "Button", "8") ret = SetForegroundWindow(lngWindWnd) ret = SendMessage(hCalc, WM_LBUTTONDOWN, 0, 0) End Sub

  • 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 '--------------------------------------------------------------- 型が一致しません と言われ動きません。 以上です、よろしくお願いいたします。

  • 64ビットエクセルでのAPI宣言/PtrSafe

    エクセルのInputboxで、入力された文字列を自動的にアスタリスクで隠すようにする方法を探し http://okwave.jp/qa/q2371878.html の回答No1のコードがまさに最適なコードで、これまで非常に助かっていました。 ところが、64bitのエクセルでは動かないことがわかりました。 表示されたエラーメッセージの言葉から調べて、PtrSafeという言葉を入れなければならないようなのでAPI宣言を以下のようにしてみました。 #If VBA7 And Win64 Then '64ビット版 Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else '32ビット版 Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If ところが、回答No1のコードで Sub Report_Open() を実行すると Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _ Optional YPos, Optional HelpFile, Optional Context) As String のところがハイライトされてエラーになります。 どう直せば良いのでしょうか? 全文のコードを乗せると字数制限に引っかかりますので、申し訳ありませんが宣言以外の部分は http://okwave.jp/qa/q2371878.html の回答No1のコードを見てくださいますようお願いします。

  • VB.netでFindWindowExやると・・・9222812402616107008!?

    VB.netでWin32APIのFindWindowExを使うと, たとえばスタートボタンのHWNDを拾ってくるとき, 本当なら65662(6.0のSpy++で確認+10進変換)が返ってきて欲しいんですが, 9222812402616107008という,異常な数が返ってきます. Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, <MarshalAs(UnmanagedType.LPTStr)> ByVal lpsz1 As String, <MarshalAs(UnmanagedType.LPTStr)> ByVal lpsz2 As String) As Long とやってあります. VB6.0のAPIビューワからコピペして,MarshalAsをつけてみました.   (初心者なので,わけわからないまま付けましたけど; hWnd_ShellTrayWnd = FindWindowEx(0,0,"Shell_TrayWnd",vbNullString) hWnd_StartButton = FindWindowEx(hwnd_ShellTrayWnd,0,"Button",vbNullString) とやってるのですが・・・. 不思議なのは,hWnd_ShellTrayWndが9222812402616238204になっているにもかかわらず,次のFindWindowExで,hWnd_StartBtnが9222812402616107008になってるところです・・・. しかも,ありえないクラス名(KeyBoadぐちゃぐちゃ押し)を指定しても,なぜか数が返ってくるんです. FindWindowExを成功させる(きちんとした数を取る)方法,またはFindWindowEx以外でhWndを拾ってくる方法,ありましたら,教えてください.

専門家に質問してみよう