windowsxpc.ctl

进销存管理系统

VERSION 5.00
Begin VB.UserControl WindowsXPC 
   BackColor       =   &H00FFFFFF&
   ClientHeight    =   615
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3735
   InvisibleAtRuntime=   -1  'True
   MaskColor       =   &H00FFFFFF&
   PropertyPages   =   "WindowsXPC.ctx":0000
   ScaleHeight     =   615
   ScaleWidth      =   3735
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "WinXPC Engine 1.0"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   195
      Left            =   960
      TabIndex        =   0
      Top             =   240
      Width           =   1680
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H00825623&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00FFFFFF&
      Height          =   615
      Left            =   0
      Top             =   0
      Width           =   3735
   End
End
Attribute VB_Name = "WindowsXPC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' **********************************************************************
'  描  述：巨牛的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日
' **********************************************************************

Option Explicit


Private m_iCount As Long
Private m_SubClassedItem() As cWinXPCEngine

Private m_IDECount As Long
Private m_IDEItem() As cWinXPCEngine

Public Enum SchemeWindowColors
       System = 1
       XP_Blue = 2
       XP_OliveGreen = 3
       XP_Silver = 4
End Enum

Private m_EngineStarted As Boolean
Private m_IDEStarted As Boolean


Private m_IDE As Boolean
Private StartedEngine As Boolean
Private RunningApp As Boolean
Private i As Long

Private m_ColorScheme         As CWindowColors

Private m_FileListBoxControl  As Boolean
Private m_DirListBoxControl   As Boolean
Private m_ListBoxControl      As Boolean
Private m_ListViewControl     As Boolean
Private m_ImageComboControl   As Boolean
Private m_SliderControl       As Boolean
Private m_ProgressBarControl  As Boolean
Private m_StatusBarControl    As Boolean
Private m_TabStripControl     As Boolean
Private m_DriveListBoxControl As Boolean
Private m_ComboBoxControl     As Boolean
Private m_OptionControl       As Boolean
Private m_CheckControl        As Boolean
Private m_ButtonControl       As Boolean
Private m_FrameControl        As Boolean
Private m_PictureControl      As Boolean
Private m_TextControl         As Boolean
Private m_MsgBox_InputBox     As Boolean
Private m_CommonDialog        As Boolean


Private Sub Timer1_Timer()
If UserControl.Ambient.UserMode And Me.EngineStarted = False Then InitSubClassing

Exit Sub
End Sub

Private Sub UserControl_InitProperties()
    m_ColorScheme = WindowsXP_Blue '//--DefaultColors
    m_ListBoxControl = True
    m_DirListBoxControl = True
    m_FileListBoxControl = True
    m_ListViewControl = True
    m_ImageComboControl = True
    m_SliderControl = True
    m_ProgressBarControl = True
    m_StatusBarControl = True
    m_TabStripControl = True
    m_DriveListBoxControl = True
    m_ComboBoxControl = True
    m_OptionControl = True
    m_CheckControl = True
    m_ButtonControl = True
    m_FrameControl = True
    m_PictureControl = True
    m_TextControl = True
    m_MsgBox_InputBox = True
    m_CommonDialog = False
    
End Sub


Public Sub InitSubClassing()
Dim SubclassThis As Boolean
Dim aControl As Control
  
'If Not UserControl.Ambient.UserMode Then Exit Sub

