progress bar in do while

B

benjamin.grimm

Registered User.
Local time
Yesterday, 16:48
Joined
Sep 3, 2013
Messages
125
hello togehter,

how can i do a progress in bar in a do while.

i export contract and during the export i want to have a progress bar.

do while

msgbox "the export runs", progress bar

Loop

Greetz benjamin
 
hello thanks for the answer.

I tried to that now, i just have one problem, that the green progress bar is not moving.

I´ve created a form with a green and a red bar.

Then a modul with the following code:

Code: 
Option Compare Database
Option Explicit
Public Function FnBalkenanzeige(strMeldung As String, intAnteil As Integer, Optional blnGebunden As Boolean = True)
    
 
Const cstrForm = "frmBalkenanzeige"
Dim lngGruen    As Long
Dim lngRot      As Long
    
    If FnblnIstFormOffen(cstrForm) = False Then
        If blnGebunden Then
            DoCmd.OpenForm cstrForm, acNormal, , , , acDialog
          Else
            DoCmd.OpenForm cstrForm, acNormal, , , , acWindowNormal
        End If
    End If
    With Forms(cstrForm)
        ' Titel 
        .Caption = "Balkenanzeige"
        .Controls("lblGruen").Left = .Controls("lblRot").Left
        .Controls("lblGruen").Top = .Controls("lblRot").Top
        .Controls("lblGruen").Height = .Controls("lblRot").Height
        .Controls("txtMeldung") = ""
    End With
    Select Case intAnteil
      Case Is > 100: 
        Forms(cstrForm).Controls("lblGruen").Visible = False
        Forms(cstrForm).Controls("lblRot").Visible = False
        DoCmd.Close acForm, cstrForm
        Exit Function
      Case 0:
        Forms(cstrForm).Controls("lblRot").Visible = True
        Forms(cstrForm).Controls("lblGruen").Visible = False
      Case Else 
        Forms(cstrForm).Controls("lblRot").Visible = True
        lngRot = Forms(cstrForm).Controls("lblRot").Width
        lngGruen = Int(lngRot / 100 * intAnteil)
        Forms(cstrForm).Controls("lblGruen").Width = lngGruen
        Forms(cstrForm).Controls("lblGruen").Visible = True
    End Select
    If Forms(cstrForm).Controls("txtMeldung") <> strMeldung Then
        Forms(cstrForm).Controls("txtMeldung") = strMeldung
    End If
    Forms(cstrForm).Requery
    Forms(cstrForm).Repaint
End Function
 
Public Function FnblnIstFormOffen(strForm As String) As Boolean
FnblnIstFormOffen = (SysCmd(acSysCmdGetObjectState, acForm, strForm) <> 0)
End Function


This works perfect.

And now i tried to put in my code, i think here is the mistake.


