ManuOrb
Mechanical
- Jun 22, 2009
- 3
Hi, I've write (taking code from here and there in Internet) a script to extract all dimensions from some drawings so I can work with them with Excel. The thing is some of these are formula driven in the drawing so I don't want to extract those. Any ideas?
See the code I wrote.
Regards,
Manolo
'Dimensions in m and rad
'In d:\tmp only PART and ASSEMBLY files
Sub main()
'Variables SW
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim swSubFeat As SldWorks.Feature
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swAnn As SldWorks.Annotation
Dim bRet As Boolean
Dim sCadena As String
Dim sFicheroTemp As String
Dim sFichero As String
'Variables for files
Dim fso As FileSystemObject
Dim objFile As File
Dim objFolder As Folder
Dim objFileCol As Variant
Dim FolderName As String
Dim FileName As String
Dim objRegEx As RegExp
Dim lErrors As Long
Dim lWarnings As Long
Set swApp = Application.SldWorks
Set fso = New FileSystemObject
Set objRegEx = New RegExp
objRegEx.IgnoreCase = True
objRegEx.Pattern = "\.SLDPRT"
FolderName = "D:\tmp\"
Set objFolder = fso.GetFolder(FolderName)
Set objFileCol = objFolder.Files
sFicheroTemp = FolderName & "temp.txt"
For Each objFile In objFileCol
FileName = FolderName + objFile.Name
If objRegEx.Test(objFile.Name) Then
Set swModel = swApp.OpenDoc6(FileName, swDocPART, swOpenDocOptions_ReadOnly, "", lErrors, lWarnings)
Else
Set swModel = swApp.OpenDoc6(FileName, swDocASSEMBLY, swOpenDocOptions_ReadOnly, "", lErrors, lWarnings)
End If
Set swFeat = swModel.FirstFeature
Do While Not swFeat Is Nothing
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension
sCadena = swDim.FullName & "*" & swDim.GetSystemValue2("")
Open sFicheroTemp For Append Access Write As #1
Print #1, sCadena
Close #1
'Sigue con el Loop
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swApp.CloseAllDocuments(False)
Next
'Eliminar las líneas repetidas
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Dim objConnection As Object
Dim objRecordset As Object
Dim strPathtoTextFile As String
Dim strFile As String
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
strPathtoTextFile = "D:\tmp\"
strFile = "temp.txt"
sFichero = FolderName & "variables.txt"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=NO;FMT=Delimited"""
objRecordset.Open "Select DISTINCT * FROM " & strFile, _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
Open sFichero For Output Access Write As #1
Do Until objRecordset.EOF
sCadena = objRecordset.Fields.Item(0).Value
sCadena = Replace(sCadena, "*", ";")
Print #1, sCadena
'Wscript.Echo objRecordset.Fields.Item(0).Value
objRecordset.MoveNext
Loop
Close #1
End Sub
See the code I wrote.
Regards,
Manolo
'Dimensions in m and rad
'In d:\tmp only PART and ASSEMBLY files
Sub main()
'Variables SW
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim swSubFeat As SldWorks.Feature
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swAnn As SldWorks.Annotation
Dim bRet As Boolean
Dim sCadena As String
Dim sFicheroTemp As String
Dim sFichero As String
'Variables for files
Dim fso As FileSystemObject
Dim objFile As File
Dim objFolder As Folder
Dim objFileCol As Variant
Dim FolderName As String
Dim FileName As String
Dim objRegEx As RegExp
Dim lErrors As Long
Dim lWarnings As Long
Set swApp = Application.SldWorks
Set fso = New FileSystemObject
Set objRegEx = New RegExp
objRegEx.IgnoreCase = True
objRegEx.Pattern = "\.SLDPRT"
FolderName = "D:\tmp\"
Set objFolder = fso.GetFolder(FolderName)
Set objFileCol = objFolder.Files
sFicheroTemp = FolderName & "temp.txt"
For Each objFile In objFileCol
FileName = FolderName + objFile.Name
If objRegEx.Test(objFile.Name) Then
Set swModel = swApp.OpenDoc6(FileName, swDocPART, swOpenDocOptions_ReadOnly, "", lErrors, lWarnings)
Else
Set swModel = swApp.OpenDoc6(FileName, swDocASSEMBLY, swOpenDocOptions_ReadOnly, "", lErrors, lWarnings)
End If
Set swFeat = swModel.FirstFeature
Do While Not swFeat Is Nothing
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension
sCadena = swDim.FullName & "*" & swDim.GetSystemValue2("")
Open sFicheroTemp For Append Access Write As #1
Print #1, sCadena
Close #1
'Sigue con el Loop
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
Set swFeat = swFeat.GetNextFeature
Loop
bRet = swApp.CloseAllDocuments(False)
Next
'Eliminar las líneas repetidas
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Dim objConnection As Object
Dim objRecordset As Object
Dim strPathtoTextFile As String
Dim strFile As String
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
strPathtoTextFile = "D:\tmp\"
strFile = "temp.txt"
sFichero = FolderName & "variables.txt"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=NO;FMT=Delimited"""
objRecordset.Open "Select DISTINCT * FROM " & strFile, _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
Open sFichero For Output Access Write As #1
Do Until objRecordset.EOF
sCadena = objRecordset.Fields.Item(0).Value
sCadena = Replace(sCadena, "*", ";")
Print #1, sCadena
'Wscript.Echo objRecordset.Fields.Item(0).Value
objRecordset.MoveNext
Loop
Close #1
End Sub