Other Tips All Tips By Date By Subject
API (33) Bit Manipulation (3) Clipboard (3) Combo Box (5) Desktop (3) GDI (13) Graphics (13) Internet (2) Interprocess Comms (3) Keyboard (2) Mouse (1) Shell (1) Sprites (1) Subclassing (3) Text Box (2) Windows (11) Windows Controls (10)
Submit
|
This tip demonstrates how to detect Windows display setting changes (i.e. screen size and display colour depth)
from Visual Basic. You will need to have installed
and registered SSubTmr.DLL, available from this site at Subclassing
without the crashes to run this sample.
Start a new project and choose Project->References. Look for
"Subclassing and Timer Assistant (with multiple control support and timer bug fix)"
in the references list. If it is there, select it and click ok. If it isn't, choose
Browse, locate SSubTmr.DLL on your disk, then select that.
Once that is done, add a Class module. Rename the Class module to cDisplayChange and then
add the following code:
Private Const WM_DISPLAYCHANGE = &H7E&
Private Const WM_DESTROY = &H2
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const BITSPIXEL = 12 ' Number of bits per pixel
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _
lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Implements ISubclass
Public Event ColourDepthChange(ByVal lNewBitsPixel As Long, ByVal lOldBitsPixel As Long)
Public Event WindowSizeChange(ByVal lNewWidth As Long, ByVal lNewHeight As Long, ByVal lOldWidth As Long, ByVal lOldHeight As Long)
Private m_hWnd As Long
Private m_lBitsPixel As Long
Private m_lWidth As Long
Private m_lHeight As Long
Public Sub Attach(ByVal hWndA As Long)
Dim hdc As Long
Detach
m_hWnd = hWndA
AttachMessage Me, m_hWnd, WM_DISPLAYCHANGE
AttachMessage Me, m_hWnd, WM_DESTROY
hdc = GetDC(m_hWnd)
m_lBitsPixel = GetDeviceCaps(hdc, BITSPIXEL)
m_lWidth = Screen.Width \ Screen.TwipsPerPixelX
m_lHeight = Screen.Height \ Screen.TwipsPerPixelY
ReleaseDC hdc, m_hWnd
End Sub
Public Sub Detach()
If Not m_hWnd = 0 Then
DetachMessage Me, m_hWnd, WM_DISPLAYCHANGE
DetachMessage Me, m_hWnd, WM_DESTROY
m_hWnd = 0
End If
End Sub
Public Property Get ColourDepth() As Long
Dim hdc As Long
If m_hWnd = 0 Then
hdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
m_lBitsPixel = GetDeviceCaps(hdc, BITSPIXEL)
DeleteDC hdc
End If
ColourDepth = m_lBitsPixel
End Property
Public Property Get DisplayWidth() As Long
If m_hWnd = 0 Then
m_lWidth = Screen.Width \ Screen.TwipsPerPixelX
End If
DisplayWidth = m_lWidth
End Property
Public Property Get DisplayHeight() As Long
If m_hWnd = 0 Then
m_lHeight = Screen.Height \ Screen.TwipsPerPixelY
End If
DisplayHeight = m_lHeight
End Property
Private Sub Class_Terminate()
Detach
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
ISubclass_MsgResponse = emrPreprocess
End Property
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_DISPLAYCHANGE
Dim lOldBitsPixel As Long
Dim lWidth As Long, lHeight As Long
Dim lOldWidth As Long, lOldHeight As Long
lWidth = lParam And &HFFFF&
lHeight = (lParam And &H7FFF0000) \ &H10000
If Not wParam = m_lBitsPixel Then
lOldBitsPixel = m_lBitsPixel
m_lBitsPixel = wParam
RaiseEvent ColourDepthChange(m_lBitsPixel, lOldBitsPixel)
End If
If Not ((lWidth = m_lWidth) And (lHeight = m_lHeight)) Then
lOldWidth = m_lWidth
lOldHeight = m_lHeight
m_lWidth = lWidth
m_lHeight = lHeight
RaiseEvent WindowSizeChange(m_lWidth, m_lHeight, lOldWidth, lOldHeight)
End If
Case WM_DESTROY
Detach
End Select
End Function
To test out the project, add a Label control to your project's form.
Private WithEvents m_c As cDisplayChange
Private Sub DisplayInfo()
Label1.AutoSize = True
Label1.Caption = "Colour Depth: " & m_c.ColourDepth & _
vbCrLf & "Size: " & m_c.DisplayWidth & " x " & m_c.DisplayHeight
End Sub
Private Sub Form_Load()
Set m_c = New cDisplayChange
m_c.Attach Me.hwnd
DisplayInfo
End Sub
Private Sub m_c_ColourDepthChange(ByVal lNewBitsPixel As Long, ByVal lOldBitsPixel As Long)
DisplayInfo
End Sub
Private Sub m_c_WindowSizeChange(ByVal lNewWidth As Long, ByVal lNewHeight As Long, ByVal lOldWidth As Long, ByVal lOldHeight As Long)
DisplayInfo
End Sub
Run the project. Choose the Windows Display settings setup box. Whenever you change the colour depth or size,
and event will fire and the Label on the form will be updated with the new colour depth and screen size.
|