Разрешение экрана vba excel

1
2
3

MsgBox$ _
            "Экран Вашего монитора имеет разрешение: " & GetSystemMetrics(0&) & "x" & GetSystemMetrics(1&) & vbCrLf & _
                                                       "Размер Вашего монитора: " & Application.UsableWidth & "x" & Application.UsableHeight, vbExclamation, "Информация"

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

Option Explicit
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Const HORZRES = 8 ' Horizontal width in pixels
Private Const VERTRES = 10 ' Vertical width in pixels
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
Public Sub usbGetFormSize()
Dim x As Variant
Dim y As Variant
Dim hDc As Long, lngRetVal As Long
Dim varScreenX As Variant, varScreenY As Variant
Dim varPixToInchX As Variant, varPixToInchY As Variant
hDc = GetDC(0)
'Get the Screen size in pixels for X & Y
varScreenX = GetDeviceCaps(hDc, HORZRES)
varScreenY = GetDeviceCaps(hDc, VERTRES)
'Get the conversion of pixels/inch for X & Y
varPixToInchX = GetDeviceCaps(hDc, LOGPIXELSX)
varPixToInchY = GetDeviceCaps(hDc, LOGPIXELSY)
'Convert to миллиметры.
x = varScreenX / varPixToInchX * 25.4
y = varScreenY / varPixToInchY * 25.4
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

Option Explicit
 
Private Const DRIVERVERSION  As Long = 0     'Версия драйвера
Private Const TECHNOLOGY     As Long = 2     'Классификация устройства
 
Private Const HORZSIZE       As Long = 4     '!!!Размер по горизонтали в мм.
Private Const VERTSIZE       As Long = 6     '!!!Размер по вертикали в мм.
 
Private Const HORZRES        As Long = 8     'Размер по горизонтали в точках
Private Const VERTRES        As Long = 10    'Размер по вертикали в точках
Private Const BITSPIXEL      As Long = 12    'Кол-во бит на точку
Private Const PLANES         As Long = 14    'Number of planes
Private Const NUMBRUSHES     As Long = 16    'Number of brushes the device has
Private Const NUMPENS        As Long = 18    'Number of pens the device has
Private Const NUMMARKERS     As Long = 20    'Number of markers the device has
Private Const NUMFONTS       As Long = 22    'Number of fonts the device has
Private Const NUMCOLORS      As Long = 24    'Макс. кол-во возможных цветов
Private Const PDEVICESIZE    As Long = 26    'Size required for device descripto
Private Const CURVECAPS      As Long = 28    'Curve capabilities
Private Const LINECAPS       As Long = 30    'Line capabilities
Private Const POLYGONALCAPS  As Long = 32    'Polygonal capabilities
Private Const TEXTCAPS       As Long = 34    'Text capabilities
Private Const CLIPCAPS       As Long = 36    'Clipping capabilities
Private Const RASTERCAPS     As Long = 38    'Bitblt capabilities
Private Const ASPECTX        As Long = 40    'Length of the X leg
Private Const ASPECTY        As Long = 42    'Length of the Y leg
Private Const ASPECTXY       As Long = 44    'Length of the hypotenuse
Private Const SHADEBLENDCAPS As Long = 45    'Shading and blending caps (IE5)
Private Const LOGPIXELSX     As Long = 88    'Logical pixels/inch in X
Private Const LOGPIXELSY     As Long = 90    'Logical pixels/inch in Y
Private Const SIZEPALETTE    As Long = 104   'Number of entries in physical palette
Private Const NUMRESERVED    As Long = 106   'Number of reserved entries in palette
Private Const COLORRES       As Long = 108   'Количество цветов
Private Const VREFRESH       As Long = 116   'Текущий рефрешь по вертикали в Гц
                                             '(только для монитора)
Private Const DESKTOPVERTRES As Long = 117   'Размер десктопа по горизонтали
Private Const DESKTOPHORZRES As Long = 118   'Размер десктопа по вертикали
Private Const BLTALIGNMENT   As Long = 119   'Preferred blt alignment
 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
Public Sub ScreenSize()
MsgBox GetDeviceCaps(GetDC(0), 4) & " X " & GetDeviceCaps(GetDC(0), 6) & " mm"
End Sub

1
2
3
4
5
6
7
8

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
Public Sub ScreenSize()
 
    MsgBox GetDeviceCaps(GetDC(0), 4) & " X " & GetDeviceCaps(GetDC(0), 6) & " mm"
 
End Sub

1
2
3
4
5
6
7
8

With GetObject("winmgmts:\.rootcimv2")
    For Each x In .ExecQuery("Select * From Win32_DisplayConfiguration")
        MsgBox "Horizontal resolution: " & x.PelsWidth
        MsgBox "Vertical resolution: " & x.PelsHeight
        MsgBox "Name: " & x.DeviceName
        MsgBox "Color depth: " & x.BitsPerPel
    Next
End With