UserForm2.Show vbModeless

Private Sub CommandButton1_Click()
Dim aktWinState As Integer
Dim aktHeight As Long
Dim aktWidth As Long
Dim Dateiname As String
Dim ImportPfad As String
Dim ExportPfad As String
Dim NewBlock As AcadBlock
Dim BlockDef As AcadBlockReference
Dim Min(2) As Double
Dim Max(2) As Double
Dim VPKreis As AcadCircle
Dim VPschraf As AcadHatch
Dim InsPkt(2) As Double
Dim Sset As AcadSelectionSet
Dim Entity(0) As AcadEntity
'Hintergrundfarbe
Dim color1 As Variant
color1 = RGB(255, 255, 255)
Dim color2 As Variant
color2 = RGB(0, 0, 0)
 
Set NewDoc = ThisDrawing.Application.Documents.Add
ThisDrawing.Application.Preferences.Display.GraphicsWinModelBackgrndColor = _
  color1
 
ImportPfad = TextBox1.Value & "\" 'Das Verzeichnis wird über Ordnerauswahl in 
' die
ExportPfad = ImportPfad
 
ThisDrawing.WindowState = acNorm
ThisDrawing.height = 400
ThisDrawing.Width = 400
 
 
'' Anzahl Dateien ermitteln für Maximale Anzahl im Fortschrittsbalken.
  Dim DateiZahl As String, i As Integer
  i = 0
  DateiZahl = Dir$(ImportPfad & "*.dwg")
  Do While DateiZahl <> ""
  i = i + 1
  DateiZahl = Dir$()
  Loop
  'Me.Hide
  'Me.ProgressBar1.Max = i
  UserForm2.ProgressBar1.Max = i
  UserForm2.Show [color=red]vbModeless[/color]
Dateiname = Dir(ImportPfad & "*.dwg")
Do While Dateiname <> ""
    Set BlockDef = ThisDrawing.ModelSpace.InsertBlock(InsPkt, ImportPfad & _
      Dateiname, 1, 1, 1, 0)
    BlockDef.Update
    'Markierung am Einfügepunkt
    DoEvents
    Set VPKreis = ThisDrawing.ModelSpace.AddCircle(InsPkt, 2)
    VPKreis.color = acRed
    VPKreis.Update
    Set VPschraf = ThisDrawing.ModelSpace.AddHatch(0, "Solid", True)
    Set Entity(0) = VPKreis
    VPschraf.AppendOuterLoop (Entity)
    VPschraf.color = acRed
    VPschraf.Update
 
    'Me.Caption = Dateiname
    UserForm2.Label1.Caption = Dateiname
    'BlockDef.GetBoundingBox Min, Max
    ThisDrawing.Application.ZoomExtents
    ThisDrawing.Application.ZoomScaled 0.9, acZoomScaledRelative
    'ThisDrawing.Regen acActiveViewport
 
    On Error Resume Next
    Set Sset = ThisDrawing.SelectionSets("MySel")
    If Err.Number Then
        Set Sset = ThisDrawing.SelectionSets.Add("MySel")
    End If
    On Error GoTo 0
    Sset.Clear
    Sset.Select acSelectionSetAll
 
    DoEvents
    ThisDrawing.Export Left(ExportPfad & Dateiname, Len(ExportPfad & Dateiname) _
      - 4), "bmp", Sset
    ThisDrawing.Export Left(ExportPfad & Dateiname, Len(ExportPfad & Dateiname) _
    - 4), "wmf", Sset
 
    BlockDef.Delete
    VPKreis.Delete
    VPschraf.Delete
    Sset.Delete
 
    '' Fortschrittsbalken um 1 erhöhen.
    Dateiname = Dir
'    If ProgressBar1 + 1 > ProgressBar1.Max Then Exit Do
'    ProgressBar1 = ProgressBar1 + 1
'    DoEvents
    If UserForm2.ProgressBar1 + 1 > UserForm2.ProgressBar1.Max Then Exit Do
    UserForm2.ProgressBar1 = UserForm2.ProgressBar1 + 1
    DoEvents
Loop
NewDoc.Close
Me.Caption = "Durchlauf beendet"
UserForm2.ProgressBar1.Value = 0
ThisDrawing.Application.Preferences.Display.GraphicsWinModelBackgrndColor = _
  color2
End Sub

mfg
brave@heart

...bis zur unendlichkeit und noch viel weiter...