For Each aControl In UserControl.Parent.Controls
     
  SubclassThis = False

  On Error Resume Next
  If Err.Number = 0 Then

     
     Select Case ThisWindowClassName(aControl.hwnd)
            
            Case "ThunderListBox", "ThunderRT6ListBox"
                  If m_ListBoxControl Then SubclassThis = True
            Case "ThunderCommandButton", "ThunderRT6CommandButton", "Button"
                  If m_ButtonControl Then SubclassThis = True
            Case "ThunderFrame", "ThunderRT6Frame"
                  If m_FrameControl Then SubclassThis = True
            Case "ThunderOptionButton", "ThunderRT6OptionButton"
                  If m_OptionControl Then SubclassThis = True
            Case "Slider20WndClass"
                  If m_SliderControl Then SubclassThis = True
            Case "ThunderTextBox", "ThunderRT6TextBox", "Edit"
                  If m_TextControl Then SubclassThis = True
            Case "ThunderCheckBox", "ThunderRT6CheckBox"
                  If m_CheckControl Then SubclassThis = True
            Case "TabStrip20WndClass", "TabStripWndClass"
                  If m_TabStripControl Then SubclassThis = True
            Case "ThunderComboBox", "ThunderRT6ComboBox", "ComboBox"
                  If m_ComboBoxControl Then SubclassThis = True
            Case "ImageCombo20WndClass"
                  If m_ImageComboControl Then SubclassThis = True
            Case "ProgressBar20WndClass"
                  If m_ProgressBarControl Then SubclassThis = True
            Case "ListView20WndClass"
                  If m_ListViewControl Then SubclassThis = True
            Case "StatusBar20WndClass"
                  If m_StatusBarControl Then SubclassThis = True
            Case "ThunderDirListBox", "ThunderRT6DirListBox"
                  If m_DirListBoxControl Then SubclassThis = True
            Case "ThunderDriveListBox", "ThunderRT6DriveListBox"
                  If m_DriveListBoxControl Then SubclassThis = True
            Case "ThunderFileListBox", "ThunderRT6FileListBox"
                  If m_FileListBoxControl Then SubclassThis = True
            Case "ThunderPictureBox", "ThunderPictureBoxDC", "ThunderRT6PictureBoxDC"
                  If m_PictureControl Then SubclassThis = True
            Case Else
                  'Nothing
                   Debug.Print ThisWindowClassName(aControl.hwnd)
     End Select
     
       If TypeName(aControl) = "Adodc" Then SubclassThis = True
    

     If (SubclassThis) Then
         
         m_EngineStarted = True
         m_iCount = m_iCount + 1
         ReDim Preserve m_SubClassedItem(1 To m_iCount) As cWinXPCEngine
         Set m_SubClassedItem(m_iCount) = New cWinXPCEngine
         m_SubClassedItem(m_iCount).SchemeColor = m_ColorScheme
         m_SubClassedItem(m_iCount).ActiveScaleMode = UserControl.Parent.ScaleMode
         m_SubClassedItem(m_iCount).IdeSubClass = m_IDE
         m_SubClassedItem(m_iCount).Attach aControl
         
         
         
     End If
 
 
 End If
 
Next aControl '//-- Each Control
       
       If m_MsgBox_InputBox Then
         m_EngineStarted = True
         m_iCount = m_iCount + 1
         ReDim Preserve m_SubClassedItem(1 To m_iCount) As cWinXPCEngine
         Set m_SubClassedItem(m_iCount) = New cWinXPCEngine
         m_SubClassedItem(m_iCount).SchemeColor = m_ColorScheme
         m_SubClassedItem(m_iCount).IdeSubClass = m_IDE
         m_SubClassedItem(m_iCount).BeforeAttachMessageBox UserControl.Parent.hwnd
        
       End If
       
       If m_CommonDialog Then
         m_EngineStarted = True
         m_iCount = m_iCount + 1
         ReDim Preserve m_SubClassedItem(1 To m_iCount) As cWinXPCEngine
         Set m_SubClassedItem(m_iCount) = New cWinXPCEngine
         m_SubClassedItem(m_iCount).SchemeColor = m_ColorScheme
         m_SubClassedItem(m_iCount).IdeSubClass = m_IDE
         m_SubClassedItem(m_iCount).BeforeAttachCommonDialog UserControl.Parent.hwnd
       End If

      
       SetProp UserControl.Parent.hwnd, "ColorScheme", m_ColorScheme
       
End Sub


Public Sub InitIDESubClassing()
Dim SubclassThis As Boolean
Dim aControl As Control
 
For Each aControl In UserControl.Parent.Controls
     
  SubclassThis = False

  On Error Resume Next
  If Err.Number = 0 Then

     
     Select Case ThisWindowClassName(aControl.hwnd)
            
            Case "ThunderListBox"
                  SubclassThis = True
            Case "ThunderCommandButton", "Button"
                  SubclassThis = True
            Case "ThunderFrame"
                  SubclassThis = True
            Case "ThunderOptionButton"
                  SubclassThis = True
            Case "Slider20WndClass"
                  SubclassThis = True
            Case "ThunderTextBox", "Edit"
                  SubclassThis = True
            Case "ThunderCheckBox"
                  SubclassThis = True
            Case "ThunderComboBox", "ComboBox"
                  SubclassThis = True
            Case "ImageCombo20WndClass"
                  SubclassThis = True
            Case "ProgressBar20WndClass"
                  SubclassThis = True
            Case "ThunderDirListBox"
                  SubclassThis = True
            Case "ThunderDriveListBox"
                  SubclassThis = True
            Case "ThunderFileListBox"
                  SubclassThis = True
            Case "ThunderPictureBox", "ThunderPictureBoxDC"
                  SubclassThis = True
            Case Else
                  'Nothing
                  
     End Select
     

     If (SubclassThis) Then
         
         m_IDEStarted = True
         m_IDECount = m_IDECount + 1
         ReDim Preserve m_IDEItem(1 To m_IDECount) As cWinXPCEngine
         Set m_IDEItem(m_IDECount) = New cWinXPCEngine
         m_IDEItem(m_IDECount).SchemeColor = m_ColorScheme
         m_IDEItem(m_IDECount).Attach aControl
         
     End If
 
 
 End If
 
Next aControl '//-- Each Control