在VB中建立可旋转的文本特效

长沙 陈锐在vb中运用windows的api因变量不妨实行很多的vb没辙实行的扩充功效，底下的步调引见的是怎样经过挪用windows中的api因变量实行文本回旋表露的特级功效。 　　开始创造一个工程文献，而后选菜单中的project | add class module 介入一个新的类文献，并将这个类的name属性变换为apifont，而后在类的代码窗口中介入以次的代码： 　　option explicit 　　 　　private declare function selectcliprgn lib “gdi32”(byval hdc as long, byval hrgn as _ 　　long) as long 　　private declare function createrectrgn lib “gdi32”(byval x1 as long, byval y1 as _ 　　long, byval x2 as long, byval y2 as long) as long 　　private declare function settextcolor lib “gdi32”(byval hdc as long, byval crcolor as _ 　　long) as long 　　private declare function deleteobject lib “gdi32”(byval hobject as long) as long 　　private declare function createfontindirect lib “gdi32” alias “createfontindirecta” _ 　　(lplogfont as logfont) as long 　　private declare function selectobject lib “gdi32”(byval hdc as long, byval hobject as _ 　　long) as long 　　private declare function textout lib “gdi32” alias “textouta” (byval hdc as long, _ 　　byval x as long, byval y as long, byval lpstring as string, byval ncount as _ 　　long) as long 　　private declare function settextalign lib “gdi32”(byval hdc as long, byval wflags _ 　　as long) as long 　　 　　private type rect 　　 left as long 　　 top as long 　　 right as long 　　 bottom as long 　　end type 　　 　　private const ta_left = 0 　　private const ta_right = 2 　　private const ta_center = 6 　　private const ta_top = 0 　　private const ta_bottom = 8 　　private const ta_baseline = 24 　　 　　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 as string ＊ 50 　　end type 　　 　　private m_lf as logfont 　　private newfont as long 　　private orgfont as long 　　public sub charplace(o as object, txt＄, x, y) 　　 dim throw as long 　　 dim hregion as long 　　 dim r as rect 　　 　　 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) 　　end sub 　　public sub setalign(o as object, top, baseline, bottom, left, center, right) 　　 dim vert as long 　　 dim horz as long 　　 　　 if top = true then vert = ta_top 　　 if baseline = true then vert = ta_baseline 　　 if bottom = true then vert = ta_bottom 　　 if left = true then horz = ta_left 　　 if center = true then horz = ta_center 　　 if right = true then horz = ta_right 　　 settextalign o.hdc, vert or horz 　　end sub 　　public sub setcolor(o as object, cvalue as long) 　　 dim throw as long 　　 　　 throw = settextcolor(o.hdc, cvalue) 　　end sub 　　public sub selectorg(o as object) 　　 dim throw as long 　　 　　 newfont = selectobject(o.hdc, orgfont) 　　 throw = deleteobject(newfont) 　　end sub 　　public sub selectfont(o as object) 　　 newfont = createfontindirect(m_lf) 　　 orgfont = selectobject(o.hdc, newfont) 　　end sub 　　public sub fontout(text＄, o as control, xx, yy) 　　 dim throw as long 　　 　　 throw = textout(o.hdc, xx, yy, text＄, len(text＄)) 　　end sub 　　 　　public property get width() as long 　　 width = m_lf.lfwidth 　　end property 　　 　　public property let width(byval w as long) 　　 m_lf.lfwidth = w 　　end property 　　 　　public property get height() as long 　　 height = m_lf.lfheight 　　end property 　　 　　public property let height(byval vnewvalue as long) 　　 m_lf.lfheight = vnewvalue 　　end property 　　 　　public property get escapement() as long 　　 escapement = m_lf.lfescapement 　　end property 　　 　　public property let escapement(byval vnewvalue as long) 　　 m_lf.lfescapement = vnewvalue 　　end property 　　 　　public property get weight() as long 　　 weight = m_lf.lfweight 　　end property 　　 　　public property let weight(byval vnewvalue as long) 　　 m_lf.lfweight = vnewvalue 　　end property 　　 　　public property get italic() as byte 　　 italic = m_lf.lfitalic 　　end property 　　 　　public property let italic(byval vnewvalue as byte) 　　 m_lf.lfitalic = vnewvalue 　　end property 　　 　　public property get underline() as byte 　　 underline = m_lf.lfunderline 　　end property 　　 　　public property let underline(byval vnewvalue as byte) 　　 m_lf.lfunderline = vnewvalue 　　end property 　　 　　public property get strikeout() as byte 　　 strikeout = m_lf.lfstrikeout 　　end property 　　 　　public property let strikeout(byval vnewvalue as byte) 　　 m_lf.lfstrikeout = vnewvalue 　　end property 　　 　　public property get facename() as string 　　 facename = m_lf.lffacename 　　end property 　　 　　public property let facename(byval vnewvalue as string) 　　 m_lf.lffacename = vnewvalue 　　end property 　　 　　private sub class_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) 　　end sub 　　在工程文献的form第11中学介入一个picturebox和一个commandbutton控件，而后在form1的代码窗口中介入以次的代码： 　　option explicit 　　 　　dim af as apifont 　　dim x, y as integer 　　 　　private sub command1_click() 　　 dim i as integer 　　 　　 set af = nothing 　　 set af = new apifont 　　 picture2.cls 　　 for i = 0 to 3600 step 360 　　 af.escapement = i 　　 af.selectfont picture2 　　 x = picture2.scalewidth / 2 　　 y = picture2.scaleheight / 2 　　 '在字符串反面要介入7个空格 　　 af.fontout “电脑商谍报第42期 ”, picture2, x, y 　　 af.selectorg picture2 　　 next i 　　end sub 　　 　　private sub form_load() 　　 picture2.scalemode = 3 　　end sub 　　运路途序，点击form上的command1按钮，在窗口的图片框就会展示回旋的文本表露，步调的功效如图所示： 　　犯得着提防的题目是，因为windows的动静贯穿库的中英文本子的联系，在少许体例中表露华文大概会有少许题目，大师大概看到，上头步调中的语句：af.fontout “脑商谍报第42期”，picture2, x, y中的字符串反面有7个空格，这是对于“电脑商谍报第42期”中的7其中笔墨符，华文体例计划的是7个字符，然而本质它们吞噬的是14个字节的空间，以是在输入时要在反面增添7个空格做“替人”。上头的步调在华文win98，vb6下运转经过。