cwinxpcengine.cls

进销存管理系统

     ElseIf m_ListView Then
     
          If ButtonState <> C_Down Then
             If CheckListViewArea(lParam) = True Then
                ButtonState = C_Over
                DrawControlClass
                SetTimer m_hWnd, 1, 1, 0
             End If
          End If
           
     ElseIf m_TabStrip Then
           
           If CheckTabStripArea(lParam) = True Then DrawControlClass
           SetTimer m_hWnd, 1, 1, 0
     
      ElseIf m_Combo Or m_ICombo Then

            If InsideArea(m_hWnd) = True Then
                    If bOver = False Then
                       bOver = True
                       ButtonState = C_Over
                       DrawControlClass
                       SetTimer m_hWnd, 1, 1, 0
                    End If
            Else
                    ButtonState = C_Down
            End If
            
       End If

'==========================================================================================
'==========================================================================================
'The WM_TIMER message is posted to the installing thread's message queue when a timer expires.
'You can process the message by providing a WM_TIMER case in the window procedure. Otherwise,
'the default window procedure will call the TimerProc callback function specified in the call
'to the SetTimer function used to install the timer.

    Case WM_TIMER
    
        
             If InsideArea(m_hWnd) = False Then
                 
                 If Not m_ListView Or m_ListView And ButtonState <> C_Down Then
                     If (m_Combo And ButtonState <> C_Down) Or (m_ICombo And ButtonState <> C_Down) Or (Not m_ICombo) Then ButtonState = C_Normal
                 End If
   
                 If m_TabStrip Then m_TSCTab = True
                 If m_Adodc Then m_CurrentButton = -1
   
                  
                  KillTimer m_hWnd, 1
                  bOver = False
                  
                  ButtonState = C_Normal
                  
                  If m_Button Then
                    PostPaintControl
                  Else
                    DrawControlClass
                  End If
                  
                  m_TSILNumber = SendMessageLong(m_hWnd, TCM_GETCURSEL, 0&, 0&)
                  m_TSINumber = m_TSILNumber
                  m_CurrentItem = -1
                  m_TSCTab = False
                        
            Else
            
                  bOver = True
                           
                  If ButtonState <> C_Down Then

                       If m_Slider Then
                           If CheckSliderArea = True Then ButtonState = C_Over
                           If CheckSliderArea = False Then ButtonState = C_Normal
                       End If
                     
                       '//--- Some Controls have Different Behavior when Mouse is Over
                       If Not m_Slider And Not m_Combo And Not m_ICombo Then ButtonState = C_Over
                     
                       If m_Combo Or m_ICombo Then
                            If DroppedDown = False Then
                               ButtonState = C_Over 'ComboBoxes Don't have C_Over (Mouse Move) When Dropped ;)
                            End If
                       End If

                   End If
         
                   If m_Adodc And ButtonState <> MovementFlag Then
                      MovementFlag = ButtonState
                      DrawControlClass
                   End If
              
              End If
          
   
   End Select
   
   
      
   
       
   
End Function

Private Sub PrePaintControl()
         DestDC = GetDC(m_hWnd)
         GetWindowRect m_hWnd, m_ItemRect
                m_Width = m_ItemRect.Right - m_ItemRect.Left
                m_Height = m_ItemRect.Bottom - m_ItemRect.Top
         CreateNewDCWorkArea m_Width, m_Height
         SelectBitmap
         m_PreDraw = True
         DrawControlClass
End Sub

Private Sub PostPaintControl()
         CreateBackMask m_Width, m_Height
         origBrush = SelectObject(TempDC, TempBrush)
         SelectObject TempDC, origBrush
        '------------------------------------------------------------------------------------------------------
        DOBitBlt m_Width, m_Height '//--- Do RasterOperations
        CleanDCs                    '//--- Free Memory <--Prevent Leaks
        m_PreDraw = False
        DrawControlClass
End Sub



'=======================================================================================================================
' CREATE A MASK COLOR BACKGROUND
'=======================================================================================================================

