xpmccombo.ctl

进销存管理系统,我是个新手,请大家多多帮助哈1

VERSION 5.00
Begin VB.UserControl XPMCCombo 
   AutoRedraw      =   -1  'True
   ClientHeight    =   780
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1755
   BeginProperty Font 
      Name            =   "Marlett"
      Size            =   9.75
      Charset         =   2
      Weight          =   500
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   52
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   117
   ToolboxBitmap   =   "XPMCCombo.ctx":0000
   Begin VB.TextBox Text1 
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   45
      TabIndex        =   0
      Top             =   45
      Width           =   1290
   End
End
Attribute VB_Name = "XPMCCombo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'# Email to :[e-mail]
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Sub OleTranslateColor Lib "oleaut32.dll" (ByVal Clr As Long, ByVal hPal As Long, ByRef lpcolorref As Long)
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
                          (ByVal hdc As Long, _
                          ByVal hBrush As Long, _
                          ByVal lpDrawStateProc As Long, _
                          ByVal lParam As Long, _
                          ByVal wParam As Long, _
                          ByVal X As Long, _
                          ByVal Y As Long, _
                          ByVal cx As Long, _
                          ByVal cY As Long, _
                          ByVal fuFlags As Long) As Long
   
Private WithEvents m_Sniff As clsSubClass
Attribute m_Sniff.VB_VarHelpID = -1

Private Type TrackMouseEvent
    cbSize As Long
    dwFlags As Long
    hWnd As Long
    dwHoverTime As Long
End Type
Public Enum pbcStyle
    pbXP = 0
    pbSmart = 1
End Enum
Private Const WM_MOUSELEAVE = &H2A3
Private Const TME_LEAVE = &H2

Private Declare Function TrackMouseEvent Lib "comctl32.dll" Alias "_TrackMouseEvent" ( _
                          ByRef lpEventTrack As TrackMouseEvent) As Long

Private Const DST_COMPLEX = &H0
Private Const DST_TEXT = &H1
Private Const DST_PREFIXTEXT = &H2
Private Const DST_ICON = &H3
Private Const DST_BITMAP = &H4

Private Const DSS_NORMAL = &H0
Private Const DSS_UNION = &H10
Private Const DSS_DISABLED = &H20
Private Const DSS_MONO = &H80
Private Const DSS_RIGHT = &H8000
Private Const SM_CXHTHUMB = 10
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const m_def_Style = pbXP
Private Const m_def_FocusColor = &HC00000
Private Const m_def_ButtonFadeColor = vbWhite
Private Const m_def_Text = "XP Multi-Column Combo"
Private Const m_def_BorderColor = &HFF8080
Private Const m_def_BorderColorOver = vbHighlight
Private Const m_def_BorderColorDown = vb3DHighlight
Private Const m_def_BgColor = vbWhite
Private Const m_def_BgColorOver = vbButtonFace
Private Const m_def_BgColorDown = vbButtonFace
Private Const m_def_ButtonColor = &HFF8080   '&HD2BDB6
Private Const m_def_ButtonColorOver = &H80FF&        'vbWhite
Private Const m_def_ButtonColorDown = &HFF00&    '&H800000
Private Const m_def_ButtonSize = 20
Private Const m_def_MinListHeight = 2000
Private Const m_def_BoundColumns = "0"
Private m_ColumnHeaders As Boolean

Private m_ButtonSize As Long
Private m_BorderColor As OLE_COLOR
Private m_BorderColorOver As OLE_COLOR
Private m_BorderColorDown As OLE_COLOR
Private m_BgColor As OLE_COLOR
Private m_BgColorOver As OLE_COLOR
Private m_BgColorDown As OLE_COLOR
Private m_ButtonColor As OLE_COLOR
Private m_ButtonColorOver As OLE_COLOR
Private m_ButtonColorDown As OLE_COLOR
Private m_ButtonCount As Long
Private m_Text As String
Private m_oStartColor As OLE_COLOR
Private m_oEndColor As OLE_COLOR

Dim m_ButtonFadeColor As OLE_COLOR
Dim m_FocusColor As OLE_COLOR
Dim m_Style As pbcStyle

Private UsrRect As RECT
Private ButtRect As RECT
Private Ret As Long
Private CrlRet As Long
Private IsMOver As Boolean
Private IsMDown As Boolean
Private IsButtDown As Boolean
Private IsCrlOver As Boolean
Private Clicked As Boolean
Private InFocus As Boolean
Private m_DropListEnabled As Boolean

Private IniLat As Long
Private IniLung As Long
Private m_NrColVisible As Integer ' Numbers of visible columns
Private m_ListHeight As Long
Private m_ListWidth As String 'example : 100;500;200 The first value will be ignored and she be considered the width of control
Private m_ColumnHeads As Boolean
Private lTotalWid As Long
Private NumBounds As Integer
Private m_BoundColumns As String


Event Click()
Event MouseOver()
Event MouseOut()
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event Change()
Event DropList()