Code: 
Private Sub Befehl13_Click()
    Dim xlApp As Object         'Excel.Application
    Dim xlBook As Object        'Excel.Workbook
    Dim xlSheet As Object       'Excel.Worksheet
    Dim xlsheet2 As Object
    
    Dim rstID As DAO.Recordset, tmpStr As String
    Dim rstGr As DAO.Recordset, strSQL As String
    Dim rst As DAO.Recordset
    
    
    
        
 
    strSQL = "SELECT SuWID FROM Abfrage_laufend_PRAP_Klagenfurt GROUP BY SuWID;"
    
    MsgBox "Die Auswertung wird gestartet"
    Dim mblnUp  As Boolean
    Dim mlngPos As Long
    Const cmlngMax  As Long = 10
    
    
    
    
    Set rstID = CurrentDb.OpenRecordset(strSQL)
    
    
    
    
    If rstID.RecordCount > 0 Then
        
        
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlBook = xlApp.Workbooks.Open("S:\Access\SuW\Tabellen\Test10.xlsm")
        Do While Not rstID.EOF
        
        
        
        
        Dim cmstrMsg  As String
    
        cmstrMsg = "Der Vertrag mit der ID" & rstID.Fields("SuWID")
    
        DoCmd.OpenForm "frmBalkenanzeige"
        
        Me.TimerInterval = 500 '0,5 Sekunden
        Me.OnTimer = "[Event Procedure]"
        mblnUp = True
        mlngPos = 1
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False
        
        
        If mblnUp Then
        If mlngPos < cmlngMax Then
            mlngPos = mlngPos + 1
          Else
            mblnUp = False
            mlngPos = mlngPos - 1
        End If
        Else
        If mlngPos > 0 Then
            mlngPos = mlngPos - 1
          Else
            mblnUp = True
            mlngPos = mlngPos + 1
        End If
        End If
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False
        
        
        
        Set xlSheet = xlBook.Sheets("Tabelle1")
 
        Set rstGr = CurrentDb.OpenRecordset("SELECT SAP1, Geris1, Pauschale1, SuWID, Jahr_Z, Monat_X, BT_Name, Vertragsbeginn, Vertragsende, Laufzeit_des_Vertrags, Zusatztext, Rückstellung, PRAP, Zusatztext_Bezahlung, Anzahl_Fahrzeuge FROM Abfrage_laufend_PRAP_Klagenfurt WHERE SuWID = " & rstID.Fields("SuWID"))
            
            
    
        xlSheet.Copy before:=xlSheet
        xlSheet.Name = "SuWID" & rstID.Fields("SuWID")
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A13").CopyFromRecordset rstGr
            
            
              
            
        Set rstGr = CurrentDb.OpenRecordset("SELECT SuWID, SAP_Nummer FROM Abfrage_SAP_Nummer_Export_laufend WHERE SuWID = " & rstID.Fields("SuWID"))
        
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000:B18000").ClearContents
            
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000").CopyFromRecordset rstGr
        
          
            
            
            
        xlBook.Sheets("Tabelle1 (2)").Select
            
        xlBook.Sheets("Tabelle1 (2)").Name = "Tabelle1"
            
            
              
        rstGr.Close
        rstID.MoveNext
            
            
        FnBalkenanzeige "", 101
        Me.TimerInterval = 0
        Me.OnTimer = ""
            
        DoCmd.Close acForm, "frmBalkenanzeige"
            
            
    Loop
    Else
        MsgBox "No information to export", vbInformation, "No data exported"
    End If
    rstID.Close
    Set rstID = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    
    
    MsgBox "Die Auswertung ist abgeschlossen"



What do i do wrong that the button does not move. Help

Greetz benjamin
 
thanke for the answer.

I am allright with the frm.

I just don´t know why the green button is not moving.

greetz benjamin
 
I just did a quick look-through, and it looks like you're re-opening the form frmBalkenanzeige with each iteration, rather than just updating the progress bar. I don't have a whole lot of time to go through things, however, and my German is beyond rusty, so that might not be the actual issue.

If you end up trying one of my implementations (first link in post 2), however, I can step you through any issues you may have.
 
hey

thanks for the answer.

Well my only question how can i put the code in my export code.

i´ve created a start button

and an end button

start button

Code: 
        Me.TimerInterval = 5
        Me.OnTimer = "[Event Procedure]"
        mblnUp = True
        mlngPos = 1
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False


end button

Code: 
        FnBalkenanzeige "", 101
        Me.TimerInterval = 0
        Me.OnTimer = ""


When i press the start button, the code runs perfectly well.

The green bar is moving.


i defined in the beginning:

Code: 
Option Explicit
Private mblnUp  As Boolean
Private mlngPos As Long
Const cmlngMax  As Long = 10
Const cmstrMsg  As String = "Bitte warten, bin noch am arbeiten!"


and i have the private sub for the timer.


Code: 
Private Sub Form_Timer()
    If mblnUp Then
        If mlngPos < cmlngMax Then
            mlngPos = mlngPos + 1
          Else
            mblnUp = False
            mlngPos = mlngPos - 1
        End If
      Else
        If mlngPos > 0 Then
            mlngPos = mlngPos - 1
          Else
            mblnUp = True
            mlngPos = mlngPos + 1
        End If
    End If
    FnBalkenanzeige cmstrMsg, mlngPos * 10, False
    
