宏代码——插入DXF文件和添加尺寸

javor · 发表于 2009-10-31 00:43:59

经典图书

Insert DXF File and Add Dimensions Example (VBA)
This example shows how to insert a DXF file on a pre-selected plane or face and how to then autodimension it.

'----------------------------------------------------
'
' Preconditions:
' (1) Part is open.
' (2) Plane or face on which to insert DXF file is selected.
'
' Postconditions:
' (1) DXF/DWG file is added as sketch.
' 2) Sketch is autodimensioned.
'
'----------------------------------------------------
Option Explicit

Const nTolerance As Double = 0.00000001

Function GetAllSketchLines _
( _
swApp As SldWorks.SldWorks, _
swModel As SldWorks.ModelDoc2, _
swSketch As SldWorks.sketch _
) As Variant
Dim vSketchSegArr As Variant
Dim vSketchSeg As Variant
Dim swSketchSeg As SldWorks.SketchSegment
Dim swSketchCurrLine As SldWorks.SketchLine
Dim swSketchLineArr() As SldWorks.SketchLine
ReDim swSketchLineArr(0)

vSketchSegArr = swSketch.GetSketchSegments
If Not IsEmpty(vSketchSegArr) Then
For Each vSketchSeg In vSketchSegArr
Set swSketchSeg = vSketchSeg

If swSketchLINE = swSketchSeg.GetType Then
Set swSketchCurrLine = swSketchSeg
Set swSketchLineArr(UBound(swSketchLineArr)) = swSketchCurrLine

ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) + 1)
End If
Next
End If
If 0 = UBound(swSketchLineArr) Then
' No straight lines in this sketch
GetAllSketchLines = Empty
Exit Function
End If

' Remove last, empty sketch line
ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) - 1)

GetAllSketchLines = swSketchLineArr
End Function

Function GetSketchPoint _
( _
swApp As SldWorks.SldWorks, _
swModel As SldWorks.ModelDoc2, _
swSketch As SldWorks.sketch, _
swSketchPt As SldWorks.SketchPoint _
) As Boolean
Dim vSketchPtArr As Variant
vSketchPtArr = swSketch.GetSketchPoints2
If Not IsEmpty(vSketchPtArr) Then
' Use first point
Set swSketchPt = vSketchPtArr(0)

GetSketchPoint = True
Exit Function
End If

GetSketchPoint = False
End Function

Function FindVerticalOrigin _
( _
swApp As SldWorks.SldWorks, _
swModel As SldWorks.ModelDoc2, _
swSketch As SldWorks.sketch, _
swSketchSegVert As SldWorks.SketchSegment, _
swSketchPtVert As SldWorks.SketchPoint _
) As Boolean
Dim vSketchLineArr As Variant
Dim vSketchLine As Variant
Dim swSketchCurrLine As SldWorks.SketchLine
Dim swStartPt As SldWorks.SketchPoint
Dim swEndPt As SldWorks.SketchPoint

' Get first vertical line
vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)
If Not IsEmpty(vSketchLineArr) Then
For Each vSketchLine In vSketchLineArr
Set swSketchCurrLine = vSketchLine
Set swStartPt = swSketchCurrLine.GetStartPoint2
Set swEndPt = swSketchCurrLine.GetEndPoint2

If Abs(swStartPt.x - swEndPt.x) < nTolerance Then
Set swSketchSegVert = swSketchCurrLine

FindVerticalOrigin = True
Exit Function
End If
Next
End If

' Get first point
FindVerticalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtVert)
End Function

Function FindHorizontalOrigin _
( _
swApp As SldWorks.SldWorks, _
swModel As SldWorks.ModelDoc2, _
swSketch As SldWorks.sketch, _
swSketchSegHoriz As SldWorks.SketchSegment, _
swSketchPtHoriz As SldWorks.SketchPoint _
) As Boolean
Dim vSketchLineArr As Variant
Dim vSketchLine As Variant
Dim swSketchCurrLine As SldWorks.SketchLine
Dim swStartPt As SldWorks.SketchPoint
Dim swEndPt As SldWorks.SketchPoint

' Get first horizontal line
vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)
If Not IsEmpty(vSketchLineArr) Then
For Each vSketchLine In vSketchLineArr
Set swSketchCurrLine = vSketchLine
Set swStartPt = swSketchCurrLine.GetStartPoint2
Set swEndPt = swSketchCurrLine.GetEndPoint2

