Hallo zusammen!
Ich habe folgendes Problem.
In einem kleinen VBA Programm habe ich eine UserForm1 mit einer ProgrsssBar eingebaut. Diese wird bei Durchlauf einer Schleife gefüllt.
Nun möchte ich aber, daß eine eigene UserForm2 mit einer ProgressBar beim ButtonClick erscheint, so wie man es aus verschiedenen Programmen kennt.
Dies habe ich bislang probiert:
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
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 Kann mir da jemand weiterhelfen?
Vielen Dank im voraus.
Gruß
Dirk |