在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

zh1110

使用Direct动画控件制作旋转文字
1.工程->引用->Direct AnimationLibrary
2.窗体中加入一个DAViewerControlWindowed控件

Private Sub Form_Load()
Dim m, half, Font, clr, txtImg, pos, scl, xf, bgr
Set m = DAViewerControlWindowed1.MeterLibrary

   '创建颜色
   Set half = m.DANumber(0.5)
   Set clr = m.ColorHslAnim( _
                m.Mul(m.LocalTime, m.DANumber(0.345)), _
                half, half)

   '构造 10pt 的字体及文字
   Set Font = m.Font("ms sans serif", 10, clr)
   Set txtImg = m.StringImage("freevbcode.com", Font)

   '在页面中移动文字图形
   Set pos = m.Mul(m.Sin(m.LocalTime), m.DANumber(0.02))
   Set scl = m.Add(m.DANumber(2), m.Abs(m.Mul(m.Sin(m.LocalTime), m.DANumber(3))))
   Set xf = m.Compose2(m.Translate2Anim(m.DANumber(0), pos), _
                       m.Scale2UniformAnim(scl))
   Set txtImg = txtImg.Transform(xf)

   '旋转文字图形
   Set bgr = m.Rotate3RateDegrees(m.Vector3(1, 1, 1), 45).ParallelTransform2
   Set txtImg = txtImg.Transform(bgr)
   
   '设置动画背景并开始运行
   DAViewerControlWindowed1.BackgroundImage = m.SolidColorImage(m.Black)
   DAViewerControlWindowed1.Image = txtImg
   DAViewerControlWindowed1.Start
End Sub

allked

真的吗?

游戏之家

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
   Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Const WM_NCLBUTTONDBLCLK = &HA3
    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2
    Const MF_STRING = &H0&
    Const MF_BYCOMMAND = &H0&
      Const SC_CLOSE = &HF060
    Private hMenu As Long
    Private CloseStr As String
       Private a As Integer
   Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Type Size
        cx As Long
        cy As Long
End Type
Private Declare Function GetViewportExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As Size) As Long
Private Declare Function SetViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Size) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SCREENSAVERRUNNING = 97
Private Const SPIF_UPDATEINIFILE = &H1
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_BOTTOM = 1
Private o As Size

------------------------------
k = GetDC(0)
r = StretchBlt(k, 0, 768, 1024, -768, k, 0, 0, 1024, 768, &HCC0020)
------------------------------
SystemParametersInfo SPI_SCREENSAVERRUNNING, True, &H0, SPIF_UPDATEINIFILE
    SetWindowPos Form1.hwnd, -1, 0, 0, 430, 120, &H40
------------------------------
SystemParametersInfo SPI_SCREENSAVERRUNNING, False, &H0, SPIF_UPDATEINIFILE

zlcnkkm

神话终于回来了~顶一个

游戏之家

2003年的贴!!
不知道被谁顶上来了.......