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

      Hello,

       

      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!

       

      Henk

      RemoveBlock.jpg

        • 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.

               

              Henk

               

              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

                  Wend

                  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))

              overnieuw:

                  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

                      Else

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

                          swApp.ActiveDoc.EditCut

                          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)

                  swApp.ActiveDoc.EditCopy

                  swdraw.ClearSelection2 True

                  retval = swdraw.ActivateSheet(vsheetname(1))

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

                  swApp.ActiveDoc.Paste

              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

                      Else

                          Set flatView = flatView.GetNextView

                      End If

                  Wend

                 

              gevondenSheet2:

                 

                  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

                  Loop

                 

              sketchnaamgevonden:

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

                  swApp.ActiveDoc.BlankSketch

              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

                  Loop

                  swApp.ActiveDoc.EditDelete

                  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.EditDelete

                  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.EditDelete

                  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

                  swdraw.EditRebuild3

              End Sub

               

               

              Sub einde()

                  Set swApp = Nothing

                  Set swModel = Nothing

                  Set swdraw = Nothing

                  End

              End Sub