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

 

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) <= (num + (Tolerance * denom))) Then
withintol = True
Exit Do
End If

denom = denom * 2

Loop While denom <= MaxDenominator

If withintol = True Then
If ((num Mod denom) = 0) Then ' Check if no fractions to be
displayed (dia is a whole number approx)
DimensionalFraction = CStr(num / denom)
ElseIf ((num / denom) > 1) Then 'Check if dia is more than 1 if
it was equal to one then num mod denom would be zero
DimensionalFraction = CStr(Int(num / denom)) + "-" +
CStr(num - Int(num / denom) * denom) + "/" + CStr(denom)
ElseIf ((num / denom) < 1) Then ' Check if dia is less than 1
so no whole numbers
DimensionalFraction = CStr(num) + "/" + CStr(denom)
Else
'there is no longer anything else
End If
Else ' give up and return the original DecimalValueimal value - not
close enough to a dimensional fraction
DimensionalFraction = DecimalValue
End If

End Function


--Mark