Do While Dateiname <> ""
    ThisDrawing.SetVariable "ATTMODE", 0
    'Dim InsPkt(2) As Double
    InsPkt(0) = 0: InsPkt(1) = 0: InsPkt(2) = 0
    On Error GoTo MyErrorHandler2 '###Fehlerbehandlung
    '###beim Einfügen einer Datei könnte hier der Laufzeitfehler ausgelöst 
    ' werden
    Set BlockDef = ThisDrawing.ModelSpace.InsertBlock(InsPkt, ImportPfad & _
      Dateiname, 1, 1, 1, 0)
    BlockDef.Update
 
    ...
    ...
 
    Dateiname = Dir
    If ProgressBar1 + 1 > ProgressBar1.Max Then Exit Do
    ProgressBar1 = ProgressBar1 + 1
    DoEvents
Loop
 
ProgressBar1.Value = 0
NewDoc.Close
With ThisDrawing
    .Application.Preferences.Display.GraphicsWinModelBackgrndColor = color2
    .SetVariable "ATTMODE", 1
    .WindowState = acMax   'Standardgröße
End With
Me.Caption = "Durchlauf beendet"
Me.CmbOK.SetFocus
 
    Exit Sub
 
MyErrorHandler2:
    If Err.Description = "Referenz auf sich selbst" Then
'###MsgBox Dateiname & "!   " & "Fehlerhafte Datei, bitte prüfen", 64, "Hinweis"
        Select Case MsgBox(Dateiname & "!   " & "Fehlerhafte Datei, bitte" & _
          "prüfen", _
                            vbInformation + vbRetryCancel, "Hinweis")
            Case vbCancel   '###Abbrechen / Einstellungen zurücksetzen
                NewDoc.Close
                With ThisDrawing
                    .Application.Preferences.Display.GraphicsWinModelBackgrndCo_
                      lor = color2
                    .SetVariable "ATTMODE", 1
                    .WindowState = acMax
                End With
                Exit Sub
            Case vbRetry    '###Ignorieren / it der nächsten Datei fortfahren 
            ' ????
                Resume Next '####dieses funktioniert noch nicht????
         End Select
    End If
End Sub

VG

Dirk