Newsgroup: it.comp.lang.visual-basic
Titolo: Testo in verticale

Come posso scrivere con una label o similare il testo in verticale?
--
Grazie
Gabriele F.
gab...@NOSPAMtin.it
Eliminare NOSPAM per scrivere

> Come posso scrivere con una label o similare il testo in verticale?
metti questo codice in un modulo di classe, e chiamalo clsTextOut:
'*******   DICHIARAZIONI API   ********
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _
    ByVal crColor 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
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, _
    ByVal hObject 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 Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'Per il refresh
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long,
lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
'Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As
Long
Private Const RDW_INVALIDATE = &H1
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
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 * 50
End Type
'*******   FINE DICHIARAZIONE API   *******
'*******   VARIABILI -> PROPERTY   *******
Private xPos As Long
Private yPos As Long
Private Rotation As Long
Private Corsivo As Boolean
Private Sottolineato As Boolean
Private Barrato As Boolean
Private Spessore As Long
Private Altezza As Long
Private Larghezza As Long
Private Handle As Long
Private Testo As String
Private Colore As Long
Private NomeFont As String
'*******   FINE VARIABILI -> PROPERTY   *******
Private Const pi As Double = 3.14159265358979
'*********   INIZIO PROPERTY   ********
Public Property Get X() As Long
    X = xPos
End Property
Public Property Let X(ByVal StartX As Long)
    xPos = StartX
End Property
Public Property Get Y() As Long
    Y = yPos
End Property
Public Property Let Y(ByVal StartY As Long)
    yPos = StartY
End Property
Public Property Get Angle() As Long
    Angle = Rotation
End Property
Public Property Let Angle(ByVal NewAngle As Long)
    Rotation = NewAngle
End Property
Public Property Get Italic() As Boolean
    Italic = Corsivo
End Property
Public Property Let Italic(InCorsivo As Boolean)
    Corsivo = InCorsivo
End Property
Public Property Get UnderLine() As Boolean
    UnderLine = Sottolineato
End Property
Public Property Let UnderLine(Sottolineo As Boolean)
    Sottolineato = Sottolineo
End Property
Public Property Get Strike() As Boolean
    Strike = Barrato
End Property
Public Property Let Strike(ConBarra As Boolean)
    Barrato = ConBarra
End Property
Public Property Get Weight() As Long
    Weight = Spessore
End Property
Public Property Let Weight(Spessor As Long)
    Spessore = Spessor
End Property
Public Property Get Height() As Long
    Height = Altezza
End Property
Public Property Let Height(Altezz As Long)
    Altezza = Altezz
End Property
Public Property Get Width() As Long
    Width = Larghezza
End Property
Public Property Let Width(Larghezz As Long)
    Larghezza = Larghezz
End Property
Public Property Get hwnd() As Long
    hwnd = Handle
End Property
Public Property Let hwnd(Handl As Long)
    Handle = Handl
End Property
Public Property Get Text() As String
    Text = Testo
End Property
Public Property Let Text(NewText As String)
    Testo = NewText
End Property
Public Property Get Color() As Long
    Color = Colore
End Property
Public Property Let Color(NewColor As Long)
    Colore = NewColor
End Property
Public Property Get FontName() As String
    FontName = NomeFont
End Property
Public Property Let FontName(NewFontName As String)
    NomeFont = NewFontName
End Property
'**********   FINE PROPERTY   ***********
Public Sub Cls()
    RedrawWindow hwnd, ByVal 0&, ByVal 0&, RDW_INVALIDATE
End Sub
Public Sub ScriviTesto()
    Dim myLogFont As LOGFONT
    With myLogFont
        .lfEscapement = Rotation * 10
        .lfItalic = Corsivo
        .lfUnderline = Sottolineato
        .lfStrikeOut = Barrato
        .lfWeight = Spessore
        .lfHeight = Altezza
        .lfWidth = Larghezza
    End With
    Dim PX As Single, PY As Single
    Dim txtWidth As Single, txtHeight As Single
    Dim rotTxtWidth As Single, rotTxtHeight As Single
    Dim newFont As Long, oldFont As Long
    Dim retValue As Long
    Dim fontStr As String
    Dim hDC As Long
    hDC = GetDC(Handle)
    retValue = SetTextColor(hDC, Colore)
    newFont = CreateFontIndirect(myLogFont)
    oldFont = SelectObject(hDC, newFont)
    fontStr = Testo
    txtWidth = myLogFont.lfWidth * Len(fontStr)
    rotTxtWidth = txtWidth * Cos((myLogFont.lfEscapement / 10) * pi / 180)
    txtHeight = myLogFont.lfHeight
    rotTxtHeight = txtWidth * Sin((myLogFont.lfEscapement / 10) * pi / 180)
    PX = xPos
    PY = yPos
    retValue = TextOut(hDC, PX, PY, fontStr, Len(fontStr))
    newFont = SelectObject(hDC, oldFont)
    retValue = DeleteObject(newFont)
End Sub
Private Sub Class_Initialize()
    Spessore = 1
End Sub
Esempio di utilizzo:
    Dim Texter As clsTextOut
    Set Texter = New clsTextOut
    With Texter
        .hwnd = Me.hwnd
        .Angle = 90
        .Color = vbBlue
        .Text = "Faber! (:"
        .X = 100
        .Y = 100
        .ScriviTesto
    End With
    Set Texter = Nothing
Ciao
Faber