IDC资讯中心
在VB中利用Windows的API函数可以实现很多的VB无法实现的扩展功能，下面的程序介绍的是如何通过调用Windows中的API函数实现文本旋转显示的特级效果。
首先建立一个工程文件，然后选菜单中的Project|AddClassModule加入一个新的类文件，并将这个类的Name属性改变为APIFont，然后在类的代码窗口中加入以下的代码：
OptionExplicit
PrivateDeclareFunctionSelectClipRgnLib“gdi32”(ByValhdcAsLong,ByValhRgnAsLong)AsLong
PrivateDeclareFunctionCreateRectRgnLib“gdi32”(ByValX1AsLong,ByValY1AsLong,ByValX2AsLong,ByValY2AsLong)AsLong
PrivateDeclareFunctionSetTextColorLib“gdi32”(ByValhdcAsLong,ByValcrColorAsLong)AsLong
PrivateDeclareFunctionDeleteObjectLib“gdi32”(ByValhObjectAsLong)AsLong
PrivateDeclareFunctionCreateFontIndirectLib“gdi32”Alias“CreateFontIndirectA”(lpLogFontAsLOGFONT)AsLong
PrivateDeclareFunctionSelectObjectLib“gdi32”(ByValhdcAsLong,ByValhObjectAsLong)AsLong
PrivateDeclareFunctionTextOutLib“gdi32”Alias“TextOutA”(ByValhdcAsLong,ByValXAsLong,ByValYAsLong,ByVallpStringAsString,ByValnCountAsLong)AsLong
PrivateDeclareFunctionSetTextAlignLib“gdi32”(ByValhdcAsLong,ByValwFlagsAsLong)AsLong
PrivateTypeRECT
LeftAsLong
TopAsLong
RightAsLong
BottomAsLong
EndType
PrivateConstTA_LEFT=0
PrivateConstTA_RIGHT=2
PrivateConstTA_CENTER=6
PrivateConstTA_TOP=0
PrivateConstTA_BOTTOM=8
PrivateConstTA_BASELINE=24
PrivateTypeLOGFONT
lfHeightAsLong
lfWidthAsLong
lfEscapementAsLong
lfOrientationAsLong
lfWeightAsLong
lfItalicAsByte
lfUnderlineAsByte
lfStrikeOutAsByte
lfCharSetAsByte
lfOutPrecisionAsByte
lfClipPrecisionAsByte
lfQualityAsByte
lfPitchAndFamilyAsByte
lfFaceNameAsString＊50
EndType
Privatem_LFAsLOGFONT
PrivateNewFontAsLong
PrivateOrgFontAsLong
PublicSubCharPlace(oAsObject,txt＄,X,Y)
DimThrowAsLong
DimhregionAsLong
DimRAsRECT
R.Left=X
R.Right=X＋o.TextWidth(txt＄)＊2
R.Top=Y
R.Bottom=Y＋o.TextHeight(txt＄)＊2
hregion=CreateRectRgn(R.Left,R.Top,R.Right,R.Bottom)
Throw=SelectClipRgn(o.hdc,hregion)
Throw=TextOut(o.hdc,X,Y,txt＄,Len(txt＄))
DeleteObject(hregion)
EndSub
PublicSubSetAlign(oAsObject,Top,BaseLine,Bottom,Left,Center,Right)
DimVertAsLong
DimHorzAsLong
IfTop=TrueThenVert=TA_TOP
IfBaseLine=TrueThenVert=TA_BASELINE
IfBottom=TrueThenVert=TA_BOTTOM
IfLeft=TrueThenHorz=TA_LEFT
IfCenter=TrueThenHorz=TA_CENTER
IfRight=TrueThenHorz=TA_RIGHT
SetTextAligno.hdc,VertOrHorz
EndSub
PublicSubsetcolor(oAsObject,CvalueAsLong)
DimThrowAsLong
Throw=SetTextColor(o.hdc,Cvalue)
EndSub
PublicSubSelectOrg(oAsObject)
DimThrowAsLong
NewFont=SelectObject(o.hdc,OrgFont)
Throw=DeleteObject(NewFont)
EndSub
PublicSubSelectFont(oAsObject)
NewFont=CreateFontIndirect(m_LF)
OrgFont=SelectObject(o.hdc,NewFont)
EndSub
PublicSubFontOut(text＄,oAsControl,XX,YY)
DimThrowAsLong
Throw=TextOut(o.hdc,XX,YY,text＄,Len(text＄))
EndSub
PublicPropertyGetWidth()AsLong
Width=m_LF.lfWidth
EndProperty
PublicPropertyLetWidth(ByValWAsLong)
m_LF.lfWidth=W
EndProperty
PublicPropertyGetHeight()AsLong
Height=m_LF.lfHeight
EndProperty
PublicPropertyLetHeight(ByValvNewValueAsLong)
m_LF.lfHeight=vNewValue
EndProperty
PublicPropertyGetEscapement()AsLong
Escapement=m_LF.lfEscapement
EndProperty
PublicPropertyLetEscapement(ByValvNewValueAsLong)
m_LF.lfEscapement=vNewValue
EndProperty
PublicPropertyGetWeight()AsLong
Weight=m_LF.lfWeight
EndProperty
PublicPropertyLetWeight(ByValvNewValueAsLong)
m_LF.lfWeight=vNewValue
EndProperty
PublicPropertyGetItalic()AsByte
Italic=m_LF.lfItalic
EndProperty
PublicPropertyLetItalic(ByValvNewValueAsByte)
m_LF.lfItalic=vNewValue
EndProperty
PublicPropertyGetUnderLine()AsByte
UnderLine=m_LF.lfUnderline
EndProperty
PublicPropertyLetUnderLine(ByValvNewValueAsByte)
m_LF.lfUnderline=vNewValue
EndProperty
PublicPropertyGetStrikeOut()AsByte
StrikeOut=m_LF.lfStrikeOut
EndProperty
PublicPropertyLetStrikeOut(ByValvNewValueAsByte)
m_LF.lfStrikeOut=vNewValue
EndProperty
PublicPropertyGetFaceName()AsString
FaceName=m_LF.lfFaceName
EndProperty
PublicPropertyLetFaceName(ByValvNewValueAsString)
m_LF.lfFaceName=vNewValue
EndProperty
PrivateSubClass_Initialize()
m_LF.lfHeight=30
m_LF.lfWidth=10
m_LF.lfEscapement=0
m_LF.lfWeight=400
m_LF.lfItalic=0
m_LF.lfUnderline=0
m_LF.lfStrikeOut=0
m_LF.lfOutPrecision=0
m_LF.lfClipPrecision=0
m_LF.lfQuality=0
m_LF.lfPitchAndFamily=0
m_LF.lfCharSet=0
m_LF.lfFaceName=”Arial”＋Chr(0)
EndSub
在工程文件的Form1中加入一个PictureBox和一个CommandButton控件，然后在Form1的代码窗口中加入以下的代码：
OptionExplicit
DimAFAsAPIFont
DimX,YAsInteger
PrivateSubCommand1_Click()
DimIAsInteger
SetAF=Nothing
SetAF=NewAPIFont
Picture2.Cls
ForI=0To3600Step360
AF.Escapement=I
AF.SelectFontPicture2
X=Picture2.ScaleWidth/2
Y=Picture2.ScaleHeight/2
在字符串后面要加入7个空格
AF.FontOut“电脑商情报第42期”,Picture2,X,Y
AF.SelectOrgPicture2
NextI
EndSub
PrivateSubForm_Load()
Picture2.ScaleMode=3
EndSub
运行程序，点击Form上的Command1按钮，在窗口的图片框就会出现旋转的文本显示，程序的效果如图所示：
值得注意的问题是，由于Windows的动态连接库的中英文版本的关系，在一些系统中显示中文可能会有一些问题，大家可能看到，上面程序中的语句：AF.FontOut“脑商情报第42期”，Picture2,X,Y中的字符串后面有7个空格，这是对于“电脑商情报第42期”中的7个中文字符，中文系统计算的是7个字符，但是实际它们占据的是14个字节的空间，所以在输出时要在后面添加7个空格做“替身”。上面的程序在中文Win98，VB6下运行通过。->
