How to transform the sketch points to assembly drawing view.
Sketch points is inside the part accompanied in assembly.
Place the block in drawing view with reference to sketch point..
reference. Below macro is fine for if sketch in front plane. Now I transferred sketch plane from front to top now its not working.. Please help me to resolve this ..otherwise any other suggestion.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swmodel As SldWorks.ModelDoc2
Dim swsel As SldWorks.SelectionMgr
Dim swview As SldWorks.View
Dim swdrw As SldWorks.DrawingDoc
Dim swfeat As SldWorks.Feature
Dim swskt As SldWorks.Sketch
Dim swpt As SldWorks.SketchPoint
Dim swmath As SldWorks.MathUtility
Dim swmtrans As SldWorks.MathTransform
Dim swmpt As SldWorks.MathPoint
Dim swblk As SldWorks.SketchBlockDefinition
Dim swblkinst As SldWorks.SketchBlockInstance
Dim sktmgr As SldWorks.SketchManager
Dim swdcomp As SldWorks.DrawingComponent
Dim swcomp As SldWorks.Component2
Dim vpos As Variant
Dim fpath As String
Dim vpt(2) As Double
Dim vbpt(2) As Double
Dim vmpt As Variant
Dim vapt As Variant
Dim bret As Boolean
Dim vSkPtArr As Variant
Dim vSkPt As Variant
Dim i As Long
Dim p As Integer
Dim scaledec As Double
Dim vRelation As Variant
Dim count As Integer
Dim swSkRel As SldWorks.SketchRelation
Dim vSkRel As Variant
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim insPt As SldWorks.MathPoint
Dim vInstPt As Variant
Dim j As Integer
Sub main()
Set swApp = Application.SldWorks
Set swmodel = swApp.ActiveDoc
Set swsel = swmodel.SelectionManager
Set swdrw = swmodel
swmodel.DeSelectByID "Sheet1", "SHEET", 0, 0, 0
Set sktmgr = swmodel.SketchManager
Set swfeat = swsel.GetSelectedObject5(1)
Set swskt = swfeat.GetSpecificFeature
Set swview = swsel.GetSelectedObjectsDrawingView2(1, 0)
Set swmath = swApp.GetMathUtility
vpos = swview.Position
scaledec = swview.ScaleDecimal
Set swdcomp = swsel.GetSelectedObject5(2)
Set swcomp = swdcomp.Component
swmodel.ClearSelection2 True
swmodel.Extension.SelectByID2 "test", "SUBSKETCHDEF", 0, 0, 0, False, 0, Nothing, 0
swmodel.EditDelete
vSkPtArr = swskt.GetSketchPoints2
For p = 0 To UBound(vSkPtArr)
Set swpt = vSkPtArr(p)
Dim swent As SldWorks.Entity
Dim ep As SldWorks.EdgePoint
Set ep = swent
Set swent = ep
count = swpt.GetRelationsCount
If count > 0 Then
vRelation = swpt.GetRelations
For Each vSkRel In vRelation
Set swSkRel = vSkRel
vpt(0) = swpt.X
vpt(1) = swpt.Y
vpt(2) = swpt.Z
'' Sketch Point location in assembly
Set swmpt = swmath.CreatePoint(vpt)
Set swmtrans = swcomp.Transform2
Set swmpt = swmpt.MultiplyTransform(swmtrans)
vapt = swmpt.ArrayData
'' Sketch Point location in drawing
Set swmtrans = swview.ModelToViewTransform
Set swmpt = swmpt.MultiplyTransform(swmtrans)
vmpt = swmpt.ArrayData
'' Calculate block insert point
vbpt(0) = (vmpt(0) / scaledec) - (vpos(0) / scaledec)
vbpt(1) = (vmpt(1) / scaledec) - (vpos(1) / scaledec)
Set swmpt = swmath.CreatePoint(vbpt)
fpath = swApp.GetCurrentMacroPathFolder
swdrw.ActivateView (swview.Name)
sktmgr.MakeSketchBlockFromFile swmpt, "C:\My data\test\test.SLDBLK", False, 1, 0
swmodel.GraphicsRedraw2
swview.SelectEntity swent, False
Next
End If
Next p
'Add the relation
vBlockDef = sktmgr.GetSketchBlockDefinitions
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
swmodel.ClearSelection2 True
vBlockInst = swBlockDef.GetInstances
Dim k As Integer
k = 0
If Not IsEmpty(vBlockInst) Then
For j = 0 To UBound(vBlockInst)
swmodel.ClearSelection2 True
Set swBlockInst = vBlockInst(j)
Set insPt = swBlockDef.InsertionPoint
vInstPt = insPt.ArrayData
swmodel.Extension.SelectByID2 "Insertion Point/" & swBlockInst.Name, "SKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0
swview.SelectEntity swent, False
swmodel.SketchAddConstraints "sgCOINCIDENT"
swmodel.ForceRebuild3 True
k = k + 1
Next j
End If
Next i
End If
MsgBox ("Completed")
End Sub
SolidworksApi macros