Text Label drehen

[hbrauchl]

Hallo zusammen!

Ist es möglich ein Text Label in Visual Basic zu drehen?

Momentan ist es mir nur möglich Texte horizontal darzustellen.
Geht dies auch senkrecht bzw. noch besser mit Winkel?

Danke im voraus.


LG,
Hans

 

[wincnc]

Hallo
Ob das mit Labeln geht, weiss ich nicht.
Du kannst aber direkt auf die Form schreiben.

Aufruf:

Private Sub Command1_Click()
 PrintRotatedText Me, 400, 10, "Das ist ein Test", 300, 14
End Sub

In Modul:

Option Explicit

' benötigte API - Deklaration
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 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 CreateFontIndirect Lib "gdi32" _
  Alias "CreateFontIndirectA" ( _
  lpLogFont As LOGFONT) As Long

Private Declare Function MulDiv Lib "kernel32.dll" ( _
  ByVal nNumber As Long, _
  ByVal nNumerator As Long, _
  ByVal nDenominator As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hdc As Long, ByVal nIndex As Long) As Long

' Konstanten
Private Const LF_FACESIZE = 32
Private Const DEFAULT_CHARSET = 1
Private Const ANTIALIASED_QUALITY = 4
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const OUT_TT_PRECIS = 4
Private Const VARIABLE_PITCH = 2
Private Const LOGPIXELSY = 90

' FONT-Struktur
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

' Text in beliebigem Winkel ausdrucken
' z.B. auf dem Drucker oder auch in eine PictureBox
Public Sub PrintRotatedText(ByRef oPrinter As Object, _
  ByVal nPosX As Long, _
  ByVal nPosY As Long, _
  ByVal sText As String, _
  Optional ByVal nWinkel As Long = 0, _
  Optional ByVal nSize As Variant, _
  Optional ByVal bBold As Variant, _
  Optional ByVal bItalic As Variant, _
  Optional ByVal bUnderline As Variant, _
  Optional ByVal sFontName As Variant)

  Dim hdc As Long
  Dim hFontOld As Long
  Dim nRetVal As Long
  Dim hFont As Long
  Dim oFont As LOGFONT
  
  ' falls optionale Parameter nicht angegeben,
  ' Standard-Werte verwenden
  With oPrinter.Font
    If IsMissing(nSize) Then nSize = 12
    If IsMissing(bBold) Then bBold = .Bold
    If IsMissing(bItalic) Then bItalic = .Italic
    If IsMissing(bUnderline) Then bUnderline = .Underline
    If IsMissing(sFontName) Then sFontName = .Name
  End With
  
  ' Position in Pixel umrechnen
  With oPrinter
    hdc = .hdc
    nPosX = .ScaleX(nPosX, .ScaleMode, vbPixels)
    nPosY = .ScaleY(nPosY, .ScaleMode, vbPixels)
  End With

  ' Neues Font-Objekt erstellen
  With oFont
    .lfHeight = -MulDiv(nSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
    .lfEscapement = CLng(nWinkel * 10)
    .lfWeight = IIf(bBold, FW_BOLD, FW_NORMAL)
    .lfItalic = Abs(bItalic)
    .lfUnderline = Abs(bUnderline)
    .lfCharSet = DEFAULT_CHARSET
    .lfFaceName = sFontName
    .lfOutPrecision = OUT_TT_PRECIS
    .lfQuality = ANTIALIASED_QUALITY
    .lfPitchAndFamily = VARIABLE_PITCH
  End With
  hFont = CreateFontIndirect(oFont)
  hFontOld = SelectObject(hdc, hFont)
  
  ' Text ausgeben
  Call TextOut(hdc, nPosX, nPosY, sText, Len(sText))

  ' Ursprüngliche Schrift wiederherstellen
  Call SelectObject(hdc, hFontOld)

  ' Objekte zerstören
  Call DeleteObject(hFont)
End Sub

 

[hbrauchl]

Hallo!

Danke für die Antwort.

Ich würde jedoch eine Möglichkeit brauchen um das Textlabel direkt
zu drehen.

Das Textlabel Objekt soll dabei erhalten bleiben, da ich damit noch andere
Dinge anstelle (verschieben, Infos auslesen, umfärben usw.).

Danke nochmals im voraus.

LG,
Hans

 

[Orakel]

Hi zusammen,

IMHO ist das mit VB Boardmitteln nicht mögich. So nette Funktionen, wie man Sie aus Powerpoint kennt dürften nur mit großem Aufwand realisierbar sein. Was man aber mittels finden kann ist http://www.mvps.org/access/modules/mdl0048.htm , die ein OCX zum Download anbieten, dass einen Text in beliebigen Graden anzeigt. Ich bin aber überzeugt, dass es sich dabei um eine Picturebox handelt, in der nach Art des Beispiels von wincnc gearbeitet wird.

maybe it helps
Das Orakel

 

[hbrauchl]

Hallo!

Danke für Deine Hilfe.
Leider ist das nicht ganz was ich brauche.

LG,
Hans