Rotating and Stretching Text 2

[MrVB50au]

I've been searching the forum for a few days before I asked this question and it appears that there are simular answers but not what I'm looking for. So, here I am again.
QUESTION:
Is there a way of rotating a labels control 90 degrees and no matter what text is inserted, the label control will keep it's size but just stretch the text to fit?

I'd really appriciate any suggestions please.

Thanks.

 

[strongm]

My starting point woud be my rotation code in thread222-537164

 

[MrVB50au]

Nope, I had the same problem as some of the others on that thread. Nothing Happened!

Thanks anyway.

 

[strongm]

>"some of the others"

One person appeared to have a problem...

Given that

a) the code is basically an extract from a freeware application that is running on several thousands of machines around the world on W95 through to XP (it may be possible that it is running on a W2003 box, but I've had no email confirming that); and

b) this is a pretty standard way of rotating text under Windows

I'm surprised that any finds the example it isn't working.

Of course,if the example is being dropped into already existing code or is being modified before use, then who knows what might happen. For example, if you're doing anything like a Form1.Refresh after drawing the rotated text on a .AutoRedraw=False form, then you'll never actually see the text....

 

[MrVB50au]

I didn't touch the code what so ever, simply copied and pasted the code you placed on the thread into a form and all that came up was the word HELLO, that's it.

Here are the Steps I took:

1. Started a New Project

2. Copied the code and pasted it.

3. placed a command1 on the form

4. ran the project and clicked the button.

5. HELLO was displayed.

END.

No rotation at all, sorry but did I miss something?

Thanks again.

 

[Gwena]

This program is taken form

http://www.dr-vb.co.il

It not exaclty what you need but very close
On the Form:
PictureBox Named picDest with AutoRedraw=true
ComboBox Named cmbFontName
TextBoxs Named txtText,txtDegree,txtFontSize
In txtDegree enter degrees for rotating, In txtText the text, In txtFontSize the font size

Try all kind of fonts, some of them don't work

The code:
Option Explicit


Const LF_FACESIZE = 32

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 As String * LF_FACESIZE
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

Sub RotateFont(Dest As Object, Text As String, X As Single, Y As Single, degree As Integer, fontName As String, fontSize As Integer, iColor As Long)
Dim LFont As LOGFONT
Dim prevFont As Long, hFont As Long

With LFont
.lfEscapement = degree * 10 'L ÷áéòú æååéú äñéáåá
.lfFaceName = fontName & Chr$(0) 'L ÷áéòú äâåôï
.lfHeight = (fontSize * -20) / Screen.TwipsPerPixelY 'L ÷áéòú âåãì äâåôï
End With

hFont = CreateFontIndirect(LFont)
prevFont = SelectObject(Dest.hdc, hFont)

Dest.CurrentX = X
Dest.CurrentY = Y
Dest.ForeColor = iColor 'L öáò äâåôï
Dest.Print Text 'L äè÷ñè ìöéåø

' ðé÷åé äàåáéé÷è äðåöø îäæëøåï
SelectObject Dest.hdc, prevFont
DeleteObject hFont
End Sub


Private Sub Form_Load()
Dim i As Integer

For i = 1 To Screen.FontCount - 1
cmbFontName.AddItem Screen.Fonts(i)
Next
cmbFontName.ListIndex = 17
End Sub

Private Sub picDest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
txtDegree.Text = CInt(txtDegree.Text)
If Err <> 0 Then txtDegree.Text = 90

On Error Resume Next
txtFontSize.Text = CInt(txtFontSize.Text)
If Err <> 0 Then txtFontSize.Text = 90
If CInt(txtFontSize.Text) > 100 Then txtFontSize.Text = 100

RotateFont picDest, _
txtText.Text, _
X, Y, _
CLng(txtDegree.Text), _
cmbFontName.Text, _
CInt(txtFontSize.Text), _
Me.ForeColor
End Sub

 

[strongm]

No, but I did. Sorry.

Basically the function requires a null-terminated string as the facename to work reliably. In the original program this is done by the calling function, whereas in this extract I have hardcoded the Facename - but forgotten the null terminator.

So, change

myFont.lfFaceName = "Arial"

to

myFont.lfFaceName = "Arial" + Chr(0)

This should fix the problem you are seeing. On a final note, it only works for TT fonts.

 

[MrVB50au]

OK People thanks for all your help by the way strongm I got it to work and thanks for the additional code Gwena very much appreciated.

I just so happened to stumble across a demo in PSC. When searching there Type: Rotate Label and of cause in Visual Basic Categ' if you want to download the first, this has got the v1 next to it.

I just downloaded a demo from PSC it has it's own ActiveX Control (NOT COMPILED THO') when trying to compile to an ocx you'd need to comment out this line:

