cwinxpcengine.cls

进销存管理系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cWinXPCEngine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

' **********************************************************************
'  描  述：巨牛的XP风格控件引擎，非常厉害
'  Play78.com : 网站导航，源码之家，绝对开源
'  海阔天空收集整理
'  主站地址：http://www.play78.com/
'  源码下载地址：http://www.play78.com/blog
'  图片下在地址：http://www.play78.com/pic
'  QQ：13355575
'  e-mail:[e-mail]
'  编写日期：2005年08月24日
' **********************************************************************


'==========================================================================================================
'==========================================================================================================
'
       '                   <<<<<<<<<<<<<<<     WINXPC ENGINE    >>>>>>>>>>>>>>>
'                                              VERSION 1.0.0
'
'                   AUTHOR:       .... MARIO ALBERTO FLORES GONZALEZ....
'
'                                       CD.JUAREZ CHIHUAHUA MEXICO
'
'                                      [e-mail]
'
'
'
'          ALL CODE WAS WRITTEN FROM SCRATCH ..WITH EXCEPTION OF STEVE MCMAHON SUBCLASS LIBRARY
'          THAT WAS UNMODIFIED..([e-mail]), I ALSO USED SOME CODE IDEAS FROM THE
'          CHAMELEON BUTTON (gonchuki@ yahoo.es) TO MAKE THE CBUTTONXP CLASS !!! NOT COPIED !!!
'          RECODED-FIXED SOME MEMORY LEAKS ANG CHANGED LOGIC TO DRAW BUTTON SOME OF THE ROUTINES
'          FOR XP COLORS WHERE USED..AND SLIGHTLY MODIFIED.
'          USED APIVIEWER 2003 TO GET THE API DECLARATIONS AND CONST VALUES
'          ALSO A LOT OF VISITS TO THE MSDN LIBRARY...
'
'                 ANY OTHER SIMILAR CODE ON OTHER PEOPLE CODE OR LIBRARY ARE COINCIDENCE
'
'                      <<<<  YOU CAN'T USE THIS CODE FOR COMMERCIAL PURPOUSES   >>>>
'
'
'          NOTE:
'                      This control is NOT intended to be compiled into your application,
'                      it is intended to be compiled as a separate OCX and packaged with your app.
'
'                   This notice may not be removed or altered from any source distribution.
'
'==========================================================================================================
'==========================================================================================================
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Option Explicit

Implements ISubclass

Private m_bSubclass        As Boolean
Private m_hWnd             As Long


Private m_ActiveScaleMode As ScaleModeConstants
Private m_SchemeColor As CWindowColors
Private m_IdeSubClass As Boolean
Private m_CBug As Boolean
 
'//-----------------------------------------------

Private m_Adodc       As Boolean
Private m_Button      As Boolean
Private m_CheckBox    As Boolean
Private m_Combo       As Boolean '+ DriveList
Private m_FileListBox As Boolean '+ DirListBox
Private m_Frame       As Boolean
Private m_ICombo      As Boolean
Private m_ListBox     As Boolean
Private m_ListView    As Boolean           '//---Supported Subclassed Controls
Private m_MsgBox      As Boolean
Private m_CommonD     As Boolean
Private m_Option      As Boolean
Private m_Picture     As Boolean
Private m_ProgressBar As Boolean
Private m_Slider      As Boolean
Private m_StatusBar   As Boolean
Private m_TabStrip    As Boolean
Private m_Text        As Boolean
Private m_SysListView32 As Boolean
Private m_Static      As Boolean
'//-----------------------------------------------


Private MyClassObject As Object         '//--- Object Sender  (Contains Subclassed Control Information) VB 6



Private ButtonState As ControlState
Private MovementFlag As ControlState



'//-----------------------------------------------
    Private isFocused As Boolean                   '//---  Controls General Properties
    Private bOver As Boolean
    Private bDown As Boolean
'//-----------------------------------------------

'//-----------------------------------------------
    Private m_CurrentButton As Integer          '//---  Adoedc Control Variables
'//-----------------------------------------------

'//-----------------------------------------------
    Private m_CurrentItem As Long
    Private m_FlagItem As Long                     '//---  ListView Control Variables
    Private m_LVIRect As RECT ' ListViewItemRect
'//-----------------------------------------------

'//-----------------------------------------------
    Private m_TSINumber  As Integer  'TabStripItemNumber
    Private m_TSILNumber As Integer  'TabStripItemLastNumber
    Private m_TSCTab     As Boolean
'//-----------------------------------------------
    
'------------------------------------
Private DestDC      As Long
Private MaskDC      As Long
Private MemDC       As Long
Private OrigDC      As Long
Private MaskPic     As Long              'Temporary DC
Private MemPic      As Long
Private TempPic     As Long
Private OrigPic     As Long
Private TempDC      As Long
'-------------------------------------

