cncaption.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 = "cNCaption"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ==================================================================================================
' 源程序由 http://vbaccelerator.com 提供(并有DLL库文件)。但由于有一些BUG，导致程序无法正常运行。
'
' 所以，我(天生三排牙，Mail：[e-mail])将它重新整理了一下，并写成了新的DLL库。
'
' 但是，BUG在所难免，所以，请使用的各位小虾、大侠们多提提意见，我也会在有空的时候再修改这个程序的。
'
' 当然，源程序以及DLL库都是免费的，你可以在任何地方使用。但请适当保留原作者信息，以示对原作者的尊重。
'
' 如果你对该程序进行了修改，增加了新的功能，希望能Mail一份给我，让我也分享你的喜悦。谢谢！
' ==================================================================================================

Option Explicit

' 声明API函数
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

'字体：
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
'===================================================
'  cNCaption类初始化，设置窗体和菜单的一些基本属性
'===================================================
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()
   'Null
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