textrot.bas

chart图片,统计,网上下来的源代码

Attribute VB_Name = "basTextRot"
Option Explicit


Public uDisplayDescript  As Boolean      'Display description when selectable

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

'Type Structures:
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 Declarations:
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

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      'Flag to continue.
Dim hFontOld    As Long         'Handle to original font.
Dim hFontNew    As Long         'Handle to new font.
Dim lfFont      As LOGFONT      'LOGFONT structure for new font.
Dim ptOrigin    As PointAPI     'Point of origin for drawing text.
Dim ptCenter    As PointAPI     'Center point of text.
Dim szText      As SizeStruct   'Width and Height of text.

    hFontOld = SelectObject(hDC, GetStockObject(SYSTEM_FONT))
    
    If hFontOld <> 0 Then
        
        bOkSoFar = (GetObjectAPI(hFontOld, Len(lfFont), lfFont) <> 0)
        
        Call SelectObject(hDC, hFontOld)
        
        hFontOld = 0
    End If
    
    If bOkSoFar Then
        lfFont.lfEscapement = RotDegrees * 10
        lfFont.lfOrientation = lfFont.lfEscapement
        lfFont.lfQuality = ANTIALIASED_QUALITY
        
        hFontNew = CreateFontIndirect(lfFont)
        
        If hFontNew <> 0 Then
            hFontOld = SelectObject(hDC, hFontNew)
            If hFontOld <> 0 Then
                bOkSoFar = (GetTextExtentPoint32(hDC, Text, Len(Text), szText) <> 0)
                
                If bOkSoFar Then
                    With ptOrigin
                        .X = CenterX - (szText.Width / 2)
                        .Y = CenterY - (szText.Height / 2)
                    End With
                    
                
                    With ptCenter
                        .X = CenterX
                        .Y = CenterY
                    End With
                    
                    Call RotatePoint(ptCenter, ptOrigin, RotDegrees)
                
                    PrintRotText = (TextOut(hDC, ptOrigin.X, _
                      ptOrigin.Y, Text, Len(Text)) <> 0)
                
                End If
                hFontNew = SelectObject(hDC, hFontOld)
            End If
            Call DeleteObject(hFontNew)
        End If
    End If
            
End Function

Private Sub RotatePoint(ptAxis As PointAPI, ptRotate As PointAPI, fDegrees As Single)

Dim fDX     As Single   'Delta X
Dim fDY     As Single   'Delta Y
Dim fRads   As Single   'Radians
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