Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

55753 / 76732

←次へ　｜　前へ→


	【25746】Re:画面の解像度の取得

Kein - 05/6/13(月) 14:23 -


	引用なし

	パスワード

どのシートのどのセルでも、ダブルクリックすれば 2列×10行拡大した範囲に
リストボックスを配置し、そこに解像度のリストを展開、一つを選ぶとその解像度に
変更できる。というマクロを作ってみました。まず ThisWorkbookモジュールに

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
　 Dim MyR As String
　
　 Cancel = True
　 If Sh.ListBoxes.Count > 0 Then Sh.ListBxes.Delete
　 MyR = Target.Resize(10, 2).Address
　 Call MyList(MyR)
End Sub

を入れて、標準モジュールの先頭から

Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal dwModeNum As Long, lpDevMode As DEVMODE) As Long
Public Declare Function ChangeDisplaySettings Lib "user32" Alias _
"ChangeDisplaySettingsA" (lpDevMode As DEVMODE, ByVal dwflags As Long) As Long

Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32

Public Type DEVMODE
　　dmDeviceName As String * CCHDEVICENAME
　　dmSpecVersion As Integer
　　dmDriverVersion As Integer
　　dmSize As Integer
　　dmDriverExtra As Integer
　　dmFields As Long
　　dmOrientation As Integer
　　dmPaperSize As Integer
　　dmPaperLength As Integer
　　dmPaperWidth As Integer
　　dmScale As Integer
　　dmCopies As Integer
　　dmDefaultSource As Integer
　　dmPrintQuality As Integer
　　dmColor As Integer
　　dmDuplex As Integer
　　dmYResolution As Integer
　　dmTTOption As Integer
　　dmCollate As Integer
　　dmFormName As String * CCHFORMNAME
　　dmUnusedPadding As Integer
　　dmBitsPerPel As Long
　　dmPelsWidth As Long
　　dmPelsHeight As Long
　　dmDisplayFlags As Long
　　dmDisplayFrequency As Long
End Type

Sub MyList(MyR As String)
　 Dim Lp As Single, Tp As Single
　 Dim Wp As Single, Hp As Single
　 Dim List1 As Object
　 Dim DEVMODE As DEVMODE
　 Dim LSt As String
　 Dim i As Integer

　 With Range(MyR)
　　　Lp = .Left: Tp = .Top
　　　Wp = .Width: Hp = .Height
　 End With
　 Set List1 = ActiveSheet.ListBoxes.Add(Lp, Tp, Wp, Hp)
　 With List1
　　　.Left = Lp: .Top = Tp
　　　.Width = Wp: .Height = Hp
　 End With
　 For i = 0 To 64
　　　If EnumDisplaySettings(vbNullString, i, DEVMODE) = 1 Then
　　　　 LSt = DEVMODE.dmBitsPerPel & "ﾋﾞｯﾄ " & _
　　　　 DEVMODE.dmPelsWidth & "×" & DEVMODE.dmPelsHeight
　　　　 List1.AddItem LSt
　　　End If
　 Next i
　 List1.OnAction = "Get_Data"
　 Set List1 = Nothing
End Sub

Sub Get_Data()
　 Dim x As Variant
　 Dim DEVMODE As DEVMODE
　
　 x = Application.Caller
　 If VarType(x) <> 8 Then Exit Sub
　 With ActiveSheet.ListBoxes(x)
　　　If EnumDisplaySettings(vbNullString, .ListIndex, DEVMODE) = 1 Then
　　　　 Call ChangeDisplaySettings(DEVMODE, 0)
　　　End If
　　　.Delete
　 End With
End Sub

を入れます。試してみて下さい。

2 hits

▼

【25739】画面の解像度の取得 ぴかる 05/6/13(月) 13:41