tracbar32.cls

本滚动条是在VB原有控件上的改进

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CTracBar32"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114

Dim TracBarWnd As Long
Private Const WM_COMMAND = &H111
Private Const WM_COMMNOTIFY = &H44
 
Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
Const ICC_BAR_CLASSES = &H20
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" _
 (iccex As tagInitCommonControlsEx) As Boolean
Private Type RECT
        left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Const WHITE_BRUSH = 0
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

Private Type WNDCLASS
    Style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra2 As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
End Type
Private Type WNDCLASSEX
    cbSize As Long
    Style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
    hIconSm As Long
End Type

Private Declare Function RegisterClass Lib "user32" (Class As WNDCLASS) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 
 

Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
'Private Const TB_ADDSTRINGA = (WM_USER + 28)
Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long
'Public Const DI_MASK = 1 'VBC NR
'Public Const DI_IMAGE = 2 'VBC NR
Private Const DI_NORMAL = 3
'Public Const DI_COMPAT = 4 'VBC NR
 Const HWND_TOPMOST = -1
Const SW_HIDE = 0
Const SW_SHOWNORMAL = 1
 
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOREDRAW = &H8
Const SWP_SHOWWINDOW = &H40

 

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
' Window Style constants
Const WS_VISIBLE = &H10000000
Const WS_CHILD = &H40000000
Const WS_POPUP = &H80000000

' CreateWindow constants
Const CW_USEDEFAULT = &H80000000
 
