| |
どのシートのどのセルでも、ダブルクリックすれば 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
を入れます。試してみて下さい。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
