多功能文本输出函数

来源：互联网发布：mac book防反射层脱落编辑：程序博客网时间：2024/04/28 22:33

这是一个我自己编写的多功能文本输出函数，可提供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