7,763
社区成员
发帖
与我相关
我的任务
分享请发表友善的回复…
发表回复
gzhoney 2005-11-15
- 打赏
- 举报
谢谢
northwolves 2005-11-15
- 打赏
- 举报
Private Sub Command1_Click()
MsgBox Screen.Width / Screen.TwipsPerPixelX & "x" & Screen.Height / Screen.TwipsPerPixelY
End Sub
MsgBox Screen.Width / Screen.TwipsPerPixelX & "x" & Screen.Height / Screen.TwipsPerPixelY
End Sub
faysky2 2005-11-15
- 打赏
- 举报
用API获得屏幕分辨率和色彩度
--------------------------------------------------------------------------------
窗体加载时通过调用函数DeviceInfo将返回的屏幕分辨率宽、高和色彩度装入变量DisplayX、DisplayY、DisplayColor中。在你的程序中使用时只需要使用红色标记的一行调用语句即可。
Option Explicit
'声明API函数
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
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 Sub Form_Load()
Dim DisplayX As Integer
Dim DisplayY As Integer
Dim DisplayColor As Integer
Form1.Show
Call DeviceInfo(DisplayX, DisplayY, DisplayColor)
Print Trim(DisplayX):Print Trim(DisplayY);:?Trim(DisplayColor)
End Sub
DeviceInfo自定义函数代码如下
Public Sub DeviceInfo(DisplayX As Integer, DisplayY As Integer, DisplayColor As Integer)
Dim hdesktopwnd
Dim hdccaps
Dim lblRes As String
Dim DisplayBits
Dim DisplayPlanes
Dim RetVal
hdccaps = GetDC(hdesktopwnd)
DisplayBits = GetDeviceCaps(hdccaps, 12)
DisplayPlanes = GetDeviceCaps(hdccaps, 14)
DisplayX = GetDeviceCaps(hdccaps, 8)
DisplayY = GetDeviceCaps(hdccaps, 10)
RetVal = ReleaseDC(hdesktopwnd, hdccaps)
Select Case DisplayBits
Case 1
If DisplayPlanes = 1 Then
DisplayColor = 1
Else
If DisplayPlanes = 4 Then DisplayColor = 4 Else DisplayColor = 0
End If
Case 8
DisplayColor = 8
Case 16
DisplayColor = 16
Case 24
DisplayColor = 24
Case 32
DisplayColor = 32
Case Else
DisplayColor = 0'未知色彩度
End Select
End Sub
--------------------------------------------------------------------------------
窗体加载时通过调用函数DeviceInfo将返回的屏幕分辨率宽、高和色彩度装入变量DisplayX、DisplayY、DisplayColor中。在你的程序中使用时只需要使用红色标记的一行调用语句即可。
Option Explicit
'声明API函数
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
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 Sub Form_Load()
Dim DisplayX As Integer
Dim DisplayY As Integer
Dim DisplayColor As Integer
Form1.Show
Call DeviceInfo(DisplayX, DisplayY, DisplayColor)
Print Trim(DisplayX):Print Trim(DisplayY);:?Trim(DisplayColor)
End Sub
DeviceInfo自定义函数代码如下
Public Sub DeviceInfo(DisplayX As Integer, DisplayY As Integer, DisplayColor As Integer)
Dim hdesktopwnd
Dim hdccaps
Dim lblRes As String
Dim DisplayBits
Dim DisplayPlanes
Dim RetVal
hdccaps = GetDC(hdesktopwnd)
DisplayBits = GetDeviceCaps(hdccaps, 12)
DisplayPlanes = GetDeviceCaps(hdccaps, 14)
DisplayX = GetDeviceCaps(hdccaps, 8)
DisplayY = GetDeviceCaps(hdccaps, 10)
RetVal = ReleaseDC(hdesktopwnd, hdccaps)
Select Case DisplayBits
Case 1
If DisplayPlanes = 1 Then
DisplayColor = 1
Else
If DisplayPlanes = 4 Then DisplayColor = 4 Else DisplayColor = 0
End If
Case 8
DisplayColor = 8
Case 16
DisplayColor = 16
Case 24
DisplayColor = 24
Case 32
DisplayColor = 32
Case Else
DisplayColor = 0'未知色彩度
End Select
End Sub
king_shadow 2005-11-15
- 打赏
- 举报
Public Function CheckRez(pixelWidth As Long, pixelHeight As Long) As Boolean
注释：
Dim lngTwipsX As Long
Dim lngTwipsY As Long
注释： convert pixels to twips
lngTwipsX = pixelWidth * 15
lngTwipsY = pixelHeight * 15
注释： check against current settings
If lngTwipsX <> Screen.Width Then
CheckRez = False
Else
If lngTwipsY <> Screen.Height Then
CheckRez = False
Else
CheckRez = True
End If
End If
End Function
If CheckRez(640, 480) = True Then
MsgBox "640, 480!"
Else if CheckRez(800, 600) = True then
MsgBox "800, 600!"
End If
要不就用API吧
注释：
Dim lngTwipsX As Long
Dim lngTwipsY As Long
注释： convert pixels to twips
lngTwipsX = pixelWidth * 15
lngTwipsY = pixelHeight * 15
注释： check against current settings
If lngTwipsX <> Screen.Width Then
CheckRez = False
Else
If lngTwipsY <> Screen.Height Then
CheckRez = False
Else
CheckRez = True
End If
End If
End Function
If CheckRez(640, 480) = True Then
MsgBox "640, 480!"
Else if CheckRez(800, 600) = True then
MsgBox "800, 600!"
End If
要不就用API吧