Set m_Font = .ReadProperty("Font", "Arial")

Thanks again for all your help, very much valued, here have a couple of stars guys.

P.S Gwena You wanna teach me Hebrew so I can understand what the heck they're talking about? LOL

 

[MrVB50au]

OK, Looks like I was wrong! Back to the drawing bord again I guess

control I downloaded doesn't seem to want to do anything when Double Clicking it in Run Mode

I set the borderstyle to 1 whenever I double click it but nothing happens.

apparently this was not a proper label control that I could use.

Even tho' in the previous posts you guys did give me some great code, I still need to find a way to do this with a LABEL CONTROL. is there a way that this can be achieved or am I barking up the wrong tree? the background must be transparent as there's a background picture behind the text.

Thanks again for your time.

 

[Gwena]

MrVB50au,
Anytime you need to curse someone, do it in Hebrew. It's funnier.

 

[strongm]

Loathe though I am to say something cannot be done...you cannot do what you are asking with a label control, not least becaue it has no hWnd or hDC of it's own.

 

[MrVB50au]

OK, I believe that there's a way to make a picturbox transparent. Having said that, would I be able to manipulate the text in the picturebox, when double clicking on the text in the picturebox the picture boxs' borderstyle = 1, a text box gathering the text from the picturebox pops up with the text shown in it? And while typing some text into the textbox it will automatically change in the picturebox as well?

Would this do the job?

Thank you once again for you valued help.

 

[strongm]

But you've been given almost everything you need already.
Look, here's a (very) minor variant of my original code. You'll need to add a lable to the form, set it to the font face you want, and put the text you want in the label's tag:

Option Explicit

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Private Const LF_FACESIZE = 32

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 As String * 32
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

' Poor method of determining the required fontsize, but it'll do for a demo
Private Function ResizeFontToClosestFitInLabel(lblTarget As Label) As Single
    Dim OldFontSize As Single
    Dim lp As Single
    
    For lp = 0.1 To 1000 Step 0.1
        lblTarget.Parent.FontSize = lp
        If lblTarget.Parent.TextWidth(lblTarget.Tag) >= lblTarget.Width Or lblTarget.Parent.TextHeight(lblTarget.Tag) >= lblTarget.Height Then
            Exit For
        End If
    Next
    
    ResizeFontToClosestFitInLabel = lp
End Function

Private Sub Command1_Click()
    ResizeFontToClosestFitInLabel Label1
    
    Dim myFont As LOGFONT
    Dim hFont As Long
    Dim hOldFont As Long
    Dim OldGraphicsMode As Long

    Form1.AutoRedraw = True

    myFont.lfFaceName = Label1.Font.Name + Chr(0)
    myFont.lfHeight = -ResizeFontToClosestFitInLabel(Label1)  ' font size
    myFont.lfEscapement = -2700 ' Rotation in tenths of a degree
    myFont.lfOrientation = -2700 ' orientation in tenths of a degree. Frankly irrelvant unless graphics mode is GM_ADVANCED
    
    hFont = CreateFontIndirect(myFont)
    hOldFont = SelectObject(Form1.hdc, hFont)
    Form1.CurrentY = Label1.Top
    Form1.CurrentX = Label1.Left

    Form1.Print Label1.Tag

    ' Clean up
    SelectObject Form1.hdc, hOldFont
    DeleteObject hFont

    Form1.AutoRedraw = False
End Sub

 

[Gwena]

To make a long story short...
Here is the link for the program on

http://www.dr-vb.co.il

download it...The instractions are in Hebrew, so after running the program change the text in the top textbox to something in English and you can see how it works for yourself

http://www.dr-vb.co.il/dws.php?id=212

 

[strongm]

Gwena, have you actually read any of the rest of this thread apart from the orginal question? The code you keep referring to is to all intents and purposes exactly the same as the code I originated. It doesn't appear to bring anything new to the solution, or am I missing something?

 

[Gwena]

Forgive me your royal highness if I’d upset you or something… I merely wanted to MrVB50au to download my code directly from the site because it seams I’d forgotten a few things…That’s all

 

[strongm]

I think you are missing my point, which is that your code (whether as posted here in the thread, or downloaded from the site) does not appear to add anything to the solution already presented. If it does, then tell me what; I'm happy to be corrected.

 

[MrVB50au]

thank you both very very muchly, your help has helped me to understand a lot of thing, please don't think me of a pest, I'm still learning and have got a lot to learn yet and still don't know too much.
I know sometimes I can be very trying so please bare with me if I get things wrong. I really appreciate all your help that had been given and its not going in vain. I am using as much as I can do get the things I'm trying to do done.

Thanks heaps guys, I really do appreciate it.