cneocaption.cls

这是一个有VB开发的学院办公自动化系统

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

' APIs
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const CLR_INVALID = -1

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_VCENTER = &H4
Private Const DT_TOP = &H0
Private Const DT_TABSTOP = &H80
Private Const DT_SINGLELINE = &H20
Private Const DT_RIGHT = &H2
Private Const DT_NOCLIP = &H100
Private Const DT_INTERNAL = &H1000
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_EXPANDTABS = &H40
Private Const DT_CHARSTREAM = 4
Private Const DT_NOPREFIX = &H800
Private Const DT_EDITCONTROL = &H2000&
Private Const DT_PATH_ELLIPSIS = &H4000&
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000

' Font:
Private Const LF_FACESIZE = 32
Private Type LOGFONT
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90

Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_SYSCOMMAND = &H112


' Implementation
Implements INCAreaModifier

Private Enum ECNCButtonStates
   up
   Down
End Enum

Private m_cNCS As cNCCalcSize
Private m_hWnd As Long

' MemDCs for storing GFX
Private m_cBorder As cMemDC
Private m_cCaption As cMemDC

' MemDC for building caption:
Private m_cFF As cMemDC
' and l/r borders
Private m_cFFB As cMemDC
' Menu bar:
Private m_cMenu As cMenuBar

Private m_oActiveCaptionColor As OLE_COLOR
Private m_oInActiveCaptionColor As OLE_COLOR
Private m_fnt As IFont

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR
Private m_oMenuBackgroundColor As OLE_COLOR
Private m_fntMenu As IFont

Private m_lButtonWidth As Long
Private m_lButtonHeight As Long
Private m_lActiveLeftEnd As Long
Private m_lActiveRightStart As Long
Private m_lActiveRightEnd As Long
Private m_lInactiveOffset As Long

Private m_tBtn(0 To 2) As RECT
Private m_bMaximise As Boolean
Private m_bMinimise As Boolean
Private m_bClose As Boolean
Private m_bMouseDownMinimise As Boolean
Private m_bMouseDownMaximise As Boolean
Private m_bMouseDownClose As Boolean



Public Sub Detach()
Dim lMenu As Long
   If Not m_cNCS Is Nothing Then
      m_cNCS.Detach
   End If
   If Not m_cMenu Is Nothing Then
      lMenu = m_cMenu.hMenu
      m_cMenu.Detach
   End If
   If Not (lMenu = 0) Then
      SetMenu m_hWnd, lMenu
   End If
   
End Sub

Public Sub Attach( _
      f As Object, _
      PicCaption As StdPicture, _
      PicBorder As StdPicture, _
      lButtonWidth As Long, _
      lButtonHeight As Long, _
      lActiveLeftEnd As Long, _
      lActiveRightStart As Long, _
      lActiveRightEnd As Long, _
      lInactiveOffset As Long _
   )
   LockWindowUpdate f.hwnd
   Detach
   
   ' Store the pictures:
   Set m_cCaption = New cMemDC
   m_cCaption.CreateFromPicture PicCaption
   Set m_cBorder = New cMemDC
   m_cBorder.CreateFromPicture PicBorder
   
   ' FF drawing
   Set m_cFF = New cMemDC
   Set m_cFFB = New cMemDC
   
   ' Store passed in vars:
   m_lButtonWidth = lButtonWidth
   m_lButtonHeight = lButtonHeight

   m_lActiveLeftEnd = lActiveLeftEnd
   m_lActiveRightStart = lActiveRightStart
   m_lActiveRightEnd = lActiveRightEnd
   m_lInactiveOffset = lInactiveOffset
         
   ' Store hWNd:
   m_hWnd = f.hwnd
         
   ' Menu:
   Set m_cMenu = New cMenuBar
   m_cMenu.Attach m_hWnd
   m_cMenu.Font = m_fntMenu
   m_cMenu.SetColors m_oActiveMenuColor, m_oActiveMenuColorOver, m_oInActiveMenuColor, m_oMenuBackgroundColor
   m_cMenu.CaptionHeight = m_cCaption.Height

         
   ' Start non-client modification:
   Set m_cNCS = New cNCCalcSize
   m_cNCS.Attach Me
   m_cNCS.Display f
   
   If IsWindowVisible(m_hWnd) <> 0 Then
      SetForegroundWindow m_hWnd
      SetFocusAPI m_hWnd
      SendMessageLong m_hWnd, WM_NCACTIVATE, 1, 0
   End If
   
   LockWindowUpdate 0
   
End Sub
Public Property Get MenuBackgroundColor() As OLE_COLOR
   MenuBackgroundColor = m_oMenuBackgroundColor
End Property
Public Property Let MenuBackgroundColor(ByVal oColor As OLE_COLOR)
   m_oMenuBackgroundColor = oColor
