VBAでモニタのサイズを取得する方法
- VBAを使用してモニタのサイズを取得する方法について説明します。
- 解像度ではなくモニタのサイズをVBAで取得することは可能です。
- モニタのサイズによって動きを変えたい場合、VBAを使用してサイズを取得することができます。デスクトップPCにモニタを付けて使っている場合に有用です。
- ベストアンサー
モニタのサイズをVBAで取得することは可能ですか？
解像度ではなく モニタのサイズをVBAで取得することは可能ですか？ Declare Function GetSystemMetrics _ Lib "user32" _ (ByVal nIndex As Long) As Long Const SM_CXSCREEN As Long = 0 Const SM_CYSCREEN As Long = 1 Function myX() '画面の幅を取得 myX = GetSystemMetrics(SM_CXSCREEN) End Function Function myY() myY = GetSystemMetrics(SM_CYSCREEN) End Function で解像度は取得できますが、 モニタのサイズによって動きを変えたいため、サイズを取得したいです。 デスクトップPCにモニタを付けて使っています。
- NTHZNRTFJV
- お礼率94% (34/36)
- その他MS Office製品
- 回答数1
- ありがとう数13
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
物理的なモニタサイズの取得は不可だと思います。 思いつく方法としては ・DPIと解像度から大よそのサイズを割り出す 一昔前なら96DPIがほぼ標準だったので特定可能でしたが高ppiのモニタが増えた昨今、現実的ではありません ・ドライバレベルでモニタサイズを推定する モニタ用のドライバが入っているようなレアケースだけに限定されます。現実的ではありません ビデオカードのドライバですら、モニタの物理的サイズは検出できていないですし ・製品名から特定する 特に設定せずPCに繋げているなら、汎用PnPとして表示されているため ビデオカードのドライバを通してモニタの製品名（型番）を取得し特定・・現実的ではありません 以上です。
関連するQ&A
- Formを動かせるようにしたい
お世話になります。 OS XP PRO VB6（SP５）で開発しています。 ディスプレイのサイズにより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 アドバイス頂きたくよろしくお願いします。 以上です。
- ベストアンサー
- Visual Basic
- WindowsAPI（GetWindowLongA）について質問です。
WindowsAPI（GetWindowLongA）について質問です。 以下コードを実行すると、ウィンドウにスクロールバーが表示されてしまいます。 実行はVBAでAccessのフォームを呼び出しています。 フォーム自体はディスプレイ幅より明らかに小さいフォームサイズです。 SetWindowLongAの引数指定が間違っているのでしょうか？ また、スクロールバーを表示させない方法はありますでしょうか？ アドバイスよろしくお願いいたします。 'Windows属性の取得 Public Declare Function GetClassLongPtr Lib "user32" Alias "GetWindowLongA" ( _ ByVal hWnd As Long, ByVal nIndex As Long) As Long 'Windows属性の変更 Public Declare Function SetWindowLongPt Lib "user32" Alias "SetWindowLongA" ( _ ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Sub MenuBarsReset() Const GWL_STYLE = (-16) Const WS_SYSMENU = &H80000 Dim lngRetVal As Long lngRetVal = GetClassLongPtr(hWndAccessApp, GWL_STYLE) lngRetVal = SetWindowLongPt(hWndAccessApp, GWL_STYLE, lngRetVal - WS_SYSMENU) End Sub
- ベストアンサー
- その他（プログラミング・開発）
- ExcelVBAでフォームのタイトルバーで右クリックした場合などに閉じるボタンが有効化されないようにするコード
Excelのプログラムで、最小化ボタンを有効にし、閉じるボタンを無効にする質問をしたんですが、うまくいったと思ったのですがフォームが開き、タイトルバーで右クリックした場合などは閉じるボタンが有効化されてしまうのでこれを無効のままにするコードを教えてください。 作ったプログラムは以下の通りです。 標準モジュール Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function DrawMenuBar Lib "user32" _ (ByVal hWnd As Long) As Long Public Declare Function GetSystemMenu Lib "user32.dll" _ (ByVal hWnd As Long, ByVal bRevert As Long) As Long Public Declare Function EnableMenuItem Lib "user32" _ (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long Public Const MF_DISABLED = &H2& Public Const GWL_STYLE = (-16) Public Const WS_MINIMIZEBOX = &H20000 Public Const MF_BYCOMMAND = &H0& Public Const SC_CLOSE = &HF060& Dim hSysMenu As Long UserForm_Initializeプロシージャ Dim fRet As Long Dim hWnd As Long Dim fStyle As Long hWnd = FindWindow("ThunderDFrame", "UserForm1") fStyle = GetWindowLong(hWnd, GWL_STYLE) fStyle = (fStyle Or WS_THICKFRAME Or WS_MINIMIZEBOX) fRet = SetWindowLong(hWnd, GWL_STYLE, fStyle) hSysMenu = GetSystemMenu(hWnd, 0) EnableMenuItem hSysMenu, SC_CLOSE, MF_BYCOMMAND Or MF_DISABLED fRet = DrawMenuBar(hWnd) 回答よろしくお願いします。
- ベストアンサー
- Visual Basic
- 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
- ベストアンサー
- その他MS Office製品
- 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 '-------------------------------------------------
- ベストアンサー
- Visual Basic
- vbaでmsgboxの位置を指定
http://okwave.jp/qa/q5253604.html を参考に、http://homepage1.nifty.com/rucio/main/technique/MsgBox.htmをやってみたのですが うまくいきません。 検証はエクセル・アクセス２００７で行いました。 ////////////////////////////////////////////////////////////////// Option Explicit Dim App As Object 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 SetWindowPos Lib "user32" _ (ByVal hwnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) As Long Const WH_CBT = 5 Const HCBT_ACTIVATE = 5 Public Const SWP_NOSIZE = &H1 '「サイズを指定しない」オプション Public Const SWP_NOZORDER = &H4 '「Ｚオーダーを指定しない」オプション Public Const SWP_NOACTIVATE = &H10 Dim HookHandle As Long '元のCBTProcプロシージャへのハンドル Dim m_Left As Long 'メッセージボックスのＸ座標 Dim m_Top As Long 'メッセージボックスのＹ座標 Public Sub SetMsgBox(Left As Long, Top As Long) m_Left = Left m_Top = Top HookHandle = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, App.Hinstance, App.ThreadID) End Sub Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim Ret As Long If nCode = HCBT_ACTIVATE Then Ret = SetWindowPos(wParam, 0, m_Left, m_Top, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE) Ret = UnhookWindowsHookEx(HookHandle) End If CBTProc = Ret End Function ////////////////////////////////////////////////////////////////// を標準モジュールに貼りつけました。 Dim App As Objectについては、参考のページにはありませんでしたが エラーになるので勝手にObjectにしました。 そしてこのコードを書いた標準モジュールに Sub test() SetMsgBox 0, 0 MsgBox "この例では左上に表示されます。" End Sub を足しました。 そして実行すると、 HookHandle = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, App.Hinstance, App.ThreadID) の部分で オブジェクト変数または With ブロック変数が設定されていません。(Error 91) になります。 ＶＢＡでの位置の指定方法を教えてください！！！
- ベストアンサー
- オフィス系ソフト
- 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のコードを見てくださいますようお願いします。
- ベストアンサー
- Excel（エクセル）
- vba引数の渡し方について
win32APIで作成したシステムを64bit環境でも動くよう修正をしています。 win7、access2010 以下のとおり宣言変更したところ、lpDevMode型が32bitの場合Long型、64bitはDEVMODE（構造体）となりました。 この時、Private Const DEFAULT_VALUES = 0のところは64bit用にどのように修正したらよいのでしょうか？ このままコンパイルすると「ByRef 引数の型が一致しません。」となります。 <<宣言>> #If VBA7 And Win64 Then Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" _ Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _ ByVal lpPort As String, ByVal iIndex As Long, ByVal lpOutput As String, _ lpDevMode As DEVMODE) As Long #Else Private Declare Function DeviceCapabilities Lib "winspool.drv" _ Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _ ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _ ByVal lpDevMode As Long) As Long #End If Private Const DEFAULT_VALUES = 0 <<呼び出し元>> lngBinCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _ lpPort:=strDevicePort, _ iIndex:=DC_BINNAMES, _ lpOutput:=ByVal vbNullString, _ lpDevMode:=DEFAULT_VALUES) ↑「ByRef 引数の型が一致しません。」
- 締切済み
- Visual Basic
- windows7のエクスプローラをVBAで操作－１
アドバイスをお願いします。 Excel－VBAで起動しているエクスプローラに対してハンドルを取得してクリックしたり、テキストボックスに文字をセットするプログラムを作って動かしています。 WindowsXPのときはできていたのですが、Windows7になったら正しく動作しなくなりました。 下のコードはエクスプローラの現在のフォルダパスが表示されるところに（添付ファイル参照）文字を入れるものです。 最後のSendMessageAnyで１が返ってしまいます。何が考えられますでしょうか。どう対策したらいいでしょうか。 なおハンドルの値は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
- ベストアンサー
- Windows 7
- windows7のエクスプローラをVBAで操作－２
アドバイスをお願いします。 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
- ベストアンサー
- Windows 7
お礼
ありがとうございます。