Defende
|
JARINÚ
SP - BRASIL
|
|
ENUNCIADA !
|
|
|
Postada em 04/01/2007 10:11 hs
Alguem conhece alguma rotina ou funcao que faca um impressao de um texto em angulo?
Peguei uma rotina no PlanetSourCe code mas nao tem como enviar pra impressora. Eu nao queria que tivesse que jogar dentro de um picture e depois imprimir - eu gostaria que fosse direto pra impressao.
Segue o codigo abaixo:
'**************************************
'Windows API/Global Declarations for :La
' bel at an angle (full code)
'**************************************
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(LF_FACESIZE) As Byte
End Type
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'\ Getting a LOGFONT from its handle
Private Declare Function GetObjectLOGFONT _
Lib "gdi32" Alias "GetObjectA" (ByVal hObject As _
Long, ByVal nCount As Long, lpObject As LOGFONT) _
As Long
Public Enum GDIStockFonts
OEM_FIXED_FONT = 10
ANSI_FIXED_FONT = 11
ANSI_VAR_FONT = 12
SYSTEM_FONT = 13
DEVICE_DEFAULT_FONT = 14
SYSTEM_FIXED_FONT = 16
DEFAULT_GUI_FONT = 17
End Enum
Private Declare Function GetStockObject _
Lib "gdi32" (ByVal nIndex As Long) As Long
'\ Declaration
Private Declare Function TextOutApi 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
'\ Declaration
Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lpLOGFONT As LOGFONT) As Long
'**************************************
' Name: Label at an angle (full code)
' Description:Prints the text you specif
' y at the location and angle you specify.
' Straight forward stuff.
' By: Duncan Jones
'
'This code is copyrighted and has' limited warranties.Please see http://w
' ww.Planet-Source-Code.com/vb/scripts/Sho
' wCode.asp?txtCodeId=28583&lngWId=1'for details.'**************************************
Public Sub PrintTextAtAnAngle(ByVal frmIn As Form, ByVal Angle As Long, ByVal xPos As Long, ByVal yPos As Long, ByVal Text As String)
Dim lfNew As LOGFONT
Dim hNewFont As Long
Dim hOldFont As Long
Dim lRet As Long
'\ Make the angled font
Call GetCurrentLogFont(frmIn, lfNew)
lfNew.lfEscapement = (Angle * 10)
hNewFont = CreateFontIndirect(lfNew)
'\ Select the angled font
hOldFont = SelectObject(frmIn.hdc, hNewFont)
'\ print the text
lRet = TextOutApi(frmIn.hdc, xPos, yPos, Text, Len(Text))
'\ Reselect the previous font
hNewFont = SelectObject(frmIn.hdc, hOldFont)
End Sub
Private Sub GetCurrentLogFont(ByVal frmIn As Form, lfIn As LOGFONT)
Dim lNewFont As Long
Dim lOldFont As Long
Dim lRet As Long
'\ get the current font's handle
lOldFont = SelectObject(frmIn.hdc, GetStockObject(ANSI_FIXED_FONT))
'\ Select it back in to prevent the act
' ual font being wrongly changed
lNewFont = SelectObject(frmIn.hdc, lOldFont)
lRet = GetObjectLOGFONT(lOldFont, Len(lfIn), lfIn)
End Sub
'\ Example of use....
Private Sub Command1_Click()
Call PrintTextAtAnAngle(Me, 45, 100, 100, "Merrion Computing Ltd")
End Sub
|
|
|
|
|
|
kerplunk
|
SÃO PAULO
SP - BRASIL
|
|
|
ENUNCIADA !
|
|
|
Postada em 04/01/2007 16:46 hs
Direto para a impressora não vai ser possível... vai ter que ser jogar pra dentro de um image ou picture e depois imprimir.
|
|
|
|
|
|
Postada em 04/01/2007 17:49 hs
Resolvido.
Pra quem quiser esta ai o codigo. Nao eh meu e nao tinha quem fez entao nao vou pegar os meritos para mim ok.
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
Private Sub RotatedText(textstring As String, angle As Long)
' Prints rotated text at the current printer x and y
' coordinates at a specified angle (in tenths of a degree
' in an anti clockwise direction (zero is normal text)
Dim MyHdc As Long
Dim oldmode As Long, xpix As Long, ypix As Long
Dim log_font As LOGFONT
Dim new_font As Long, old_font As Long
With Printer
xpix = .ScaleX(.CurrentX - .ScaleLeft, .ScaleMode, vbTwips)
ypix = .ScaleY(.CurrentY - .ScaleTop, .ScaleMode, vbTwips)
MyHdc = .hdc ' get the Printer.hDC and save it to a variable
End With
With log_font
.lfEscapement = angle
.lfHeight = (Printer.Font.Size * -20) / Printer.TwipsPerPixelY
.lfFaceName = Printer.Font.Name & vbNullChar
If Printer.Font.Bold = True Then
.lfWeight = 700
Else
.lfWeight = 400
End If
.lfItalic = Printer.Font.Italic
.lfUnderline = Printer.Font.Underline
End With
new_font = CreateFontIndirect(log_font)
old_font = SelectObject(MyHdc, new_font)
TextOut MyHdc, xpix, ypix, textstring, Len(textstring)
SelectObject MyHdc, old_font
DeleteObject new_font
End Sub
Private Sub Command1_Click()
Dim angle As Long, s1 As String
Printer.ScaleMode = vbTwips
Printer.Font.Name = "Times New Roman"
Printer.Font.Size = 14
' always start every print job with a simple Print statement
Printer.Print
Printer.CurrentX = 100
Printer.CurrentY = 500
s1 = "Hello World"
'angle = 0 ' standard (no rotation)
'RotatedText s1, angle
angle = 900 ' 90 degrees anticlockwise rotation
RotatedText s1, angle
Printer.EndDoc
End Sub
Valeu
|
|
|
|
|
