Option Strict Off
Option Explicit On
Module basTextRot
	
	
	Public uDisplayDescript As Boolean 'Display description when selectable
	
	'API Constants:
	Private Const LF_FACESIZE As Integer = 32
	Private Const SYSTEM_FONT As Integer = 13
	Private Const ANTIALIASED_QUALITY As Short = 4
	
	'Type Structures:
	Private Structure PointAPI
		Dim X As Integer
		Dim Y As Integer
	End Structure
	
	Private Structure SizeStruct
		Dim Width As Integer
		Dim Height As Integer
	End Structure
	
	Private Structure LOGFONT
		Dim lfHeight As Integer
		Dim lfWidth As Integer
		Dim lfEscapement As Integer
		Dim lfOrientation As Integer
		Dim lfWeight As Integer
		Dim lfItalic As Byte
		Dim lfUnderline As Byte
		Dim lfStrikeOut As Byte
		Dim lfCharSet As Byte
		Dim lfOutPrecision As Byte
		Dim lfClipPrecision As Byte
		Dim lfQuality As Byte
		Dim lfPitchAndFamily As Byte
		<VBFixedArray(LF_FACESIZE)> Dim lfFaceName() As Byte
		
		'UPGRADE_TODO: 必須調用“Initialize”來初始化此結構的實例。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="B4BFF9E0-8631-45CF-910E-62AB3970F27B"”
		Public Sub Initialize()
			ReDim lfFaceName(LF_FACESIZE)
		End Sub
	End Structure
	
	'API Declarations:
	'UPGRADE_WARNING: 結構 LOGFONT 可能要求封送處理屬性作為此 Declare 語句中的參數傳遞。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"”
	Private Declare Function CreateFontIndirect Lib "gdi32"  Alias "CreateFontIndirectA"(ByRef lpLogFont As LOGFONT) As Integer
	Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Integer) As Integer
	'UPGRADE_ISSUE: 不支持將參數聲明為“As Any”。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"”
	Private Declare Function GetObjectAPI Lib "gdi32"  Alias "GetObjectA"(ByVal hObject As Integer, ByVal nCount As Integer, ByRef lpObject As Any) As Integer
	Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Integer) As Integer
	'UPGRADE_WARNING: 結構 SizeStruct 可能要求封送處理屬性作為此 Declare 語句中的參數傳遞。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"”
	Private Declare Function GetTextExtentPoint32 Lib "gdi32"  Alias "GetTextExtentPoint32A"(ByVal hDC As Integer, ByVal lpsz As String, ByVal cbString As Integer, ByRef lpSize As SizeStruct) As Integer
	Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
	Private Declare Function TextOut Lib "gdi32"  Alias "TextOutA"(ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer
	
	Public Function PrintRotText(ByVal hDC As Integer, ByVal Text As String, ByVal CenterX As Integer, ByVal CenterY As Integer, ByVal RotDegrees As Single) As Boolean
		
		
		
		Dim bOkSoFar As Boolean 'Flag to continue.
		Dim hFontOld As Integer 'Handle to original font.
		Dim hFontNew As Integer 'Handle to new font.
		'UPGRADE_WARNING: 結構 lfFont 中的數組可能需要先初始化才可以使用。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="814DF224-76BD-4BB4-BFFB-EA359CB9FC48"”
		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
			
			'UPGRADE_WARNING: 未能解析對象 lfFont 的默認屬性。 單擊以獲得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
			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(ByRef ptAxis As PointAPI, ByRef ptRotate As PointAPI, ByRef 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 * System.Math.Cos(fRads)) + (fDY * System.Math.Sin(fRads)))
		ptRotate.Y = ptAxis.Y - ((fDX * System.Math.Sin(fRads)) - (fDY * System.Math.Cos(fRads)))
		
	End Sub
End Module