End Property
Public Property Get ActiveCaptionColor() As OLE_COLOR
   ActiveCaptionColor = m_oActiveCaptionColor
End Property
Public Property Let ActiveCaptionColor(ByVal oColor As OLE_COLOR)
   m_oActiveCaptionColor = oColor
End Property
Public Property Get InActiveCaptionColor() As OLE_COLOR
   InActiveCaptionColor = m_oInActiveCaptionColor
End Property
Public Property Let InActiveCaptionColor(ByVal oColor As OLE_COLOR)
   m_oInActiveCaptionColor = oColor
End Property
Public Property Get CaptionFont() As IFont
   Set CaptionFont = m_fnt
End Property
Public Property Let CaptionFont(iFnt As IFont)
   Set m_fnt = iFnt
End Property
Public Property Get MenuFont() As IFont
   Set MenuFont = m_fntMenu
End Property
Public Property Let MenuFont(iFnt As IFont)
   Set m_fntMenu = iFnt
End Property
Public Property Get ActiveMenuColor() As OLE_COLOR
   ActiveMenuColor = m_oActiveMenuColor
End Property
Public Property Get ActiveMenuColorOver() As OLE_COLOR
   ActiveMenuColorOver = m_oActiveMenuColorOver
End Property
Public Property Get InActiveMenuColor() As OLE_COLOR
   InActiveMenuColor = m_oInActiveMenuColor
End Property
Public Property Let ActiveMenuColor(oColor As OLE_COLOR)
   m_oActiveMenuColor = oColor
End Property
Public Property Let ActiveMenuColorOver(oColor As OLE_COLOR)
   m_oActiveMenuColorOver = oColor
End Property
Public Property Let InActiveMenuColor(oColor As OLE_COLOR)
   m_oInActiveMenuColor = oColor
End Property
Private Sub Class_Initialize()
   m_oActiveCaptionColor = &HCCCCCC
   m_oInActiveCaptionColor = &H999999
   m_oActiveMenuColor = &H0&
   m_oActiveMenuColorOver = &H0&
   m_oInActiveMenuColor = &H808080
   m_oMenuBackgroundColor = &HFFFFFF
   Set m_fnt = New StdFont
   m_fnt.Name = "MS Sans Serif"
   Set m_fntMenu = New StdFont
   m_fntMenu.Name = "MS Sans Serif"
End Sub

Private Sub Class_Terminate()
   '
End Sub

Private Function INCAreaModifier_AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long
    INCAreaModifier_AltKeyAccelerator = m_cMenu.AltKeyAccelerator(vKey)
End Function

Private Sub INCAreaModifier_ExitMenuLoop()
   m_cMenu.pRestoreList
End Sub

Private Sub INCAreaModifier_HitTest(ByVal x As Long, ByVal y As Long, eHitTest As ECNCHitTestConstants)
Dim bMouseOverClose As Boolean
Dim bMouseOverMaximise As Boolean
Dim bMouseOverMinimise As Boolean
Dim bBtnMouseDown As Boolean
Dim hdc As Long

   '
   Dim tR As RECT
   tR.left = 12: tR.top = 11: tR.right = 42: tR.bottom = 43
   If PtInRect(tR, x, y) <> 0 Then
      eHitTest = HTSYSMENU
      Exit Sub
   End If

   ' Code for working out whether in the buttons or not:
   If m_bClose Then
      If PtInRect(m_tBtn(0), x, y) <> 0 Then
         eHitTest = HTSYSMENU
         bMouseOverClose = True
      Else
         bMouseOverClose = False
      End If
   End If
   If m_bMaximise Then
      If PtInRect(m_tBtn(1), x, y) <> 0 Then
         eHitTest = HTSYSMENU
         bMouseOverMaximise = True
      Else
         bMouseOverMaximise = False
      End If
   End If
   If m_bMinimise Then
      If PtInRect(m_tBtn(2), x, y) <> 0 Then
         eHitTest = HTSYSMENU
         bMouseOverMinimise = True
      Else
         bMouseOverMinimise = False
      End If
   End If
   
   hdc = GetWindowDC(m_hWnd)
   
   bBtnMouseDown = GetAsyncKeyState(vbLeftButton)
   If m_bClose Then
      If Not (m_bMouseDownClose = bMouseOverClose) Then
         If bMouseOverClose And bBtnMouseDown And m_bMouseDownClose Then
            DrawButton hdc, 0, Down
         Else
            DrawButton hdc, 0, up
         End If
      End If
   End If
   If m_bMaximise Then
      If Not (m_bMouseDownMaximise = bMouseOverMaximise) Then
         If bMouseOverMaximise And bBtnMouseDown And m_bMouseDownMaximise Then
            DrawButton hdc, 1, Down
         Else
            DrawButton hdc, 1, up
         End If