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

王朝other·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

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

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

输出:

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
 
 
© 2005- 王朝網路 版權所有 導航