Private origBrush As Long
Private TempBrush As Long
Private origColor As Long 'BackColor
Dim m_ItemRect As RECT
Dim m_Width    As Long
Dim m_Height   As Long


Private m_PreDraw As Boolean
Private iHw As Integer, iLW As Integer


'==========================================================================================
'==========================================================================================
'                        THIS WILL SUBCLASS MESSAGESBOXES & INPUTBOXES
                      

Public Sub BeforeAttachMessageBox(ByVal lhWnd As Long)
 If lhWnd = 0 Then Exit Sub
 
 pRelease
    m_MsgBox = True      ' PRE-DEFINE "m_MsgBox" VALUE BEFORE ENGINE IS STARTED
 pAttach lhWnd
 
End Sub

'==========================================================================================
'==========================================================================================
'                        THIS WILL SUBCLASS COMMONDIALOG
        
Public Sub BeforeAttachCommonDialog(ByVal lhWnd As Long)
 If lhWnd = 0 Then Exit Sub
 
 pRelease
    m_CommonD = True
    pAttach lhWnd
End Sub

'==========================================================================================
'==========================================================================================
'                        THIS WILL SUBCLASS MESSAGESBOXES & INPUTBOXES

Public Sub AfterAttachMessageBox(ByVal lhWnd As Long)

 If lhWnd = 0 Then Exit Sub
 
 pRelease

     Select Case ThisWindowClassName(lhWnd)
      
       Case "Edit"
         
         If InStr(ThisWindowClassName(GetParent(lhWnd)), "ComboBox") = 0 Then
            MakeWindowFlat lhWnd
            m_Text = True
         End If            '//---MessagesBoxes and InputBoxes only have this kind of controls
       
       Case "Button"
        If Left$(GetObjectText(lhWnd), InStr(GetObjectText(lhWnd), vbNullChar) - 1) <> "Open as &read-only" Then
          m_Button = True
        Else
          m_CheckBox = True
        End If
        
       Case "ComboBox"
          m_Combo = True
      
       Case Else:
            Exit Sub '(Nothing) UnSupported Control
          
     End Select
 
 pAttach lhWnd


       
End Sub



'==========================================================================================
'==========================================================================================
'                         THIS WILL SUBCLASS ALL THE SUPPORTED CONTROLS

Public Sub Attach(ByVal ObjThis As Object)
Dim lhWnd As Long
    
    
    pRelease '//--- First UnSubclass All Controls.. ;)
   
    On Error Resume Next
   
    If TypeName(ObjThis) = "Adodc" Then
       lhWnd = ChildWindowFromPoint(ObjThis.Parent.hwnd, ObjThis.Left, ObjThis.Top)
    Else
       lhWnd = ObjThis.hwnd '//---Short Reference
    End If
       
    If Err.Number <> 0 Then Exit Sub  'Something happen :(
  

    Set MyClassObject = ObjThis '//--- Control's Properties Container
   

    
    
    '//======================================================================================
    '                             Select the Type Of Control to Subclass
    '//======================================================================================
    

    
''
    
    Select Case ThisWindowClassName(lhWnd)
   
        Case "AdodcWndClass"
             m_Adodc = True
             m_CurrentButton = -1
             MakeWindowFlat lhWnd
        
        Case "ThunderCheckBox", "ThunderRT6CheckBox"
           ' If MyClassObject.Style = 1 Then Exit Sub              '//--- Only Standard Style CheckBox (No Graphical)
            m_CheckBox = True

        Case "ThunderComboBox", "ThunderRT6ComboBox", "ThunderDriveListBox", "ThunderRT6DriveListBox"
            m_Combo = True

        Case "ThunderCommandButton", "ThunderRT6CommandButton", "Button"
           m_Button = True

        Case "ThunderFrame", "ThunderRT6Frame"
            If MyClassObject.BorderStyle = 0 Then Exit Sub        '//--- If Frame <> Fixed Single Then Don't Sublcass ;)
             m_Frame = True

        Case "ComboBox", "ImageCombo20WndClass"
            lhWnd = FindWindowEx(lhWnd, 0&, "ComboBox", ByVal 0&) '//--- Find Combo Inside control
            m_ICombo = True
  
        Case "ListView20WndClass"
            If m_IdeSubClass = True Then Exit Sub
            MakeWindowFlat lhWnd
            lhWnd = FindWindowEx(lhWnd, 0, "msvb_lib_header", 0&) '//--- Find Header Inside control
            m_ListView = True

        Case "ThunderOptionButton", "ThunderRT6OptionButton"
           'If MyClassObject.Style = 1 Then Exit Sub              '//--- Only Standard Style OptionButton (No Graphical)
            m_Option = True

        Case "ProgressBar20WndClass"
             MakeWindowFlat lhWnd
             SendMessageLong lhWnd, CCM_SETBKCOLOR, 0&, ByVal &HFFFFFF  '//--Give The XP Look BackGroundColor = White
             SendMessageLong lhWnd, PBM_SETBARCOLOR, 0&, ByVal &HFFFFFF             '//--Give The XP Look BackGroundColor = White
             m_ProgressBar = True

        Case "Slider20WndClass"
            m_Slider = True

        Case "StatusBar20WndClass"
            m_StatusBar = True

        Case "ThunderListBox", "ThunderRT6ListBox", "ThunderDirListBox", "ThunderRT6DirListBox"
            MakeWindowFlat lhWnd
            m_ListBox = True
        
        Case "ThunderFileListBox", "ThunderRT6FileListBox"
             MakeWindowFlat lhWnd
             m_FileListBox = True
        
        Case "TabStrip20WndClass", "TabStripWndClass"
            Dim TSOWNERDRAW As Long
            
            TSOWNERDRAW = GetWindowLong(lhWnd, GWL_STYLE)
            Call SetWindowLong(lhWnd, GWL_STYLE, TSOWNERDRAW Or TCS_OWNERDRAWFIXED)
            m_TabStrip = True
        
         Case "ThunderTextBox", "ThunderRT6TextBox", "Edit"
             '//--- Set TextBox Appareance= FLAT Style
                    
                                     
                    MakeWindowFlat lhWnd
                    m_Text = True
        Case "ThunderPictureBox", "ThunderPictureBoxDC", "ThunderRT6PictureBoxDC"
             '//--- Set PictureBox Appareance= FLAT Style
                    MakeWindowFlat lhWnd
                    m_Picture = True
        Case Else:
        
            Exit Sub '(Nothing) UnSupported Control <---Actually This Line is never Fired.
            
   
   
    End Select


   pAttach lhWnd '//--- Finally Subclass
   
