Ændre fontstørrelse

Hej.

Det tvivler jeg på du kan i VB.  Der findes programmer, hvor du kan definere dine egne TrueType fonte.  I billedbehandlings-programmer kan du stække og vride og vende vektorbaseret tekst, men det ved du selvfølgelig.

M.v.h. Jørn

Det kan lade sig gøre. Jeg har haft dl flere forskellige. Men ens for dem alle har været, at jeg ikke kunne få dem til at printe, kun til at skrive til skærmen.

hej

bare lige en utestet idé. Kunne man ikke skrive teksten til en picturebox og siden ændre skalaen på denne?

/hiks

Hiks >

Det kunne man godt men en picturebox laver fonten om til bitmapgrafik og når den så skaleres, ja så forringes kvaliteten.

Jeg ved at man kan bruge "createfont" men jeg ved ikke hvordan man gør...

Hej.

Min VB5 indeholder ikke en kommando:  Createfont, - er det underforstået at spørgsmålet vedr. VB6 eller Vb.net?
På Google kan man f.eks. ved en søgning på: createfont VB finde:
http://www.vb-helper.com/howto_text_filled_text.html

Kommer ingen dig til hjælp i tråden kan du jo prøve VB-helper o.l.

M.v.h. Jørn

Det du linker til er lidt i retning af den kode jeg har i det eksempel jeg har dl'et. Jeg har bare ikke kunne finde ud af at få det ud på printer. Jeg prøver at nærlæse dit link samt den forklaring der også er at læse...

Hej.

I eksemplet er det en picturebox, der skal modtage den genererede tekst, du må vel så indsætte printer i stedet. 

Printer.print    'vækker printeren
Printer.fontsize = 22
printer.Font = "times new roman"
Printer.print "Dette er forsøg nr. 3456"
Printer.EndDoc

Er det sådan, du vil gøre - med din "stræk-kode" indeholdt begribeligvis.

M.v.h.  Jørn

joern: "er det underforstået at spørgsmålet vedr. VB6"

Ja da!!!
Vb6 er fra forige årtusinde. Spørger man til noget der er ENDNU ældre (VB5), så bliver det præciseret. Bliver der IKKE præciseret noget, så ER det underforstået at det er VB6.

Ligesom det er underforstået, at spørgsmål i word-kategorien ikke er til word 2.0, men til word 2000/2003.

Uden at jeg ved det, vil jeg tro, at du udgør 25-50 % af alle VB5 brugere på forumet - de resterende mange hundrede bruger VB6. Vil jeg tro. Og jeg tror godt du kan begynde at forudsætte at spørgerne ikke bruger VB5

:o)

Nej, det er desværre ikke så lige til. I eksemplet styres højden på fonten sådan her:

new_font = CustomFont(250, 65, 0, 0, _
        FW_BOLD, False, False, False, _
        "Times New Roman")
    old_font = SelectObject(Printer.hdc, new_font)

Hvor 250 er højden. Længere nede skrives der til pictureboxen og der er fonten strukket til 250 pixel i højden:

  SelectObject Picture1.hdc, new_font
    BeginPath Picture1.hdc
    Picture1.CurrentX = (ScaleWidth - Picture1.TextWidth(TEXT1)) / 2
    Picture1.CurrentY = -40
    Picture1.Print TEXT1
    EndPath Picture1.hdc
    hRgn = PathToRegion(Picture1.hdc)

I pictureboxen vises fonten korrekt. Ændres 25 til f.eks. 500, ja så strækkes den i højden uden at blive bredere. Det nemmeste ville jo være, bare at skrive til printeren i stedet for. Men der kommer teksten til at stå helt normalt eller som i dit eksempel med en 22 pkt. skriftstørrelse...

Rettelse: Ændres 250 til 500

Nu har jeg fundet et eksempel hvor det virker på skærm. Er der en der kan "konvertere" det så jeg kan bruge funktionen på printeren ?

Private Sub DrawRotatedText(ByVal txt As String, _
    ByVal X As Single, ByVal Y As Single, _
    ByVal font_name As String, ByVal hgt As Long, ByVal wid As Single, _
    ByVal weight As Long, ByVal escapement As Long, _
    ByVal use_italic As Boolean, ByVal use_underline As Boolean, _
    ByVal use_strikethrough As Boolean)

Const CLIP_LH_ANGLES = 16  ' Needed for tilted fonts.
Const PI = 3.14159625
Const PI_180 = PI / 180#

Dim newfont As Long
Dim oldfont As Long

    newfont = CreateFont(hgt, wid, _
        escapement, escapement, weight, _
        use_italic, use_underline, _
        use_strikethrough, 0, 0, _
        CLIP_LH_ANGLES, 0, 0, font_name)

    ' Select the new font.
    oldfont = SelectObject(hdc, newfont)
   
    ' Display the text.
    CurrentX = X - TextWidth(txt) / 2
    CurrentY = Y - TextHeight(txt) / 2
    Print txt

    ' Restore the original font.
    newfont = SelectObject(hdc, oldfont)
   
    ' Free font resources (important!)
    DeleteObject newfont
End Sub

Private Sub Form_Load()
Const FW_NORMAL = 400  ' Normal font weight.
Const FW_BOLD = 700    ' Bold
Const FW_HEAVY = 1000  ' Extra bold
Const SKIP = 0.8
Dim X As Single
Dim Y As Single
Dim hgt As Single
Dim wid As Single

    AutoRedraw = True
    ScaleMode = vbPixels
    BackColor = RGB(89, 166, 255)
    ForeColor = vbWhite
    BackColor = vbWhite
    ForeColor = vbBlack

    hgt = 75 * 1.5
    wid = 20
    X = 200
    Y = 10
    DrawRotatedText "Visual", X, Y, _
        "Tahoma", hgt, wid, _
        FW_HEAVY, 3600, _
        False, False, False
    Y = Y + hgt * SKIP
    DrawRotatedText "Basic", X, Y, _
        "Tahoma", hgt, wid, _
        FW_HEAVY, 3600, _
        False, False, False
    Y = Y + hgt * SKIP
    DrawRotatedText "Graphics", X, Y, _
        "Tahoma", hgt, wid, _
        FW_HEAVY, 3600, _
        False, False, False
    Y = Y + hgt * SKIP
    DrawRotatedText "Programming", X, Y, _
        "Tahoma", hgt, wid, _
        FW_HEAVY, 3600, _
        False, False, False
End Sub

Det er linien her der styrer højden:

hgt = 75 * 1.5

Jeg har fundet løsningen i nedenstående eksempel:

Option Explicit

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 * LF_FACESIZE
End Type

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 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 ' or Boolean

' Print rotated text.
Private Sub cmdPrint_Click()
Const FONT_SIZE = 30
Const FONT_FACE = "Times New Roman"
Const TXT = "Here is some rotated text"

Dim printer_hdc As Long
Dim log_font As LOGFONT
Dim new_font As Long
Dim old_font As Long

    ' Initialize the printer.
    Printer.Print " "

    ' Save the hDC.
    printer_hdc = Printer.hdc

    ' Create the rotated font.
    With log_font
        .lfEscapement = 0  ' 3150
        .lfHeight = 500 '(FONT_SIZE * -20) / Printer.TwipsPerPixelY
        .lfWeight = 5000
        .lfHeight = 5000
        .lfWidth = 500
       
        ' End the font name with a vbNullChar.
        ' Thanks to Tim Rude (timrude@ hotmail.com) for finding this.
        .lfFaceName = FONT_FACE & vbNullChar
    End With
    new_font = CreateFontIndirect(log_font)

    ' Select the font.
    old_font = SelectObject(printer_hdc, new_font)

    ' Draw the text.
    TextOut printer_hdc, 500, 500, TXT, Len(TXT)

    ' Restore the original font.
    SelectObject printer_hdc, old_font
    DeleteObject new_font

    Printer.EndDoc
End Sub

Hej.

Fornemt at du stiller løsningen til rådighed.  Jeg gemmer, selv om jeg ikke hidtil har savnet denne mulighed.

M.v.h. Jørn