If Abs(swStartPt.y - swEndPt.y) < nTolerance Then
Set swSketchSegHoriz = swSketchCurrLine

FindHorizontalOrigin = True
Exit Function
End If
Next
End If

' Get first point
FindHorizontalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtHoriz)
End Function

Function AutoDimensionSketch _
( _
swApp As SldWorks.SldWorks, _
swModel As SldWorks.ModelDoc2, _
swSketch As SldWorks.sketch, _
swSelData As SldWorks.SelectData _
) As Long
Dim swFeat As SldWorks.feature
Dim swSketchSegHoriz As SldWorks.SketchSegment
Dim swSketchPtHoriz As SldWorks.SketchPoint
Dim swSketchSegVert As SldWorks.SketchSegment
Dim swSketchPtVert As SldWorks.SketchPoint
Dim bRet As Boolean

If False = FindHorizontalOrigin(swApp, swModel, swSketch, swSketchSegHoriz, swSketchPtHoriz) Then
AutoDimensionSketch = swAutodimStatusDatumLineNotHorizontal
Exit Function
End If

If False = FindVerticalOrigin(swApp, swModel, swSketch, swSketchSegVert, swSketchPtVert) Then
AutoDimensionSketch = swAutodimStatusDatumLineNotVertical
Exit Function
End If

Set swFeat = swSketch

bRet = swFeat.Select2(False, 0)
Debug.Assert bRet

' Editing sketch clears selections
swModel.EditSketch

' Reselect sketch segments with correct marks for auto-dimensioning
If Not swSketchSegVert Is Nothing Then
' Vertical line is for horizontal datum
bRet = swSketchSegVert.Select4(True, swSelData)
ElseIf Not swSketchPtHoriz Is Nothing Then
bRet = swSketchPtHoriz.Select4(True, swSelData)
ElseIf Not swSketchPtVert Is Nothing Then
' Use any sketch point for horizontal datum
bRet = swSketchPtVert.Select4(True, swSelData)
End If
Debug.Assert bRet

If Not swSketchSegHoriz Is Nothing Then
' Horizontal line is for vertical datum
bRet = swSketchSegHoriz.Select4(True, swSelData)
ElseIf Not swSketchPtVert Is Nothing Then
bRet = swSketchPtVert.Select4(True, swSelData)
ElseIf Not swSketchPtHoriz Is Nothing Then
' Use any sketch point for vertical datum
bRet = swSketchPtHoriz.Select4(True, swSelData)
End If
Debug.Assert bRet

' No straight lines, probably contains circles
' so use sketch points for datums
If IsEmpty(GetAllSketchLines(swApp, swModel, swSketch)) Then
If Not swSketchPtHoriz Is Nothing Then
bRet = swSketchPtHoriz.Select4(False, swSelData)
ElseIf Not swSketchPtVert Is Nothing Then
bRet = swSketchPtVert.Select4(False, swSelData)
End If
End If
Debug.Assert bRet

AutoDimensionSketch = swSketch.AutoDimension2( _
swAutodimEntitiesAll, _
swAutodimSchemeBaseline, _
swAutodimHorizontalPlacementBelow, _
swAutodimSchemeBaseline, _
swAutodimVerticalPlacementLeft)

' Redraw so dimensions are displayed immediately
swModel.GraphicsRedraw2

' Exit sketch edit
' Leave rebuild to later
swModel.InsertSketch2 False
End Function

Sub main()
Const sDwgFileName As String = "d:samplesrainbow.dxf"

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.modelDoc
Dim swFeatMgr As SldWorks.FeatureManager
Dim swFeat As SldWorks.feature
Dim swSketch As SldWorks.sketch
Dim swSelMgr As SldWorks.SelectionMgr
Dim swSelData As SldWorks.SelectData
Dim nRetVal As Long
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swFeatMgr = swModel.FeatureManager
Set swFeat = swFeatMgr.InsertDwgOrDxfFile(sDwgFileName)
Set swSketch = swFeat.GetSpecificFeature2
Set swSelMgr = swModel.SelectionManager
Set swSelData = swSelMgr.CreateSelectData

nRetVal = AutoDimensionSketch(swApp, swModel, swSketch, swSelData)

' Rebuild to update sketch
swModel.EditRebuild3
End Sub
'----------------------------------------------------