home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / ActiveChar60765392002.psc / TextRot.bas < prev    next >
Encoding:
BASIC Source File  |  2002-03-06  |  8.7 KB  |  220 lines
  1. Attribute VB_Name = "basTextRot"
  2. Option Explicit
  3.  
  4. ' ***************************************************
  5. ' *             Text Rotation Module                *
  6. ' *                                                 *
  7. ' *  Created by: Rocky Clark (Kath-Rock Software)   *
  8. ' *                                                 *
  9. ' * This module may be used and distributed, as     *
  10. ' * is, in your code, as long as these credits and  *
  11. ' * the code itself remain unchanged.               *
  12. ' *                                                 *
  13. ' ***************************************************
  14.  
  15. Public uDisplayDescript  As Boolean      'Display description when selectable
  16.  
  17. 'API Constants:
  18. Private Const LF_FACESIZE   As Long = 32&
  19. Private Const SYSTEM_FONT   As Long = 13&
  20. Private Const ANTIALIASED_QUALITY = 4
  21.  
  22. 'Type Structures:
  23. Private Type PointAPI
  24.     X   As Long
  25.     Y   As Long
  26. End Type
  27.  
  28. Private Type SizeStruct
  29.     Width   As Long
  30.     Height  As Long
  31. End Type
  32.  
  33. Private Type LOGFONT
  34.     lfHeight            As Long
  35.     lfWidth             As Long
  36.     lfEscapement        As Long
  37.     lfOrientation       As Long
  38.     lfWeight            As Long
  39.     lfItalic            As Byte
  40.     lfUnderline         As Byte
  41.     lfStrikeOut         As Byte
  42.     lfCharSet           As Byte
  43.     lfOutPrecision      As Byte
  44.     lfClipPrecision     As Byte
  45.     lfQuality           As Byte
  46.     lfPitchAndFamily    As Byte
  47.     lfFaceName(LF_FACESIZE) As Byte
  48. End Type
  49.  
  50. 'API Declarations:
  51. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  52. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  53. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  54. Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
  55. 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
  56. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  57. 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
  58.  
  59. 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
  60.  
  61. ' ***************************************************
  62. ' *                 PrintRotText                    *
  63. ' *                                                 *
  64. ' *  Created by: Rocky Clark (Kath-Rock Software)   *
  65. ' *                                                 *
  66. ' *  Print text on an object centered on CenterX,   *
  67. ' *  CenterY and rotated by RotDegrees.             *
  68. ' *                                                 *
  69. ' * This procedure may be used and distributed, as  *
  70. ' * is, in your code, as long as these credits and  *
  71. ' * the code itself remain unchanged.               *
  72. ' *                                                 *
  73. ' ***************************************************
  74.  
  75. ' *************** I M P O R T A N T ***************
  76. ' This procedure only works for vector fonts, such
  77. ' as True Type fonts like Times New Roman. Raster
  78. ' fonts, such as MS Sans Serif or System will not
  79. ' rotate and may produce unpredictable results.
  80. ' **************************************************
  81.  
  82. 'Parameters:
  83. '
  84. 'hDC = Device context where printing will occur.
  85. '       This may be any object with an hDC (Form,
  86. '       PictureBox, UserControl, etc.)
  87. '
  88. 'Text = Text string to be printed.
  89. '
  90. 'CenterX, CenterY = Center point of text in pixels.
  91. '
  92. 'RotDegrees = Rotation amount in degrees (0.0 to 359.9999999)
  93. '   (counter-clockwise; zero = horizontal (no rotation)).
  94.  
  95. Dim bOkSoFar    As Boolean      'Flag to continue.
  96. Dim hFontOld    As Long         'Handle to original font.
  97. Dim hFontNew    As Long         'Handle to new font.
  98. Dim lfFont      As LOGFONT      'LOGFONT structure for new font.
  99. Dim ptOrigin    As PointAPI     'Point of origin for drawing text.
  100. Dim ptCenter    As PointAPI     'Center point of text.
  101. Dim szText      As SizeStruct   'Width and Height of text.
  102.  
  103.     'Get the current LOGFONT structure from the device.
  104.     'To accomplish this, first select a stock font into the
  105.     'device, which will return a handle to it's current font.
  106.     hFontOld = SelectObject(hDC, GetStockObject(SYSTEM_FONT))
  107.     
  108.     'If successful getting the font from the device...
  109.     If hFontOld <> 0 Then
  110.         
  111.         'Now get the LOGFONT structure from the font.
  112.         bOkSoFar = (GetObjectAPI(hFontOld, Len(lfFont), lfFont) <> 0)
  113.         
  114.         'Put the original font back into the device.
  115.         Call SelectObject(hDC, hFontOld)
  116.         
  117.         'Reset for use later
  118.         hFontOld = 0
  119.     End If
  120.     
  121.     'Continue only if successful getting the LOGFONT structure.
  122.     If bOkSoFar Then
  123.     
  124.         'Change the escapement and orientation of the font.
  125.         lfFont.lfEscapement = RotDegrees * 10
  126.         lfFont.lfOrientation = lfFont.lfEscapement
  127.         lfFont.lfQuality = ANTIALIASED_QUALITY
  128.         
  129.         'Now create a font object from the LOGFONT structure.
  130.         hFontNew = CreateFontIndirect(lfFont)
  131.         
  132.         'If font creation was successful...
  133.         If hFontNew <> 0 Then
  134.             
  135.             'Select the new font into the device.
  136.             hFontOld = SelectObject(hDC, hFontNew)
  137.             
  138.             'If successful selecting the new font into the device...
  139.             If hFontOld <> 0 Then
  140.                 
  141.                 'Get the size of the text in logical units (pixels).
  142.                 bOkSoFar = (GetTextExtentPoint32(hDC, Text, Len(Text), szText) <> 0)
  143.                 
  144.                 'If successful getting the size of the text...
  145.                 If bOkSoFar Then
  146.                     
  147.                     'Calculate the point of origin for the text
  148.                     'as it would be if the text was horizontal.
  149.                     With ptOrigin
  150.                         .X = CenterX - (szText.Width / 2)
  151.                         .Y = CenterY - (szText.Height / 2)
  152.                     End With
  153.                     
  154.                     'Convert CenterX, CenterY to a point structure
  155.                     '(needed for call to RotatePoint).
  156.                     With ptCenter
  157.                         .X = CenterX
  158.                         .Y = CenterY
  159.                     End With
  160.                     
  161.                     'Rotate the point of origin to match
  162.                     'the desired rotation (RotDegrees).
  163.                     Call RotatePoint(ptCenter, ptOrigin, RotDegrees)
  164.                 
  165.                     'Now Print the rotated text and return success/failure.
  166.                     PrintRotText = (TextOut(hDC, ptOrigin.X, _
  167.                       ptOrigin.Y, Text, Len(Text)) <> 0)
  168.                 
  169.                 End If
  170.                 
  171.                 'Put the original font back into the device.
  172.                 hFontNew = SelectObject(hDC, hFontOld)
  173.             
  174.             End If
  175.             
  176.             'Clean up memory by deleting the created font.
  177.             Call DeleteObject(hFontNew)
  178.         
  179.         End If
  180.         
  181.     End If
  182.             
  183. End Function
  184.  
  185. Private Sub RotatePoint(ptAxis As PointAPI, ptRotate As PointAPI, fDegrees As Single)
  186.  
  187. ' ***************************************************
  188. ' *                 RotatePoint                     *
  189. ' *                                                 *
  190. ' *  Created by: Rocky Clark (Kath-Rock Software)   *
  191. ' *                                                 *
  192. ' *  Rotate ptRotate around ptAxis, fDegrees from   *
  193. ' *  its current position.                          *
  194. ' *                                                 *
  195. ' * This procedure may be used and distributed, as  *
  196. ' * is, in your code, as long as these credits and  *
  197. ' * the code itself remain unchanged.               *
  198. ' *                                                 *
  199. ' ***************************************************
  200.  
  201. Dim fDX     As Single   'Delta X
  202. Dim fDY     As Single   'Delta Y
  203. Dim fRads   As Single   'Radians
  204. Const dPi   As Double = 3.14159265358979 'Pi
  205.  
  206.  
  207.     'Convert degrees to radians.
  208.     fRads = fDegrees * (dPi / 180#)
  209.     
  210.     'Calculate the deltas from the center point.
  211.     fDX = ptRotate.X - ptAxis.X
  212.     fDY = ptRotate.Y - ptAxis.Y
  213.     
  214.     'Rotate the point.
  215.     ptRotate.X = ptAxis.X + ((fDX * Cos(fRads)) + (fDY * Sin(fRads)))
  216.     ptRotate.Y = ptAxis.Y + -((fDX * Sin(fRads)) - (fDY * Cos(fRads)))
  217.     
  218. End Sub
  219.  
  220.