Private Declare Function SendStringMessage Lib "user32" Alias "SendMessageA" _
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" _
 (ByVal dwExStyle As Long, _
 ByVal lpClassName As String, ByVal lpWindowName As String, _
 ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
 ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, _
 ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
 (ByVal hwnd 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 ShowWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function MoveWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
 ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" _
 (ByVal hwnd As Long) As Long

 
 

 
Private Const WM_PAINT = &HF
 
Private Const WM_USER = &H400
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_STYLE = (-16)
 
 
 
Private Const WS_BORDER = &H800000
Private Const WM_DRAWITEM = &H2B
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WM_SETREDRAW = &HB
'//Common Control Constants
Private Const CCS_TOP = &H1
Private Const CCS_NOMOVEY = &H2
Private Const CCS_BOTTOM = &H3
Private Const CCS_NORESIZE = &H4
Private Const CCS_NOPARENTALIGN = &H8
'Private Const CCS_ADJUSTABLE          &H00020L
Private Const CCS_NODIVIDER = &H40
'Private Const CCS_VERT                &H00080L
'Private Const CCS_LEFT                (CCS_VERT | CCS_TOP)
'Private Const CCS_RIGHT               (CCS_VERT | CCS_BOTTOM)
'Private Const CCS_NOMOVEX             (CCS_VERT | CCS_NOMOVEY)
 
 
Private Declare Function SetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long

 
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
  
 


'//
'Private Declare Function CreateToolbarEx Lib "COMCTL32" (ByVal hWnd As Long, ByVal ws As Long, ByVal wID As Long, ByVal nBitmaps As Long, ByVal hBMInst As Long, ByVal wBMID As Long, ByRef lpButtons As TBBUTTON, ByVal iNumButtons As Long, ByVal dxButton As Long, ByVal dyButton As Long, ByVal dxBitmap As Long, ByVal dyBitmap As Long, ByVal uStructSize As Long) As Long

Private Const PROGRESS_CLASSA = "msctls_progress32"
 

Private Const TRACKBAR_CLASSA = "msctls_trackbar32"
 
Private Const TBS_AUTOTICKS = &H1
Private Const TBS_VERT = &H2
Private Const TBS_HORZ = &H0
Private Const TBS_TOP = &H4
Private Const TBS_BOTTOM = &H0
Private Const TBS_LEFT = &H4
Private Const TBS_RIGHT = &H0
Private Const TBS_BOTH = &H8
Private Const TBS_NOTICKS = &H10
Private Const TBS_ENABLESELRANGE = &H20
Private Const TBS_FIXEDLENGTH = &H40
Private Const TBS_NOTHUMB = &H80
Private Const TBS_TOOLTIPS = &H100
'"TB_THUMPOSITION"
Private Const TBM_GETPOS = (WM_USER)
Private Const TBM_GETRANGEMIN = (WM_USER + 1)
Private Const TBM_GETRANGEMAX = (WM_USER + 2)
Private Const TBM_GETTIC = (WM_USER + 3)
Private Const TBM_SETTIC = (WM_USER + 4)
Private Const TBM_SETPOS = (WM_USER + 5)
Private Const TBM_SETRANGE = (WM_USER + 6)
Private Const TBM_SETRANGEMIN = (WM_USER + 7)
Private Const TBM_SETRANGEMAX = (WM_USER + 8)
Private Const TBM_CLEARTICS = (WM_USER + 9)
Private Const TBM_SETSEL = (WM_USER + 10)
Private Const TBM_SETSELSTART = (WM_USER + 11)
Private Const TBM_SETSELEND = (WM_USER + 12)
Private Const TBM_GETPTICS = (WM_USER + 14)
Private Const TBM_GETTICPOS = (WM_USER + 15)
Private Const TBM_GETNUMTICS = (WM_USER + 16)
Private Const TBM_GETSELSTART = (WM_USER + 17)
Private Const TBM_GETSELEND = (WM_USER + 18)
Private Const TBM_CLEARSEL = (WM_USER + 19)
Private Const TBM_SETTICFREQ = (WM_USER + 20)
Private Const TBM_SETPAGESIZE = (WM_USER + 21)
Private Const TBM_GETPAGESIZE = (WM_USER + 22)
Private Const TBM_SETLINESIZE = (WM_USER + 23)
Private Const TBM_GETLINESIZE = (WM_USER + 24)
Private Const TBM_GETTHUMBRECT = (WM_USER + 25)
Private Const TBM_GETCHANNELRECT = (WM_USER + 26)
Private Const TBM_SETTHUMBLENGTH = (WM_USER + 27)
Private Const TBM_GETTHUMBLENGTH = (WM_USER + 28)
Private Const TBM_SETTOOLTIPS = (WM_USER + 29)
Private Const TBM_GETTOOLTIPS = (WM_USER + 30)
Private Const TBM_SETTIPSIDE = (WM_USER + 31)
'// TrackBar Tip Side flags
Private Const TBTS_TOP = 0
Private Const TBTS_LEFT = 1
Private Const TBTS_BOTTOM = 2
Private Const TBTS_RIGHT = 3

Private Const TBM_SETBUDDY = (WM_USER + 32) ' // wparam = BOOL fLeft; (or right)
Private Const TBM_GETBUDDY = (WM_USER + 33) ' // wparam = BOOL fLeft; (or right)


Private Const TB_LINEUP = 0
Private Const TB_LINEDOWN = 1
Private Const TB_PAGEUP = 2
Private Const TB_PAGEDOWN = 3
Private Const TB_THUMBPOSITION = 4
Private Const TB_THUMBTRACK = 5
Private Const TB_TOP = 6
Private Const TB_BOTTOM = 7
Private Const TB_ENDTRACK = 8


'// custom draw item specs
Private Const TBCD_TICS = &H1
Private Const TBCD_THUMB = &H2
Private Const TBCD_CHANNEL = &H3
 
Dim mlngStyle As Long
Dim mlngTop As Long
Dim mlngLeft As Long
Dim mlngWidth As Long
Dim mlngHeight As Long
Dim mfrmParent As Object
Dim mstrFormat As String
Dim mvarMin As Variant
Dim mvarMax As Variant

Public Function GetTracBarHwnd()
GetTracBarHwnd = TracBarWnd
End Function

 
Private Sub Class_Initialize()
 Dim iccex As tagInitCommonControlsEx
    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_BAR_CLASSES
    End With
    Call InitCommonControlsEx(iccex)
 
   TracBarWnd = 0
End Sub



Public Function Create( _
 Optional left As Variant, _
 Optional Top As Variant, _
 Optional Width As Variant, _
 Optional Height As Variant, Optional Vertical As Boolean) _
  As Boolean
Dim VertLong As Long
VertLong = 0
If Parent Is Nothing Then
      Create = False
      Exit Function
End If
 If Vertical = True Then VertLong = TBS_VERT
    If IsMissing(left) Then left = 0
    If IsMissing(Top) Then Top = 0
    If IsMissing(Width) Then Width = Parent.Width \ Screen.TwipsPerPixelX
    If IsMissing(Height) Then Height = 25
 
 
 
    TracBarWnd = CreateWindowEX(0, "msctls_trackbar32", "", _
          WS_CHILD Or WS_VISIBLE Or TBS_HORZ Or VertLong Or TBTS_LEFT Or TBS_RIGHT, 0, 0, 0, 0, _
     Parent.hwnd, 0&, App.hInstance, 0&)

  Dim X As Integer
 
  Dim Range(1) As Integer
  Range(0) = 0
  Range(1) = 100
    Create = (TracBarWnd <> 0)
     Call SendMessage(TracBarWnd, TBM_SETTICFREQ, 10, 0)
   
  ' (Minimum range = low word, Maximum range = high word).
 
  
     
    Call SendMessage(TracBarWnd, TBM_SETRANGE, True, ByVal (&H100 * &H10000))
  
 ' // Set the initial range.
   
    Call SendMessage(TracBarWnd, TBM_SETRANGEMIN, True, ByVal 1)  'CLng(1))
     Call SendMessage(TracBarWnd, TBM_SETRANGEMAX, True, ByVal 100)  'CLng(100))
 
'  {
      Call SetParent(TracBarWnd, Parent.hwnd)
 
 
      Call MoveWindow(TracBarWnd, CLng(left), CLng(Top), CLng(Width), CLng(Height), True)
      Call ShowWindow(TracBarWnd, SW_SHOWNORMAL)
   
End Function
Public Property Get Parent() As Object
    Set Parent = mfrmParent
End Property

Public Property Set Parent(frm As Object)
    Set mfrmParent = frm
End Property


Private Sub Class_Terminate()
 Exit Sub
    If TracBarWnd <> 0 Then
        Call DestroyWindow(TracBarWnd)
    End If
End Sub

Public Sub DestroyTracBar()
On Error Resume Next
 
If TracBarWnd <> 0 Then

        Call DestroyWindow(TracBarWnd)
    End If
End Sub

Public Sub ClearTracBar()
DoEvents
Call SendMessage(TracBarWnd, TBM_SETPOS, 0, 0)
DoEvents
End Sub

Public Sub SetTracBarPos(TracPos As Integer)
DoEvents
 Call SendMessage(TracBarWnd, TBM_SETPOS, True, ByVal CLng(TracPos))
 Call UpdateWindow(TracBarWnd)
 
DoEvents
End Sub

 

Public Function GetTracBarPos()
DoEvents
'Dim x As Integer
 GetTracBarPos = SendMessage(TracBarWnd, TBM_GETPOS, 0, 0)
 
 
DoEvents
End Function