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

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

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

	<!-- AUTHORS: End -->

输出: