Keskustelu: Ohjelmointikysymykset: VB6: Tekstien kallistus VB6

jtha [09.03.2011 15:42:51]

Tämä ei taida onnistua helposti, mutta kysytään kuitenkin.

Tarkoitus olisi kirjoittaa tekstiä pictureboxiin 90 astetta kääntyneenä vastapäivään.

Tämä onnistuukin googlettamalla löytyneen jutun avulla (http://support.microsoft.com/kb/154515), mutta printterin kanssa ei teksti enää käännykkään.

Olisiko parmpaa konstia takataskussa?

neau33 [12.03.2011 02:44:01]

Moikka jtha!

kyllä kääntyy...

Option Explicit

Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function MapVirtualKey Lib "user32" Alias _
"MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) 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 Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const LF_FACESIZE = 32
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2


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 Sub Form_Load()

   Picture2.Width = Picture1.Width
   Picture2.Height = Picture1.Height
   Picture2.Left = Picture1.Left
   Picture2.Top = Picture1.Top
   Picture1.ZOrder 0

End Sub

Private Sub Command1_Click()

   Dim font As LOGFONT

   Dim prevFont As Long, hFont As Long, ret As Long
   Const FONTSIZE = 10
   font.lfEscapement = 1800
   font.lfFaceName = "Arial" & Chr$(0)


   font.lfHeight = (FONTSIZE * -23) / Screen.TwipsPerPixelY
   hFont = CreateFontIndirect(font)
   prevFont = SelectObject(Picture1.hdc, hFont)
   Picture1.CurrentX = Picture1.ScaleWidth
   Picture1.CurrentY = Picture1.ScaleHeight / 2
   Picture1.Print "Rotated Text"

   ret = SelectObject(Picture1.hdc, prevFont)
   ret = DeleteObject(hFont)
   Picture1.CurrentY = Picture1.ScaleHeight / 2

   Clipboard.Clear

   Dim alt_key As Long
   Clipboard.Clear
   alt_key = MapVirtualKey(VK_MENU, 0)
   keybd_event VK_MENU, alt_key, 0, 0
   DoEvents
   keybd_event VK_SNAPSHOT, 0, 0, 0
   DoEvents
   keybd_event VK_MENU, alt_key, KEYEVENTF_KEYUP, 0
   DoEvents

   Picture2.Picture = Clipboard.GetData(vbCFBitmap)
   Printer.Print
   Printer.PaintPicture Picture2.Picture, 0, _
   0, Picture2.Width, Picture2.Height, Picture2.Left + 100, _
   Picture2.Top + 475, Picture2.Width, Picture2.Height
   Printer.EndDoc

End Sub

jtha [12.03.2011 10:28:49]

Kiitos jälleen, Nea.

Testaan golfmessujen jälkeen. Antamani linkin ohje ei toiminut ainakaan PDFCreatorin kanssa, joten hylkäsin sen (tai en osannut käyttää koodia oikein).

Antamasi koodi käyttänee leikepöytää hyväkseen. Epäilyttää, että miten kirjoittaminen kuvan päälle onnistuu, mutta testataan...

jtha [12.03.2011 10:36:45]

Testasinkin oitis:

- "Printer.PaintPicture" antaa "Invalid picture (Error 481)"

BTW: Ennen "Printer.EndDoc" käskyä pitää aina antaa "Printer.NewPage" käsky. Tämä siksi, että muuten jotku printterit jättävät tulostamisen "kesken" - sivu ei tule printteristä ulos.

neau33 [12.03.2011 11:54:49]

Moikka taas jtha!

kokeile seuraavin muutoksin...

Option Explicit

Private Declare Function CreateFontIndirect Lib _
"gdi32" Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) 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 Sub SimulateKeyboard Lib "user32" _
Alias "keybd_event" (ByVal KeyCode As Byte, _
ByVal Scan As Byte, ByVal Flags As Long, _
ByVal ExtraInfo 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 * LF_FACESIZE

End Type
Private Sub Form_Load()

   Picture2.Width = Picture1.Width
   Picture2.Height = Picture1.Height
   Picture2.Left = Picture1.Left
   Picture2.Top = Picture1.Top
   Picture1.ZOrder 0

End Sub

Private Sub Command1_Click()

   Dim font As LOGFONT

   Dim prevFont As Long, hFont As Long, ret As Long
   Const FONTSIZE = 10
   font.lfEscapement = 1800
   font.lfFaceName = "Arial" & Chr$(0)


   font.lfHeight = (FONTSIZE * -23) _
   / Screen.TwipsPerPixelY
   hFont = CreateFontIndirect(font)
   prevFont = SelectObject(Picture1.hdc, hFont)
   Picture1.CurrentX = Picture1.ScaleWidth
   Picture1.CurrentY = Picture1.ScaleHeight / 2
   Picture1.Print "Rotated Text"

   ret = SelectObject(Picture1.hdc, prevFont)
   ret = DeleteObject(hFont)
   Picture1.CurrentY = Picture1.ScaleHeight / 2

   Clipboard.Clear
   SimulateKeyboard 44, 1, 0, 0

   Dim stoptime As Single
   stoptime = Timer + 5

   Do While Clipboard.GetData(vbCFBitmap) = 0
      If Timer > stoptime Then
         MsgBox "VIRHE! Leikepöytä ei sisällä kuvadataa!" & _
         vbCrLf & vbCrLf & _
         "Käyttöjärjestelmäsi estää 'keybd_event' API-funktion käyttön."
         Exit Sub
      End If
   DoEvents: Loop

   Picture2.Picture = Clipboard.GetData(vbCFBitmap)
   Printer.Print
   Printer.PaintPicture Picture2.Picture, 0, _
   0, Picture2.Width, Picture2.Height, Picture2.Left + 100, _
   Picture2.Top + 475, Picture2.Width, Picture2.Height
   Printer.NewPage
   Printer.EndDoc

End Sub

neau33 [12.03.2011 19:48:37]

Moikka taas jtha!

yksinkertainen on kaunista eli unohda kaikki toi edellinen paska...

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 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 Sub Command1_Click()

   Dim font As LOGFONT
   Dim prevFont As Long, hFont As Long, ret As Long
   Const FONTSIZE = 10
   font.lfEscapement = 900
   font.lfFaceName = "Arial" & Chr$(0)

   font.lfHeight = (FONTSIZE * -23) _
   / Screen.TwipsPerPixelY
   hFont = CreateFontIndirect(font)
   prevFont = SelectObject(Picture1.hDC, hFont)
   Picture1.CurrentX = Picture1.ScaleWidth / 2
   Picture1.CurrentY = Picture1.ScaleHeight / 1.5
   Picture1.Print "Rotated Text"

   ret = SelectObject(Picture1.hDC, prevFont)
   ret = DeleteObject(hFont)

   Picture1.Picture = Picture1.Image
   Picture1.Refresh

   Printer.Print
   Printer.PaintPicture Picture1.Image, 0, 0
   Printer.NewPage
   Printer.EndDoc

End Sub

jtha [13.03.2011 11:25:57]

Tämä toimii :-), kiitos.

(Edellisissä esimerkeissä näytti siltä että leikepöydälle ei kopioitunut mitään)

jtha [13.03.2011 12:31:36]

:-( arvaatko mitä?

Tarkempi kokeilu osoitti, että ei pelaa ainakaan PDFCreatorin kanssa. Ongelmana on tekstin kirjoittaminen kuvien päälle. Leikattu kuva peittää kaiken alleen, tähän ei auta asetuksetkaan. Näytöllä kaikki toimii hyvin, mutta printteriajurit eivät osaa käsitellä ilmeisesti samalla tavalla.

Luovun tekstien kallistamisesta ja puhallan pelin poikki tältä osin.

Kiitos Nealle vinkistä kuitenkin !

neau33 [13.03.2011 18:39:13]

Moikka taas jtha!

eipä tulostellut tekstiä minullakaan jos nappasin kuvan pictureboxiin suoraan leikepöydältä, mutta seuraavin muutoksin onnistui...

Private Sub Command1_Click()

   '(Picture1.AutoRedraw = True)

   If Clipboard.GetData(vbCFBitmap) <> 0 Then
        SavePicture Clipboard.GetData(vbCFBitmap), "C:\temp.bmp"
        Picture1.Picture = LoadPicture("C:\temp.bmp")
   End If

   '...

Grez [13.03.2011 21:36:44]

Alkupostauksesta jäi minulle epäselväksi, että onko se kierretty teksti tarkoitus saada pictureboxiin vai tulostettua printterille?

Meinaan kyllähän tulostimelle saa tulostettua suoraan kierrettyä tekstiä, en keksi miksi se pitää kuvan kautta kierrättää.

jtha [14.03.2011 00:09:06]

Moi, Grez.

Tekstiä oli tarkoitus saada nimenomaan myös printterille printattuun sivuun lisättyä, mutta ei ole vielä onnistunut. Kuvan kautta kierrättäminen oli Nean idea ja vaikuttikin aluksi toimivalta. Ongelma esiintyi PDFCreatorin kanssa, jota käytän kuvien tekemiseen (printteriajuri PDF:fiä varten), normaalia printteriä en edes kokeillut.

Ylinnä mainitsemani Microsoftin ohje ei toteuta tekstin kiertoa printterille, kuvaruudulla toimii kylläkin. Printattava sivu sisältää tekstiä ja piirroksia sekä valokuviakin, kallistetut tekstit olisivat ohjetekstejä kaiken tämän mahdollisen päälle.

Esimerkissä http://www.jth-automaatio.fi/esimerkki.gif näkyy mahdollisesti käännettävä teksti punaisella kirjoitettuna.

Grez [14.03.2011 08:57:26]

Mikset käyttäisi tätä Microsoftin esimerkkiä suoraan tulostimelle tulostamisesta:
http://support.microsoft.com/kb/119673

jtha [14.03.2011 09:58:04]

Siksi kun ei toimi edes sen verta kuin ekassa viestissä lähettämäni linkki.

Kopsasin suoraan koodin sivulta ja tuo päätyy erroriin: "53 - file not found: GDI"

LISÄYS:
- piti olla gdi32 koodissa (vanha esimerkki Microsoftilla)

kuitenkin korjauksin tämänkin saa toimimaan näytöllä, mutta ei printtaa PDF:fään oikein.

LISÄYS 2:
-Ei toimi myöskään normaaliin printteriin !!

Grez [14.03.2011 11:11:38]

Niin, piti tietenkin laittaa linkki tuohon 32-bittiseen versioon. (Tosin miksi kukaan koodaisi VB:llä 32-bittiselle Windowsille?)

http://support.microsoft.com/kb/154515

Mutta eihän se toimi koska:
http://support.microsoft.com/kb/175535

(Tuosta löytyy myös toimiva koodiesimerkki)

neau33 [14.03.2011 11:23:35]

Heippa taas!

alan olla jokseenkin ihmeissäni...

Kokeilin neljää eri tulostinjutskaa:
Canon LASER SHOT LBP-1120
Bullzip PDF Printer
Microsoft Office Document Image Writer
Microsoft XPS Document Writer

tällä VB(6)-koodilla:

'Formilla:
'1 Picture-objekti (Picture1, BackColor=&H80000004&, Autoredraw=True)
'1 Komentopainike (Command1)
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 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 Sub Command1_Click()

   If Clipboard.GetData(vbCFBitmap) <> 0 Then
        SavePicture Clipboard.GetData(vbCFBitmap), "C:\temp.bmp"
        Picture1.Picture = LoadPicture("C:\temp.bmp")
   End If

   Dim font As LOGFONT
   Dim prevFont As Long, hFont As Long, ret As Long
   Const FONTSIZE = 10
   font.lfEscapement = 900
   font.lfFaceName = "Arial" & Chr$(0)

   font.lfHeight = (FONTSIZE * -23) _
   / Screen.TwipsPerPixelY
   hFont = CreateFontIndirect(font)
   prevFont = SelectObject(Picture1.hDC, hFont)
   Picture1.CurrentX = Picture1.ScaleWidth / 2.2
   Picture1.CurrentY = Picture1.ScaleHeight / 1.5
   Picture1.Print "Rotated Text"

   ret = SelectObject(Picture1.hDC, prevFont)
   ret = DeleteObject(hFont)
   Picture1.Picture = Picture1.Image
   Picture1.Refresh

   Printer.Print
   Printer.PaintPicture Picture1.Image, 0, 0
   Printer.NewPage
   Printer.EndDoc

End Sub

ja tulostus toimii sekä näytöllä että kaikilla neljällä tulostimella

jtha [14.03.2011 11:28:23]

Hei, Nea ja Grez

Grezin antamassa linkissä on toimiva koodi. Nyt kääntyy kaikissa printtereissäkin. (Harmi kun noita artikkeleita ei löydä aina itse)

Kiitoksia!

LISÄYS: Nea, kyllä tuokin periaatteessa toimii mutta kuva ei saa peittää muuta alleen ja näköjään fontin ulkonäkö voi heiketä myös. Testailin kyllä kuvan kautta siirtämistä mutta se ei vaikuttanut toimivalta. Itseasiassa se ei toiminut samalla tavalla kuin pictreboxissa. Kokeile kirjoittaa kaksi tekstiä ristiin, mulla ei toiminut. (tämä siksi että näet peittääkö se taustan alleen)

Grez [14.03.2011 11:53:20]

Sinänsähän kuviakin on mahdollista laittaa kirjoittimelle niin, että ne ovat "Läpinäkyviä". En tosin tiedä onnistuuko VB:n PaintPicturella. Mutta kuvaksi piirtäminen on kuitenkin mielestäni turha välivaihe joka vaan, kuten totesitkin, huonontaa tulosteeseen tulevan tekstin laatua. Lisäksi siitä on se haitta (joskus voi olla hyöty) että esimerkiksi PDF:stä ei voi kopioida tekstiä, joka on käynyt välillä kuvana.

neau33 [14.03.2011 11:57:05]

HV (eli hyvää vappua)!

Elikäs jutska ei toimi ainoastaan periaatteessa vaan PELAA MYÖS KÄYTÄNNÖSSÄ
(kokeilin tekstejä ristiin rastiin kuvalla/ilman ja pelittää)

Kindly yours

Nea Uusitalo

jtha [14.03.2011 12:38:03]

HELP! Mikä tässä menee pieleen?
"Kohde." on muualla ohjelmassa SETattu objekti, joka on joko "Picturebox1" tai "Printer" riippuen kumpaan halutaan printata. (esikatselu/printteri).
Näytöllä kaikki OK, myös Grezin esimerkki toimi kun ei printattu mitään muuta kuin esimerkin tekstit. Ennen tätä koodin kohtaa tulostetaan kaikenlaista ja tämän jälkeenkin ennen kuin päätetään tulostaminen .EndDoc käskyllä. Vaikuttanee ilmeisesti asiaan(?).
(moduulissa on tarvittavat funktiot ihan OK kuten esimerkissäkin (public tosin)
LOGFONT kuten esimerkeissä jne.)
Uusi koodi on osassa missä vaaditaan kallistamista:

Public Sub XPrint(X1, Y1, TekstiIn, Optional KallistusX10 As Integer)
  If DlgPrint.ChkDXF.Value = 1 Then
    Dim TekstiOut As String
    TekstiOut = TekstiIn
    YLisäSivunMukaan = DXFSivu * Kohde.ScaleHeight
    Dim X1d As Double, Y1d As Double, Koko As Double
    X1d = CLng(X1)
    Y1d = CLng(Kohde.ScaleHeight - Y1 - YLisäSivunMukaan - Kohde.TextHeight(TekstiOut) / 2)
    Koko = CLng(Kohde.TextHeight(TekstiOut) / 2)
    DXFLayer = "tekstit_" & Trim(Str(Koko))
    DXFText X1d, Y1d, TekstiOut, Koko
    DXFLayer = ""
    Kohde.CurrentX = X1
    Kohde.CurrentY = Y1
  ElseIf KallistusX10 <> 0 Then
    Dim lf As LOGFONT
    Dim result As Long
    Dim hOldfont As Long
    Dim hFont As Long
    lf.lfEscapement = KallistusX10
    lf.lfFaceName = Trim(Kohde.FontName) & Chr$(0)
    If Formi.SrlSivu.Tag <> "Esikatselu" Then
      lf.lfHeight = (Kohde.FontSize * -20) / Kohde.TwipsPerPixelY
      PikseliSuhdeY = Kohde.TwipsPerPixelY
      PikseliSuhdeX = Kohde.TwipsPerPixelX
    Else
      lf.lfHeight = (Kohde.FontSize * -20) / Screen.TwipsPerPixelY
      PikseliSuhdeY = Screen.TwipsPerPixelY
      PikseliSuhdeX = Screen.TwipsPerPixelX
    End If
    hFont = CreateFontIndirect(lf)
    hOldfont = SelectObject(Kohde.hdc, hFont)
    result = TextOut(Kohde.hdc, X1 / PikseliSuhdeX, Y1 / PikseliSuhdeY, TekstiIn, Len(TekstiIn))
    result = SelectObject(Kohde.hdc, hOldfont)
    result = DeleteObject(hFont)
  Else
    Kohde.CurrentX = X1
    Kohde.CurrentY = Y1
    Kohde.Print TekstiIn
  End If

Grez [14.03.2011 12:43:16]

Kuten tuolla linkittämälläni sivulla sanottiinkin, niin voit käyttää tulostamiseen joko API-kutsuja tai VB:n kutsuja, mutta ei molempia ristiin. Jos on ihan pakko käyttää VB:n toimintoja tulostuksessa, niin sitten ei oikein jää muuta keinoa kuin tehdä tekstit kuviksi ja laittaa niitä mukaan.

Itse tekisin homman C#:lla tai jos on pakko vanhalla VB:llä tehdä niin luultavasti käyttäisin pelkkiä suoria API-kutsuja sekä näytölle että kirjoittimelle tai jos tämä aiheuttaisi liian paljon työtä enkä olisi kovin ammattiylpeä niin tekisin tuolla kuvakikalla.

jtha [14.03.2011 12:51:23]

Vaihdetaan VB6 partaveitseen *#@º!

Luovun tästä kallistamisesta nyt viimeistään ihan suosiolla!

Kiitos Grez ja Nea,

Hyvää Vappua :-)

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Keskustelu: Ohjelmointikysymykset: VB6: Tekstien kallistus VB6

jtha [09.03.2011 15:42:51]

neau33 [12.03.2011 02:44:01]

jtha [12.03.2011 10:28:49]

jtha [12.03.2011 10:36:45]

neau33 [12.03.2011 11:54:49]

neau33 [12.03.2011 19:48:37]

jtha [13.03.2011 11:25:57]

jtha [13.03.2011 12:31:36]

neau33 [13.03.2011 18:39:13]

Grez [13.03.2011 21:36:44]

jtha [14.03.2011 00:09:06]

Grez [14.03.2011 08:57:26]

jtha [14.03.2011 09:58:04]

Grez [14.03.2011 11:11:38]

neau33 [14.03.2011 11:23:35]

jtha [14.03.2011 11:28:23]

Grez [14.03.2011 11:53:20]

neau33 [14.03.2011 11:57:05]

jtha [14.03.2011 12:38:03]

Grez [14.03.2011 12:43:16]

jtha [14.03.2011 12:51:23]

Vastaus