制作垂直标题栏的窗体

源代码如下：

Module1

Option Explicit
Public Const GWL_WNDPROC = (-4)

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_NCHITTEST = &H84
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCLIENT = 1
Public Const HTCAPTION = 2

Public Const LF_FACESIZE = 32
Public Const DEFAULT_CHARSET = 1
Public Const DT_CALCRECT = &H400

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(0 To LF_FACESIZE - 1) As Byte
End Type

Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
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

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

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
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public prevWndProc As Long

Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_LBUTTONDOWN Then
SendMessage Form1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
Else
WndProc = CallWindowProc(prevWndProc, hwnd, Msg, wParam, lParam)
End If
End Function

Form1

Private Sub Form_Load()
prevWndProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
SetWindowLong Picture1.hwnd, GWL_WNDPROC, AddressOf WndProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Picture1.hwnd, GWL_WNDPROC, prevWndProc
End Sub

Private Sub Picture1_Paint()
Dim font As LOGFONT, hOldFont As Long, hFont As Long
Dim w As Integer, h As Integer, r As RECT

With Picture1

RtlMoveMemory font.lfFaceName(0), _
ByVal CStr(.font.Name), _
LenB(StrConv(.font.Name, vbFromUnicode)) 1
font.lfHeight = (.font.Size * -20) / Screen.TwipsPerPixelY
font.lfEscapement = 2700
font.lfWeight = IIf(.font.Bold, 700, 400)
font.lfItalic = .font.Italic
font.lfUnderline = .font.Underline
font.lfStrikeOut = .font.Strikethrough
font.lfCharSet = DEFAULT_CHARSET
hFont = CreateFontIndirect(font)
hOldFont = SelectObject(.hDC, hFont)

r.Left = 0: r.Top = 0
DrawText Me.hDC, .Tag, LenB(StrConv(.Tag, vbFromUnicode)), r, DT_CALCRECT
w = r.Right
h = r.Bottom

.Cls

.CurrentX = .ScaleWidth - h / 2
.CurrentY = cmdClose.Height 15
Picture1.Print .Tag

SelectObject .hDC, hOldFont
DeleteObject hFont
End With
End Sub