End Sub


The only question is how do i get the start and the end into this code, when i eport the data to excel.

Code: 
Private Sub Befehl13_Click()
    Dim xlApp As Object         'Excel.Application
    Dim xlBook As Object        'Excel.Workbook
    Dim xlSheet As Object       'Excel.Worksheet
    Dim xlsheet2 As Object
    
    Dim rstID As DAO.Recordset, tmpStr As String
    Dim rstGr As DAO.Recordset, strSQL As String
    Dim rst As DAO.Recordset
    
    
    
        
 
    strSQL = "SELECT SuWID FROM Abfrage_laufend_PRAP_Klagenfurt GROUP BY SuWID;"
    
    MsgBox "Die Auswertung wird gestartet"
    
    
    
    Set rstID = CurrentDb.OpenRecordset(strSQL)
    
    
    
    
    If rstID.RecordCount > 0 Then
        
        
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlBook = xlApp.Workbooks.Open("S:\Access\SuW\Tabellen\Test10.xlsm")
        Do While Not rstID.EOF
        
        
        Me.TimerInterval = 5
        Me.OnTimer = "[Event Procedure]"
        mblnUp = True
        mlngPos = 1
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False
        
        
 
        
        
        
        Set xlSheet = xlBook.Sheets("Tabelle1")
 
        Set rstGr = CurrentDb.OpenRecordset("SELECT SAP1, Geris1, Pauschale1, SuWID, Jahr_Z, Monat_X, BT_Name, Vertragsbeginn, Vertragsende, Laufzeit_des_Vertrags, Zusatztext, Rückstellung, PRAP, Zusatztext_Bezahlung, Anzahl_Fahrzeuge FROM Abfrage_laufend_PRAP_Klagenfurt WHERE SuWID = " & rstID.Fields("SuWID"))
            
            
    
        xlSheet.Copy before:=xlSheet
        xlSheet.Name = "SuWID" & rstID.Fields("SuWID")
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A13").CopyFromRecordset rstGr
            
            
              
            
        Set rstGr = CurrentDb.OpenRecordset("SELECT SuWID, SAP_Nummer FROM Abfrage_SAP_Nummer_Export_laufend WHERE SuWID = " & rstID.Fields("SuWID"))
        
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000:B18000").ClearContents
            
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000").CopyFromRecordset rstGr
        
          
            
            
            
        xlBook.Sheets("Tabelle1 (2)").Select
            
        xlBook.Sheets("Tabelle1 (2)").Name = "Tabelle1"
            
            
              
        rstGr.Close
        rstID.MoveNext
            
        FnBalkenanzeige "", 101
        Me.TimerInterval = 0
        Me.OnTimer = ""
        
            
       
            
            
    Loop
    Else
        MsgBox "No information to export", vbInformation, "No data exported"
    End If
    rstID.Close
    Set rstID = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    
    
    MsgBox "Die Auswertung ist abgeschlossen"


Do you understand what i mean?

greetz benjamin
 
If
loop
else
end if

I'm not sure if this is valid syntax. Is it?
 
Sorry your tab order had confused me. I didn't see your DoWhile statement.
 
Make a counter. Before you rs.MoveNext add.

Code: 
[COLOR="SeaGreen"]'If you use my sample progress bar I provided you you can use:[/COLOR]
index = index + 1
rectProgress.Width = rectContainer.Width * ((index / rstID.RecordCount) / 100)
 
so the only think what i want to do ist that after the do while, the code from my "start button" starts

and after the loop the code from my "end button starts".

You know what i mean?
 
No sorry, I don't see your plan here.

Write some pseudo code for me explaining the process.
 
