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

原创 2001年06月04日 21:19:00

在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
  在工程文件的Form1中加入一个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下运行通过。(长沙 陈锐)

VB实现文字“闪入”显示的特殊效果

 对于编程爱好者来说,开发软件过程中文字显示处理是一项很重要的内容,它的显示效果的好坏,对程序的界面效果有很大的影响,如果文字显示时能够打破陈规,有所创新,使用一些别致的方式,可以给用户耳目一新的感觉...
  • jevylau
  • jevylau
  • 2007年02月25日 10:39
  • 667

css圆圈旋转特效

css圆圈旋转特效
  • bsh_csn
  • bsh_csn
  • 2016年10月12日 10:05
  • 1072

西川善司的3D图形技术概念和渲染管线的处理

from: http://psv.tgbus.com/news/ynzx/201305/20130528094843.shtml   3D图形技术概念和渲染管线的处理 一:3D图形的...
  • smsmn
  • smsmn
  • 2014年02月13日 13:33
  • 1229

程序加载时的旋转进度圈组件

一个写得很好的旋转进度组件不错,所以转与大家一起Martin Gagne.著How to write a loading circle animation in .NET? 查看相关信息http://...
  • jackydream
  • jackydream
  • 2007年11月02日 12:28
  • 550

一个jQuery旋转特效插件

在学习过程中搜到了一个很有意思的jquery旋转特效插件。 下面先附上插件地址:jquery某大神写的旋转特效插件下面就直接来记录一下我对這个插件的结果。首先是导入,不用说,先要把主jquery导进...
  • qq_29301781
  • qq_29301781
  • 2016年04月02日 22:30
  • 467

在Unity3D中使用uGUI实现3D旋转特效

各位朋友大家好,欢迎大家关注我的博客,我是Payne,我的博客地址是http://qinyuanpei.com。最近一位朋友问我,如何在Unity引擎中实现类似《英雄联盟》中选择皮肤时的3D滚动视图效...
  • qinyuanpei
  • qinyuanpei
  • 2016年10月18日 23:42
  • 5990

使用VB去掉文本行后多余空格的技巧

 一个快捷的解决方法(希望大家能够掌握VB中的这个技巧):只修改语言文件,具体步骤如下: 1,将语言文件用UE打开,点击“列选”按钮 2,在第一列插入特殊字符,例如:“#◎#”(确保原文中不含这个特殊...
  • xust999
  • xust999
  • 2010年07月08日 23:08
  • 1270

另一种VB图像旋转的方法

一般来说,大家都会使用PlgBlt进行图像旋转,其实系统还提供了另一种旋转方式——坐标转换,为了演示使用坐标转换进行图象旋转的方法,我编了一个通用的图象旋转类,代码如下:     建立一个CDC.cl...
  • lyserver
  • lyserver
  • 2008年10月06日 20:46
  • 4291

通过VB编写UTF-8格式的文本文件

    由于系统的需要,要国际化,但是由于那些字符串和翻译都写在EXCEL表格里面,如果一个一个的复制出来,那是相当麻烦的.所以老大让我写一个转换器,从EXECEL表格中导出数据,然后写到.PO扩展名...
  • wtz1985
  • wtz1985
  • 2008年09月23日 21:02
  • 3145

OpenCV学习笔记(十二)旋转文本矫正

旋转文本矫正: 图像文本旋转通常在仿射变换时获取图像的倾斜角度,利用傅里叶变换中的时域与频域的变换关系,实现旋转文本的校正。 旋转文本的特征明显就是存在分行间隔,当文本图像旋转时,其频域中的频谱也...
  • spw_1201
  • spw_1201
  • 2016年12月13日 13:47
  • 3687
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:在VB中建立司旋转的文本特效
举报原因:
原因补充:

(最多只允许输入30个字)