|
P: n/a
|
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
| |
Share this Question
|
P: n/a
|
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> | |
|
P: n/a
|
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 | |
|
P: n/a
|
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
| |
|
P: n/a
|
Thanks for the reply.
I'll look at your class, it sounds like the work around I need.
Rick
| |
|
P: n/a
|
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 | |
|
P: n/a
|
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
| |
|
P: n/a
|
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
| |
|
P: n/a
|
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
| |
|
P: n/a
|
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 discussion thread is closed Replies have been disabled for this discussion. | |  Question stats - viewed: 2543
- replies: 9
- date asked: Nov 13 '05
|