Private Sub CreateBackMask(ByVal m_Width As Long, ByVal m_Height As Long)
        
        origColor = SetBkColor(DestDC, GetSysColor(15))
        SetBkColor OrigDC, GetSysColor(15)
        BitBlt MaskDC, 0, 0, m_Width, m_Height, OrigDC, 0, 0, vbSrcCopy
       
End Sub


'=======================================================================================================================
' CREATE THE NEW TEMP WORK AREA
'=======================================================================================================================

Private Sub CreateNewDCWorkArea(ByVal m_Width As Long, ByVal m_Height As Long)
        
        MaskDC = CreateCompatibleDC(DestDC)
        MaskPic = CreateBitmap(m_Width, m_Height, 1, 1, ByVal 0&)
        MemDC = CreateCompatibleDC(DestDC)
        MemPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)
        TempDC = CreateCompatibleDC(DestDC)
        TempPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)
        OrigDC = CreateCompatibleDC(DestDC)
        OrigPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)

End Sub


'=======================================================================================================================
' BITBLT  RasterOperations
'=======================================================================================================================

Private Sub DOBitBlt(ByVal m_Width As Long, ByVal m_Height As Long)
        
        BitBlt MemDC, 0, 0, m_Width, m_Height, MaskDC, 0, 0, vbSrcCopy
        BitBlt MemDC, 0, 0, m_Width, m_Height, OrigDC, 0, 0, vbSrcPaint
        BitBlt TempDC, 0, 0, m_Width, m_Height, MaskDC, 0, 0, vbMergePaint
        BitBlt TempDC, 0, 0, m_Width, m_Height, MemDC, 0, 0, vbSrcAnd
        BitBlt DestDC, 0, 0, m_Width, m_Height, TempDC, 0, 0, vbSrcCopy

End Sub

'=======================================================================================================================
' CLEAN UP MEMORY
'=======================================================================================================================

Private Sub CleanDCs()
        
        DeleteDC TempDC
        DeleteObject TempPic
        DeleteDC MaskDC
        DeleteObject MaskPic
        DeleteDC MemDC
        DeleteObject MemPic
        DeleteDC OrigDC
        DeleteObject OrigPic
        DeleteObject TempBrush

End Sub


'=======================================================================================================================
' SELECT THE CURRENT IMAGE
'=======================================================================================================================

Private Sub SelectBitmap()
Dim cHandle As Long

       cHandle = SelectObject(MaskDC, MaskPic)
       DeleteObject cHandle
       cHandle = SelectObject(MemDC, MemPic)
       DeleteObject cHandle
       cHandle = SelectObject(TempDC, TempPic)
       DeleteObject cHandle
       cHandle = SelectObject(OrigDC, OrigPic)
       DeleteObject cHandle
       
End Sub


Private Function CheckAdodcArea() As Boolean
  Dim WinItem As RECT
  Dim Point As POINTAPI
  Dim hRgn As Long
  Dim NButton As Integer
   
    GetCursorPos Point
    
    
    GetWindowRect m_hWnd, WinItem
    WinItem.Left = WinItem.Left + 41
    WinItem.Right = WinItem.Right - 42
    NButton = -1
    GoSub CheckThisButton
    If CheckAdodcArea = True Then Exit Function
        
    GetWindowRect m_hWnd, WinItem
    WinItem.Right = WinItem.Left + 20
    NButton = 0
    GoSub CheckThisButton
    If CheckAdodcArea = True Then Exit Function
    
    GetWindowRect m_hWnd, WinItem
    WinItem.Right = WinItem.Left + 40
    WinItem.Left = WinItem.Left + 21
    NButton = 1
    GoSub CheckThisButton
    If CheckAdodcArea = True Then Exit Function
    
    GetWindowRect m_hWnd, WinItem
    WinItem.Left = WinItem.Right - 41
    WinItem.Right = WinItem.Right - 22
    NButton = 2
    GoSub CheckThisButton
    If CheckAdodcArea = True Then Exit Function
    
    GetWindowRect m_hWnd, WinItem
    WinItem.Left = WinItem.Right - 21
    NButton = 3
    GoSub CheckThisButton
    
           
   
   Exit Function

