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 2769
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 discussion thread is closed Replies have been disabled for this discussion. Similar topics
1 post
views
Thread by Dennis |
last post: by
|
9 posts
views
Thread by Lauren Quantrell |
last post: by
|
3 posts
views
Thread by mariantrygg |
last post: by
|
reply
views
Thread by dynfax |
last post: by
|
9 posts
views
Thread by Zlatko Matić |
last post: by
|
5 posts
views
Thread by 2D Rick |
last post: by
|
3 posts
views
Thread by Vera |
last post: by
|
reply
views
Thread by me |
last post: by
|
13 posts
views
Thread by usenet |
last post: by
| | | | | | | | | | |