2 Replies Latest reply on Feb 15, 2016 4:07 PM by H. Kemper

    How do I remove a block from a drawing view with API?

    H. Kemper



      Can anybody help me? I'm writing a macro to copy a (dimensioned) flatpattern view from sheet 1 to sheet 2.

      After copying,  my macro removes the dimensions and sketchpoints from the copied drawing view of sheet 2.

      What's the code to remove sketch block instances from the drawing view?

      Thanks in advance!




        • Re: How do I remove a block from a drawing view with API?
          Amen Allah Jlili

          Do you mind posting your macro code so we can help you modify it to achieve your desired outcome?

            • Re: How do I remove a block from a drawing view with API?
              H. Kemper

              Here is my code and a .sldprt and .slddrw to test the macro.




              Dim swApp As Object

              Dim swModel As SldWorks.ModelDoc2

              Dim swdraw As SldWorks.ModelDoc2

              Dim swView As SldWorks.View

              Dim flatView As SldWorks.View

              Dim swViewToCopy As SldWorks.View

              Dim swCopiedView As SldWorks.View

              Dim swSelMgr As SldWorks.SelectionMgr

              Dim swFeatMgr As SldWorks.FeatureManager

              Dim swSketchMgr As SldWorks.SketchManager

              Dim swModeldocExt As Variant

              Dim retval As Variant

              Dim vsheetname As Variant

              Dim boolstatus As Boolean

              Dim a As String

              Dim vArr As Variant

              Dim outline

              Option Explicit

              Sub MacroMain()

                  Set swApp = Application.SldWorks

                  Set swdraw = swApp.ActiveDoc

                  Set swModeldocExt = swdraw.Extension

                  Set swSketchMgr = swApp.ActiveDoc.SketchManager

                  Set swViewToCopy = Nothing


                  If InStr(LCase(swdraw.GetPathName), "slddrw") = 0 Then Application.SldWorks.SendMsgToUser ("Deze macro moet vanuit een drawing gestart worden"): Call einde

                  On Error Resume Next: Err.Clear

                  vsheetname = swdraw.GetSheetNames

                  If Err.Number <> 0 Then Application.SldWorks.SendMsgToUser ("Geen drawing sheet gevonden"): Call einde


                  retval = swdraw.ActivateSheet(vsheetname(0))

                  Set flatView = swdraw.GetFirstView

                  Set flatView = flatView.GetNextView


                  While Not flatView Is Nothing

                      If flatView.IsFlatPatternView Then Set swViewToCopy = flatView

                      Set flatView = flatView.GetNextView


                  If swViewToCopy Is Nothing Then Application.SldWorks.SendMsgToUser ("Geen flatpattern gevonden op sheet 1"): Call einde


                  'check if flat pattern exists on sheet 2

                  retval = swdraw.ActivateSheet(vsheetname(1))


                  Set flatView = swdraw.GetFirstView

                  Set flatView = flatView.GetNextView


                  If Not flatView Is Nothing Then

                      a = Application.SldWorks.SendMsgToUser2("Er bestaat al een drawing sheet op sheet 2, deze verwijderen en nieuwe plaatsen?", swMbQuestion, swMbYesNo)

                      If a <> swMbHitYes Then

                          Application.SldWorks.SendMsgToUser ("Kopieren afgebroken, macro wordt beeindigd.")

                          retval = swdraw.ActivateSheet(vsheetname(0))

                          Call einde


                          boolstatus = swModeldocExt.SelectByID2(flatView.GetName2, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)


                          GoTo overnieuw 'als er meerdere views op sheet staan

                      End If

                  End If


                  Call CopyFlatPattern

                  Call VerwijderBendLines

                  Call verwijderBemating

                  Call VerwijderSketch

                  Call AanpassenSchaal

                  Call VerplaatsView

                  Call VerwijderBlocks

                  swdraw.GetCurrentSheet.FocusLocked = True

                  retval = swApp.ActiveDoc.ViewZoomtofit

              End Sub

              Sub CopyFlatPattern()

                  boolstatus = swdraw.ActivateView(swViewToCopy.GetName2)

                  boolstatus = swModeldocExt.SelectByID2(swViewToCopy.GetName2, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)


                  swdraw.ClearSelection2 True

                  retval = swdraw.ActivateSheet(vsheetname(1))

                  boolstatus = swApp.ActiveDoc.Extension.SelectByID2(vsheetname(1), "SHEET", 0, 0, 0, False, 0, Nothing, 0)


              End Sub

              Sub VerwijderBendLines()

                 'hide bend lines and notes in copied view

                  Set flatView = swdraw.GetFirstView

                  While Not flatView Is Nothing

                       If flatView.IsFlatPatternView Then

                          Set swCopiedView = flatView

                          GoTo gevondenSheet2


                          Set flatView = flatView.GetNextView

                      End If





                  Dim deel1 As String

                  Dim deel2 As String

                  Dim swfeat As Feature


                  Dim swsubfeat As SldWorks.Feature


                  Set swModel = swApp.GetOpenDocument(flatView.GetReferencedModelName)

                  deel2 = Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)

                  Set swfeat = swModel.FirstFeature

                  Do While Not swfeat Is Nothing

                      Set swfeat = swfeat.GetNextFeature


                      If LCase(swfeat.GetTypeName) = "flatpattern" Then

                          Set swsubfeat = swfeat.GetFirstSubFeature

                          deel1 = swsubfeat.Name

                          GoTo sketchnaamgevonden

                      End If




                  retval = swApp.ActiveDoc.Extension.SelectByID2(deel1 & "@" & deel2 & "-1" & Right(flatView.Name, 1) & "@" & flatView.Name, "SKETCH", 0, 0, 0, False, 0, Nothing, 0)


              End Sub

              Sub verwijderBemating()

                  Dim swSeldata, swDspdim, swAnnot

                  swApp.ActiveDoc.ClearSelection2 True

                  Set swSelMgr = swApp.ActiveDoc.SelectionManager

                  Set swSeldata = swSelMgr.CreateSelectData

                  Set swDspdim = swCopiedView.GetFirstDisplayDimension5


                  Do Until swDspdim Is Nothing

                      Set swAnnot = swDspdim.GetAnnotation

                      retval = swAnnot.Select3(True, swSeldata)

                      Set swDspdim = swDspdim.GetNext5



                  swApp.ActiveDoc.ClearSelection2 True


              End Sub

              Sub VerwijderSketch()

                  Set swApp = Application.SldWorks

                  Set swModel = swApp.ActiveDoc


                  swModel.ActivateView (swCopiedView.GetName2)


                  Dim swSketch As SldWorks.Sketch

                  Dim i As Integer

                  Dim vPoints As Variant


                  Set swSketch = swCopiedView.GetSketch

                  vPoints = swSketch.GetSketchPoints2

                  On Error Resume Next

                  For i = 0 To UBound(vPoints)

                      Dim swSkPoint As SldWorks.SketchPoint

                      Set swSkPoint = vPoints(i)

                      swSkPoint.Select (True)

                  Next i


                  swModel.ClearSelection2 True



                  Dim vSegs As Variant

                  vSegs = swSketch.GetSketchSegments

                  For i = 0 To UBound(vSegs)

                      Dim swSkSeg As SldWorks.SketchSegment

                      Set swSkSeg = vSegs(i)

                      swSkSeg.Select (True)

                  Next i


                  swModel.ClearSelection2 True



              End Sub

              Sub AanpassenSchaal()

                'schaal van sheet2 op 1:1 zetten

                  Dim vSheetProps As Variant

                  vSheetProps = swdraw.GetCurrentSheet.GetProperties

                  vSheetProps(2) = 1

                  vSheetProps(3) = 1

                  swdraw.GetCurrentSheet.SetProperties vSheetProps(0), vSheetProps(1), vSheetProps(2), vSheetProps(3), vSheetProps(4), vSheetProps(5), vSheetProps(6)

                  'viewscale = sheetscale zetten

                  flatView.UseSheetScale = True

              End Sub

              Sub VerwijderBlocks()

                  MsgBox ("In this sub the blocks in the drawing view will be removed. Is not working yet, need help!")

              End Sub

              Sub VerplaatsView()

                  vArr = flatView.Position

                  outline = flatView.GetOutline


                  vArr(0) = vArr(0) + outline(2)

                  vArr(1) = vArr(1) + outline(3)


                  flatView.Position = vArr


              End Sub



              Sub einde()

                  Set swApp = Nothing

                  Set swModel = Nothing

                  Set swdraw = Nothing


              End Sub