Option Explicit
'*********************************************************************
'
'Written / adapted by Andrew Fergus (andrew93) 2 Nov 2006
'in response to this question :
'http://www.mrexcel.com/board2/viewtopic.php?p=1155825#1155825
'on MrExcel.com
'
'This is still in the process of being developed
'
'Known issues :
'The roatated text height is not 100% correct (assumptions made)
'The background colour is white - not sure how to change
'The choice of font colours are like the colour choices for the Model T
'No options yet for fancy text formatting
'
'Feel free to correct my code!
'
'*********************************************************************
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex 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
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Private Sub CommandButton1_Click()
Dim strMyText As String
strMyText = "Hello World"
'Image1 is the name of the image control from the form
Call RotateText(Image1, strMyText, Image1.Left + (Image1.Width / 3), Image1.Height + Image1.Top)
End Sub
Private Sub RotateText(PBCtrl As Image, disptxt As String, CX, CY)
Dim Font As LOGFONT
Dim hFont As Long, ret As Long, MyHDC As Long
Dim xPos As Long, yPos As Long
'Desired point size of font
Const FONTSIZE = 9
Font.lfEscapement = 900 ' 90-degree rotation (ie desired rotation in degrees x 10)
Font.lfFaceName = "Arial" + Chr$(0) 'only tested with true type fonts
Font.lfWeight = 50
Font.lfHeight = (FONTSIZE * -20) / TwipsPerPixelY
hFont = CreateFontIndirect(Font)
MyHDC = GetDC(0&)
ret = SelectObject(MyHDC, hFont)
xPos = (((Me.Width - Me.InsideWidth) / 2 + Me.Left + CX) * (20 / TwipsPerPixelX))
yPos = (((Me.Height - Me.InsideHeight) * 0.75 + Me.Top + CY) * (20 / TwipsPerPixelY))
'I'm having some trouble with the height position so used the 0.75 as a 'fix'
ret = TextOut(MyHDC, xPos, yPos, disptxt, Len(disptxt))
'Clean up
ret = DeleteObject(hFont)
ReleaseDC 0&, MyHDC
End Sub
Function TwipsPerPixelY() As Single
Dim lngDC As Long
lngDC = GetDC(HWND_DESKTOP)
TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
ReleaseDC HWND_DESKTOP, lngDC
End Function
Function TwipsPerPixelX() As Single
Dim lngDC As Long
lngDC = GetDC(HWND_DESKTOP)
TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
ReleaseDC HWND_DESKTOP, lngDC
End Function