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

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

(作者: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

输出: