Atlanta Custom Software Development 

 
   Search        Code/Page
 

User Login
Email

Password

 

Forgot the Password?
Services
» Web Development
» Maintenance
» Data Integration/BI
» Information Management
Programming
  Database
Automation
OS/Networking
Graphics
Links
Tools
» Regular Expr Tester
» Free Tools

Rotator - A class for printing rotated text to screen or the printer

Total Hit ( 3089)

Rate this article:     Poor     Excellent 

 Submit Your Question/Comment about this article

Rating


 


Click here to copy the following block
' ----------------------------------------
' The Rotator class module
'
' A class for printing rotated text to a
' Form, PictureBox or the Printer
'
' Author: Timm Dickel (Tim.Dic@t-online.de)
'
' ----------------------------------------
' Usage:
'   Dim rotTest As New Rotator
'   Set rotTest.Device = Printer
'   ' set all font attributes as required, e.g.
'   Printer.Font.Size = 12
'   'Label strings at a variety of angles
'   For nA = 0 To 359 Step 15
'    rotTest.Angle = nA
'    rotTest.PrintText Space(10) & Printer.Font.Name & Str(nA)
'   Next
'   Printer.EndDoc
'
' ----------------------------------------

Option Explicit

'API constants
Private Const LF_FACESIZE = 32
Private Const LOGPIXELSY = 90

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 - 1) As Byte
End Type

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
  ByVal hObject 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 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long

'Module-level private variables
Private mobjDevice As Object
Private mfSX1 As Single
Private mfSY1 As Single
Private mfXRatio As Single
Private mfYRatio As Single
Private lfFont As LOGFONT
Private mnAngle As Integer

'~~~Angle
Property Let Angle(nAngle As Integer)
  mnAngle = nAngle
End Property
Property Get Angle() As Integer
  Angle = mnAngle
End Property

'~~~PrintText
Public Sub PrintText(sText As String)
  Dim lFont As Long
  Dim lOldFont As Long
  Dim lRes As Long
  Dim byBuf() As Byte
  Dim nI As Integer
  Dim sFontName As String
  Dim mobjDevicehdc As Long
  Dim mobjDeviceCurrentX As Single
  Dim mobjDeviceCurrentY As Single
  
  mobjDevicehdc = mobjDevice.hdc
  mobjDeviceCurrentX = mobjDevice.CurrentX
  mobjDeviceCurrentY = mobjDevice.CurrentY
  
  'Prepare font name, decoding from Unicode
  sFontName = mobjDevice.Font.Name
  byBuf = StrConv(sFontName & Chr$(0), vbFromUnicode)
  For nI = 0 To UBound(byBuf)
    lfFont.lfFaceName(nI) = byBuf(nI)
  Next nI
  
  'Convert known font size to required units
  lfFont.lfHeight = mobjDevice.Font.Size * GetDeviceCaps(mobjDevicehdc, _
    LOGPIXELSY) \ 72
  
  'Set Italic or not
  If mobjDevice.Font.Italic = True Then
    lfFont.lfItalic = 1
  Else
    lfFont.lfItalic = 0
  End If
  'Set Underline or not
  If mobjDevice.Font.Underline = True Then
    lfFont.lfUnderline = 1
  Else
    lfFont.lfUnderline = 0
  End If
  'Set Strikethrough or not
  If mobjDevice.Font.Strikethrough = True Then
    lfFont.lfStrikeOut = 1
  Else
    lfFont.lfStrikeOut = 0
  End If
  'Set Bold or not (use font's weight)
  lfFont.lfWeight = mobjDevice.Font.Weight
  'Set font rotation angle
  lfFont.lfEscapement = CLng(mnAngle * 10#)
  lfFont.lfOrientation = lfFont.lfEscapement
  
  'Build temporary new font and output the string
  lFont = CreateFontIndirect(lfFont)
  lOldFont = SelectObject(mobjDevicehdc, lFont)
  lRes = TextOut(mobjDevicehdc, XtoP(mobjDeviceCurrentX), _
    YtoP(mobjDeviceCurrentY), sText, Len(sText))
  lFont = SelectObject(mobjDevicehdc, lOldFont)
  DeleteObject lFont
End Sub

'~~~Device
Property Set Device(objDevice As Object)
  Dim fSX2 As Single
  Dim fSY2 As Single
  Dim fPX2 As Single
  Dim fPY2 As Single
  Dim nScaleMode As Integer
  Set mobjDevice = objDevice
  With mobjDevice
    'Grab current scaling parameters
    nScaleMode = .ScaleMode
    mfSX1 = .ScaleLeft
    mfSY1 = .ScaleTop
    fSX2 = mfSX1 + .ScaleWidth
    fSY2 = mfSY1 + .ScaleHeight
    'Temporarily set pixels mode
    .ScaleMode = vbPixels
  '  .ScaleMode = vbMillimeters
    'Grab pixel scaling parameters
    fPX2 = .ScaleWidth
    fPY2 = .ScaleHeight
    'Reset user's original scale
    If nScaleMode = 0 Then
      mobjDevice.Scale (mfSX1, mfSY1)-(fSX2, fSY2)
    Else
      mobjDevice.ScaleMode = nScaleMode
    End If
    'Calculate scaling ratios just once
    mfXRatio = fPX2 / (fSX2 - mfSX1)
    mfYRatio = fPY2 / (fSY2 - mfSY1)
  End With
End Property

'Scales X value to pixel location
Private Function XtoP(fX As Single) As Long
  XtoP = (fX - mfSX1) * mfXRatio
End Function

'Scales Y value to pixel location
Private Function YtoP(fY As Single) As Long
  YtoP = (fY - mfSY1) * mfYRatio
End Function


Submitted By : Nayan Patel  (Member Since : 5/26/2004 12:23:06 PM)

Job Description : He is the moderator of this site and currently working as an independent consultant. He works with VB.net/ASP.net, SQL Server and other MS technologies. He is MCSD.net, MCDBA and MCSE. In his free time he likes to watch funny movies and doing oil painting.
View all (893) submissions by this author  (Birth Date : 7/14/1981 )


Home   |  Comment   |  Contact Us   |  Privacy Policy   |  Terms & Conditions   |  BlogsZappySys

© 2008 BinaryWorld LLC. All rights reserved.