Code: 
[COLOR=blue]Option Compare Database
Option Explicit
Private mblnUp  As Boolean
Private mlngPos As Long
Const cmlngMax  As Long = 10
Const cmstrMsg  As String = "Bitte warten, bin noch am arbeiten!"[/[/COLOR]CODE]
 
[CODE]Private Sub Befehl13_Click()
    Dim xlApp As Object         'Excel.Application
    Dim xlBook As Object        'Excel.Workbook
    Dim xlSheet As Object       'Excel.Worksheet
    Dim xlsheet2 As Object
    
    Dim rstID As DAO.Recordset, tmpStr As String
    Dim rstGr As DAO.Recordset, strSQL As String
    Dim rst As DAO.Recordset
    
    
    
    
    
        
 
    strSQL = "SELECT SuWID FROM Abfrage_laufend_PRAP_Klagenfurt GROUP BY SuWID;"
    
    MsgBox "Die Auswertung wird gestartet"
    
    
    
    Set rstID = CurrentDb.OpenRecordset(strSQL)
    
    
    
    
    If rstID.RecordCount > 0 Then
        
        
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlBook = xlApp.Workbooks.Open("S:\Access\SuW\Tabellen\Test10.xlsm")
        Do While Not rstID.EOF
        
        
[COLOR=blue]        Me.TimerInterval = 5
        Me.OnTimer = "[Event Procedure]"
        mblnUp = True
        mlngPos = 1
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False
        
            If mblnUp Then
        If mlngPos < cmlngMax Then
            mlngPos = mlngPos + 1
          Else
            mblnUp = False
            mlngPos = mlngPos - 1
        End If
      Else
        If mlngPos > 0 Then
            mlngPos = mlngPos - 1
          Else
            mblnUp = True
            mlngPos = mlngPos + 1
        End If
    End If
    If mblnUp Then
        SysCmd acSysCmdUpdateMeter, mlngPos
      Else
        SysCmd acSysCmdClearStatus
        SysCmd acSysCmdInitMeter, cmstrMsg, cmlngMax
        SysCmd acSysCmdUpdateMeter, mlngPos
    End If[/COLOR]

        
        
        
        Set xlSheet = xlBook.Sheets("Tabelle1")
 
        Set rstGr = CurrentDb.OpenRecordset("SELECT SAP1, Geris1, Pauschale1, SuWID, Jahr_Z, Monat_X, BT_Name, Vertragsbeginn, Vertragsende, Laufzeit_des_Vertrags, Zusatztext, Rückstellung, PRAP, Zusatztext_Bezahlung, Anzahl_Fahrzeuge FROM Abfrage_laufend_PRAP_Klagenfurt WHERE SuWID = " & rstID.Fields("SuWID"))
            
            
    
        xlSheet.Copy before:=xlSheet
        xlSheet.Name = "SuWID" & rstID.Fields("SuWID")
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A13").CopyFromRecordset rstGr
            
            
              
            
        Set rstGr = CurrentDb.OpenRecordset("SELECT SuWID, SAP_Nummer FROM Abfrage_SAP_Nummer_Export_laufend WHERE SuWID = " & rstID.Fields("SuWID"))
        
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000:B18000").ClearContents
            
            
        xlBook.Sheets("SuWID" & CStr(rstID![SuWID])).Range("A1000").CopyFromRecordset rstGr
        
          
            
            
            
        xlBook.Sheets("Tabelle1 (2)").Select
            
        xlBook.Sheets("Tabelle1 (2)").Name = "Tabelle1"
            
            
              
        rstGr.Close
            
        
        
        
        rstID.MoveNext
            
[COLOR=blue]        FnBalkenanzeige "", 101
        Me.TimerInterval = 0
        Me.OnTimer = ""
         
[/COLOR]       
       
       
            
            
    Loop
    Else
        MsgBox "No information to export", vbInformation, "No data exported"
    End If
    rstID.Close
    Set rstID = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    
    
    MsgBox "Die Auswertung ist abgeschlossen"


and the code for the moving of the green progress bar is

