Code to Convert

I have written this macro, and I have gotten a little help from this
forum, and I need some more. If macro is not written very well, don't
be surprised. Like I said, I am no expert.
The pre-requisite to this macro is that your part is modeled, and 3
reference dimension are put on the part. The problem is that I have a
few variables that I need written to the custom properties of
SolidWorks. I can write them as a decimal, but I don't know how to
write them as a fraction that rounds to the 16th.
I am posting all of my code below. Can someone please help.
=================================================================
Public Thickness As String
Public Width As String
Public Length As String
Public RW As Double
Sub Main()
Dim swApp As Object
Dim Part As Object
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
FlatPattern
SelectDims
ChgDimsToFractions
WriteEquation
HideAnnotations
DeleteCustomProps
GetDimValues
WriteCustomProps
Formed_Iso_Fit
Part.ForceRebuild
End Sub
Private Sub FlatPattern()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Flat-Pattern1",
"BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
Part.ClearSelection2 True
Part.SetBendState 2
boolstatus = Part.EditRebuild3
End Sub
Private Sub SelectDims()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("RD3@Annotations@DS
TEST.moPart_c", "DIMENSION", -0.004780741706299, -0.05064288656189,
0.1173281560361, False, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("RD2@Annotations@DS
TEST.moPart_c", "DIMENSION", 0.09844823636707, -0.07157967685629,
0.03503256571634, True, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("RD1@Annotations@DS
TEST.moPart_c", "DIMENSION", 0.07994366233927, -0.06914516635694,
0.05110302488907, True, 0, Nothing, 0)
End Sub
Private Sub ChgDimsToFractions()
Dim swApp As Object
Dim swModel As Object
Dim swSelMgr As Object
Dim selCount As Integer
Dim selType As Integer
Dim CurrentSelDimension As Object
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager()
selCount = swSelMgr.GetSelectedObjectCount()
If (selCount > 0) Then
For i = 1 To selCount
selType = swSelMgr.GetSelectedObjectType2(i)
If (selType = swSelDIMENSIONS) Then
Set CurrentSelDimension = swSelMgr.GetSelectedObject3(i)
CurrentSelDimension.SetDual True
CurrentSelDimension.SetUnits False, swINCHES, swFRACTION,
16, True
End If
Next
End If
End Sub
Private Sub WriteEquation()
Dim swApp As Object
Dim Part As Object
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Part.ClearSelection2 True
Part.DeleteAllRelations
Part.AddRelation """D1@RectWeight"" = ""RD1@Annotations"" *
""RD2@Annotations"" *
""RD3@Annotations"" * .2836"
Part.ForceRebuild
End Sub
Private Sub HideAnnotations()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
boolstatus = Part.SetUserPreferenceToggle(197, False)
End Sub
Private Sub GetDimValues()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Const Density = 0.2836
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Thickness = Round(Part.Parameter("RD1@Annotations").SystemValue /
0.0254, 3)
Width = Round(Part.Parameter("RD2@Annotations").SystemValue /
0.0254, 3)
Length = Round(Part.Parameter("RD3@Annotations").SystemValue /
0.0254, 3)
RW = Round(Thickness * Width * Length * Density, 3)
End Sub
Private Sub DeleteCustomProps()
Dim ModelDoc2 As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc2 = swApp.ActiveDoc
retval = ModelDoc2.DeleteCustomInfo2("", "CutSize")
retval = ModelDoc2.DeleteCustomInfo2("", "RectangularWeight")
retval = ModelDoc2.DeleteCustomInfo2("", "SWDescription")
retval = ModelDoc2.DeleteCustomInfo2("", "GroupType")
End Sub
Private Sub WriteCustomProps()
Dim ModelDoc2 As Object
Set swApp = CreateObject("SldWorks.Application")
Set ModelDoc2 = swApp.ActiveDoc
retval = ModelDoc2.AddCustomInfo3("", "CutSize", 30, Width & " x "
& Length)
retval = ModelDoc2.AddCustomInfo3("", "RectangularWeight", 30, RW)
retval = ModelDoc2.AddCustomInfo3("", "SWDescription", 30, "PLATE,
" & Thickness & " x " & Width & " x " & Length & ", ""SW-Material@DS
TEST.SLDPRT""")
retval = ModelDoc2.AddCustomInfo3("", "GroupType", 30, Thickness)
'MsgBox Thickness
'MsgBox Width
'MsgBox Length
'MsgBox RW
End Sub
Private Sub Formed_Iso_Fit()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Flat-Pattern1",
"BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
Part.ClearSelection2 True
Part.SetBendState 3
boolstatus = Part.EditRebuild3
Part.ShowNamedView2 "*
Isometric", 7
Part.ViewZoomtofit2
End Sub
Reply to
inthepickle
Loading thread data ...
I pulled this function from one of my programs. There may be simpler methods out there, but I know it works. You can specify any denominator value and if the number you pass to the function is close enough to the fractional value it send the fraction, otherwise it leaves it alone. You can specify a tolerance large enough such that it will always return a fraction if you want to.
Function DimensionalFraction(DecimalValue As Double, MaxDenominator As Double, Tolerance As Double) As String 'converts Decimal Value to a mixed fraction text in a dimesional form using 2,4,8,16,32 in the denominator Dim withintol As Boolean Dim toler As Double Dim num As Double 'numerator Dim denom As Double 'denominator
denom = 2 ' start with denominator = 2 for halves then double it for 4ths ,8ths etc. withintol = False
Do ' num = Application.WorksheetFunction.RoundUp(DecimalValue * denom, 0) ' Use this function in Excel. num = Round(DecimalValue * denom, 0) 'Multiply decimal value by the denominator and round to nearest int If num < (DecimalValue * denom) Then 'If it rounded down then add 1 to force Round Up to nearest integer num = num + 1 End If 'if the decimal value times the denominator is greater than the rounded up value plus the 'tolerance * denom, then it is within tolerance If ((DecimalValue * denom) >= (num - (Tolerance * denom))) Then withintol = True Exit Do End If
num = Round(DecimalValue * denom, 0) 'Round Down to nearest integer If num > (DecimalValue * denom) Then num = num - 1 End If If ((DecimalValue * denom) be surprised. Like I said, I am no expert.
Reply to
Mark Reimer

PolyTech Forum website is not affiliated with any of the manufacturers or service providers discussed here. All logos and trade names are the property of their respective owners.