Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub XrefAttach2Dwg()
Dim XrefRng As Range, XrefPathRng As Range, cell As Range, cxrefname As String, Xrefpaste As Range, cellx As Range, Alive As String, checkcellRange As Range, Checkcellval As String, fileName As String, pctCompl As Single, inRng As Range, n, myworkbook, cellxval As String, CurrentDWG As String, sleeptime As Integer, Tidy As Integer
Dim TempLoc As String
Dim LayName As Range
Dim acadApp As Object
TempLoc = "File Path/Drawing.dwt"
Set XrefRng = Range("Xref_Attach_Range")
Set XrefLookup = Range("Xref_Lookup")
Set inRng = Application.Range("Table4[DWG Path]")
Set wS1 = Worksheets("Send AutoCAD Commands")
Set XrefPathRng = Range("Xref_Paths")
Set outCell = wS1.Range("E18") 'change to be first cell of output range
Set inlay = Application.Range("Table4[Layout]") 'set copy location of layout name
Set outlay = wS1.Range("F16") 'set paste location of layout name
i = 0
Startcolumn = "F"
Endcolumn = "N"
n = 0
Currrow = 18
Application.ScreenUpdating = False
Checkcellval = Worksheets("Project builder").Range("F6").Value
'------------Checking if XRef's Exist-------------------
For Each checkcell In XrefPathRng
Checkcellval = checkcell.Value
'MsgBox checkcell.Address
If Checkcellval = "" Then
GoTo SkipCell
Else
End If
If Dir(Checkcellval) <> "" Then
'MsgBox "File exists."
Else
MsgBox ("The following Xref does not exist:" & vbNewLine & Checkcellval & vbNewLine & "Please check the file and try again")
Exit Sub
End If
i = 1 + i
SkipCell:
Next checkcell
'-------End Checking Xrefs---------------
If MsgBox("Excel and AutoCAD will not be accessible during the operation Are you sure you would like to continue?", vbYesNo) = vbNo Then Exit Sub
Worksheets("Project Builder").Range("F19").Select
'-------------Creating Drawing--------------------
For Each incell In inRng
'incell.Select
'MsgBox incell
CurrentDWG = incell.Offset(0, -11).Value
Set LayName = Worksheets("Project Builder").Cells(incell.Row, 1)
If Dir(incell.Value) <> "" Then
Tidy = 1
GoTo DWGExist
Else
[B]On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If[/B]
' Set acadApp = GetObject(, "AutoCAD.Application")
' acadApp.Visible = True
'If acadApp Is Nothing Then
'Sleep (3000)
'Set acadApp = CreateObject("AutoCAD.Application")
'acadApp.Visible = True
'Alive = "Yes"
'Else
'Alive = "No"
'End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
AutoCAD.Application.Documents.Open TempLoc
AutoCAD.Application.ActiveDocument.SendCommand ("LAYOUT" & vbCr & "R" & vbCr & "000" & vbCr & LayName & vbCr) 'renames the layout from default "000" to the name stored in LayName
AutoCAD.Application.ActiveDocument.SaveAs incell.Value, AcSaveAsType.ac2007_dwg 'Saves the drawing to the incell value in a 2007 DWG format
UserForm1.DWG.Caption = "Created" & CurrentDWG 'Updates the progress indicator to display drawing created
End If
'Progress Bar Code Start
pctCompl = (n / (Range("Table4[DWG Path]").Count)) * 100
progress pctCompl
progressDWG CurrentDWG
'Progress Bar Code Ends
'End If
'--------Searching XrefRange For Instances of "Yes"---------------
Sheets("Project Builder").Select
Currrow = Currrow + 1
Set Currrange = Range(Startcolumn & Currrow & ":" & Endcolumn & Currrow)
For Each cell In Currrange
'cell.Select
Sheets("Project Builder").Select
If cell.Value = "Yes" Then
sleeptime = 2000
cxrefname = Cells(17, cell.Column).Value
'MsgBox cxrefname & " " & ActiveCell.Address 'Use for Testing Variable Value
Else
sleeptime = 100
cxrefname = "No Xref to Attach"
End If
'--------once it finds an instance of yes search for Xref particulars-------------
Sheets("Project Builder").Select
For Each cellx In XrefLookup
cellxval = cellx.Value
If cellxval = cxrefname Then
Set Xrefpaste = cellx.Offset(0, 1)
fileName = Replace(Dir(Xrefpaste), ".dwg", "")
AutoCAD.Application.ActiveDocument.ActiveSpace = acModelSpace
AutoCAD.Application.ActiveDocument.SendCommand ("FILEDIA" & vbCr & "0" & vbCr & "-Xref" & vbCr & "o" & vbCr & Xrefpaste & vbCr & "0,0" & vbCr & "1" & vbCr & "1" & vbCr & "0" & vbCr & "FILEDIA" & vbCr & "1" & vbCr) 'Attaches Xref into Drawing
AutoCAD.Application.ActiveDocument.SendCommand ("FILEDIA" & vbCr & "0" & vbCr & "-rename" & vbCr & "b" & vbCr & fileName & vbCr & cxrefname & vbCr & "FILEDIA" & vbCr & "1" & vbCr) 'Renames Xref from default name to that specified in Project builder
UserForm1.DWG.Caption = "Attaching Xrefs to " & CurrentDWG 'Updates Progress Indicator to display that Xrefs are currently being attached to Drawings
Else
End If
Next cellx
'--------End searching for xref particulars------------
Next cell
AutoCAD.Application.ActiveDocument.SendCommand ("FILEDIA" & vbCr & "0" & vbCr & "FILEDIA" & vbCr & "1" & vbCr & "COMMANDLINE" & vbCr) 'Quick Saves Drawing
AutoCAD.Application.ActiveDocument.Save
AutoCAD.Application.ActiveDocument.Close 'Closes AutoCAD
Sleep (sleeptime)
n = n + 1
Tidy = 0
DWGExist:
Next incell
'----------------End Searching XrefRange For Instances of "Yes"----------------
If Tidy = 0 Then
Sheets("Send AutoCAD Commands").Range("C13:O73").ClearContents
AutoCAD.Application.ActiveDocument.SendCommand ("FILEDIA" & vbCr & "1" & vbCr & "COMMANDLINE" & vbCr)
If Alive = "Yes" Then
AutoCAD.Application.Quit
End If
Else
End If
[B]acadApp.Quit
Set acadApp = Nothing[/B]
Application.ScreenUpdating = True
pctCompl = 100
UserForm1.Bar.Width = 246.5
progress pctCompl
MsgBox "The project has been built. " & vbNewLine & n & " Drawing(s) were created.", vbInformation, "Done"
End Sub