Excel VBA質問箱 IV

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

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


9733 / 13644 ツリー ←次へ | 前へ→

【25739】画面の解像度の取得 ぴかる 05/6/13(月) 13:41 質問[未読]
【25744】Re:画面の解像度の取得 小僧 05/6/13(月) 14:02 回答[未読]
【25745】Re:画面の解像度の取得 ぴかる 05/6/13(月) 14:15 お礼[未読]
【25746】Re:画面の解像度の取得 Kein 05/6/13(月) 14:23 回答[未読]
【25747】Re:画面の解像度の取得 ぴかる 05/6/13(月) 15:10 お礼[未読]

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

引用なし
パスワード
   こんにちは。

各PCによって画面の解像度が異なる為、共用ソフトを作成した際、表示レイアウトも異なってしまいます。そこで画面の解像度(1024*768,1280*1024)を取得し、表示倍率を設定出来ればと考えています。もし取得可能でありましたら、よろしくお願い致します。

【25744】Re:画面の解像度の取得
回答  小僧  - 05/6/13(月) 14:02 -

引用なし
パスワード
   ▼ぴかる さん:
こんにちは。

APIは詳しくないので他サイトを参考にしましたが、

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

Function ResolutionPro()

  Dim X As Long, Y As Long
  
  X = GetSystemMetrics(SM_CXSCREEN) '画面の幅を取得します。
  Y = GetSystemMetrics(SM_CYSCREEN) '画面の高さを取得します。
  
    Debug.Print "現在の解像度は " & X & " × " & Y & " です。"
  
End Function

でどうでしょうか?

【25745】Re:画面の解像度の取得
お礼  ぴかる  - 05/6/13(月) 14:15 -

引用なし
パスワード
   小僧さん、こんにちは。

バッチリでした。色んなソフトに使えそうです。ありがとうございました。

【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

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

【25747】Re:画面の解像度の取得
お礼  ぴかる  - 05/6/13(月) 15:10 -

引用なし
パスワード
   Keinさん、こんにちは。

取得するだけでなく、設定も出来るんですね。おもしろかったです。ありがとうございました。
ただ画面が真っ黒になった瞬間、ひやぁ〜としました。設定中やったんですね。(^^;)

9733 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free