Code: 
Option Compare Database
Option Explicit
Public Function FnBalkenanzeige(strMeldung As String, intAnteil As Integer, _
                                Optional blnGebunden As Boolean = True)
    Const cstrForm = "frmBalkenanzeige"
    Dim lngGruen    As Long
    Dim lngRot      As Long
    
    If FnblnIstFormOffen(cstrForm) = False Then
        If blnGebunden Then
            DoCmd.OpenForm cstrForm, acNormal, , , , acDialog
          Else
            DoCmd.OpenForm cstrForm, acNormal, , , , acWindowNormal
        End If
    End If
    With Forms(cstrForm)
        .Caption = "Balkenanzeige"
        .Controls("lblGruen").Left = .Controls("lblRot").Left
        .Controls("lblGruen").Top = .Controls("lblRot").Top
        .Controls("lblGruen").Height = .Controls("lblRot").Height
    
        .Controls("txtMeldung") = ""
    End With
    Select Case intAnteil
      Case Is > 100:
        Forms(cstrForm).Controls("lblGruen").Visible = False
        Forms(cstrForm).Controls("lblRot").Visible = False
        DoCmd.Close acForm, cstrForm
        Exit Function
      Case 0:
        Forms(cstrForm).Controls("lblRot").Visible = True
        Forms(cstrForm).Controls("lblGruen").Visible = False
      Case Else
        Forms(cstrForm).Controls("lblRot").Visible = True
        lngRot = Forms(cstrForm).Controls("lblRot").Width
        lngGruen = Int(lngRot / 100 * intAnteil)
        Forms(cstrForm).Controls("lblGruen").Width = lngGruen
        Forms(cstrForm).Controls("lblGruen").Visible = True
    End Select
    If Forms(cstrForm).Controls("txtMeldung") <> strMeldung Then
        Forms(cstrForm).Controls("txtMeldung") = strMeldung
    End If
    Forms(cstrForm).Requery
    Forms(cstrForm).Repaint
End Function

Public Function FnblnIstFormOffen(strForm As String) As Boolean
    FnblnIstFormOffen = (SysCmd(acSysCmdGetObjectState, acForm, strForm) <> 0)
End Function


I tried the code and it works, when i have a start button and an endbutton.

start button:

Code: 
[COLOR=blue]        Me.TimerInterval = 5
        Me.OnTimer = "[Event Procedure]"
        mblnUp = True
        mlngPos = 1
        FnBalkenanzeige cmstrMsg, mlngPos * 10, False
        
            If mblnUp Then
        If mlngPos < cmlngMax Then
            mlngPos = mlngPos + 1
          Else
            mblnUp = False
            mlngPos = mlngPos - 1
        End If
      Else
        If mlngPos > 0 Then
            mlngPos = mlngPos - 1
          Else
            mblnUp = True
            mlngPos = mlngPos + 1
        End If
    End If
    If mblnUp Then
        SysCmd acSysCmdUpdateMeter, mlngPos
      Else
        SysCmd acSysCmdClearStatus
        SysCmd acSysCmdInitMeter, cmstrMsg, cmlngMax
        SysCmd acSysCmdUpdateMeter, mlngPos
    End If[/COLOR]


end button

Code: 
[COLOR=#0000ff]        FnBalkenanzeige "", 101
        Me.TimerInterval = 0
        Me.OnTimer = ""[/COLOR]


It just dont work in my do while

greetz benjamin
 
You must log in or register to reply here.

Similar threads

G
  • Question Question
How to count the number of digits in a field while typing -with vba code?
Replies
7
Views
437
Pat Hartman
P
B
  • Question Question
export and transpose problem
Replies
8
Views
577
Pat Hartman
P
M
Show a Progress Bar on Form Loading ...
2 3
Replies
43
Views
6,602
Marshall Brooks
M
D
Remember where I was in a table and return to same record
Replies
7
Views
382
Pat Hartman
P
T
Conundrum
Replies
2
Views
295
TheSearcher
T

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom