textrot.bas

The most perfect bubble.rar

Attribute VB_Name = "basTextRot"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2008/07/23
'描    述：支持换肤动画特效图表源代码
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
'

Option Explicit

' ***************************************************
' *             文本旋转模块                        *
' *                                                 *
' ***************************************************

Public uDisplayDescript  As Boolean      '选中时显示详细描述

'API 常数:
Private Const LF_FACESIZE   As Long = 32&
Private Const SYSTEM_FONT   As Long = 13&
Private Const ANTIALIASED_QUALITY = 4

'结构类型:
Private Type PointAPI
    X   As Long
    Y   As Long
End Type

Private Type SizeStruct
    Width   As Long
    Height  As Long
End Type

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

'API 声明:
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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SizeStruct) 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


'*************************************************************************
'**函 数 名：PrintRotText
'**输    入：ByVal hDC(Long)          -
'**        ：ByVal Text(String)       -  要打印的文字
'**        ：ByVal CenterX(Long)      -  X中心点的文字像素
'**        ：ByVal CenterY(Long)      -  Y中心点的文字像素
'**        ：ByVal RotDegrees(Single) -  旋转角度(0.0 至 359.9999999) 反顺时针，0=水平(不旋转)
'**输    出：(Boolean) -
'**功能描述：在一个对象上以中心X,中心Y坐标轴上以角度绘制旋转文字
'**全局变量：
'**调用模块：
'*************************************************************************
Public Function PrintRotText(ByVal hDC As Long, ByVal Text As String, ByVal CenterX As Long, ByVal CenterY As Long, ByVal RotDegrees As Single) As Boolean

Dim bOkSoFar    As Boolean      '继续标识.
Dim hFontOld    As Long         '原字体句柄
Dim hFontNew    As Long         '新字体句柄
Dim lfFont      As LOGFONT      'LOGFONT 新字体结构.
Dim ptOrigin    As PointAPI     '文字绘制原点
Dim ptCenter    As PointAPI     '文字中心点.
Dim szText      As SizeStruct   '文字宽度和高度

    '从设备中得到当前 LOGFONT 结构.
    hFontOld = SelectObject(hDC, GetStockObject(SYSTEM_FONT))
    
    '如果从设备得到的字体成功...
    If hFontOld <> 0 Then
        
        '从字体获取 LOGFONT 结构
        bOkSoFar = (GetObjectAPI(hFontOld, Len(lfFont), lfFont) <> 0)
        
        '把原字体重载
        Call SelectObject(hDC, hFontOld)
        
        '复位稍后使用
        hFontOld = 0
    End If
    
    '如果成功获得 LOGFONT 结构，继续.
    If bOkSoFar Then
    
        '改变字体方向和出口
        lfFont.lfEscapement = RotDegrees * 10
        lfFont.lfOrientation = lfFont.lfEscapement
        lfFont.lfQuality = ANTIALIASED_QUALITY
        
        '从 LOGFONT 结构中创建新字体对象
        hFontNew = CreateFontIndirect(lfFont)
        
        '字体创建成功
        If hFontNew <> 0 Then
            
            'Select the ne选择新的字体到该设备
            hFontOld = SelectObject(hDC, hFontNew)
            
            '成功
            If hFontOld <> 0 Then
                
                '获取文字逻辑单位大小(像素)
                bOkSoFar = (GetTextExtentPoint32(hDC, Text, LenB(StrConv(Text, vbFromUnicode)), szText) <> 0)
                
                '成功
                If bOkSoFar Then
                    
                    '计算文字水平原点
                    With ptOrigin
                        .X = CenterX - (szText.Width / 2)
                        .Y = CenterY - (szText.Height / 2)
                    End With
                    
                    '转换 CenterX, CenterY 到点结构
                    '(需要调用 RotatePoint).
                    With ptCenter
                        .X = CenterX
                        .Y = CenterY
                    End With
                    
                    '以原点选择以匹配预期选择
                    Call RotatePoint(ptCenter, ptOrigin, RotDegrees)
                
                    '现在打印旋转文本并返回成功/失败
                    PrintRotText = (TextOut(hDC, ptOrigin.X, _
                      ptOrigin.Y, Text, LenB(StrConv(Text, vbFromUnicode))) <> 0)
                
                End If
                
                '恢复字体到原先设备
                hFontNew = SelectObject(hDC, hFontOld)
            
            End If
            
            '清除内存并删除创建的字体
            Call DeleteObject(hFontNew)
        
        End If
        
    End If
            
End Function



'*************************************************************************
'**函 数 名：RotatePoint
'**输    入：ptAxis(PointAPI)   -
'**        ：ptRotate(PointAPI) -
'**        ：fDegrees(Single)   -
'**输    出：无
'**功能描述：从前fdegrees当前坐标选择ptRotate左右的ptAxis
'**全局变量：
'**调用模块：
'*************************************************************************
Private Sub RotatePoint(ptAxis As PointAPI, ptRotate As PointAPI, fDegrees As Single)

' ***************************************************
' *                 RotatePoint                     *
' *                                                 *
' *  Created by: Rocky Clark (Kath-Rock Software)   *
' *                                                 *
' *  Rotate ptRotate around ptAxis, fDegrees from   *
' *  its current position.                          *
' *                                                 *
' * This procedure may be used and distributed, as  *
' * is, in your code, as long as these credits and  *
' * the code itself remain unchanged.               *
' *                                                 *
' ***************************************************

Dim fDX     As Single   'X坐标
Dim fDY     As Single   'Y坐标
Dim fRads   As Single   '弧度
Const dPi   As Double = 3.14159265358979  'Pi 圆周率


    '转换角度为弧度
    fRads = fDegrees * (dPi / 180#)
    
    '从中心点计算入口
    fDX = ptRotate.X - ptAxis.X
    fDY = ptRotate.Y - ptAxis.Y
    
    '旋转点
    ptRotate.X = ptAxis.X + ((fDX * Cos(fRads)) + (fDY * Sin(fRads)))
    ptRotate.Y = ptAxis.Y + -((fDX * Sin(fRads)) - (fDY * Cos(fRads)))
    
End Sub