With the help from members in the VB forum I've pieced together code
that works in VB6 to create radial text similar to "text on a path"
seen in graphics programs.(on a circle only)
I use an Access2003 app to gather the data via a barcode reader which
is then concatenated for the radial text.
Is there any possibility that this code can be converted to run in
Access2003?
Option Explicit
Dim dblSpacing As Double
Dim dblRadius As Single
Dim s1 As String
Dim sMarginX As Single
Dim sMarginY As Single
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
lfPitchAndFamil y As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function CreateFontIndir ect Lib "gdi32" _
Alias "CreateFontIndi rectA" (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 "GetTextMetrics A" (ByVal hdc As Long, _
lpMetrics As TEXTMETRIC) As Long
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeadi ng As Long
tmExternalLeadi ng As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspe ctX As Long
tmDigitizedAspe ctY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamil y As Byte
tmCharSet As Byte
End Type
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const RadToTenthDegre e 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(outD evice As Object, angle As Single)
Dim myAngle As Long
myhDC = outDevice.hdc
myAngle = angle * RadToTenthDegre e ' convert from radians
Dim log_font As LOGFONT
With log_font
.lfEscapement = myAngle
.lfOrientation = myAngle
.lfHeight = outDevice.Scale Y(outDevice.Fon t.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 = CreateFontIndir ect(log_font)
old_font = SelectObject(my hDC, 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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidd en / 12) + 3
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 cmdPrint_Click( )
Printer.Font.Na me = "Courier New"
Printer.Font.Si ze = txt_Font_Size
Select Case Val(txt_Radius_ Hidden)
Case 1 To 49
sMarginX = 2
sMarginY = 2
Case 50 To 59
sMarginX = 2.5
sMarginY = 2.5
Case 60 To 75
sMarginX = 3
sMarginY = 3
Case 76 To 100
sMarginX = 4
sMarginY = 4
End Select
' s1 = "3072670-901 LN05P123 SN050136012345 M555 "
dblSpacing = Len(s1) * (txt_Radial_Spa cing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidd en / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidd en / 32, s1
Printer.EndDoc
Call Print_to_Screen
End Sub
Public Sub Print_to_Screen ()
Me.Cls
Me.Print
Me.Font.Name = "Courier New"
Me.Font.Size = txt_Font_Size
Me.FontBold = True
' s1 = "3072670-901 LN05P123 SN050136012345 M555 "
dblSpacing = Len(s1) * (txt_Radial_Spa cing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidd en / 32, s1
DrawWidth = 5
Me.Line (1, 1.5)-(8, 1.5)
Me.Line (1, 1.5)-(1, 8)
End Sub
Private Sub Form_Activate()
Call Print_to_Screen
End Sub
Private Sub Form_Load()
txt_Radius_Hidd en = 32
txt_Radial_Spac ing = 30
txt_Font_Size = 10
txt_Radius_Visi ble = txt_Radius_Hidd en / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spa cing_Change()
txt_Radial_Spac ing = spin_Radial_Spa cing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Cha nge()
txt_Radius_Hidd en = spin_Radius.Val ue
txt_Radius_Visi ble = Format((txt_Rad ius_Hidden / 32), "0.0000")
Call Print_to_Screen
End Sub
Private Sub spin_Font_Size_ Change()
Call Print_to_Screen
End Sub
Public Function Get_Data()
Dim ExtDB As Database
Dim ExtTable As Recordset
Dim varRecords As Variant
Dim intRcount As Integer
Dim intMdayLength As String
Set ExtDB =
DBEngine.Worksp aces(0).OpenDat abase("S:\TRANS FER\!pics\!Stam ping
Program Cell15\!Stampin g
Program\Part_Ma rking_Input_2-18-03_102_bldg_200 3.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecor dset("tbl_Label _Data") ' external
table
If ExtTable.Record Count <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.Record Count
ExtTable.MoveFi rst
varRecords = ExtTable.GetRow s(intRcount)
If IsNull(varRecor ds(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecord s(1, 0)) & " " & UCase(varRecord s(2, 0)) & " "
& UCase(varRecord s(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Cha nge()
txtRotate_Hidde n = spin_Rotate.Val ue
txtRotate_Visib le = txtRotate_Hidde n * 15 & " deg."
Call Print_to_Screen
End Sub
that works in VB6 to create radial text similar to "text on a path"
seen in graphics programs.(on a circle only)
I use an Access2003 app to gather the data via a barcode reader which
is then concatenated for the radial text.
Is there any possibility that this code can be converted to run in
Access2003?
Option Explicit
Dim dblSpacing As Double
Dim dblRadius As Single
Dim s1 As String
Dim sMarginX As Single
Dim sMarginY As Single
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
lfPitchAndFamil y As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function CreateFontIndir ect Lib "gdi32" _
Alias "CreateFontIndi rectA" (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 "GetTextMetrics A" (ByVal hdc As Long, _
lpMetrics As TEXTMETRIC) As Long
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeadi ng As Long
tmExternalLeadi ng As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspe ctX As Long
tmDigitizedAspe ctY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamil y As Byte
tmCharSet As Byte
End Type
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const RadToTenthDegre e 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(outD evice As Object, angle As Single)
Dim myAngle As Long
myhDC = outDevice.hdc
myAngle = angle * RadToTenthDegre e ' convert from radians
Dim log_font As LOGFONT
With log_font
.lfEscapement = myAngle
.lfOrientation = myAngle
.lfHeight = outDevice.Scale Y(outDevice.Fon t.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 = CreateFontIndir ect(log_font)
old_font = SelectObject(my hDC, 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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidd en / 12) + 3
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 cmdPrint_Click( )
Printer.Font.Na me = "Courier New"
Printer.Font.Si ze = txt_Font_Size
Select Case Val(txt_Radius_ Hidden)
Case 1 To 49
sMarginX = 2
sMarginY = 2
Case 50 To 59
sMarginX = 2.5
sMarginY = 2.5
Case 60 To 75
sMarginX = 3
sMarginY = 3
Case 76 To 100
sMarginX = 4
sMarginY = 4
End Select
' s1 = "3072670-901 LN05P123 SN050136012345 M555 "
dblSpacing = Len(s1) * (txt_Radial_Spa cing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidd en / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidd en / 32, s1
Printer.EndDoc
Call Print_to_Screen
End Sub
Public Sub Print_to_Screen ()
Me.Cls
Me.Print
Me.Font.Name = "Courier New"
Me.Font.Size = txt_Font_Size
Me.FontBold = True
' s1 = "3072670-901 LN05P123 SN050136012345 M555 "
dblSpacing = Len(s1) * (txt_Radial_Spa cing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidd en / 32, s1
DrawWidth = 5
Me.Line (1, 1.5)-(8, 1.5)
Me.Line (1, 1.5)-(1, 8)
End Sub
Private Sub Form_Activate()
Call Print_to_Screen
End Sub
Private Sub Form_Load()
txt_Radius_Hidd en = 32
txt_Radial_Spac ing = 30
txt_Font_Size = 10
txt_Radius_Visi ble = txt_Radius_Hidd en / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spa cing_Change()
txt_Radial_Spac ing = spin_Radial_Spa cing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Cha nge()
txt_Radius_Hidd en = spin_Radius.Val ue
txt_Radius_Visi ble = Format((txt_Rad ius_Hidden / 32), "0.0000")
Call Print_to_Screen
End Sub
Private Sub spin_Font_Size_ Change()
Call Print_to_Screen
End Sub
Public Function Get_Data()
Dim ExtDB As Database
Dim ExtTable As Recordset
Dim varRecords As Variant
Dim intRcount As Integer
Dim intMdayLength As String
Set ExtDB =
DBEngine.Worksp aces(0).OpenDat abase("S:\TRANS FER\!pics\!Stam ping
Program Cell15\!Stampin g
Program\Part_Ma rking_Input_2-18-03_102_bldg_200 3.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecor dset("tbl_Label _Data") ' external
table
If ExtTable.Record Count <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.Record Count
ExtTable.MoveFi rst
varRecords = ExtTable.GetRow s(intRcount)
If IsNull(varRecor ds(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecord s(1, 0)) & " " & UCase(varRecord s(2, 0)) & " "
& UCase(varRecord s(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Cha nge()
txtRotate_Hidde n = spin_Rotate.Val ue
txtRotate_Visib le = txtRotate_Hidde n * 15 & " deg."
Call Print_to_Screen
End Sub
Comment