|
|
Slider BackColor
|
Hier wird die Hintergrundfarbe der Steuerelemente Slider, ProgressBar und StatusBar verändert.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.
Projekt - Download |
 Quell-Code frmMain
|
'Erstellen Sie folgende Steuerelemente:
'Form Form1, ProgressBar ProgressBar1, Slider Slider1,
'StatusBar StBar
Option Explicit
Private Sub Form_Load()
Me.BackColor = "11655422"
SBBackColor(StBar) = Me.BackColor
PBBackColor(ProgressBar1) = Me.BackColor
PBBarColor(ProgressBar1) = vbGreen
'-- Keine Systemfarbe übergeben !!!
CreateSliderBrush RGB(lR(Me.BackColor), _
lG(Me.BackColor), lB(Me.BackColor)), False
hSliderHwnd = Slider1.hwnd
Call SubClass(Me.hwnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call UnSubClass(Me.hwnd)
End Sub
Private Sub Timer1_Timer()
If ProgressBar1.Value > 99 Then ProgressBar1.Value = 0
ProgressBar1.Value = ProgressBar1.Value + 1
End Sub
|
 Quell-Code ModSliderBackcolor.bas
|
Option Explicit
Public defWindowProc As Long
Public hSliderHwnd As Long
Private hSliderBGBrush As Long
Private Const WM_USER = &H400&
Private Const TBM_GETTOOLTIPS = (WM_USER + 30)
Private Const TTM_ACTIVATE = (WM_USER + 1)
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_GETMINMAXINFO As Long = &H24
Private Const WM_TIMECHANGE = &H1E
Private Const WM_DESTROY = &H2
Private Const WM_CTLCOLORSTATIC = &H138
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Public Sub CreateSliderBrush(clrref As Long, bReset As Boolean)
If (hSliderBGBrush <> 0) Or (bReset = True) Then
Call DeleteSliderBrush
End If
If hSliderBGBrush = 0 Then
hSliderBGBrush = CreateSolidBrush(clrref)
End If
End Sub
Public Sub DeleteSliderBrush()
If (hSliderBGBrush <> 0) Then
DeleteObject hSliderBGBrush
hSliderBGBrush = 0
End If
End Sub
Public Sub SubClass(hwnd As Long)
On Error Resume Next
defWindowProc = SetWindowLong(hwnd, _
GWL_WNDPROC, _
AddressOf WindowProc)
End Sub
Public Sub UnSubClass(hwnd As Long)
If defWindowProc Then
SetWindowLong hwnd, GWL_WNDPROC, defWindowProc
defWindowProc = 0
End If
End Sub
Public Function WindowProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Select Case hwnd
Case Form1.hwnd
Select Case uMsg
Case WM_CTLCOLORSTATIC
If (lParam = hSliderHwnd) And (hSliderBGBrush <> 0) Then
WindowProc = hSliderBGBrush
Exit Function
Else
WindowProc = CallWindowProc(defWindowProc, _
hwnd, _
uMsg, _
wParam, _
lParam)
Exit Function
End If
Case WM_DESTROY
If (hSliderBGBrush <> 0) Then
Call DeleteSliderBrush
hSliderBGBrush = 0
End If
Call UnSubClass(hwnd)
Case Else
WindowProc = CallWindowProc(defWindowProc, _
hwnd, _
uMsg, _
wParam, _
lParam)
Exit Function
End Select
Case Else
WindowProc = CallWindowProc(defWindowProc, _
hwnd, _
uMsg, _
wParam, _
lParam)
End Select
End Function
|
Quell-Code modSBBackColor.bas
|
Option Explicit
'StatusBar
Private Const CCM_FIRST = &H2000
Private Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
Private Const SB_SETBKCOLOR = CCM_SETBKCOLOR
'ProgressBar
Public Const PBM_SETBKCOLOR = CCM_SETBKCOLOR
Public Const WM_USER = &H400
Public Const PBM_SETBARCOLOR = (WM_USER + 9)
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function OleTranslateColor Lib "olepro32" _
(ByVal clr As OLE_COLOR, ByVal hpal As Long, _
pcolorref As Long) As Long
Public Property Let SBBackColor(ByRef StatusBar As StatusBar, _
ByVal New_Value As OLE_COLOR)
OleTranslateColor New_Value, 0, New_Value
SendMessage StatusBar.hwnd, SB_SETBKCOLOR, 0, ByVal New_Value
End Property
Public Property Let PBBackColor(ByRef ProgBar As ProgressBar, _
ByVal nBackColor As OLE_COLOR)
OleTranslateColor nBackColor, 0, nBackColor
SendMessage ProgBar.hwnd, PBM_SETBKCOLOR, 0, ByVal nBackColor
End Property
Public Property Let PBBarColor(ByRef ProgBar As ProgressBar, _
ByVal nBarColor As OLE_COLOR)
' neue Vordergrundfarbe
OleTranslateColor nBarColor, 0, nBarColor
SendMessage ProgBar.hwnd, PBM_SETBARCOLOR, 0&, nBarColor
End Property
|
Quell-Code ModRGB.bas
|
Option Explicit
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal _
ByteLen As Long)
Private Type OLECOLOR
RedOrSys As Byte
Green As Byte
Blue As Byte
Type As Byte
End Type
Function WinColor(VBColor As Long) As Long
Dim SysClr As OLECOLOR
CopyMemory SysClr, VBColor, Len(SysClr)
If SysClr.Type = &H80 Then 'Es ist eine Systemfarbe
WinColor = GetSysColor(SysClr.RedOrSys)
Else 'Es ist keine Systemfarbe
WinColor = VBColor
End If
End Function
Public Function lR(ByVal Color As Long) As Byte
CopyMemory lR, WinColor(Color), 1
End Function
Public Function lG(ByVal Color As Long) As Byte
CopyMemory lG, ByVal VarPtr(WinColor(Color)) + 1, 1
End Function
Public Function lB(ByVal Color As Long) As Byte
CopyMemory lB, ByVal VarPtr(WinColor(Color)) + 2, 1
End Function
|
| |