Thank you for the reply. Of course when it comes to me - I rarely get things correct the first time. I have read your reply - and understand it for the most part - but I'm not quite getting it to work for me. Can you tell me from the code below what I have done wrong? The macro still runs - but the error dialog box (for Error code 786434) still pops up. Have I placed the error handling incorrectly:
Code:
Dim OutputFolder As String
Dim Inputfolder As String
'*************************************************************************************************************
Sub CreateGrayBackgroundDrawing()
Inputfolder = BrowseForFolderF("Select Input folder")
OutputFolder = BrowseForFolderF("Select Output folder")
XRefFolder Inputfolder
MsgBox ("Complete")
End Sub
'*************************************************************************************************************'
Private Function BrowseForFolderF(ByVal msg As String) As String
Dim oBrowser, folderObj, folderAcpt As Object
Dim folderStr As String
Set oBrowser = ThisDrawing.Application.GetInterfaceObject("Shell.Application")
Set folderAcpt = oBrowser.BrowseForFolder(vbOKOnly, msg, vbDefaultButton3, 0)
With folderAcpt
Set folderObj = .Self
folderStr = folderObj.Path
End With
Set folderObj = Nothing
Set folderAcpt = Nothing
Set oBrowser = Nothing
BrowseForFolderF = folderStr
End Function
'*************************************************************************************************************'
Private Function XRefFolder(dirpath As String)
Dim objFolder
Dim objFile
Dim varFs() As Variant
Dim m_objFSO, n, m_lngFileCount
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = m_objFSO.GetFolder(dirpath)
Dim Gumby As String
Dim Pokey As Variant
Gumby = "The drawing for area_"
Pokey = objFolder.Name
For Each objFile In objFolder.Files
On Error GoTo Err_Control
tmpFile = objFile.Name
If LCase(Right(tmpFile, 4)) = ".dwg" Then
Dim xrfilename As String
xrfilename = dirpath & "\" & tmpFile
Dim blkname As String
blkname = tmpFile
Dim InsertPoint(0 To 2) As Double
Dim insertedBlock As AcadExternalReference
Dim tempBlock As AcadBlock
InsertPoint(0) = 0: InsertPoint(1) = 0: InsertPoint(2) = 0
Set insertedBlock = ThisDrawing.ModelSpace.AttachExternalReference(xrfilename, blkname, InsertPoint, 1, 1, 1, 0, False)
Set tmpFile = Nothing
End If
Next objFile
Set objFolder = Nothing
Set objFile = Nothing
CheckFolder = varFs
outfile = OutputFolder & "\" & Gumby & Pokey
ThisDrawing.SaveAs outfile
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Is = 786434
'Handle Error
Err.Clear
Resume Exit_Here
Case Else
MsgBox Err.Number & ", " & Err.Description, , "ErrorTest"
Err.Clear
Resume Exit_Here
End Select
End Function
(I have also included a jpg of the error message that I receive)