Printing Text in a Circle Right then WRONG! Help pls.

[estatefacts]

Hello,

I got the following code off of another website. It is used to print text into a circle (and it is very nice however I wish I could figure out how to keep the orientation of the letters up in the top half of the circle and the same in the bottom half so that both sets will have an upright looking orientation instead of the bottom half being upsidedown letters).

I loaded it as a separate module into another VB6 program that I wrote to print out word processing documents and changed the command button to a public sub to call upon.

The code works well for the first printing but when I go to click again or use another procedure that uses word processing documents things go wrong.

I am using pdf995 to print out to pdf files and what it does print on subsequent tries is either the exact same output as before (wrong unlike the very first time) or I get error in the other procedures that were working fine before.

Any ideas would be very helpful.
Thanks:
David

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

Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nBkMode As Long) As Long

Private Declare Function GetTextMetrics Lib "gdi32" _
Alias "GetTextMetricsA" (ByVal hdc As Long, _
lpMetrics As TEXTMETRIC) As Long

Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const RadToTenthDegree As Single = 572.957795
Private Const pi = 3.14159
Private myhDC As Long
Private new_font As Long, old_font As Long


Private Sub RotateFont(outDevice As Object, angle As Single)
Dim myAngle As Long
myhDC = outDevice.hdc
myAngle = angle * RadToTenthDegree ' convert from radians
Dim log_font As LOGFONT
With log_font
.lfEscapement = myAngle
.lfOrientation = myAngle
.lfHeight = outDevice.ScaleY(outDevice.Font.Size * 20, vbTwips, vbPixels)
.lfFaceName = outDevice.Font.Name & vbNullChar
If outDevice.Font.Bold = True Then
.lfWeight = 700
Else
.lfWeight = 400
End If
.lfItalic = outDevice.Font.Italic
.lfUnderline = outDevice.Font.Underline
End With
new_font = CreateFontIndirect(log_font)
old_font = SelectObject(myhDC, new_font)
End Sub


Private Sub CircleText(obj As Object, x1 As Single, y1 As Single, r1 As Single, s1 As String)
' add code later to check for valid object type
Dim angle As Single, p As Long, n As Long
Dim xp As Single, yp As Single, position As Single
Dim myhDC As Long, ret As Long
Dim NewFontMetrics As TEXTMETRIC

obj.ScaleMode = vbInches
p = Len(s1)
angle = (2 * pi) / p
position = pi / 2
myhDC = obj.hdc
For n = 0 To p - 1

xp = x1 - (r1 * Sin(position))
yp = y1 - (r1 * Cos(position))
xp = obj.ScaleX(xp, vbInches, vbPixels)
yp = obj.ScaleY(yp, vbInches, vbPixels)
RotateFont obj, position
GetTextMetrics myhDC, NewFontMetrics ' << NOT obj.hdc

' Adjust for variances in font cell height between individual
' characters by lining up the baselines
xp = xp - NewFontMetrics.tmAscent * Sin(position)
yp = yp - NewFontMetrics.tmAscent * Cos(position)


ret = TextOut(myhDC, xp, yp, Mid$(s1, n + 1, 1), 1)
' change the font back and get rid of the new font
SelectObject myhDC, old_font
DeleteObject new_font
position = position - angle
Next n
End Sub
Private Sub Command1_Click()
Printer.Font.Name = "Arial"
Printer.Font.Size = 6
' set to FontTransparent = False just for test purposes so
' that we can see the actual top left corner of each
' character block (note we use SetBkMode instead of using
' the Me.FontTransparent property becase the
' FontTransparent property has some odd behaviour when
' printing rotated text characters)
SetBkMode Printer.hdc, OPAQUE
Printer.ForeColor = vbBlack
' draw a light grey rectangle just for test purposes
Printer.FillStyle = vbFSSolid
Printer.Line (0, 0)-(8, 8), RGB(255, 255, 255), BF
Printer.FillStyle = vbFSTransparent
Dim s1 As String
s1 = "IS THIS TEXT PRINTED CORRECTLY OR IS IT NOT "
CircleText Printer, 4, 4, 0.7, s1
Printer.EndDoc
End Sub

 

[chiph]

You probably need to think of it not as a whole circle, but has two half-circles, with half the text in one, and the remaining half in the other.

So instead of going to 2 * pi, you'd go to pi twice.
Chip H.


____________________________________________________________________
If you want to get the best response to a question, please read FAQ222-2244 first

 

[estatefacts]

Thanks I will look at using pi twice; but that doesn't answer my main concern. Is there anything in the code which would cause the printer to not reset (I don't know if that is the right term) but the output becomes wierd after the first run.

Thanks
David

 

[Golom]

Just as a test I took your code and switched the device to a form. Everything seems to be OK on successive runs except that the form background color changes from the default (vbButtonFace) to white. Specifically, what are the symptoms that you are seeing?

As to upright text ... well ...
A small change to your code will rotate the characters in the bottom half of the circle so that they are upright. The problem is that we are accustomed to reading left-to-right so things at the bottom of the circle appear to be backwards because the last letter in a word is now the left-most character.

 

[dglienna]

You could also use PDFCreator programmatically, or CutePDF, which prints the same filename/location each time, once it is set up once (unless you change it)

-David
2006 Microsoft Valueable Professional (MVP)
2006 Dell Certified System Professional (CSP)

 

[macropod]

Hi estatefacts,

Since you're using cutepdf, you've got a postscript driver. In that case, you could simply use vba to output generic postscript code. See 'Program 10 - Circular Text' in the "PostScript Language Tutorial and Cookbook" (aka the Blue Book), available as an 850K PDF you can download from:

http://www-cdf.fnal.gov/offline/PostScript/BLUEBOOK.PDF

The code there also adjusts the kerning to take account of the effcts of rotating the text on readability.

You can even implement prostcript code such as the bluebook code referred to above directly in a Word document by incorporating it into a PRINT field.

Even if you decide not to go down that path, the poscript code should help you work out how to implement the process in vba

Cheers

 

[dglienna]

You can also look at code from

http://www.allapi.net

to find code for circular text, that allows you to change the orientation for each string. It'd be easy to switch it to either right-side up, or upside-down, if that's what you want.

If you need a link, just ask

-David
2006 Microsoft Valueable Professional (MVP)
2006 Dell Certified System Professional (CSP)