Ich suche eine Möglichkeit Command Buttons, List Box, Text Fields u.ä. „flach“ und mit Hottrack darzustellen (Wie bei Java Swing).
Über eine Quelle für solche Controls wäre ich sehr dankbar!
cu René
Hallo
Zunächst erstellst du ein neues Klassenmodul mit dem folgenden Code
und gibt ihm den Namen „clsFlatControl“:
Option Explicit
' Declare constants
Implements ISubclass
Private Const WM\_COMMAND = &H111
Private Const WM\_PAINT = &HF
Private Const WM\_TIMER = &H113
Private Const WM\_MOUSEMOVE = &H200
Private Const WM\_LBUTTONDOWN = &H201
Private Const WM\_LBUTTONUP = &H202
Private Const SM\_CXHTHUMB = 10
Private Const WM\_SETFOCUS = &H7
Private Const WM\_KillFileFOCUS = &H8
Private Const WM\_MOUSEACTIVATE = &H21
Private Const PS\_SOLID = 0
Private Const GWL\_EXSTYLE = (-20)
Private Const GWL\_STYLE = (-16)
Private Const WS\_EX\_CLIENTEDGE = &H200&
Private Const CBS\_DROPDOWN = &H2&
Private Const CBS\_DROPDOWNLIST = &H3&
Private Const CBN\_DROPDOWN = 7
Private Const CBN\_CLOSEUP = 8
Private Const CB\_GETDROPPEDSTATE = &H157
Private Const GW\_CHILD = 5
' Declare enums
Private Enum EDrawStyle
FC\_DRAWNORMAL = &H1
FC\_DRAWRAISED = &H2
FC\_DRAWPRESSED = &H4
End Enum
' Declare types
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Declare functions
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd
As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32.dll" (ByVal hwnd
As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long)
As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long)
As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As
Long) As Long
Private Declare Function InflateRect Lib "user32.dll" (lpRect As
RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function OffsetRect Lib "user32.dll" (lpRect As RECT,
ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32.dll" (ByVal hwnd
As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal
nIndex As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd
As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As
Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal
lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As
Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As
POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd
As Long, lpRect As RECT) As Long
Private Declare Function PtInRect Lib "user32.dll" (lpRect As RECT,
ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle
As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As
Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject
As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hdc As Long,
ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long,
ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal
OLE\_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As
Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal
dwNewLong As Long) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias
"FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal
lpsz1 As String, lpsz2 As Any) As Long
Private Declare Function SendMessageLong Lib "user32.dll" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindow Lib "user32.dll" (ByVal hwnd As
Long, ByVal wCmd As Long) As Long
Private Declare Function GetFocus Lib "user32.dll" () As Long
' Declare values
Private m\_bLBtnDown As Boolean
Private m\_bCombo As Boolean
Private m\_hWnd As Long
Private m\_hWndEdit As Long
Private m\_hWndParent As Long
Private m\_bSubclass As Boolean
Private m\_bMouseOver As Boolean
Public Sub Attach(ByRef objthis As Object)
Dim lStyle As Long
Dim lhWnd As Long
pRelease
On Error Resume Next
lhWnd = objthis.hwnd
If (Err.Number 0) Then
Err.Raise vbObjectError + 1048 + 1, App.EXEName &
".cFlatControl", "Incorrect control type passed to 'Attach' parameter
- must be a control with a hWnd property."
Exit Sub
End If
m\_bCombo = False
If TypeName(objthis) = "ImageCombo" Then
m\_hWndParent = lhWnd
lhWnd = FindWindowEx(lhWnd, 0&, "ComboBox", ByVal 0&:wink:
m\_bCombo = True
ElseIf TypeName(objthis) = "ComboBox" Then
m\_hWndParent = GetParent(objthis.hwnd)
m\_bCombo = True
ElseIf TypeName(objthis) = "OwnerDrawComboList" Then
m\_hWndParent = lhWnd
m\_bCombo = True
Else
lStyle = GetWindowLong(lhWnd, GWL\_STYLE)
If ((lStyle And CBS\_DROPDOWN) = CBS\_DROPDOWN) Or ((lStyle And
CBS\_DROPDOWNLIST) = CBS\_DROPDOWNLIST) Then
m\_hWndParent = objthis.Parent.hwnd
m\_bCombo = True
Else
With objthis
.Move .Left + 2 \* Screen.TwipsPerPixelX, .Top + 2 \*
Screen.TwipsPerPixelY, .Width - 4 \* Screen.TwipsPerPixelX, .Height -
4 \* Screen.TwipsPerPixelY
End With
End If
End If
pAttach lhWnd
End Sub
Private Sub pAttach(ByRef hWndA As Long)
Dim lStyle As Long
m\_hWnd = hWndA
If (m\_hWnd 0) Then
lStyle = GetWindowLong(m\_hWnd, GWL\_STYLE)
If (lStyle And CBS\_DROPDOWN) = CBS\_DROPDOWN Then
m\_hWndEdit = GetWindow(m\_hWnd, GW\_CHILD)
End If
AttachMessage Me, m\_hWnd, WM\_PAINT
AttachMessage Me, m\_hWnd, WM\_MOUSEACTIVATE
AttachMessage Me, m\_hWnd, WM\_SETFOCUS
AttachMessage Me, m\_hWnd, WM\_KillFileFOCUS
AttachMessage Me, m\_hWnd, WM\_MOUSEMOVE
AttachMessage Me, m\_hWnd, WM\_TIMER
If (m\_hWndEdit 0) Then
AttachMessage Me, m\_hWndEdit, WM\_MOUSEACTIVATE
AttachMessage Me, m\_hWndEdit, WM\_SETFOCUS
AttachMessage Me, m\_hWndEdit, WM\_KillFileFOCUS
AttachMessage Me, m\_hWndEdit, WM\_MOUSEMOVE
End If
If (m\_bCombo) Then
AttachMessage Me, m\_hWndParent, WM\_COMMAND
End If
m\_bSubclass = True
End If
End Sub
Private Sub pRelease()
If (m\_bSubclass) Then
DetachMessage Me, m\_hWnd, WM\_PAINT
DetachMessage Me, m\_hWnd, WM\_SETFOCUS
DetachMessage Me, m\_hWnd, WM\_KillFileFOCUS
DetachMessage Me, m\_hWnd, WM\_MOUSEACTIVATE
DetachMessage Me, m\_hWnd, WM\_MOUSEMOVE
DetachMessage Me, m\_hWnd, WM\_TIMER
If (m\_hWndEdit 0) Then
DetachMessage Me, m\_hWndEdit, WM\_MOUSEACTIVATE
DetachMessage Me, m\_hWndEdit, WM\_SETFOCUS
DetachMessage Me, m\_hWndEdit, WM\_KillFileFOCUS
DetachMessage Me, m\_hWndEdit, WM\_MOUSEMOVE
End If
If (m\_bCombo) Then
DetachMessage Me, m\_hWndParent, WM\_COMMAND
End If
End If
m\_hWnd = 0
m\_hWndEdit = 0
m\_hWndParent = 0
End Sub
Private Sub Draw(ByVal dwStyle As EDrawStyle, clrTopLeft As
OLE\_COLOR, clrBottomRight As OLE\_COLOR)
If m\_hWnd = 0 Then Exit Sub
If (m\_bCombo) Then
DrawCombo dwStyle, clrTopLeft, clrBottomRight
Else
DrawEdit dwStyle, clrTopLeft, clrBottomRight
End If
End Sub
Private Sub DrawEdit(ByVal dwStyle As EDrawStyle, clrTopLeft As
OLE\_COLOR, clrBottomRight As OLE\_COLOR)
Dim rcItem As RECT
Dim rcItem2 As RECT
Dim pDC As Long
Dim hWndFocus As Long
Dim tP As POINTAPI
Dim hWndP As Long
hWndP = GetParent(m\_hWnd)
GetWindowRect m\_hWnd, rcItem
tP.X = rcItem.Left: tP.Y = rcItem.Top
ScreenToClient hWndP, tP
rcItem.Left = tP.X: rcItem.Top = tP.Y
tP.X = rcItem.Right: tP.Y = rcItem.Bottom
ScreenToClient hWndP, tP
rcItem.Right = tP.X: rcItem.Bottom = tP.Y
InflateRect rcItem, 2, 2
pDC = GetDC(hWndP)
Draw3DRect pDC, rcItem, clrTopLeft, clrBottomRight
InflateRect rcItem, -1, -1
If (IsWindowEnabled(m\_hWnd) = 0) Then
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
Else
Draw3DRect pDC, rcItem, vbButtonFace, vbButtonFace
End If
If (IsWindowEnabled(m\_hWnd) = 0) Then
DeleteDC pDC
Exit Sub
End If
Select Case dwStyle
Case FC\_DRAWNORMAL
Case FC\_DRAWRAISED, FC\_DRAWPRESSED
InflateRect rcItem, -1, -1
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
InflateRect rcItem, -1, -1
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
InflateRect rcItem, -1, -1
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
End Select
DeleteDC pDC
End Sub
Private Function Draw3DRect(ByVal hdc As Long, ByRef rcItem As RECT,
ByVal oTopLeftColor As OLE\_COLOR, ByVal oBottomRightColor As
OLE\_COLOR)
Dim hPen As Long
Dim hPenOld As Long
Dim tP As POINTAPI
hPen = CreatePen(PS\_SOLID, 1, TranslateColor(oTopLeftColor))
hPenOld = SelectObject(hdc, hPen)
MoveToEx hdc, rcItem.Left, rcItem.Bottom - 1, tP
LineTo hdc, rcItem.Left, rcItem.Top
LineTo hdc, rcItem.Right - 1, rcItem.Top
SelectObject hdc, hPenOld
DeleteObject hPen
If (rcItem.Left rcItem.Right) Then
hPen = CreatePen(PS\_SOLID, 1, TranslateColor(oBottomRightColor))
hPenOld = SelectObject(hdc, hPen)
LineTo hdc, rcItem.Right - 1, rcItem.Bottom - 1
LineTo hdc, rcItem.Left, rcItem.Bottom - 1
SelectObject hdc, hPenOld
DeleteObject hPen
End If
End Function
Private Function TranslateColor(ByVal clr As OLE\_COLOR, Optional hPal
As Long = 0) As Long
If OleTranslateColor(clr, hPal, TranslateColor) Then
TranslateColor = -1
End If
End Function
Private Sub DrawCombo(ByVal dwStyle As EDrawStyle, clrTopLeft As
OLE\_COLOR, clrBottomRight As OLE\_COLOR)
Dim rcItem As RECT
Dim rcItem2 As RECT
Dim pDC As Long
Dim hWndFocus As Long
Dim tP As POINTAPI
GetClientRect m\_hWnd, rcItem
pDC = GetDC(m\_hWnd)
Draw3DRect pDC, rcItem, clrTopLeft, clrBottomRight
InflateRect rcItem, -1, -1
If (IsWindowEnabled(m\_hWnd) = 0) Then
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
Else
Draw3DRect pDC, rcItem, vbButtonFace, vbButtonFace
End If
InflateRect rcItem, -1, -1
rcItem.Left = rcItem.Right - Offset()
Draw3DRect pDC, rcItem, vbButtonFace, vbButtonFace
InflateRect rcItem, -1, -1
Draw3DRect pDC, rcItem, vbButtonFace, vbButtonFace
If (IsWindowEnabled(m\_hWnd) = 0) Then
DeleteDC pDC
Exit Sub
End If
Select Case dwStyle
Case FC\_DRAWNORMAL
rcItem.Top = rcItem.Top - 1
rcItem.Bottom = rcItem.Bottom + 1
Draw3DRect pDC, rcItem, vb3DHighlight, vb3DHighlight
rcItem.Left = rcItem.Left - 1
rcItem.Right = rcItem.Left
Draw3DRect pDC, rcItem, vbWindowBackground, &H0
Case FC\_DRAWRAISED
rcItem.Top = rcItem.Top - 1
rcItem.Bottom = rcItem.Bottom + 1
rcItem.Right = rcItem.Right + 1
Draw3DRect pDC, rcItem, vb3DHighlight, vbButtonShadow
Case FC\_DRAWPRESSED
rcItem.Left = rcItem.Left - 1
rcItem.Top = rcItem.Top - 2
OffsetRect rcItem, 1, 1
Draw3DRect pDC, rcItem, vbButtonShadow, vb3DHighlight
End Select
DeleteDC pDC
End Sub
Private Function Offset() As Long
Offset = GetSystemMetrics(SM\_CXHTHUMB)
End Function
Public Property Get DroppedDown() As Boolean
If (m\_bCombo) And (m\_hWnd 0) Then
DroppedDown = (SendMessageLong(m\_hWnd, CB\_GETDROPPEDSTATE, 0, 0)
0)
End If
End Property
Private Sub OnPaint(ByVal bFocus As Boolean, ByVal bDropped As
Boolean)
If bFocus Then
If (bDropped) Then
Draw FC\_DRAWPRESSED, vbButtonShadow, vb3DHighlight
Else
Draw FC\_DRAWRAISED, vbButtonShadow, vb3DHighlight
End If
Else
Draw FC\_DRAWNORMAL, vbButtonFace, vbButtonFace
End If
End Sub
Private Sub Class\_Terminate()
pRelease
End Sub
Private Sub OnTimer(ByVal bCheckMouse As Boolean)
Dim bOver As Boolean
Dim rcItem As RECT
Dim tP As POINTAPI
If (bCheckMouse) Then
bOver = True
GetCursorPos tP
GetWindowRect m\_hWnd, rcItem
If (PtInRect(rcItem, tP.X, tP.Y) = 0) Then
bOver = False
End If
End If
If Not (bOver) Then
KillTimer m\_hWnd, 1
m\_bMouseOver = False
End If
End Sub
Private Property Let ISubclass\_MsgResponse(ByVal RHS As
SSubTimer.EMsgResponse)
' do not remove this comment
End Property
Private Property Get ISubclass\_MsgResponse() As
SSubTimer.EMsgResponse
If (CurrentMessage = WM\_PAINT) Then
ISubclass\_MsgResponse = emrPreprocess
Else
ISubclass\_MsgResponse = emrPostProcess
End If
End Property
Private Function ISubclass\_WindowProc(ByVal hwnd As Long, ByVal iMsg
As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim bDown As Boolean
Dim bFocus As Boolean
Select Case iMsg
Case WM\_COMMAND
If (m\_hWnd = lParam) Then
Select Case wParam \ &H10000
Case CBN\_CLOSEUP
OnPaint (m\_hWnd = GetFocus() Or m\_hWndEdit = GetFocus() Or
bDown), bDown
End Select
OnTimer False
End If
Case WM\_PAINT
bDown = DroppedDown()
bFocus = (m\_hWnd = GetFocus() Or m\_hWndEdit = GetFocus() Or
bDown)
OnPaint (bFocus), bDown
If (bFocus) Then
OnTimer False
End If
Case WM\_SETFOCUS
OnPaint True, False
OnTimer False
Case WM\_KillFileFOCUS
OnPaint False, False
Case WM\_MOUSEMOVE
If Not (m\_bMouseOver) Then
bDown = DroppedDown()
If Not (m\_hWnd = GetFocus() Or m\_hWndEdit = GetFocus() Or
bDown) Then
OnPaint True, False
m\_bMouseOver = True
SetTimer m\_hWnd, 1, 10, 0
End If
End If
Case WM\_TIMER
OnTimer True
If Not (m\_bMouseOver) Then
OnPaint False, False
End If
End Select
End Function
Über „Projekt“ -> „Verweise“ musst du sicherstellen, dass die Datei
„Ssubtmr.dll“ in dein Projekt eingebunden wird. Die Datei findest du
unter anderem hier:
http://www.vbaccelerator.com/codelib/ssubtmr/ssubtmr…
(Kopiere die Datei „Ssubtmr.dll“ einfach ins Windows-System-
Verzeichnis!)
Um gewisse Controls nun flach aussehen zu lassen, musst du den
folgenden Code in ein entsprechendes Formmodul einfügen:
Private mclsFlat(2) As clsFlatControl
Private Sub Form\_Load()
Set mclsFlat(0) = New clsFlatControl
Call mclsFlat(0).Attach(Text1)
Set mclsFlat(1) = New clsFlatControl
Call mclsFlat(1).Attach(Combo1)
Set mclsFlat(2) = New clsFlatControl
Call mclsFlat(2).Attach(Combo2)
End Sub
Je nach Anzahl flacher Controls musst du den Index und die Anzahl der
Attach-Methoden anpassen.
Mit freundlichen Grüßen
Samuel
Team: Name entfernt