Export all dimensions to a table
Export all dimensions to a table
(OP)
From either a part or a drawing, is there a way to
export all of the dimensions (and tolerances) into an
excel spreadsheet or other document?
This would reduce errors from re-typing all inspection
dimensions to a table.
One method I've thought of is too time consuming.
I create a 2nd configuration in the part and then
go through every dimension and change it to
"this configuration". Then add a design table and
all dimensions appear.
But there must be an easier way or a macro???
Thanks






RE: Export all dimensions to a table
Regards,
Scott Baugh, CSWP
www.scottjbaugh.com
FAQ731-376
RE: Export all dimensions to a table
RE: Export all dimensions to a table
CODE
Dim swDoc As SldWorks.ModelDoc2
Dim swDwg As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swTol As SldWorks.DimensionTolerance
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBooks As Excel.Workbooks
Dim CurRow As Long
Const STARTROW As Long = 3
Const DIMNAMECOL As Long = 2
Const DIMVALCOL As Long = 3
Const DIMTOLTYPECOL As Long = 4
Const DIMUPPERTOLVALCOL As Long = 5
Const DIMLOWERTOLVALCOL As Long = 6
Const DIMTOLFITCLASSCOL As Long = 7
Const TOLSCALEFACTOR As Double = 1000
Sub ExportDims()
Dim NumTolVals As Integer
Dim TolIsFit As Boolean
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
If swDoc.GetType <> swDocDRAWING Then
MsgBox "This macro only works for drawing files."
Exit Sub
End If
Set swDwg = swDoc
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBooks = xlApp.Workbooks
xlBooks.Add
Set xlSheet = xlApp.ActiveSheet
CurRow = STARTROW
xlSheet.Cells(CurRow, DIMNAMECOL).Value = "Dimension Name"
xlSheet.Cells(CurRow, DIMVALCOL).Value = "Nominal Value"
xlSheet.Cells(CurRow, DIMTOLTYPECOL).Value = "Tolerance Type"
xlSheet.Cells(CurRow, DIMUPPERTOLVALCOL).Value = "Upper Tol"
xlSheet.Cells(CurRow, DIMLOWERTOLVALCOL).Value = "Lower Tol"
xlSheet.Cells(CurRow, DIMTOLFITCLASSCOL).Value = "Fit Class (Hole/shaft)"
CurRow = CurRow + 1
Set swView = swDwg.GetFirstView
While Not (swView Is Nothing)
Set swDispDim = swView.GetFirstDisplayDimension5
While Not swDispDim Is Nothing
Set swDim = swDispDim.GetDimension
Set swTol = swDim.Tolerance
xlSheet.Cells(CurRow, DIMNAMECOL).Value = swDim.FullName
xlSheet.Cells(CurRow, DIMVALCOL).Value = swDim.Value
xlSheet.Cells(CurRow, DIMTOLTYPECOL).Value = GetTolTypeName(swTol, NumTolVals, TolIsFit)
If NumTolVals > 0 Then
xlSheet.Cells(CurRow, DIMUPPERTOLVALCOL).Value = swTol.GetMaxValue * TOLSCALEFACTOR
End If
If NumTolVals > 1 Then
xlSheet.Cells(CurRow, DIMLOWERTOLVALCOL).Value = swTol.GetMinValue * TOLSCALEFACTOR
End If
If TolIsFit Then xlSheet.Cells(CurRow, DIMTOLFITCLASSCOL).Value = swTol.GetHoleFitValue & "/" & swTol.GetShaftFitValue
Set swDispDim = swDispDim.GetNext5
CurRow = CurRow + 1
Wend
Set swView = swView.GetNextView
Wend
xlApp.Range("A:Z").EntireColumn.AutoFit
End Sub
Function GetTolTypeName(ByRef myTol As SldWorks.DimensionTolerance, ByRef NumVals As Integer, ByRef FitTol As Boolean) As String
Dim s As String
FitTol = False
Select Case myTol.Type
Case swTolNONE
s = "None"
NumVals = 0
Case swTolBASIC
s = "Basic"
NumVals = 0
Case swTolBILAT
s = "Bilateral"
NumVals = 2
Case swTolLIMIT
s = "Limit"
NumVals = 2
Case swTolSYMMETRIC
s = "Symmetric"
NumVals = 1
Case swTolMIN
s = "Minimum"
NumVals = 0
Case swTolMAX
s = "Maximum"
NumVals = 0
Case swTolMETRIC
s = "Metric"
NumVals = 2
Case swTolFIT
s = "Fit"
NumVals = 0
FitTol = True
Case swTolFITWITHTOL
s = "Fit With Tolerance"
NumVals = 2
FitTol = True
Case swTolFITTOLONLY
s = "Fit, Tolerance Only"
NumVals = 2
FitTol = False
Case swTolBLOCK
s = "Block"
NumVals = 2
FitTol = False
End Select
GetTolTypeName = s
End Function