frmtracbar.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "滚动条演示"
   ClientHeight    =   4410
   ClientLeft      =   3780
   ClientTop       =   2970
   ClientWidth     =   5655
   LinkTopic       =   "Form1"
   ScaleHeight     =   4410
   ScaleWidth      =   5655
   Begin VB.TextBox Text3 
      Height          =   285
      Left            =   3780
      TabIndex        =   3
      Text            =   "1"
      Top             =   2205
      Width           =   810
   End
   Begin VB.TextBox Text2 
      Height          =   285
      Left            =   1050
      TabIndex        =   2
      Text            =   "1"
      Top             =   3615
      Width           =   810
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   4200
      TabIndex        =   1
      Text            =   "1"
      Top             =   1170
      Width           =   810
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Set Slider position to ---->"
      Height          =   405
      Left            =   1515
      TabIndex        =   0
      Top             =   2130
      Width           =   2070
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim SliderH As New CTracBar32
Dim SliderV As New CTracBar32
Private Const WM_PAINT = &HF
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
 
Private Sub Command1_Click()
SliderH.SetTracBarPos CInt(Text3)
SliderV.SetTracBarPos CInt(Text3)
Text1 = SliderH.GetTracBarPos
Text2 = SliderV.GetTracBarPos
End Sub

Private Sub Form_Load()
'Written by Ramon Guerrero
'[e-mail]
'[e-mail]
'[e-mail]
 
With SliderH
Set .Parent = Me
    .Create 70, 70, 200, 35
End With

With SliderV
Set .Parent = Me
    .Create 20, 70, 35, 200, True

End With

'Subclass form to receive messages
SubClass Me.hwnd
Me.Show
Text3.SetFocus

End Sub

Public Sub ProcMsg(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, result As Long)
   
On Error Resume Next
 
Select Case uMsg
 
Case WM_HSCROLL
'the window being scrolled is the slider we created then
'Get the position
If lParam = SliderH.GetTracBarHwnd Then
Text1 = SliderH.GetTracBarPos
End If

Case WM_VSCROLL
If lParam = SliderV.GetTracBarHwnd Then
Text2 = SliderV.GetTracBarPos
End If

End Select
End Sub

Private Sub SubClass(hwnd As Long)
On Error Resume Next
NextProcs = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Private Sub UnSubClass()
Dim hWndCur As Long
hWndCur = Me.hwnd
If NextProcs Then
SetWindowLong hWndCur, GWL_WNDPROC, NextProcs
NextProcs = 0
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
UnSubClass
End Sub

 
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii < 49 Or KeyAscii > 57 Then
KeyAscii = 0
Exit Sub
End If
End Sub