Rotating label / Text Orientation in VBA

[nadzri]

Hi all,

Just wondering, how do you rotate a label or orientate a text vertically in a VBA userform?

Tq...

Nadz

[Andrew Poulsom]

There is no direct way. You may be able to achieve the effect you want by having a tall narrow label and setting its WordWrap property to True.

[nadzri]

Hi Andrew,

Thank for your reply, but is there a way to orientate the text as well?

[Andrew Fergus]

Hi Nadz

I haven't seen this done (or tried it) in VBA but I did in VB6 recently by following this snippet of code here:

http://www.a1vbcode.com/snippet-3401.asp

To get this to work, you actually display the text in a picture box, not a text box or a label (assuming you are using a form).

You might want to see if you can adapt that code for what you want (the coding in VB6 is just about identical to VBA).

HTH, Andrew

[nadzri]

Hi Andrew,

thanks for the snippet link.

I actually tought about that, but i only have a code that refer to a file in the hard disk:

image1.Picture = _
LoadPicture("C:\My Documents\My Pictures\Nadzri.jpg")

I need to send this file to multiple recipient, if they were to copy the picture somewhere else, the code will not work. is there a code that can refer to an image inside the workbook itself?

Thanks...

[Andrew Fergus]

Hi Nadz
Maybe you misunderstood me - or I'm misunderstanding picture boxes on forms in Excel. The 'picture box' the code refers to is just an empty picture box on the form itself - the code will put the text into the empty picture box.
Andrew

[nadzri]

Hi Andrew,

My idea is to capture an image that have the word and load the image when it is required but the image have to be from within the worksheet.

By the way, still trying the code that you gave me... give me a few minutes...

cheers

[nadzri]

Hi Andrew,

i've tried few times but I cant seem to be able to run your code. it say user defined type not defined.

what should i do?

[Andrew Fergus]

Hi

The code snippet from VB6 required almost a total re-write but I did (sort of) get the following to work in Excel VBA. I didn't have to enable any unusual references. I created a form with a blank image box (Image1) and a control button (CommandButton1). There are a couple of issues (see my notes at the top of the code) and anyone please feel free to correct my code for errors / improvements. Here is the code :

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

HTH, Andrew

[Andrew Fergus]

The following fixes should be applied to get more accurate positioning of the text over the image box :

Call RotateText(Image1, strMyText, Image1.Left + (Image1.Width / 2), Image1.Height + Image1.Top)

and

xPos = ((((Me.Width - Me.InsideWidth - FONTSIZE) / 2 + Me.Left + CX) - 1) * (20 / TwipsPerPixelX))
yPos = (((Me.Height - Me.InsideHeight + Me.Top + CY - ((Me.Width - Me.InsideWidth) / 2)) - 1) * (20 / TwipsPerPixelY))

Please note this code is only useful for turning the text through angels from 0 through to about 90 degrees. I haven't adapted it for the likes of 180 or 270 degrees.

Andrew