CAD export each drawing to form separate dwg file

'testing export each drawing from the cubicle drawing as separate file. 

Sub inttest()

Dim entry As AcadEntity

Dim BlockObj As AcadBlock

Dim ssetObj As AcadSelectionSet

Dim moSpace As AcadModelSpace

Set moSpace = ThisDrawing.ModelSpace

Dim minExt As Variant

Dim maxExt As Variant

Dim minExt1 As Variant

Dim maxExt1 As Variant

Dim test1 As Variant

Dim test2 As Variant

Dim name As String

Dim txt As String

j = 0

Dim count As Integer

count = 0

    'count = ThisDrawing.ModelSpace.count

'MsgBox count

For Each entry In ThisDrawing.ModelSpace

    count = count + 1

    'MsgBox "objid is " & entry.ObjectID

    'MsgBox "objname is " & entry.ObjectName

  

    

    

    If entry.ObjectName = "AcDbBlockReference" Then

        If entry.name = "FDFDSGDGFDH" Then

            j = j + 1

            'If j = 1 Then

            entry.GetBoundingBox minExt, maxExt

            'MsgBox "The extents of the bounding box for the drawing are:" & vbCrLf _

         & "Min Extent: " & minExt(0) & "," & minExt(1) & "," & minExt(2) _

         & vbCrLf & "Max Extent: " & maxExt(0) & "," & maxExt(1) & "," & maxExt(2), vbInformation, "GetBoundingBox Example"

            ReDim minExt1(2)

            ReDim maxExt1(2)

            minExt1(0) = minExt(0) - 10

            minExt1(1) = minExt(1) - 10

            minExt1(2) = minExt(2)

            maxExt1(0) = maxExt(0) + 10

            maxExt1(1) = maxExt(1) + 10

            maxExt1(2) = maxExt(2)

            

            'End If

            Do While ThisDrawing.SelectionSets.count > 0

                ThisDrawing.SelectionSets.Item(0).Delete

            Loop

            Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SELECTIONSET")

            Set objUtility = ThisDrawing.Utility

            objUtility.CreateTypedArray test1, vbDouble, minExt1(0), minExt1(1), minExt1(2)

            objUtility.CreateTypedArray test2, vbDouble, maxExt1(0), maxExt1(1), maxExt1(2)

            ssetObj.Select acSelectionSetCrossing, test1, test2

            

            

            'MsgBox "ssetObj.count is " & ssetObj.count

            For Each objobj In ssetObj

                    If objobj.ObjectName = "AcDbText" Then

                        txt = objobj.TextString

                        If InStr(txt, "853/W/") > 0 Then

                            name = Right(txt, 3)

                            name = Left(ThisDrawing.name, Len(ThisDrawing.name) - 4) & "-" & name & ".dwg"

                        End If

                    End If

            Next

'name = ShowSave(ThisDrawing.HWND, "Drawing1.dwg", "新建图形文件", "图形（*.dwg)")

'ThisDrawing.Wblock name, ssetObj

'ThisDrawing.Wblock ShowSave(ThisDrawing.HWND, "Drawing1.dwg"), ssetObj

            'name = j & ".dwg"

            ThisDrawing.Wblock name, ssetObj

        End If

        

    

    End If

Next

MsgBox "job finish!"

End Sub