This is some old code from vb6. It will automatically clear the grouping in autocad, create a new set of grouped objects based on their attacked xdata, export each assembly to their own drawing file, reopen each exported assembly of solids in their respective drawings, create a paperspace layout, insert a title block, fill out the title block with the necessary info, create a viewport of the assembly, and automatically dimension the assembly in modelspace on top of the paperspace viewport, print the page to a *.plt file, and after finished with all of the assemblies pop up a window to review each and every auto-generated and dimensioned drawing for the user to confirm everything is correct or add additional dims or notes. Some variables are public or globally defined, so you will have to create those so there are available for storage by their type.
Public Sub WallLayoutc(AcadApp As AcadApplication)
'WallLayoutc(AcadApp As AcadApplication)
WallLayout.Show vbModal
Set AutoCAD_Application = AcadApp
Set AcadApp2 = AcadApp
Set AutoCAD_Application = AcadApp2
On Error Resume Next
Set thisdrawing = AutoCAD_Application.ActiveDocument
Dim ssetObj As AcadSelectionSet
Dim Ent As AcadEntity
Dim objSelSet As AcadSelectionSet
Dim intIndex As Integer
Dim objGrp As AcadGroup
Dim MyGroupData As String
Dim objEnts() As AcadEntity
Dim Ent2 As AcadEntity
Dim Groups As AcadGroups
Dim Grp As AcadGroup
Dim GrpEnt As AcadObject
'Dim grpName As String
Dim objEnts2(0 To 0) As AcadEntity
Dim EB1Name As String
Dim EB2Name As String
Dim TempPartName As String
Dim MyWSolid As Acad3DSolid
Dim BeenHere As Integer
Dim BeenHere2 As Integer
Dim EntCounter As Integer
Dim MyFileName As String
Dim SolidCentriod(0 To 2) As Double
Dim activeDoc As AcadDocument
Dim plotFileName As String
Dim EPSplotFileName As String
Dim result As Boolean
Dim result2 As Boolean
Dim objLayout As AcadLayout
'Dim JobName As String
'JobName = WallLayout.Text1.Text
PlotTypeCounter = -1
On Error Resume Next
thisdrawing.SelectionSets("prev").Delete
Set objSelSet = thisdrawing.SelectionSets.Add("prev")
objSelSet.Select acSelectionSetPrevious
On Error GoTo 0
ReDim entityarray(0) As AcadEntity
On Error Resume Next
thisdrawing.SelectionSets("EXPORTSET").Delete
Set exportObjSet = thisdrawing.SelectionSets.Add("EXPORTSET")
On Error GoTo 0
DocHoldName = thisdrawing.Name
Set Groups = thisdrawing.Groups
'clean out the folder
If Len(Dir("C:\SL-DWG\*.*")) > 0 Then
Kill "C:\SL-DWG\*.*"
End If
'explode all groups and make a new one on eb1
For Each Grp In Groups
grpName = Grp.Name
If GroupExists(grpName) Then
thisdrawing.Groups.Item(grpName).Delete
End If
Next
Dim GroupArray() As String
Dim GroupArrayCounter As Integer
GroupArrayCounter = -1
Dim YY As Integer
Dim MySelectionSet As AcadSelectionSet
'all exploded
'i need to get the groups of only the selected parts
'so make a list of only need groups and pass that in
If WallUserSelectable = 4 Then
For Each Ent In objSelSet
MyGroupData = UCase(getXdataInformation2(Ent.Handle, "EB1", thisdrawing))
'create a list of all groups in the selectionset as an array
If MyGroupData "" Then
GroupArrayCounter = GroupArrayCounter + 1
ReDim Preserve GroupArray(GroupArrayCounter)
GroupArray(GroupArrayCounter) = MyGroupData
'Set objGrp = thisdrawing.Groups.Add(MyGroupData)
'Set objEnts2(0) = Ent
'objGrp.AppendItems objEnts2
End If
Next
On Error Resume Next
For Each Ent In thisdrawing.ModelSpace
MyGroupData = UCase(getXdataInformation2(Ent.Handle, "EB1", thisdrawing))
For YY = 0 To UBound(GroupArray)
If MyGroupData "" Then
If GroupArray(YY) = MyGroupData Then
Set objGrp = thisdrawing.Groups.Add(MyGroupData)
Set objEnts2(0) = Ent
objGrp.AppendItems objEnts2
End If
End If
Next
Next
GoTo SkipOverAuto
End If
'this auto code makes groups based on everything in the drawing
For Each Ent In thisdrawing.ModelSpace
MyGroupData = UCase(getXdataInformation2(Ent.Handle, "EB1", thisdrawing))
If MyGroupData "" Then
Set objGrp = thisdrawing.Groups.Add(MyGroupData)
Set objEnts2(0) = Ent
objGrp.AppendItems objEnts2
End If
Next
SkipOverAuto:
On Error GoTo 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'new code for making a block
'Create a new block called "New_Block"
Dim blockObj As AcadBlock
Dim blkName2 As String
Dim insertionPnt(0 To 2) As Double
Dim MyItemCounter As Integer
Dim blkRef As AcadBlockReference
Dim insPtx(0 To 2) As Double
insertionPnt(0) = 0
insertionPnt(1) = 0
insertionPnt(2) = 0
insPtx(0) = 0
insPtx(1) = 0
insPtx(2) = 0
For Each Grp In Groups
'make sure the exportObjSet is cleared each time
On Error Resume Next
thisdrawing.SelectionSets("EXPORTSET").Delete
On Error GoTo 0
Set exportObjSet = thisdrawing.SelectionSets.Add("EXPORTSET")
exportObjSet.Clear
'cre
ate a selection set of solids in the group
grpName = Grp.Name
ExportCounter = -1
For Each Ent In Grp
ExportCounter = ExportCounter + 1
ReDim Preserve entityarray(ExportCounter) As AcadEntity
Set entityarray(ExportCounter) = Ent
Next
'add entities to the exportObjSet selectionset
exportObjSet.AddItems entityarray
' 'clear out the ref and the block if they exist
' If BlockExists("New_Block") Then
' blkRef.Delete
' blockObj.Delete
' End If
'add the block to the blocks collection
Set blockObj = thisdrawing.Blocks.Add(insertionPnt, "New_Block")
'declare array of objects
ReDim objColl(0 To exportObjSet.Count - 1) As Object
'fill array with selected objects
For MyItemCounter = 0 To exportObjSet.Count - 1
Set objColl(MyItemCounter) = exportObjSet.Item(MyItemCounter)
Next
'copy array to the newly created block definition
thisdrawing.CopyObjects objColl, blockObj
'delete selected objects / may to uncomment this line if you need it!
'oSset.Erase
blkName2 = "New_Block"
Set blkRef = thisdrawing.ModelSpace.InsertBlock(insPtx, blkName2, 1, 1, 1, 0)
'create a new selectionset and add the block to it
ReDim entityarray(0) As AcadEntity
On Error Resume Next
thisdrawing.SelectionSets("EXPORTSET").Delete
Set exportObjSet = thisdrawing.SelectionSets.Add("EXPORTSET")
exportObjSet.Clear
On Error GoTo 0
ReDim Preserve entityarray(0) As AcadEntity
Set entityarray(0) = blkRef
exportObjSet.AddItems entityarray
thisdrawing.Wblock "C:\SL-DWG\" & grpName & ".dwg", exportObjSet
blkRef.Delete
blockObj.Delete
Next
'hold this no matter what
'''For Each Grp In Groups
'''
''' 'make sure the exportObjSet is cleared each time
''' On Error Resume Next
''' thisdrawing.SelectionSets("EXPORTSET").Delete
''' On Error GoTo 0
''' Set exportObjSet = thisdrawing.SelectionSets.Add("EXPORTSET")
''' exportObjSet.Clear
''' 'create a selection set of solids in the group
''' grpName = Grp.Name
''' ExportCounter = -1
'''
''' For Each Ent In Grp
''' ExportCounter = ExportCounter + 1
''' ReDim Preserve entityarray(ExportCounter) As AcadEntity
''' Set entityarray(ExportCounter) = Ent
''' Next
'''
''' 'now export it
''' exportObjSet.AddItems entityarray
''' thisdrawing.Wblock "C:\SL-DWG\" & grpName & ".dwg", exportObjSet
'''Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'all walls are exported
'now to open each and process it
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DocHoldName = thisdrawing.Name
Dim MySolid2 As Acad3DSolid
For Each Grp In Groups
grpName = Grp.Name
'now open the file and
thisdrawing.Application.Documents.Open "C:\SL-DWG\" & grpName & ".dwg"
Set ThisDrawing2 = thisdrawing.Application.ActiveDocument
DocHoldName2 = ThisDrawing2.Name
Set ThisDrawing2 = Application.Documents(DocHoldName2)
ThisDrawing2.Activate
'temp code
Dim TempBlock As AcadBlockReference
Dim TempBlock2 As AcadBlockReference
WallTotalSize = 0
For Each Ent In ThisDrawing2.ModelSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set TempBlock = Ent
TempBlock.GetBoundingBox minExt, maxExt
WallTotalSize = maxExt(0) - minExt(0)
TempBlock.explode
End If
Next
GetOut:
'process it
For Each Ent In ThisDrawing2.ModelSpace
TempPartName = UCase(getXdataInformation2(Ent.Handle, "PartName", ThisDrawing2))
If TempPartName = "COMMON-STUD" Then
Set MyWSolid = Ent
'Get its matrix here
'then transform them all out of this loop
Dim DataTypeC1(0 To 4) As Integer
Dim DataC1(0 To 4) As Variant
getXdataInformation3 MyWSolid.Handle, "MILLLISTER", ThisDrawing2
AppName = AppName
HoldVecO = HoldVecO
HoldVecX = HoldVecX
HoldVecY = HoldVecY
HoldVecZ = HoldVecZ
DataC1(0) = AppName
DataC1(1) = ObjOrigin
DataC1(2) = HoldVecX
DataC1(3) = HoldVecY
DataC1(4) = HoldVecZ
'build a matrix from the data:
variantX = DataC1(2)
variantY = DataC1(3)
variantZ = DataC1(4)
X1 = variantX(0)
X2 = variantX(1)
X3 = variantX(2)
Y1 = variantY(0)
Y2 = variantY(1)
Y3 = variantY(2)
Z1 = variantZ(0)
Z2 = variantZ(1)
Z3 = variantZ(2)
Erase ReturnMatrix
ReturnMatrix(0, 0) = X1: ReturnMatrix(0, 1) = X2: ReturnMatrix(0, 2) = X3: ReturnMatrix(0, 3) = 0#
ReturnMatrix(1, 0) = Y1: ReturnMatrix(1, 1) = Y2: ReturnMatrix(1, 2) = Y3: ReturnMatrix(1, 3) = 0#
ReturnMatrix(2, 0) = Z1: ReturnMatrix(2, 1) = Z2: ReturnMatrix(2, 2) = Z3: ReturnMatrix(2, 3) = 0#
ReturnMatrix(3, 0) = 0#: ReturnMatrix(3, 1) = 0#: ReturnMatrix(3, 2) = 0#: ReturnMatrix(3, 3) = 1#
'its done getting it, so get out
GoTo TransformAll
End If
Next
TransformAll:
For Each Ent In ThisDrawing2.ModelSpace
If Ent.ObjectName "AcDbBlockReference" Then
Ent.Delete
End If
Next
For Each Ent In ThisDrawing2.ModelSpace
Ent.TransformBy (ReturnMatrix)
Ent.Update
'rotate everything about the z
Dim rotatePt1(0 To 2) As Double
Dim rotatePt2(0 To 2) As Double
Dim rotateAngle As Double
rotatePt1(0) = 0
rotatePt1(1) = 0
rotatePt1(2) = 0
rotatePt2(0) = 0
rotatePt2(1) = 0
rotatePt2(2) = 1
rotateAngle = 90
rotateAngle = rotateAngle * 3.14159265358979 / 180#
Ent.Rotate3D rotatePt1, rotatePt2, rotateAngle
Ent.Update
Next
'moving this here to check wall size
''''''''''''''''''''''''''''''''''''''''''
WallTotalSize = 0
For Each Ent In ThisDrawing2.ModelSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set TempBlock = Ent
TempBlock.GetBoundingBox minExt, maxExt
WallTotalSize = maxExt(0) - minExt(0)
End If
Next
For Each Ent In ThisDrawing2.ModelSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set TempBlock = Ent
TempBlock.explode
'TempBlock.Delete
End If
Next
For Each Ent In ThisDrawing2.ModelSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set TempBlock = Ent
TempBlock.Delete
GoTo MyOut
End If
Next
MyOut:
'delete all entites not on the layers I want!!
For Each Ent In ThisDrawing2.ModelSpace
If Ent.Layer "0-FOAM" Or Ent.Layer "0-HEADER" Or _
Ent.Layer "0-TRACK" Or Ent.Layer "0-CNR-METAL" Or _
Ent.Layer "0-CMN-STUD" Then
Ent.Delete
End If
Next
Dim Starter(0 To 2) As Double
Dim Ender(0 To 2) As Double
Starter(0) = 0
Starter(1) = 0
Starter(2) = 0
Ender(0) = 10000
Ender(1) = 10000
Ender(2) = -10000
'move everything over on x y z
For Each Ent In ThisDrawing2.ModelSpace
Ent.Move Starter, Ender
Next
'insert the titleblock
Dim MyBlock As AcadBlockReference
Dim path As String
Dim insPt3(0 To 2) As Double
If WallTotalSize 377.5 Then
' path = "C:\Program Files\SmartLister07\sample files\Wall-Layout-Block814.dwg"
' UseTitleSize = 1
'End If
If WallTotalSize > 377.5 Then
path = "C:\Program Files\SmartLister07\sample files\Wall-Layout-Block1117.dwg"
UseTitleSize = 1
End If
insPt3(0) = 0#: insPt3(1) = 0#: insPt3(2) = 0#
On Error GoTo 0
ThisDrawing2.Layouts("Layout1").block.InsertBlock insPt3, path, 1, 1, 1, 0
'block.explode and delete
ThisDrawing2.ActiveSpace = acPaperSpace
For Each Ent In ThisDrawing2.PaperSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set MyBlock = Ent
MyBlock.explode
ZoomAll
GoTo Out
End If
Next
Out:
For Each Ent In ThisDrawing2.PaperSpace
If Ent.ObjectName = "AcDbBlockReference" Then
Set MyBlock = Ent
MyBlock.Delete
ZoomAll
GoTo Out2
End If
Next
Out2:
'AcadApp2.Application.Update
'delete unneed reference objects
For Each Ent In ThisDrawing2.PaperSpace
If Ent.ObjectName = "AcDbRotatedDimension" Or Ent.ObjectName = "AcDbMText" Then
If Ent.Layer = "temp" Then
Ent.Delete
End If
End If
Next
ThisDrawing2.SendCommand "zoom " & "e "
'go to modelspace and GET THE dims for diming in paperspace
ThisDrawing2.ActiveSpace = acModelSpace
ThisDrawing2.SendCommand "-dimstyle " & "r " & "dimsize1" & vbCr
ThisDrawing2.SendCommand "-style " & "size1" & vbCr & vbCr & vbCr & vbCr & vbCr & vbCr & vbCr
DoWLDims ThisDrawing2
'go to paperspace and set a viewport with the contents
Dim LayerName As AcadLayer
Dim pviewportObj1 As AcadPViewport
Dim currLayer As AcadLayer
Dim center(0 To 2) As Double
Dim width As Double
Dim height As Double
Set currLayer = ThisDrawing2.ActiveLayer
ThisDrawing2.ActiveSpace = acPaperSpace
ThisDrawing2.SendCommand "zoom " & "e "
ThisDrawing2.MSpace = False
Dim ViewCenter(0 To 2) As Double
If UseTitleSize = 0 Then
center(0) = 4.7028: center(1) = 3.9555: center(2) = 0
width = 9.125
height = 7.6875
ZoomExtents
ViewCenter(0) = center(0)
ViewCenter(1) = center(1)
ViewCenter(2) = center(2)
End If
'If UseTitleSize = 1 Then
' center(0) = 6.2028: center(1) = 3.9555: center(2) = 0
' width = 12.125
' height = 7.6875
' ZoomExtents
' ViewCenter(0) = center(0)
' ViewCenter(1) = center(1)
' ViewCenter(2) = center(2)
'End If
If UseTitleSize = 1 Then
center(0) = 7.625: center(1) = 5.1875: center(2) = 0
width = 14.875
height = 10.125
ZoomExtents
ViewCenter(0) = center(0)
ViewCenter(1) = center(1)
ViewCenter(2) = center(2)
End If
ThisDrawing2.Layers.Add ("vports")
ThisDrawing2.ActiveLayer = ThisDrawing2.Layers("vports")
ThisDrawing2.ActiveLayer.Color = acGreen
Set pviewportObj1 = ThisDrawing2.PaperSpace.AddPViewport(center, width, height)
pviewportObj1.Update
pviewportObj1.Display (True)
Dim removeHidden As Boolean
pviewportObj1.ShadePlot = acShadePlotHidden
pviewportObj1.Update
ThisDrawing2.SendCommand "mview " & "hideplot " & "on " & "all " & " "
ThisDrawing2.MSpace = True
ThisDrawing2.ActivePViewport = pviewportObj1
ThisDrawing2.SendCommand "zoom " & "e "
ZoomScaled 2.08333333333333E-02, acZoomScaledRelativePSpace
ThisDrawing2.SendCommand "hideprecision " & "1 "
ThisDrawing2.MSpace = False
ThisDrawing2.PaperSpace.Layout.PlotType = acExtents
ThisDrawing2.PaperSpace.Layout.StandardScale = ac1_1
Set Layouts = ThisDrawing2.Layouts
Dim Layout As AcadLayout
Dim mediaNames As Variant
Dim t As Integer
If UseTitleSize = 0 Then
For Each Layout In Layouts
Layout.ConfigName = "KIP All-Other Systems 8.5 x 11.pc3"
mediaNames = ThisDrawing2.ActiveLayout.GetCanonicalMediaNames
Layouts("Layout1").C
onfigName = "KIP All-Other Systems 8.5 x 11.pc3"
ThisDrawing2.PaperSpace.Layout.ConfigName = "KIP All-Other Systems 8.5 x 11.pc3"
ThisDrawing2.ActiveLayout.CanonicalMediaName = "ANSI_A_(11.00_x_8.50_Inches)" 'mediaNames(t)
ThisDrawing2.ActiveLayout.RefreshPlotDeviceInfo
Next
End If
'If UseTitleSize = 1 Then
' For Each Layout In Layouts
' Layout.ConfigName = "KIP All-Other Systems 8.5 x 14.pc3"
' mediaNames = ThisDrawing2.ActiveLayout.GetCanonicalMediaNames
' Layouts("Layout1").ConfigName = "KIP All-Other Systems 8.5 x 14.pc3"
' ThisDrawing2.PaperSpace.Layout.ConfigName = "KIP All-Other Systems 8.5 x 14.pc3"
' ThisDrawing2.ActiveLayout.CanonicalMediaName = "UserDefinedImperial (14.00 x 8.50Inches)" 'mediaNames(t)
' ThisDrawing2.ActiveLayout.RefreshPlotD' ThisDrawing2.ActiveLayout.RefreshPlotDeviceInfo
' Next
'End If
If UseTitleSize = 1 Then
For Each Layout In Layouts
Layout.ConfigName = "KIP All-Other Systems 11 x 17.pc3"
mediaNames = ThisDrawing2.ActiveLayout.GetCanonicalMediaNames
Layouts("Layout1").C
onfigName = "KIP All-Other Systems 11 x 17.pc3"
ThisDrawing2.PaperSpace.Layout.ConfigName = "KIP All-Other Systems 11 x 17.pc3"
ThisDrawing2.ActiveLayout.CanonicalMediaName = "ANSI_B_(17.00_x_11.00_Inches)" 'mediaNames(t)
ThisDrawing2.ActiveLayout.RefreshPlotDeviceInfo
Next
End If
Layouts("Layout1").StyleSheet = "C:\Program Files\SmartLister07\sample files\new2.ctb"
Layouts("Layout1").PlotRotation = ac0degrees
Dim MyOrigin(0 To 1) As Double
MyOrigin(0) = 0.5 * 25.4
MyOrigin(1) = 0.09 * 25.4
Layouts("Layout1").PlotOrigin = MyOrigin
ThisDrawing2.PaperSpace.Layout.PlotOrigin = MyOrigin
ThisDrawing2.Layers("vports").LayerOn = False
ThisDrawing2.ActiveLayer = ThisDrawing2.Layers("0-DIMENSION")
Set MyActiveLayer = ThisDrawing2.ActiveLayer
ThisDrawing2.SendCommand "-style " & "size4" & vbCr & vbCr & vbCr & vbCr & vbCr & vbCr & vbCr
'edit titleblock
Dim mtextObjx As AcadMText
Dim insertPointx(0 To 2) As Double
Dim widthx As Double
Dim textStringx As String
If UseTitleSize = 0 Then
insertPointx(0) = 9.5
End If
'If UseTitleSize = 1 Then
' insertPointx(0) = 12.5
'End If
If UseTitleSize = 1 Then
insertPointx(0) = 15.4375
End If
insertPointx(1) = 0.625
insertPointx(2) = 0
widthx = 10
textStringx = grpName
Set mtextObjx = ThisDrawing2.PaperSpace.AddMText(insertPointx, widthx, textStringx)
mtextObjx.height = 0.125
If UseTitleSize = 0 Then
insertPointx(0) = 9.5
insertPointx(1) = 1.625
End If
'If UseTitleSize = 1 Then
' insertPointx(0) = 12.5
'End If
If UseTitleSize = 1 Then
insertPointx(0) = 15.4375
insertPointx(1) = 2
End If
'insertPointx(1) = 1.625
insertPointx(2) = 0
widthx = 10
textStringx = UCase(PubJobName)
Set mtextObjx = ThisDrawing2.PaperSpace.AddMText(insertPointx, widthx, textStringx)
mtextObjx.height = 0.125
rotatePt1(0) = insertPointx(0)
rotatePt1(1) = insertPointx(1)
rotatePt1(2) = 0
rotatePt2(0) = insertPointx(0)
rotatePt2(1) = insertPointx(1)
rotatePt2(2) = 1
rotateAngle = 90
rotateAngle = rotateAngle * 3.14159265358979 / 180#
mtextObjx.Rotate3D rotatePt1, rotatePt2, rotateAngle
mtextObjx.Update
'add the drawn by
If UseTitleSize = 0 Then
insertPointx(0) = 9.5
insertPointx(1) = insertPointx(1) - 0.5
End If
'If UseTitleSize = 1 Then
' insertPointx(0) = 12.5
'End If
If UseTitleSize = 1 Then
insertPointx(0) = 15.375
insertPointx(1) = insertPointx(1) - 0.55
End If
insertPointx(2) = 0
widthx = 10
textStringx = UCase(DrawnName)
Set mtextObjx = ThisDrawing2.PaperSpace.AddMText(insertPointx, widthx, textStringx)
mtextObjx.height = 0.125
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'back up code
'debug mode
'add dims to array
'change dim style
'need to make public type arrays for the dims, might as well add the dim style in there?
'revisit bookmarks on that delete block issue. I may not have to loop that twice, two times!!!
'make floorplan code
'make wall process choice
'add wall number to wall builder
'now add the dims
For Each Ent In ThisDrawing2.ModelSpace
If LCase(Ent.ObjectName) = "acdb3dsolid" Then
Set MySolid = Ent
momentOfInertia = MySolid.Centroid
momentOfInertia(2) = 0
GoTo Jumpouter
End If
Next
Jumpouter:
'leave the originals in model space for now
Dim Dpoint1(0 To 2) As Double
Dim Dpoint2(0 To 2) As Double
Dim Dlocation(0 To 2) As Double
Dim dimObj As AcadDimAligned
Dim dimObj2 As AcadDimAligned
Dim P1 As Variant
Dim P2 As Variant
Dim M1 As Variant
Dim M2 As Variant
Dim PSpt As AcadPoint, MSpt As AcadPoint
Dim util As AcadUtility
'a little trick because im too stupid to fill M1 as a variant it otherwise
M1 = momentOfInertia
Set util = ThisDrawing2.Utility
Dim FixDim(0 To 2) As Double
Dim DimHandles() As String
'HORZ. DIMS BOTTOM
For D = 0 To UBound(DimArray)
Dpoint1(0) = DimArray(D).Point1X
Dpoint1(1) = DimArray(D).Point1Y '- 0.125
Dpoint1(2) = DimArray(D).Point1Z
Dpoint2(0) = DimArray(D).Point2X
Dpoint2(1) = DimArray(D).Point2Y '- 0.125
Dpoint2(2) = DimArray(D).Point2Z
Dlocation(0) = DimArray(D).CenterX
Dlocation(1) = DimArray(D).CenterY '- (5.125 + AddAmount)
Dlocation(2) = DimArray(D).CenterZ
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0)
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
M1(0) = Dpoint2(0)
M1(1) = Dpoint2(1)
M1(2) = Dpoint2(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint2(0) = P1(0)
Dpoint2(1) = P1(1)
Dpoint2(2) = P1(2)
M1(0) = Dlocation(0)
M1(1) = Dlocation(1)
M1(2) = Dlocation(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dlocation(0) = P1(0)
Dlocation(1) = P1(1) - 0.375
Dlocation(2) = P1(2)
Set dimObj = ThisDrawing2.PaperSpace.AddDimAligned(Dpoint1, Dpoint2, Dlocation)
'add its handle to an array
ReDim Preserve DimHandles(D)
DimHandles(D) = dimObj.Handle
Next
DimArrayCounter2 = -1
Dim BaseYPosition As Double
BaseYPosition = 100000
'open the exemptlist and add it to an array
Dim ExemptArray() As Double
Dim ExemptArrayCounter As Integer
ExemptArrayCounter = -1
Dim ReadValue As Double
Dim FileName As String
Dim sLine As String
Dim ReturnText As String
Dim F As Integer
Dim G As Integer
F = FreeFile
FileName = "C:\Program Files\SmartLister07\exemptlist.txt"
'If Right(App.path, 1) = "\" Then
' FileName = App.path & "exemptlist.txt"
'Else
' FileName = App.path & "\exemptlist.txt"
'End If
Open FileName For Input As #F
ExemptArrayCounter = -1
Do Until EOF(F)
Line Input #F, sLine
sLine = LCase(sLine)
ReadValue = CDbl(Trim(sLine))
ExemptArrayCounter = ExemptArrayCounter + 1
ReDim Preserve ExemptArray(ExemptArrayCounter)
ExemptArray(ExemptArrayCounter) = ReadValue
Loop
Close #F
Dim TotalFlats As Integer
TotalFlats = 0
Dim FarRightFlat1 As Integer
FarRightFlat1 = 0
Dim FarRightFlat2 As Integer
FarRightFlat2 = 0
Dim FarRightFlat3 As Integer
FarRightFlat3 = 0
Dim FarLeftFlat1 As Integer
FarLeftFlat1 = 0
Dim FarLeftFlat2 As Integer
FarLeftFlat2 = 0
Dim FarLeftFlat3 As Integer
FarLeftFlat3 = 0
Dim CenterFlat As Integer
CenterFlat = 0
Dim dConvert As Double
Dim BB As Integer
For BB = 0 To UBound(DimHandles)
Set dimObj = ThisDrawing2.HandleToObject(DimHandles(BB))
DimArrayCounter2 = DimArrayCounter2 + 1
ReDim Preserve DimArray2(DimArrayCounter2)
DimArray2(DimArrayCounter2).Handle = dimObj.Handle
DimArray2(DimArrayCounter2).Measurement = dimObj.Measurement
DimArray2(DimArrayCounter2).Adjusted = 0
DimArray2(DimArrayCounter2).Adjustable = 1
DimArray2(DimArrayCounter2).OriginalXlocation = dimObj.TextPosition(0)
DimArray2(DimArrayCounter2).OriginalYlocation = dimObj.TextPosition(1)
DimArray2(DimArrayCounter2).OriginalZlocation = dimObj.TextPosition(2)
DimArray2(DimArrayCounter2).TextLocationX = dimObj.TextPosition(0)
DimArray2(DimArrayCounter2).TextLocationY = dimObj.TextPosition(1)
DimArray2(DimArrayCounter2).TextLocationZ = dimObj.TextPosition(2)
DimArray2(DimArrayCounter2).Point1X = dimObj.ExtLine1Point(0)
DimArray2(DimArrayCounter2).Point1Y = dimObj.ExtLine1Point(1)
DimArray2(DimArrayCounter2).Point1Z = dimObj.ExtLine1Point(2)
DimArray2(DimArrayCounter2).Point2X = dimObj.ExtLine2Point(0)
DimArray2(DimArrayCounter2).Point2Y = dimObj.ExtLine2Point(1)
DimArray2(DimArrayCounter2).Point2Z = dimObj.ExtLine2Point(2)
If dimObj.TextPosition(1) = 32 Then
DimArray2(DimArrayCounter2).Adjustable = 0
TotalFlats = TotalFlats + 1
If BB = UBound(DimHandles) Then 'im at the far right
FarRightFlat1 = 1
ElseIf BB = 0 Then
FarLeftFlat1 = 1
End If
If UBound(DimHandles) > 0 Then
If BB = UBound(DimHandles) - 1 Then 'im at the far right -1
FarRightFlat2 = 1
ElseIf BB = 1 Then
FarLeftFlat2 = 1
End If
End If
If UBound(DimHandles) > 1 Then
If BB = UBound(DimHandles) - 2 Then 'im at the far right -2
FarRightFlat3 = 1
ElseIf BB = 2 Then
FarLeftFlat3 = 1
End If
End If
GoTo Marked
End If
''''''''''
If DimArray2(DimArrayCounter2).Measurement = 15 Then
For G = 0 To UBound(ExemptArray)
If Round(dConvert, 4) = Round(ExemptArray(G), 4) Then
DimArray2(DimArrayCounter2).Adjustable = 0
TotalFlats = TotalFlats + 1
If BB = UBound(DimHandles) Then 'im at the far right
FarRightFlat1 = 1
ElseIf BB = 0 Then
FarLeftFlat1 = 1
End If
If UBound(DimHandles) > 0 Then
If BB = UBound(DimHandles) - 1 Then 'im at the far right -1
FarRightFlat2 = 1
ElseIf BB = 1 Then
FarLeftFlat2 = 1
End If
End If
If UBound(DimHandles) > 1 Then
If BB = UBound(DimHandles) - 2 Then 'im at the far right -2
FarRightFlat3 = 1
ElseIf BB = 2 Then
FarLeftFlat3 = 1
End If
End If
End If
Next
End If
Marked:
Next
'now go through the dim array in reverse and adjust them
'if the dim count is 3 or more, I can look for a centered flat spot
'go through the array and look for the flat furtherest to the right
'and hold its number
'change this to look for the flat just past center
Dim LowestY As Double
LowestY = 10000
Dim Steps As Integer
Steps = 0
Dim MaxSteps As Integer
MaxSteps = 0
'i need the center here. Perhaps the viewport center can work
Dim FlatBeenSet As Integer
FlatBeenSet = 0
Dim ClosetestToCenter As Double
ClosetestToCenter = 100000
G = UBound(DimArray2)
Do While G > -1
If DimArray2(G).Adjustable = 0 Then
If DimArray2(G).OriginalXlocation > ViewCenter(0) Then
If DimArray2(G).OriginalXlocation - ViewCenter(0) 0 Then
G = CenterFlat
If UBound(DimHandles) > 0 Then
Do While G > -1
If DimArray2(G).Adjustable = 1 Then
Steps = Steps + 1
Set dimObj = ThisDrawing2.HandleToObject(DimArray2(G).Handle)
Set dimObj2 = ThisDrawing2.HandleToObject(DimArray2(G + 1).Handle)
'get the previous dim y text location and add to it
If DimArray2(G + 1).Adjustable = 0 Then
FixDim(0) = dimObj.TextPosition(0)
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
Else
FixDim(0) = dimObj.TextPosition(0)
FixDim(1) = dimObj2.TextPosition(1) - 0.15
FixDim(2) = 0
dimObj.TextPosition = FixDim
End If
Else
Steps = 0
End If
If Steps > MaxSteps Then
MaxSteps = Steps
End If
G = G - 1
Loop
End If
'now work my way out the other way
'read other direction and move the x too!!!
'G = CenterFlat
If UBound(DimHandles) > 0 Then
For G = CenterFlat To UBound(DimArray2)
If DimArray2(G).Adjustable = 1 Then
Steps = Steps + 1
Set dimObj = ThisDrawing2.HandleToObject(DimArray2(G).Handle)
Set dimObj2 = ThisDrawing2.HandleToObject(DimArray2(G - 1).Handle)
'get the previous dim y text location and add to it
If DimArray2(G - 1).Adjustable = 0 Then
If DimArray2(G - 1).Measurement >= 55 Then
FixDim(0) = dimObj.TextPosition(0) - 0.55606028
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
Else
FixDim(0) = dimObj.TextPosition(0) - 0.55606028
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
End If
End If
'''''''''''''''''''''''''''''''''''''''''''
If DimArray2(G - 1).Adjustable = 1 Then
If DimArray2(G - 1).Measurement >= 30.9375 Then
FixDim(0) = dimObj.TextPosition(0) - 0.55606028
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
Else
FixDim(0) = dimObj.TextPosition(0) - 0.55606028
FixDim(1) = dimObj2.TextPosition(1) - 0.15
FixDim(2) = 0
dimObj.TextPosition = FixDim
'Steps = Steps + 1
End If
End If
Else
Steps = 0
End If
If Steps > MaxSteps Then
MaxSteps = Steps
End If
Next
End If
GoTo HorzDimsAdjusted
End If
'jump over below it code above ran
'else run the code below and kill the extention line so it looks acceptable
Option2:
'going backwards
G = UBound(DimArray2)
Do While G > -1
If DimArray2(G).Adjustable = 0 Then
DimArray2(G).TextLocationY = DimArray2(G).OriginalYlocation
G = G - 1
'don't mod it, and leave it
GoTo ExitThis1
End If
If DimArray2(G).Adjustable = 1 Then
DimArray2(G).TextLocationY = DimArray2(G).OriginalYlocation
'flip it backwards if previous is flat and big enough
Set dimObj = ThisDrawing2.HandleToObject(DimArray2(G).Handle)
If G > 0 Then
Set dimObj2 = ThisDrawing2.HandleToObject(DimArray2(G - 1).Handle)
End If
Steps = Steps + 1
'may bug out on 1' think i fixed it
If G > 0 Then
If DimArray2(G - 1).Measurement >= 30.9375 Then
If DimArray2(G - 1).Adjustable = 0 Then
FixDim(0) = dimObj.TextPosition(0) - 0.55606028
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
If Steps > MaxSteps Then
MaxSteps = Steps
End If
End If
Else
'its smaller and wont fit period! Flip it right
'its already there
If Steps > MaxSteps Then
MaxSteps = Steps
End If
End If
G = G - 1
'get its baseline
End If
If G = 0 Then
'its smaller and wont fit period! Flip it right
'its already there
End If
GoTo ExitThis1
End If
Loop
ExitThis1:
Dim ModLeg As Integer
ModLeg = 0
If UBound(DimHandles) > 0 Then
Do While G > -1
If DimArray2(G).Adjustable = 1 Then
Set dimObj = ThisDrawing2.HandleToObject(DimArray2(G).Handle)
Set dimObj2 = ThisDrawing2.HandleToObject(DimArray2(G + 1).Handle)
Steps = Steps + 1
'get the previous dim y text location and add to it
If DimArray2(G + 1).Adjustable = 0 Then
FixDim(0) = dimObj.TextPosition(0) ' + 0.25
FixDim(1) = dimObj.TextPosition(1)
FixDim(2) = 0
dimObj.TextPosition = FixDim
'ModLeg = 0
Else
FixDim(0) = dimObj.TextPosition(0) ' + 0.25
FixDim(1) = dimObj2.TextPosition(1) - 0.15
FixDim(2) = 0
dimObj.TextPosition = FixDim
End If
Else
Steps = 0
End If
If Steps > MaxSteps Then
MaxSteps = Steps
End If
G = G - 1
Loop
End If
'now mod the leg!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'.30176714
'.55606028
HorzDimsAdjusted:
If TrackExists = 0 Then
'MsgBox "There is no track on wall " & grpName & ". Dimensions will not be placed."
GoTo SkipDims
End If
'single y, left placement
Dpoint1(0) = SingleYLeftPlacement1(0)
Dpoint1(1) = SingleYLeftPlacement1(1)
Dpoint1(2) = 0
Dpoint2(0) = SingleYLeftPlacement2(0)
Dpoint2(1) = SingleYLeftPlacement2(1)
Dpoint2(2) = 0
Dlocation(0) = SingleYLeftPlacementlocation(0)
Dlocation(1) = SingleYLeftPlacementlocation(1)
Dlocation(2) = 0
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0)
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
M1(0) = Dpoint2(0)
M1(1) = Dpoint2(1)
M1(2) = Dpoint2(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint2(0) = P1(0)
Dpoint2(1) = P1(1)
Dpoint2(2) = P1(2)
M1(0) = Dlocation(0)
M1(1) = Dlocation(1)
M1(2) = Dlocation(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dlocation(0) = P1(0) - 0.375
Dlocation(1) = P1(1)
Dlocation(2) = P1(2)
Set dimObj = ThisDrawing2.PaperSpace.AddDimAligned(Dpoint1, Dpoint2, Dlocation)
'OverAllYlocation
If UseOverAll = 1 Then
Dpoint1(0) = OverAllY1(0)
Dpoint1(1) = OverAllY1(1)
Dpoint1(2) = 0
Dpoint2(0) = OverAllY2(0)
Dpoint2(1) = OverAllY2(1)
Dpoint2(2) = 0
Dlocation(0) = OverAllYlocation(0)
Dlocation(1) = OverAllYlocation(1)
Dlocation(2) = 0
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0)
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
M1(0) = Dpoint2(0)
M1(1) = Dpoint2(1)
M1(2) = Dpoint2(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint2(0) = P1(0)
Dpoint2(1) = P1(1)
Dpoint2(2) = P1(2)
M1(0) = Dlocation(0)
M1(1) = Dlocation(1)
M1(2) = Dlocation(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
If dimObj.Measurement 0 Then
'overall x, bottom placement
Dpoint1(0) = OverAllX1(0)
Dpoint1(1) = OverAllX1(1)
Dpoint1(2) = 0
Dpoint2(0) = OverAllX2(0)
Dpoint2(1) = OverAllX2(1)
Dpoint2(2) = 0
Dlocation(0) = OverAllXlocation(0)
Dlocation(1) = OverAllXlocation(1)
Dlocation(2) = 0
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0)
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
M1(0) = Dpoint2(0)
M1(1) = Dpoint2(1)
M1(2) = Dpoint2(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint2(0) = P1(0)
Dpoint2(1) = P1(1)
Dpoint2(2) = P1(2)
M1(0) = Dlocation(0)
M1(1) = Dlocation(1)
M1(2) = Dlocation(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dlocation(0) = P1(0)
If MaxSteps = 0 Then
Dlocation(1) = P1(1) - 0.67676714 '- 0.375 '.375 = aligned with others
End If
If MaxSteps = 1 Then
Dlocation(1) = P1(1) - (0.67676714 + 0.15) '- 0.375
End If
If MaxSteps > 1 Then
Dlocation(1) = P1(1) - (0.67676714 + 0.15 + (0.15 * MaxSteps))
End If
Dlocation(2) = P1(2)
Set dimObj = ThisDrawing2.PaperSpace.AddDimAligned(Dpoint1, Dpoint2, Dlocation)
dimObj.ExtLine1Suppress = False
dimObj.ExtLine2Suppress = False
dimObj.ExtLineFixedLen = 5
If ModLeg = 1 Then
dimObj.ExtLine2Suppress = True
End If
End If
'0.30176714
Dim TestCollisionPoint(0 To 2) As Double
Dim u As Integer
Dim ModuleText As String
widthx = 0.75
Dim PreviousModulePoint(0 To 2) As Double
Dim P As Integer
Dim dist As Double
Dim dist2 As Double
Dim Xme As Double
Dim Yme As Double
Dim Zme As Double
'OverAllAngle placment
Dpoint1(0) = OverAllAngle1(0)
Dpoint1(1) = OverAllAngle1(1)
Dpoint1(2) = 0
Dpoint2(0) = OverAllAngle2(0)
Dpoint2(1) = OverAllAngle2(1)
Dpoint2(2) = 0
Dlocation(0) = OverAllAnglelocation(0)
Dlocation(1) = OverAllAnglelocation(1)
Dlocation(2) = 0
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0)
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
M1(0) = Dpoint2(0)
M1(1) = Dpoint2(1)
M1(2) = Dpoint2(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint2(0) = P1(0)
Dpoint2(1) = P1(1)
Dpoint2(2) = P1(2)
M1(0) = Dlocation(0)
M1(1) = Dlocation(1)
M1(2) = Dlocation(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dlocation(0) = P1(0)
Dlocation(1) = P1(1)
Dlocation(2) = P1(2)
Set dimObj = ThisDrawing2.PaperSpace.AddDimAligned(Dpoint1, Dpoint2, Dlocation)
TestCollisionPoint(0) = Dlocation(0)
TestCollisionPoint(1) = Dlocation(1)
TestCollisionPoint(2) = Dlocation(2)
SkipDims:
'module placment
P = 1
If ModuleArrayCounter > -1 Then
For u = 0 To UBound(ModuleArray)
If P = 1 Then
P = 0
Else
P = 1
End If
Dpoint1(0) = ModuleArray(u).PointX
Dpoint1(1) = ModuleArray(u).PointY
Dpoint1(2) = 0
ModuleText = ModuleArray(u).StringName
M1(0) = Dpoint1(0)
M1(1) = Dpoint1(1)
M1(2) = Dpoint1(2)
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
Dpoint1(0) = P1(0) - 0.375
Dpoint1(1) = P1(1)
Dpoint1(2) = P1(2)
'test for center collision
' Xme = Dpoint1(0) - TestCollisionPoint(0)
' Yme = Dpoint1(1) - TestCollisionPoint(1)
' Zme = Dpoint1(2) - TestCollisionPoint(2)
' dist = Sqr((Sqr((Xme ^ 2) + (Yme ^ 2)) ^ 2) + (Zme ^ 2))
'check the one before it
'if it is to the left of the dim, move it left and up .25
' If u 0 Then
' Xme = Dpoint1(0) - PreviousModulePoint(0)
' Yme = Dpoint1(1) - PreviousModulePoint(1)
' Zme = Dpoint1(2) - PreviousModulePoint(2)
' dist2 = Sqr((Sqr((Xme ^ 2) + (Yme ^ 2)) ^ 2) + (Zme ^ 2))
' End If
'
'
' If u 0 Then
' If dist2 TestCollisionPoint(0) Then
' If Dpoint1(0) - TestCollisionPoint(0) TestCollisionPoint(0) Then
''' If Dpoint1(0) - TestCollisionPoint(0) UBound(FilesArrayCheck) Then GoTo ExitNow
If FileCountx < 0 Then
MsgBox "There are no more previous drawing files to review."
GoTo ExitNow
End If
importFile = FilesArrayCheck(FileCountx)
tmpFilename = importFile
thisdrawing.Application.Documents.Open importFile
Set ThisDrawing2 = thisdrawing.Application.ActiveDocument
teststring2 = ThisDrawing2.Name
Text2.Text = str(FileCountx + 1)
ZoomExtents
GoTo ExitNow2
ExitNow:
IsOpeningDrawing = False
Unload Me
ExitNow2:
IsOpeningDrawing = False
End Sub