Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Can’t get module to work with progress bar popup form 1

Status
Not open for further replies.
patriciaxxx

patriciaxxx

Programmer
Jan 30, 2012
277
GB
Here is my mod the highlighted line creates a backup of the db which can take a second to several minutes depending on its size.

Code: 
[COLOR=#204A87]Public Function BackupDatabase()
Dim strData As String
Dim strDir As String
Dim lngOpen As Long
Dim datBackup As Date
Dim strBkp As String
Dim strDbBkp As String
Dim intBkp As Integer
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("tblBackupDatabase", dbOpenDynaset)
rst.MoveFirst
lngOpen = rst!OpenCount
datBackup = rst!LastBackup
rst.Close
Set rst = Nothing
strData = Mid(db.TableDefs("tblBackupDatabase").Connect, 11)
strDbBkp = CreateObject("scripting.filesystemobject").GetBaseName(strData) 
strDir = Left(strData, InStrRev(strData, "\"))
strBkp = Dir(strDir & "BackupData\" & strDbBkp & "*.mdb")
strBkp = strDir & "BackupData\" & strDbBkp & "_Bkp" & Format(Date, "yymmdd") & ".mdb"
[highlight #FCE94F]DBEngine.CompactDatabase strData, strBkp[/highlight]
MsgBox "Backup created successfully.", vbInformation, "Backup Database"
Set db = Nothing
End Function[/color]

For this line I need to open a form which acts as the progress meter to show the actual progress of the backup action.

Here is the form code for the progress meter.

Can anyone show me how to combine the two codes to achieve what I want.

Code: 
[COLOR=#204A87]Private Sub cmdGo_Click()
Dim inti As Integer
Dim dblPct As Double
Me.lblEscape.Visible = True
Me.lblAbort.Visible = False
Me.txtI.Visible = True
Me.txtPctComplete.Visible = True
Me.boxWhole.Visible = True
Me.boxPct.Visible = True

Do Until inti > Me.txtNumIterations
dblPct = inti / Me.txtNumIterations
Me.txtPctComplete = dblPct
Me.boxPct.Width = Me.boxWhole.Width * dblPct
Me.txtI = inti
'If Me.txtI Mod 1 = 0 Then
DoEvents
'End If
inti = inti + 1
Loop
Me.lblEscape.Visible = False
End Sub
[/color]
 
Sort by date Sort by votes
Patricia,

ignoring other issues about how you display a progress bar during a synchronous atomic operation (or, more generally, how you do anything else at all during such) how would your progress bar dispay progress when you have no information about how much progress has actually been made (CompactDatabase does not provide any information about how far it has got)?

I'd guess what you really want is simply some feedback that something is actually going on (such as the AJAX spinnereel, for example).

Once upon a time we used to do this in VBA with a spinning hourglass (the full VB product used to ship with a whole series of animated cursors), but that seems to be considered a bit old-fashioned now. Perhaps some sort of 'thinking' bar ...


Here's an outline of how we'd run CompactDatabase asynchronously and regularly update some information whilst that is happening.

The following goes in a module:


Code: 
[blue]Option Compare Database
Option Explicit

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private hThreadID As Long
Private lTimer As Long

Public Sub BackupDataBase()
    ' Blah
    ' Blah
    ' Blah
    ' DBEngine.CompactDatabase strData, strBkp
    Sleep 10000 ' this is my replacement for CompactDatabase. Just gives us a known-length atomic event
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
End Sub

Public Sub SpawnBackup()
    Dim hThread As Long
    Dim hThreadID As Long
    ' launch a timer that tickes every 500ms
    lTimer = SetTimer(0&, 0&, 500, AddressOf nTimerHandler) ' Note that timer events are not exact
    ' spawn asynch processing ...
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf BackupDataBase, ByVal 0&, ByVal 0&, hThreadID)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Long
    Progress = Progress + 500
    Debug.Print Progress & " msecs"
End Sub[/blue]


And is invoked by calling Spawnbackup

 
Upvote 0 Downvote
Hello strongm

Thank you for you reply, I’ve been trying it.

Your comments of what I need are correct, and I did indeed look at trying to implement a spinnerreal, I got as far as obtaining a suitable animated gif but couldn’t find a way to display it in my Access db, if you have a working solution I would be grateful.

Your code solution was very smart, however when I use my code it errors with the following message:

Method 'CurrentDb' of object '_Application' failed

Which is followed by the following message:

microsoft access has encountered a problem and needs to close

This is how I used your code:

Code: 
[COLOR=#204A87]Option Compare Database
Option Explicit

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private hThreadID As Long
Private lTimer As Long

Public Sub BackupDataBase()
Dim inti As Integer
Dim dblPct As Double
Me.lblEscape.Visible = True
Me.lblAbort.Visible = False
Me.txtI.Visible = True
Me.txtPctComplete.Visible = True
Me.boxWhole.Visible = True
Me.boxPct.Visible = True

Do Until inti > Me.txtNumIterations
dblPct = inti / Me.txtNumIterations
Me.txtPctComplete = dblPct
Me.boxPct.Width = Me.boxWhole.Width * dblPct
Me.txtI = inti
'If Me.txtI Mod 1 = 0 Then
DoEvents
'End If
inti = inti + 1
Loop
Me.lblEscape.Visible = False
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
End Sub

Public Sub SpawnBackup()
    Dim hThread As Long
    Dim hThreadID As Long
    ' launch a timer that tickes every 500ms
    lTimer = SetTimer(0&, 0&, 500, AddressOf nTimerHandler) ' Note that timer events are not exact
    ' spawn asynch processing ...
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf BackupDataBase, ByVal 0&, ByVal 0&, hThreadID)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Long
    Progress = Progress + 500
    Debug.Print Progress & " msecs"
End Sub
[/color]

Is it possible to use the nTimerHandler function to then update the progress bar form? I will try it now with you original code sample just to see (not my code as it errors and crashes).
 
Upvote 0 Downvote
>Is it possible to use the nTimerHandler function to then update the progress bar form

Exactly
 
Upvote 0 Downvote
Hello strongm

Have I used your code correct as in my reply because it errors and crashes, any idea what is wrong with it.
Also tried to use the timer function, can you show me how does my form progress bar code change to achieve this.

Code: 
[COLOR=#204A87]Private Sub cmdGo_Click()
Dim inti As Integer
Dim dblPct As Double
Me.lblEscape.Visible = True
Me.lblAbort.Visible = False
Me.txtI.Visible = True
Me.txtPctComplete.Visible = True
Me.boxWhole.Visible = True
Me.boxPct.Visible = True

Do Until inti > Me.txtNumIterations
dblPct = inti / Me.txtNumIterations
Me.txtPctComplete = dblPct
Me.boxPct.Width = Me.boxWhole.Width * dblPct
Me.txtI = inti
'If Me.txtI Mod 1 = 0 Then
DoEvents
'End If
inti = inti + 1
Loop
Me.lblEscape.Visible = False
End Sub
[/color]
 
Upvote 0 Downvote
Try the following example. You'll need a UserForm (which we are using to host our thinking bar) with one command button and an Image control placed on it. The following code goes in the UserForm's module:

Code: 
[blue]Option Compare Database
Option Explicit

Private Sub CommandButton1_Click()
    SpawnBackup
End Sub

Private Sub UserForm_Initialize()
    Image1.Move 0, InsideHeight - 12, 0, 12
    Image1.BackColor = vbBlue
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     ' Don't allow exit while spawned thread still running
     If lTimer Then Cancel = True
End Sub[/blue]

The the following minor modification of the earlier example goes in a normal module:

Code: 
[blue]Option Compare Database
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Public lTimer As Long

Public Sub BackupDataBase()
    ' Blah
    ' Blah
    ' Blah
    ' DBEngine.CompactDatabase strData, strBkp
    UserForm1.Image1.Visible = True
    Sleep 10000 ' this is my replacement for CompactDatabase. Just gives us a known-length atomic event
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
    lTimer = 0
    UserForm1.Image1.Visible = False
End Sub

Public Sub SpawnBackup()
    Dim hThread As Long
    Dim hThreadID As Long
    ' launch a timer that tickes every 500ms
    lTimer = SetTimer(0&, 0&, 50, AddressOf nTimerHandler) ' Note that timer events are not exact
    ' spawn asynch processing ...
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf BackupDataBase, ByVal 0&, ByVal 0&, hThreadID)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Double
    Dim Step As Double
    
    Step = UserForm1.InsideWidth / 50 ' arbitary step size
    UserForm1.Image1.Width = (UserForm1.Image1.Width + Step) Mod UserForm1.InsideWidth
    Progress = Progress + Step
End Sub[/blue]
 
Upvote 0 Downvote
Hello strongm

I tried your example as you said it shows the progress but I don’t think the Private Sub UserForm_Initialize() and Private Sub UserForm_QueryClose bits kick in because the color stays the color of the image control and you can exit the form whilst it is still running.

But when I insert the BackupDatabase code in place of your ‘Sleep 10000’ it still errors with the following message:

Method 'CurrentDb' of object '_Application' failed

Which is followed by the following message:

microsoft access has encountered a problem and needs to close

Any ideas what I might be doing wrong?

 
Upvote 0 Downvote
The example provided by strongm is for a UserForm (msform) not an AccessForm.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
>I don’t think the Private Sub UserForm_Initialize() and Private Sub UserForm_QueryClose

strongm said:
You'll need a UserForm
Click to expand...

>Method 'CurrentDb' of object '_Application' failed

>Which is followed by the following message:

>microsoft access has encountered a problem and needs to close

As I mentioned in my first post, there are issues in achieving what you want. The main issue is that we are doing something VBA was never designed to support - spawning an asynchronous thread (VBA is a resolutely single-threaded environment). The asynch thread isn't really under the normal control of VBA, so if there are any problems with the code in that thread ... VBA will blow up spectacularly. And when VBA blows up, the host blows up.
 
Upvote 0 Downvote
Hello strongm

My mistake, I get it now, UserForm not AccessForm.

It starts with the following error and just sticks there going round and round, do you know why that might be?

automation error coinitialize has not been called
 
Upvote 0 Downvote
We get into some relatively esoteric areas here ...

Try adding the following declarations:

Public Declare Sub CoInitialize Lib "COMDLL.dll" ()
Public Declare Sub CoUninitialize Lib "COMDLL.dll" ()

Then wrap the BackupDatabase sub with the calls, i.e.:

Code: 
[blue]Public Sub BackupDataBase()
    [b]CoInitialize[/b]
    ' Blah
    ' Blah
    ' Blah
    ' DBEngine.CompactDatabase strData, strBkp
    UserForm1.Image1.Visible = True
    Sleep 10000 ' this is my replacement for CompactDatabase. Just gives us a known-length atomic event
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
    lTimer = 0
    UserForm1.Image1.Visible = False
    [b]CoUninitialize[/b]
End Sub[/blue]

 
Upvote 0 Downvote
Hello strongm

Tried that but get yet another error, and whatever code I insert in place of your ‘Sleep 10000’ just gives errors and crashes the db.

So think its time to draw a line under this one, very complicated need to be an expert programmer to sort this one out.

Guess its like you said ‘we are doing something VBA was never designed to support’ ergo all the errors.

Thank you very much for your time and effort.



 
Upvote 0 Downvote
Hello strongm

Been playing with it some more.

A final thought how would you modify your code to dynamically create the UserForm with just the image control (no Button) so that it runs each time with your code and is closed and removed when the code has finished running.
 
Upvote 0 Downvote
Does anyone know how to modify the code below to dynamically create and display the UserForm with just the image control (no Button) so that it runs each time with the code and is closed and removed when the code has finished running.

Code: 
[COLOR=#204A87]Option Compare Database
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Public lTimer As Long

Public Sub BackupDataBase()
    ' Blah
    ' Blah
    ' Blah
    ' DBEngine.CompactDatabase strData, strBkp
    UserForm1.Image1.Visible = True
    Sleep 10000 ' this is my replacement for CompactDatabase. Just gives us a known-length atomic event
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
    lTimer = 0
    UserForm1.Image1.Visible = False
End Sub

Public Sub SpawnBackup()
    Dim hThread As Long
    Dim hThreadID As Long
    ' launch a timer that tickes every 500ms
    lTimer = SetTimer(0&, 0&, 50, AddressOf nTimerHandler) ' Note that timer events are not exact
    ' spawn asynch processing ...
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf BackupDataBase, ByVal 0&, ByVal 0&, hThreadID)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Double
    Dim Step As Double
    
    Step = UserForm1.InsideWidth / 50 ' arbitary step size
    UserForm1.Image1.Width = (UserForm1.Image1.Width + Step) Mod UserForm1.InsideWidth
    Progress = Progress + Step
End Sub  
[/color]

Below was the UserForm code (when I created the UserForm manually) just incase you need it to know what was happening or still use it somehow in the dynamically created UserForm.

Code: 
[COLOR=#204A87]Option Compare Database
Option Explicit

Private Sub CommandButton1_Click()
    SpawnBackup
End Sub

Private Sub UserForm_Initialize()
    Image1.Move 0, InsideHeight - 12, 0, 12
    Image1.BackColor = vbBlue
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     ' Don't allow exit while spawned thread still running
     If lTimer Then Cancel = True
End Sub 
[/color]
 
Upvote 0 Downvote
I thought we'd already established that you don't don't want asynchronous threads, so presumably what you are asking is how do we implement a timer like the one in an Access form to drive a thinking/progress bar. In which case, with very minor modification (and you still need the UserForm as before;, but you can dispense with the CommandButton and it's associated code):

Code: 
[blue]Option Compare Database
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public lTimer As Long

Public SomeEndCondition As Long ' we need a way of flagging the end of this, so I'm simply goping to be setting a maximum time limit

Public Sub PatriciaExample()
    UserForm1.Show False ' show the hosting form
    SomeEndCondition = 5000 'set for 500ms i.e. 5 seconds
    lTimer = SetTimer(0&, 0&, 50, AddressOf nTimerHandler)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Double
    Static Tick
    
    Tick = Tick + 50 ' 50ms is time interval we selected for this timer
    
    Dim Step As Double
    
    Step = UserForm1.InsideWidth / 50 ' arbitary step size
    UserForm1.Image1.Width = (UserForm1.Image1.Width + Step) Mod UserForm1.InsideWidth
    Progress = Progress + Step

    If Tick >= SomeEndCondition Then ' check whether end condition has been met
        lTimer = SetTimer(0&, lTimer, 50, 0&) ' reset Timer else we get in a mess
        KillTimer 0&, lTimer ' and kill it
        lTimer = 0
        Unload UserForm1 ' and unload our hosting form
    End If
End Sub[/blue]
 
Upvote 0 Downvote
Hello strongm

Thank you for your reply.

What I was hoping for was the code below modified so that it created the UserForm and image control each time it was run and removed it when it ended.

Is that not possible?

Code: 
[COLOR=#204A87]Option Compare Database
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Public lTimer As Long

Public Sub BackupDataBase()
    ' Blah
    ' Blah
    ' Blah
    ' DBEngine.CompactDatabase strData, strBkp
    UserForm1.Image1.Visible = True
    Sleep 10000 ' this is my replacement for CompactDatabase. Just gives us a known-length atomic event
    ' Kill our timer once this sub is about to end
    KillTimer 0&, lTimer
    lTimer = 0
    UserForm1.Image1.Visible = False
End Sub

Public Sub SpawnBackup()
    Dim hThread As Long
    Dim hThreadID As Long
    ' launch a timer that tickes every 500ms
    lTimer = SetTimer(0&, 0&, 50, AddressOf nTimerHandler) ' Note that timer events are not exact
    ' spawn asynch processing ...
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf BackupDataBase, ByVal 0&, ByVal 0&, hThreadID)
End Sub

Public Sub nTimerHandler(ByVal hwnd As Long, ByVal uMSG As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' This is where you'd update your 'thinking' bar
    Static Progress As Double
    Dim Step As Double
    
    Step = UserForm1.InsideWidth / 50 ' arbitary step size
    UserForm1.Image1.Width = (UserForm1.Image1.Width + Step) Mod UserForm1.InsideWidth
    Progress = Progress + Step
End Sub[/color]
 
Upvote 0 Downvote
My code in thread705-1700623 shows two ways of dynamically creating and destroying a userform that shows a progress bar.
 
Upvote 0 Downvote
Hello strongm

I had come across that code whilst doing a search on tektips, I took out the bits I thought were needed and placed them in the Public Sub BackupDataBase() but when I ran SpawnBackup it crashed out.

This type of coding is tricky like you said and I guess it needs to be exactly right, something I'm just not good enough yet to do, if you could demonstrate how it would be accomplished in the code above I would be grateful.
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

DarkOne72
  • Locked
  • Question
Message Box Popup on certain days help !
2
Replies
23
Views
1K
Norman Sherlock
Norman Sherlock
M
  • Question
display a calendar with appointments in body of html email with access vba
Replies
1
Views
413
SoftwareRT
SoftwareRT
JimStrand
  • Locked
  • Question
Trying to Use Form Control as Variable in Report Control Source 2
Replies
5
Views
273
Andrzejek
Andrzejek
Dan Stoica
  • Locked
  • Question
Problems with Foxpro dsnless linked tables
Replies
0
Views
195
Dan Stoica
Dan Stoica
feipezi
  • Locked
  • Question
How to get the macros back as they vanish somehow in a AccessDB?
Replies
8
Views
296
combo
combo

Part and Inventory Search

Sponsor

Back
Top