PDA

Vollständige Version anzeigen : Hintergrundfarbe der Applikation


casy1301
07.08.2005, 15:46
Hintergrundfarbe der Applikation


'Modul anlegen

'
' CONSTANT's
'
Private Const GCL_HBRBACKGROUND = (-10)
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200

Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_CHILD = 5

'===========================================================
' API's
'===========================================================
Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" (ByVal hwnd&, ByVal lpClassName$, _
ByVal nMaxCount&) As Long

Private Declare Function apiSetClassLong Lib "user32" _
Alias "SetClassLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&) As Long

Private Declare Function apiGetWindow Lib "user32" _
Alias "GetWindow" (ByVal hwnd&, ByVal wCmd&) As Long

Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject&) As Long

Private Declare Function apiCreateSolidBrush Lib "gdi32" _
Alias "CreateSolidBrush" (ByVal crColor&) As Long

Private Declare Function apiRedrawWindow Lib "user32" _
Alias "RedrawWindow" (ByVal hwnd&, lprcUpdate As Any, _
ByVal hrgnUpdate&, ByVal fuRedraw&) As Long

' ===========================================================
' FUNCTION's / SUB's
' ===========================================================
Public Function SetAppBkColor(lColorRef&) As Boolean
' ändert die Hintergrundfarbe der Applikation über WNDCLASS: hbrBackground
' Returns: TRUE = ok, sonst False
Dim hw&, hBrush&
SetAppBkColor = False

hw = fGetMDIClientHandle()
If hw <> 0 Then
' das mdi fenster wurde gefunden
' solid brush erzeugen
hBrush = apiCreateSolidBrush(lColorRef&)
' fensterklasse ändern
apiSetClassLong hw, GCL_HBRBACKGROUND, hBrush
' fenster neu ausgeben (Paint-event auslösen)
apiRedrawWindow hw, ByVal 0&, ByVal 0&, RDW_INVALIDATE Or RDW_ERASE _
Or RDW_ERASENOW

SetAppBkColor = True
End If

End Function

Private Function fGetMDIClientHandle() As Long
' Returns a handle to the mdiclient window of a form
Dim hw&, hwChild&
hw = Application.hWndAccessApp
'durchlaufen aller fenster
Do While hw > 0
' nach dem application main window "OMain" suchen
If fGetClassName(hw) = "OMain" Then
' nach dem child "MDIClient" suchen
hwChild& = apiGetWindow(hw, GW_CHILD)
Do While hwChild > 0
If fGetClassName(hwChild&) = "MDIClient" Then
fGetMDIClientHandle = hwChild
Exit Do
End If
' handle zum nächsten child ermitteln
hwChild& = apiGetWindow(hwChild, GW_HWNDNEXT)
Loop
Exit Do
End If
' handle zum nächsten fenster ermitteln
hw = apiGetWindow(hw, GW_HWNDNEXT)
Loop
End Function


Private Function fGetClassName$(hw&)
'den Klassennamen ermitteln
Dim strBuffer$, lLen&
fGetClassName = ""
strBuffer = String$(255, vbNullChar)
lLen = apiGetClassName(hw, strBuffer, 255)
If lLen > 0 Then: fGetClassName = Left$(strBuffer, lLen)
End Function
'Aufruf z.B.

Private Sub Form_Load()
Call SetAppBkColor(RGB(255, 0, 0))
End Sub