End Sub

Private Sub pAttach(ByRef hWndA As Long)
  
  m_hWnd = hWndA '//-- Reference Used in All Class Subs & Functions Point's Control hWnd
  
  SubclassMessage m_hWnd, True '//--- Subclass
      
  m_bSubclass = True '//--- Success Control is Subclassed !!  ;)
   
End Sub

Private Sub pRelease()
   
   If m_bSubclass = False Then Exit Sub '//--- No Subclass before...Don't Unsubclass (Exit)
       
   SubclassMessage m_hWnd, False  '//--- Unsubclass
   RedrawWindow m_hWnd, ByVal 0&, ByVal 0&, &H1 '//---(invoke a Paint-event) turn Normal ;)
   KillTimer m_hWnd, 1         '//--  Should never happen that we have a timer left over (but just in case)
   Set MyClassObject = Nothing '//--  Cleaning ClassObject just in case
    
End Sub





Private Sub SubclassMessage(ByVal Sender As Long, ByVal Action As Boolean)

    
     
     If Action = True Then
        
         If Not m_MsgBox Or Not m_CommonD Or Not m_TabStrip Or Not m_ListView Then AttachMessage Me, Sender, WM_PAINT
         If m_MsgBox Or m_CommonD Then AttachMessage Me, Sender, WM_ACTIVATE
        
         If m_Button Then AttachMessage Me, Sender, WM_SETFOCUS
         If m_Button Then AttachMessage Me, Sender, WM_KILLFOCUS
         If m_Button Or m_CheckBox Or m_Option Then AttachMessage Me, Sender, WM_KEYDOWN
         If m_Button Or m_CheckBox Or m_Option Then AttachMessage Me, Sender, WM_KEYUP
         
         If m_TabStrip Then AttachMessage Me, GetParent(Sender), WM_DRAWITEM
         If m_TabStrip Then AttachMessage Me, Sender, WM_PRINTCLIENT
        
         If m_Adodc Or m_Button Or m_CheckBox Or m_Combo Or m_ICombo Or m_ListView Or m_Option Or m_Slider Or m_TabStrip _
         Then AttachMessage Me, Sender, WM_MOUSEMOVE
         
         If m_Adodc Or m_Button Or m_CheckBox Or m_Combo Or m_ICombo Or m_ListView Or m_Option Or m_Slider Or m_TabStrip _
         Then AttachMessage Me, Sender, WM_TIMER
         
         If m_Adodc Or m_Button Or m_CheckBox Or m_Combo Or m_ICombo Or m_ListView Or m_Option Or m_Slider Or m_TabStrip _
         Then AttachMessage Me, Sender, WM_LBUTTONDOWN
         
         If m_Adodc Or m_Button Or m_CheckBox Or m_Combo Or m_ICombo Or m_ListView Or m_Option Or m_Slider Or m_TabStrip _
         Then AttachMessage Me, Sender, WM_LBUTTONUP
         
         If m_Picture Or m_Button Or m_CheckBox Or m_ICombo Or m_Option _
         Then AttachMessage Me, Sender, WM_ENABLE
         
         If m_Combo Then AttachMessage Me, GetParent(Sender), WM_COMMAND
         If m_ICombo Then AttachMessage Me, GetWindow(Sender, GW_CHILD), WM_COMMAND