在场景中输出横向或纵向压缩的中文字符

最新推荐文章于 2021-05-18 16:25:04 发布

原创最新推荐文章于 2021-05-18 16:25:04 发布 · 1.7k 阅读

0 ·

CC 4.0 BY-SA版权

文章标签：

#byte #integer #function #documentation #string #command

字符串处理同时被 2 个专栏收录

60 篇文章

订阅专栏

图形界面

38 篇文章

订阅专栏

该博客展示了一段参考外文代码编写的VBA代码。代码中定义了常量和结构体，声明了多个函数，实现了将OLE StdFont转换为LOGFONT结构，进而创建字体句柄并进行文本打印的功能。还通过按钮点击事件调用函数，设置不同字体样式打印文本。

今天参考一个外文代码写的:

(作者:Steve McMahon steve@vbaccelerator.com,

网址: http://www.shitalshah.com/vbxlr/tips/vba0035.htm )

Private Const LF_FACESIZE = 32
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 Const DT_CALCRECT = &H400
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 Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Sub printtext(ByVal hdc As Long, ByVal mystr As String, myfont As StdFont, Optional ByVal fontwidth As Integer = 30, Optional ByVal fontheight As Integer = 15, Optional ByVal fontbold As Boolean = False, Optional ByVal fontitlaic As Boolean = False, Optional ByVal fontunderline As Boolean = False, Optional ByVal fontStrikethrough As Boolean = False)

Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim tR As RECT
Dim sFont As String
Dim iChar As Integer
Dim temp() As Byte

   ' Convert an OLE StdFont to a LOGFONT structure:
   With tLF
     sFont = myfont.Name
     temp = StrConv(sFont, vbFromUnicode)
     For iChar = 1 To Len(sFont)
       .lfFaceName(iChar - 1) = temp(iChar - 1)
     Next iChar
     ' Based on the Win32SDK documentation:
        .lfItalic = myfont.Italic
      lfWeight = IIf(myfont.Bold, FW_BOLD, FW_NORMAL)
      .lfWidth = fontwidth
     .lfHeight = fontheight
     .lfUnderline = fontunderline
     .lfStrikeOut = fontStrikethrough
     .lfCharSet = myfont.Charset
   End With

hFnt = CreateFontIndirect(tLF) ' Convert the LOGFONT into a font handle

   ' Test the font out:
   hFntOld = SelectObject(hdc, hFnt)
   DrawText hdc, mystr, -1, tR, DT_CALCRECT
   OffsetRect tR, 32, 32
   DrawText hdc, mystr, -1, tR, 0&
   SelectObject hdc, hFntOld

   ' remember to delete the font when finished

   DeleteObject hFnt

End Sub

Private Sub Command1_Click()
Me.Cls
Dim myfont As New StdFont
myfont.Name = "arial"
printtext Me.hdc, "扁扁的几个字", myfont, 50, 20

End Sub

Private Sub Command2_Click()
Dim myfont As New StdFont
myfont.Name = "arial"
printtext Me.hdc, "修长的几个字", myfont, 10, 200, True, True, False, False
End Sub