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
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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
Printer.Font.Size = 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_Spacing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
txt_Radial_Spacing = 30
txt_Font_Size = 10
txt_Radius_Visible = txt_Radius_Hidden / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spacing_Change()
txt_Radial_Spacing = spin_Radial_Spacing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Change()
txt_Radius_Hidden = spin_Radius.Value
txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
Program Cell15\!Stamping
Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
table
If ExtTable.RecordCount <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.RecordCount
ExtTable.MoveFirst
varRecords = ExtTable.GetRows(intRcount)
If IsNull(varRecords(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
& UCase(varRecords(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Change()
txtRotate_Hidden = spin_Rotate.Value
txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
Call Print_to_Screen
End Sub
9  2911 
On 31 Oct 2005 07:57:08 -0800, "2D Rick" <rb*******@compuserve.com>
wrote:
What happens when you try?
Without studying all your code, it seems to be using a lot of Windows
API functions that would work the same from VB6 as from Acces2003, so
chances are most of it will work just fine.
-Tom. 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?
<clip>
In taking a quick glance at the code I would say you have two issues.
1) Access does not expose a handle to a window or control's Device
Context(hDC).
2) The Access Form object does not expose any drawing methods.
If want to get the code up and running quickly then use the vbPictureBox
class on my site. It exposes a hDC and supports several drawing methods. http://www.lebans.com/imageclass.htm
--
HTH
Stephen Lebans http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"2D Rick" <rb*******@compuserve.com> wrote in message
news:11*********************@g47g2000cwa.googlegro ups.com... 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
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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
Printer.Font.Size = 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_Spacing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
txt_Radial_Spacing = 30
txt_Font_Size = 10
txt_Radius_Visible = txt_Radius_Hidden / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spacing_Change()
txt_Radial_Spacing = spin_Radial_Spacing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Change()
txt_Radius_Hidden = spin_Radius.Value
txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
Program Cell15\!Stamping
Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
table
If ExtTable.RecordCount <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.RecordCount
ExtTable.MoveFirst
varRecords = ExtTable.GetRows(intRcount)
If IsNull(varRecords(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
& UCase(varRecords(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Change()
txtRotate_Hidden = spin_Rotate.Value
txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
Call Print_to_Screen
End Sub
Thanks for the reply.
My glitch came when trying to send the output directly to the form.
I think Stephen may have a solution I'm looking at.
Any other solution are appreciated.
Rick
Thanks for the reply.
I'll look at your class, it sounds like the work around I need.
Rick
Stephen Lebans wrote: 1) Access does not expose a handle to a window or control's Device
Context(hDC).
Stephen,
Would the GetForegroundWindow API function inside the GetDC API
function allow me to get the handle of the window's device context? If
so, this could possibly allow subsequent GDI functions to draw in the
client area of the window.
James A. Fortune
Would he be better off drawing on a Report instead of a Form?
(david)
"Stephen Lebans" <ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com>
wrote in message news:eU**********************@ursa-nb00s0.nbnet.nb.ca... In taking a quick glance at the code I would say you have two issues.
1) Access does not expose a handle to a window or control's Device
Context(hDC).
2) The Access Form object does not expose any drawing methods.
If want to get the code up and running quickly then use the vbPictureBox
class on my site. It exposes a hDC and supports several drawing methods.
http://www.lebans.com/imageclass.htm
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"2D Rick" <rb*******@compuserve.com> wrote in message
news:11*********************@g47g2000cwa.googlegro ups.com... 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
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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
Printer.Font.Size = 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_Spacing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
txt_Radial_Spacing = 30
txt_Font_Size = 10
txt_Radius_Visible = txt_Radius_Hidden / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spacing_Change()
txt_Radial_Spacing = spin_Radial_Spacing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Change()
txt_Radius_Hidden = spin_Radius.Value
txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
Program Cell15\!Stamping
Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
table
If ExtTable.RecordCount <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.RecordCount
ExtTable.MoveFirst
varRecords = ExtTable.GetRows(intRcount)
If IsNull(varRecords(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
& UCase(varRecords(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Change()
txtRotate_Hidden = spin_Rotate.Value
txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
Call Print_to_Screen
End Sub
Again the same issue is that neither the Report object nor any of the Access
intrinsic controls, expose a handle to a permanent Device Context.
--
HTH
Stephen Lebans http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"david epsom dot com dot au" <david@epsomdotcomdotau> wrote in message
news:43***********************@lon-reader.news.telstra.net... Would he be better off drawing on a Report instead of a Form?
(david)
"Stephen Lebans" <ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com>
wrote in message news:eU**********************@ursa-nb00s0.nbnet.nb.ca... In taking a quick glance at the code I would say you have two issues.
1) Access does not expose a handle to a window or control's Device
Context(hDC).
2) The Access Form object does not expose any drawing methods.
If want to get the code up and running quickly then use the vbPictureBox
class on my site. It exposes a hDC and supports several drawing methods.
http://www.lebans.com/imageclass.htm
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"2D Rick" <rb*******@compuserve.com> wrote in message
news:11*********************@g47g2000cwa.googlegro ups.com... 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
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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
Printer.Font.Size = 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_Spacing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
txt_Radial_Spacing = 30
txt_Font_Size = 10
txt_Radius_Visible = txt_Radius_Hidden / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spacing_Change()
txt_Radial_Spacing = spin_Radial_Spacing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Change()
txt_Radius_Hidden = spin_Radius.Value
txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
Program Cell15\!Stamping
Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
table
If ExtTable.RecordCount <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.RecordCount
ExtTable.MoveFirst
varRecords = ExtTable.GetRows(intRcount)
If IsNull(varRecords(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
& UCase(varRecords(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Change()
txtRotate_Hidden = spin_Rotate.Value
txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
Call Print_to_Screen
End Sub
Isn't the hdc = GetDC(Me.hwnd) valid during the
format/print events? I see that pset/line are
only valid in the format/print events.
But I can't even get pset/line to work.
Just interested. This is not a work related question.
Regards
(david)
"Stephen Lebans" <ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com>
wrote in message news:bP**********************@ursa-nb00s0.nbnet.nb.ca... Again the same issue is that neither the Report object nor any of the
Access intrinsic controls, expose a handle to a permanent Device Context.
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"david epsom dot com dot au" <david@epsomdotcomdotau> wrote in message
news:43***********************@lon-reader.news.telstra.net... Would he be better off drawing on a Report instead of a Form?
(david)
"Stephen Lebans"
<ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com> wrote in
message news:eU**********************@ursa-nb00s0.nbnet.nb.ca... In taking a quick glance at the code I would say you have two issues.
1) Access does not expose a handle to a window or control's Device
Context(hDC).
2) The Access Form object does not expose any drawing methods.
If want to get the code up and running quickly then use the vbPictureBox
class on my site. It exposes a hDC and supports several drawing methods.
http://www.lebans.com/imageclass.htm
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"2D Rick" <rb*******@compuserve.com> wrote in message
news:11*********************@g47g2000cwa.googlegro ups.com...
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
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 = (dblSpacing * pi) / p
position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
Printer.Font.Size = 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_Spacing / 1000) + 0.02
Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
txt_Radial_Spacing = 30
txt_Font_Size = 10
txt_Radius_Visible = txt_Radius_Hidden / 32
sMarginX = 1
sMarginY = 1
Call Get_Data
End Sub
Private Sub spin_Radial_Spacing_Change()
txt_Radial_Spacing = spin_Radial_Spacing.Value
Call Print_to_Screen
End Sub
Private Sub spin_Radius_Change()
txt_Radius_Hidden = spin_Radius.Value
txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
Program Cell15\!Stamping
Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
table
If ExtTable.RecordCount <= 0 Then
MsgBox "There is no current data to use"
End
End If
intRcount = ExtTable.RecordCount
ExtTable.MoveFirst
varRecords = ExtTable.GetRows(intRcount)
If IsNull(varRecords(5, 0)) Then
intMdayLength = ""
Else
intMdayLength = "M" & varRecords(5, 0)
End If
s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
& UCase(varRecords(3, 0)) & " " & intMdayLength
ExtTable.Close
ExtDB.Close
End Function
Private Sub spin_Rotate_Change()
txtRotate_Hidden = spin_Rotate.Value
txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
Call Print_to_Screen
End Sub
No. Access only has the ability to return the correct hDC when that
particualr control or form has the focus.
--
HTH
Stephen Lebans http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"david epsom dot com dot au" <david@epsomdotcomdotau> wrote in message
news:43***********************@lon-reader.news.telstra.net... Isn't the hdc = GetDC(Me.hwnd) valid during the
format/print events? I see that pset/line are
only valid in the format/print events.
But I can't even get pset/line to work.
Just interested. This is not a work related question.
Regards
(david)
"Stephen Lebans" <ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com>
wrote in message news:bP**********************@ursa-nb00s0.nbnet.nb.ca... Again the same issue is that neither the Report object nor any of the
Access intrinsic controls, expose a handle to a permanent Device Context.
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"david epsom dot com dot au" <david@epsomdotcomdotau> wrote in message
news:43***********************@lon-reader.news.telstra.net... Would he be better off drawing on a Report instead of a Form?
(david)
"Stephen Lebans"
<ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com> wrote in
message news:eU**********************@ursa-nb00s0.nbnet.nb.ca...
In taking a quick glance at the code I would say you have two issues.
1) Access does not expose a handle to a window or control's Device
Context(hDC).
2) The Access Form object does not expose any drawing methods.
If want to get the code up and running quickly then use the
vbPictureBox class on my site. It exposes a hDC and supports several
drawing methods.
http://www.lebans.com/imageclass.htm
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"2D Rick" <rb*******@compuserve.com> wrote in message
news:11*********************@g47g2000cwa.googlegro ups.com...
> 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
> 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 = (dblSpacing * pi) / p
> position = pi * (txtRotate_Hidden / 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.Name = "Courier New"
> Printer.Font.Size = 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_Spacing / 1000) + 0.02
> Printer.Line (0, 0)-(0, 0), RGB(255, 255, 255), BF
> CircleText Printer, sMarginX, sMarginY, txt_Radius_Hidden / 32, s1
> ' CircleText Printer, 2, 2, txt_Radius_Hidden / 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_Spacing / 1000) + 0.02
> CircleText Me, 4, 4, txt_Radius_Hidden / 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_Hidden = 32
> txt_Radial_Spacing = 30
> txt_Font_Size = 10
> txt_Radius_Visible = txt_Radius_Hidden / 32
> sMarginX = 1
> sMarginY = 1
>
> Call Get_Data
> End Sub
>
> Private Sub spin_Radial_Spacing_Change()
> txt_Radial_Spacing = spin_Radial_Spacing.Value
> Call Print_to_Screen
> End Sub
>
> Private Sub spin_Radius_Change()
> txt_Radius_Hidden = spin_Radius.Value
> txt_Radius_Visible = Format((txt_Radius_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.Workspaces(0).OpenDatabase("S:\TRANSFER\! pics\!Stamping
> Program Cell15\!Stamping
> Program\Part_Marking_Input_2-18-03_102_bldg_2003.mdb") ' external DB
> Set ExtTable = ExtDB.OpenRecordset("tbl_Label_Data") ' external
> table
>
> If ExtTable.RecordCount <= 0 Then
> MsgBox "There is no current data to use"
> End
> End If
>
> intRcount = ExtTable.RecordCount
> ExtTable.MoveFirst
> varRecords = ExtTable.GetRows(intRcount)
>
> If IsNull(varRecords(5, 0)) Then
> intMdayLength = ""
> Else
> intMdayLength = "M" & varRecords(5, 0)
> End If
>
> s1 = UCase(varRecords(1, 0)) & " " & UCase(varRecords(2, 0)) & " "
> & UCase(varRecords(3, 0)) & " " & intMdayLength
>
> ExtTable.Close
> ExtDB.Close
>
> End Function
>
> Private Sub spin_Rotate_Change()
>
> txtRotate_Hidden = spin_Rotate.Value
> txtRotate_Visible = txtRotate_Hidden * 15 & " deg."
> Call Print_to_Screen
>
> End Sub
>
This thread has been closed and replies have been disabled. Please start a new discussion. Similar topics
by: Dennis |
last post by:
If I create a database in AccessXP-2000mode, can someone with Access2003 run it?
Do either of us have to do anything special?
Thanks!
Dennis
|
by: Lauren Quantrell |
last post by:
Hoping someonce can tell me what compatibility problems I might run
into when I have to have my Access Project developed on Access2K run
in a user environment where users are using Access2003 as...
|
by: mariantrygg |
last post by:
Hi
I have an app that uses the a2K run-time. I have just discovered that
installing this app breaks an access2003 installation causing the user
to have to repair the installation using the...
|
by: dynfax |
last post by:
When I use Access 97 with Terminal Services, and the terminal window is
minimized, the popup form displays - and when i reset the focus to the
terminal window the popup form displays.
In...
|
by: Zlatko Matić |
last post by:
Hello.
Could somebody explain the following situation:
I have a .mdb on my notebook with Windows XP SP2 and Access 2003. I prepared
..mde and tried to use it on another computer with Windows XP...
|
by: 2D Rick |
last post by:
Using Access2003 I've set up a frontend/backend app that uses a modem
triggered from the frontend.
When an operator scans a job out, the app calls the transportation
person's beeper and places the...
|
by: Vera |
last post by:
I built a class in VB.NET that has an overloaded constructor. It can either accept nothing, a string or an object
Public Sub New(
MyBase.New(
End Su
Public Sub New(ByVal strName As String...
|
by: me |
last post by:
Hello,
How do you create a snapshot/read only view of the complete data from Access2003 from a disconnected network db?
TIA
|
by: usenet |
last post by:
How and where can one find out about the basics of VB/Access2003
syntax?
I am a died in the wool C/C++/Java Linux/Unix programmer and I am
finding it difficult to understand the program format...
|
by: Charles Arthur |
last post by:
How do i turn on java script on a villaon, callus and itel keypad mobile phone
|
by: emmanuelkatto |
last post by:
Hi All, I am Emmanuel katto from Uganda. I want to ask what challenges you've faced while migrating a website to cloud.
Please let me know.
Thanks!
Emmanuel
|
by: BarryA |
last post by:
What are the essential steps and strategies outlined in the Data Structures and Algorithms (DSA) roadmap for aspiring data scientists? How can individuals effectively utilize this roadmap to progress...
|
by: nemocccc |
last post by:
hello, everyone, I want to develop a software for my android phone for daily needs, any suggestions?
|
by: Hystou |
last post by:
There are some requirements for setting up RAID:
1. The motherboard and BIOS support RAID configuration.
2. The motherboard has 2 or more available SATA protocol SSD/HDD slots (including MSATA, M.2...
|
by: Oralloy |
last post by:
Hello folks,
I am unable to find appropriate documentation on the type promotion of bit-fields when using the generalised comparison operator "<=>".
The problem is that using the GNU compilers,...
|
by: jinu1996 |
last post by:
In today's digital age, having a compelling online presence is paramount for businesses aiming to thrive in a competitive landscape. At the heart of this digital strategy lies an intricately woven...
|
by: Hystou |
last post by:
Overview:
Windows 11 and 10 have less user interface control over operating system update behaviour than previous versions of Windows. In Windows 11 and 10, there is no way to turn off the Windows...
|
by: tracyyun |
last post by:
Dear forum friends,
With the development of smart home technology, a variety of wireless communication protocols have appeared on the market, such as Zigbee, Z-Wave, Wi-Fi, Bluetooth, etc. Each...
| |
