??? 今天參考一個外文代碼寫的:

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

?
?	?

輸出:

?

轉載于:https://www.cnblogs.com/fengju/archive/2004/08/01/6336381.html

與50位技術專家面對面20年技術見證，附贈技術全景圖

總結

以上是生活随笔為你收集整理的在场景中输出横向或纵向压缩的中文字符的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。