這是一個我自己編寫的多功能文本輸出函數，可提供Print語句需配合定位、字體等屬性才能實現的功能；還可提供自動換行、字體旋轉、無效文本等功能。
Public Enum DrawTextAlign
DT_LEFT = &H0&
DT_CENTER = &H1&
DT_RIGHT = &H2&
DT_TOP = &H0&
DT_VCENTER = &H4&
DT_BOTTOM = &H8&
End Enum
Public Enum DrawTextOption
DT_EXTERNALLEADING = &H200&
DT_EXPANDTABS = &H40&
DT_EDITCONTROL = &H2000&
DT_PATH_ELLIPSIS = &H4000&
DT_END_ELLIPSIS = &H8000&
DT_MODIFYSTRING = &H10000
DT_RTLREADING = &H20000
DT_WORD_ELLIPSIS = &H40000
End Enum
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Enum DrawTextFlag
DT_WORDBREAK = &H10&
DT_NOCLIP = &H100&
DT_CALCRECT = &H400&
DT_SINGLELINE = &H20&
End Enum
Private Enum BackMode
TRANSPARENT = 1
OPAQUE = 2
End Enum
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(0 To 31) As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
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 Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount 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 SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Function TextPrint(ByVal dhDC As Long, ByVal Text As String, x As Long, y As Long, Optional ByVal w As Long, Optional ByVal h As Long, _
Optional TextColor As Long = -1, Optional DrawAlign As DrawTextAlign, Optional FontSize As Long, Optional FontBold As Long = -1, _
Optional LineAngle As Long, Optional NewFont As String, Optional DrawOpt As DrawTextOption) As RECT
'過程說明：
'在目標hDC中多功能透明方式輸出文本
'本過程可提供Print語句需配合定位、字體等屬性才能實現的功能
'還提供字體旋轉、無效文本功能
'在不啓用可選項時，本過程輸出文本比Print語句約快20%
'參數說明：
'必須參數
'-------------
'hDC 目標DC
'Text 輸出文本
'x、y 起始位置左上角座標
'-----------------------
'可選參數
'-----------------------
'LineAngle 旋轉角度，若不爲0時，將不能支持多行，且文本也不會被裁剪，返回的矩形只是爲0時的正常矩形
'TextColor 0與正值時指定文本顏色,-1時用原有文本顏色,-2時爲將文本描述成無效文本輸出
'FontSize、FontBold 字體高度與加粗，標準宋體9號字高度爲12
'DrawAlign 文本對齊方式 參見DrawTextAlign常數
'W、H 設置文本矩形寬與高，W=0時爲單行輸出
'當W>0時，即爲自動換行文本，注意，啓動此功能，輸出速度會下降6-10倍
'NewFont 指定字體名，爲空時，使用"宋體"
'DrawOpt 使用DrawText輸出的Flag，參見DrawTextOption常數
Dim hFont As Long, hOldFont As Long
Dim Font As LOGFONT, TextRect As RECT, hBrush As Long, tColor As Long
Dim szText As Size, BkM As Long, LineOP As Long, UseDraw As Boolean
If LineAngle <> 0 Or FontSize <> 0 Or FontBold <> -1 Or Len(NewFont) > 0 Then
With Font
.lfCharSet = 134
.lfEscapement = LineAngle * 10
If FontSize <> 0 Then
If FontSize > 0 Then
.lfHeight = -FontSize
Else
.lfHeight = FontSize
End If
Else
.lfHeight = -12
End If
.lfWidth = 0
If FontBold <> -1 Then
If FontBold = 0 Then
.lfWeight = 400
Else
.lfWeight = 700
End If
End If
If NewFont <> vbNullString Then
CopyMemory .lfFaceName(0), ByVal NewFont & vbNullChar, lstrlen(NewFont & vbNullChar)
Else
CopyMemory .lfFaceName(0), ByVal "宋體" & vbNullChar, lstrlen("宋體" & vbNullChar)
End If
End With
hFont = CreateFontIndirect(Font)
hOldFont = SelectObject(dhDC, hFont)
End If
If TextColor <> -1 Then
If TextColor < -1 Then
tColor = vbWhite
If w > 0 Then
w = w - 1
If h > 0 Then h = h - 1
End If
Else
tColor = TextColor
End If
tColor = SetTextColor(dhDC, tColor)
End If
BkM = SetBkMode(dhDC, TRANSPARENT)
GetTextExtentPoint32 dhDC, Text, lstrlen(Text), szText
If LineAngle = 0 And w > 0 Then
If DrawOpt <> 0 Then
UseDraw = True
LineOP = DrawOpt
End If
If w < szText.cx Then
UseDraw = True
szText.cx = w
If h > 0 And h <= szText.cy Then
LineOP = LineOP Or DT_SINGLELINE
szText.cy = h
Else
LineOP = LineOP Or DT_WORDBREAK
TextRect.Right = w
DrawText dhDC, Text & vbNullChar, -1, TextRect, LineOP Or DT_CALCRECT
If h = 0 Or h >= szText.cy Then
szText.cy = TextRect.Bottom
LineOP = LineOP Or DT_NOCLIP
Else
szText.cy = h
End If
End If
Else
If (LineOP And DT_EXPANDTABS) <> 0 Then szText.cx = w
LineOP = LineOP Or DT_SINGLELINE
If h = 0 Or h >= szText.cy Then LineOP = LineOP Or DT_NOCLIP
End If
End If
Select Case DrawAlign And (DT_CENTER Or DT_RIGHT)
Case DT_LEFT
TextRect.Left = x
Case DT_CENTER
TextRect.Left = x - szText.cx / 2
Case DT_RIGHT
TextRect.Left = x - szText.cx
End Select
Select Case DrawAlign And (DT_VCENTER Or DT_BOTTOM)
Case DT_TOP
TextRect.Top = y
Case DT_VCENTER
TextRect.Top = y - szText.cy / 2
Case DT_BOTTOM
TextRect.Top = y - szText.cy
End Select
TextRect.Bottom = TextRect.Top + szText.cy
TextRect.Right = TextRect.Left + szText.cx
If UseDraw = False Then
If TextColor < -1 Then
TextOut dhDC, TextRect.Left + 1, TextRect.Top + 1, Text, lstrlen(Text)
SetTextColor dhDC, &H808080
End If
TextOut dhDC, TextRect.Left, TextRect.Top, Text, lstrlen(Text)
Else
If TextColor < -1 Then
OffsetRect TextRect, 1, 1
DrawText dhDC, Text, lstrlen(Text), TextRect, LineOP
OffsetRect TextRect, -1, -1
SetTextColor dhDC, &H808080
End If
DrawText dhDC, Text, lstrlen(Text), TextRect, LineOP
End If
If TextColor <> -1 Then
SetTextColor dhDC, tColor
If TextColor < -1 Then
TextRect.Right = TextRect.Right + 1
TextRect.Bottom = TextRect.Bottom + 1
End If
End If
SetBkMode dhDC, BkM
If hOldFont <> 0 Then
SelectObject dhDC, hOldFont
DeleteObject hFont
End If
TextPrint = TextRect
End Function