Public Sub DrawControl()

  Dim Brsh As Long, Clr As Long
  Dim lx As Long, ty As Long
  Dim rx As Long, by As Long
  Dim dR(1 To 3) As Double
  Dim rct As RECT
  Dim lHeight As Long, lWidth As Long
  Dim lYStep As Long
  Dim lY As Long
  Dim bRGB(1 To 3) As Integer
  Dim hBr As Long
  Dim oColor As Long
  Dim lcolor As Long
  Dim m_RGBStartCol1(1 To 3) As Long

    lx = ScaleLeft: ty = ScaleTop
    rx = ScaleWidth: by = ScaleHeight
    
    Cls
    If m_Style = pbSmart Then
        lHeight = (UserControl.Height + 30) \ Screen.TwipsPerPixelY
        rct.Right = UserControl.Width \ Screen.TwipsPerPixelY
        rct.Bottom = lHeight
        FadeColor m_oStartColor, rct, m_oEndColor
      Else
        'control Backgound
        Call SetRect(UsrRect, 0, 0, rx - m_ButtonSize, by)
        Call OleTranslateColor(m_BgColor, ByVal 0&, Clr)
        Brsh = CreateSolidBrush(Clr)
        Call FillRect(hdc, UsrRect, Brsh)
        DeleteObject Brsh
    End If
    
    'Button
    Call SetRect(ButtRect, rx - m_ButtonSize, 0, rx, by)
    If m_Style = pbXP Then
   
        If IsMDown Then
            Call OleTranslateColor(m_ButtonColorDown, ByVal 0&, Clr)
          ElseIf IsMOver Then
            Call OleTranslateColor(m_ButtonColorOver, ByVal 0&, Clr)
          Else
            Call OleTranslateColor(m_ButtonColor, ByVal 0&, Clr)
        End If
        Brsh = CreateSolidBrush(Clr)
        Call FillRect(hdc, ButtRect, Brsh)
        DeleteObject Brsh
      Else
        SetRect rct, rx - m_ButtonSize, 0, rx, by
        If IsMDown Then
            Call FadeColor(m_ButtonColorDown, rct, m_ButtonFadeColor)
          ElseIf IsMOver Then
            Call FadeColor(m_ButtonColorOver, rct, m_ButtonFadeColor)
        End If
        SetRectEmpty rct
    End If
    'Borders

    If IsMDown Then
        Call OleTranslateColor(m_BorderColorDown, ByVal 0&, Clr)
    ElseIf IsMOver Then
        Call OleTranslateColor(m_BorderColorOver, ByVal 0&, Clr)
    ElseIf InFocus Then
        Call OleTranslateColor(m_FocusColor, ByVal 0&, Clr)
    Else
        Call OleTranslateColor(m_BorderColor, ByVal 0&, Clr)
    End If
    
    Brsh = CreateSolidBrush(Clr)
    Call FrameRect(hdc, ButtRect, Brsh)
    DeleteObject Brsh

    Call SetRect(UsrRect, 0, 0, rx, by)
    Brsh = CreateSolidBrush(Clr)
    Call FrameRect(hdc, UsrRect, Brsh)
    DeleteObject Brsh
    Call DrawText(hdc, "6", 1&, ButtRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
    Call SetRectEmpty(UsrRect)
 '# Whether Hide Listview's column Header?
 'Note : You can't put those rungs in other Routine either showpopup or load_rs_to_lsw.
 'Because DrawControl is Executed before them.
 If m_ColumnHeaders = False Then
        HideColumnHeaders = True
 Else
        HideColumnHeaders = False
 End If
End Sub

Private Sub Text1_Change()

    m_Text = Text1.text
    RaiseEvent Change

End Sub

Private Sub Text1_GotFocus()

    InFocus = True
    Call DrawControl

End Sub

Private Sub Text1_LostFocus()

    InFocus = False
    Call DrawControl

End Sub

Private Sub UserControl_Initialize()

    Set m_Sniff = New clsSubClass
    m_Sniff.SubClassHwnd UserControl.hWnd, True

End Sub

Private Sub UserControl_Terminate()

    m_Sniff.SubClassHwnd UserControl.hWnd, False

End Sub

Private Sub UserControl_LostFocus()

    InFocus = False

End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    RaiseEvent MouseMove(Button, Shift, X, Y)
    If Not Clicked Then
        UserControl_MouseOut
    End If

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If m_DropListEnabled = True Then
    
    IsButtDown = False
    Call DrawControl
 
    If (X >= ButtRect.Left And X <= ButtRect.Right) And (Y >= ButtRect.Top And Y <= ButtRect.Bottom) Then
        Call ShowPopup(1)
    
      Else
        Call ShowPopup(0)
        Unload frmpopup
   
     End If
     
End If
End Sub

Private Sub UserControl_Resize()

    On Error Resume Next
      Text1.Move 2, (ScaleHeight / 2) - (Text1.Height / 2), ScaleWidth - 3 - m_def_ButtonSize
      Call DrawControl

End Sub

Function UserControl_MouseOut()

  Dim tTrackMouseEvent As TrackMouseEvent

    If Not IsMOver Then
     
        With tTrackMouseEvent
            .cbSize = Len(tTrackMouseEvent)
            .dwFlags = TME_LEAVE
            .hWnd = UserControl.hWnd
        End With
        RaiseEvent MouseOver
        TrackMouseEvent tTrackMouseEvent
     
        IsMOver = True
        
    End If
    Call DrawControl

End Function

Private Sub m_Sniff_NewMessage( _
                               ByVal hWnd As Long, _
                               uMsg As Long, _
                               wParam As Long, _
                               lParam As Long, _
                               Cancel As Boolean)
     
    Select Case uMsg
      Case WM_MOUSELEAVE
        IsMOver = False
        RaiseEvent MouseOut
        Call DrawControl
    End Select

End Sub





'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BorderColor() As OLE_COLOR

    BorderColor = m_BorderColor