CheckThisButton:
    
    hRgn = CreateRectRgnIndirect(WinItem)
       
    If PtInRegion(hRgn, CLng(Point.X), CLng(Point.Y)) Then
        If NButton <> m_CurrentButton Then
            m_CurrentButton = NButton
            CheckAdodcArea = True
        End If
    Else
        CheckAdodcArea = False
    End If
        
        DeleteObject hRgn
      
    Return
    
End Function


Private Function CheckSliderArea() As Boolean
        
   Dim SliderRegion As RECT
   Dim RcItem As RECT
   Dim Point As POINTAPI
   Dim hRgn As Long
   
   
   SendMessageLong m_hWnd, TBM_GETTHUMBRECT, 0, SliderRegion
   
   GetCursorPos Point
   GetWindowRect m_hWnd, RcItem

   SliderRegion.Left = SliderRegion.Left + RcItem.Left
   SliderRegion.Right = SliderRegion.Right + RcItem.Left
   SliderRegion.Top = SliderRegion.Top + RcItem.Top
   SliderRegion.Bottom = SliderRegion.Bottom + RcItem.Top
   
    hRgn = CreateRectRgnIndirect(SliderRegion)
       
    If PtInRegion(hRgn, CLng(Point.X), CLng(Point.Y)) Then
        CheckSliderArea = True
    Else
        CheckSliderArea = False
    End If
        
    DeleteObject hRgn
        
End Function
'==========================================================================================
'==========================================================================================
'ListView Check Area
Private Function CheckListViewArea(ByVal lParam As Long) As Boolean
 
 Dim hti As HDHITTESTINFO
 Dim mLH As TLoHiLong, mAL As TAllLong
 
      mAL.All = lParam
      LSet mLH = mAL
      hti.pt.X = mLH.Lo
      hti.pt.Y = mLH.Hi
            
      SendMessageLong m_hWnd, HDM_HITTEST, 0&, hti
      SendMessageLong m_hWnd, HDM_GETITEMRECT, hti.iItem, m_LVIRect
     
      If hti.iItem <> m_CurrentItem Then
        m_CurrentItem = hti.iItem
        CheckListViewArea = True
      End If
      
End Function

'==========================================================================================
'==========================================================================================
'Tab Strip Check Area
Private Function CheckTabStripArea(ByVal lParam As Long) As Boolean
 
 Dim tTI As TCHITTESTINFO
 Dim iItem As Long
 Dim mLH As TLoHiLong, mAL As TAllLong
 
      mAL.All = lParam
      LSet mLH = mAL
      tTI.pt.X = mLH.Lo
      tTI.pt.Y = mLH.Hi
            
           
      iItem = SendMessageLong(m_hWnd, TCM_HITTEST, 0&, tTI)
             
     
       If iItem <> m_TSINumber Then
           m_TSILNumber = m_TSINumber
           m_TSINumber = iItem
           CheckTabStripArea = True
       End If
      
End Function

Private Sub PrintTabClientColor()
Dim TRec As RECT
Dim cHdc As Long
Dim Valh As Long

cHdc = GetDC(m_hWnd)

GetClientRect m_hWnd, TRec

Select Case m_ActiveScaleMode

Case vbTwips
     TRec.Top = Abs((MyClassObject.ClientTop - MyClassObject.Top) / Screen.TwipsPerPixelY)

Case vbPixels
     TRec.Top = Abs(MyClassObject.ClientTop - MyClassObject.Top)
     
Case vbPoints
     TRec.Top = (Abs(MyClassObject.ClientTop - MyClassObject.Top) * 100) / 75
     
End Select



DrawFillRectangle TRec, vbWhite, cHdc
   
ReleaseDC m_hWnd, cHdc


End Sub


Public Property Let ActiveScaleMode(ByRef cActiveScaleMode As ScaleModeConstants)
   m_ActiveScaleMode = cActiveScaleMode
End Property

Public Property Let IdeSubClass(ByVal cIdeSubClass As Boolean)
   m_IdeSubClass = cIdeSubClass
End Property

Public Property Get SchemeColor() As CWindowColors
   SchemeColor = m_SchemeColor
End Property

Public Property Let SchemeColor(ByRef cSchemeColor As CWindowColors)
   m_SchemeColor = cSchemeColor
End Property