Microsoft ActiveX ProgressMeter working from my 2 functions 1

[patriciaxxx]

I have the following 2 functions on a form they compile and work perfectly.

'Uses the undocumented [Application.LoadFromText] syntax.
Private Function ObjLoadFromText()
On Error GoTo Err_Handler
Dim app As New Access.Application
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim nObjSelected As Long
Dim nObjLoaded As Long
Dim acObjType As Integer
Dim ObjPrefix As String
Dim objName As String
Dim ObjType As String
Dim ReturnDir As String
Dim fPrefix As Boolean

'Set up the File dialog box.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = True
.Title = "Type of Objects to load"
.Filters.Clear
.Filters.Add "Text Files", "*.txt"
.Filters.Add "All Files", "*.*"
If .Show = True Then 'Show the dialog box.
Set app = CreateObject("Access.application")
app.OpenCurrentDatabase Me!txtDb
For Each varFile In .SelectedItems
objName = CreateObject("scripting.filesystemobject").GetBaseName(varFile)
ReturnDir = CreateObject("scripting.filesystemobject").GetParentFolderName(varFile) & "\"
If Left(objName, 6) = "Query_" Or Left(objName, 5) = "Form_" Or Left(objName, 7) = "Report_" Or Left(objName, 6) = "Macro_" Or Left(objName, 7) = "Module_" Then
ObjPrefix = InStr(objName, "_")
ObjType = Left(objName, ObjPrefix - 1)
Select Case ObjType
Case "Query"
acObjType = acQuery
Case "Form"
acObjType = acForm
Case "Report"
acObjType = acReport
Case "Macro"
acObjType = acMacro
Case "Module"
acObjType = acModule
End Select
app.LoadFromText acObjType, objName, varFile
Else
nObjLoaded = nObjLoaded + 1
End If
nObjSelected = nObjSelected + 1 'Count all objects.
Next varFile
app.Quit acQuitSaveNone 'Clean up.
Set app = Nothing
If nObjSelected - nObjLoaded > 0 Then
ObjTypeFilter 'Refresh list.
MsgBox nObjSelected & " object(s) were selected." & vbCrLf _
& nObjSelected - nObjLoaded & " object(s) have been loaded." & vbCrLf & vbCrLf _
& "From: " & ReturnDir & vbCrLf _
& "To: " & Space(4) & Me!txtDb, vbOKOnly, "Load Complete"
Else
MsgBox "No object prefixes detected." & vbCrLf _
& "Query_" & vbCrLf _
& "Form_" & vbCrLf _
& "Report_" & vbCrLf _
& "Macro_" & vbCrLf _
& "Module_", vbOKOnly, "Objects as Text"
End If
End If
End With

Exit_Handler:
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

'Uses the undocumented [Application.SaveAsText] syntax.
Private Function ObjSaveAsText()
On Error GoTo Err_Handler
Dim app As New Access.Application
Dim fDialog As Office.FileDialog
Dim varRow As Variant
Dim nObjSelected As Long
Dim nObjWritten As Long
Dim ReturnDir As String

If Me.lstObjects.ItemsSelected.Count > 0 Then
'Set up the File dialog box.
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Pick a destination folder"
.Show
If .SelectedItems.Count > 0 Then _
ReturnDir = .SelectedItems(1)
End With
If Len(ReturnDir) > 0 Then
'When using the SaveAsText method ensure there is a backslash at the end of the
'destination path.
If (Mid$(ReturnDir, Len(ReturnDir), 1) <> "\") Then ReturnDir = ReturnDir & "\"
Set app = CreateObject("Access.application")
app.OpenCurrentDatabase Me!txtDb
'If the application is not compiled, compile it.
If Not app.IsCompiled Then app.RunCommand acCmdCompileAllModules
With Me.lstObjects
For Each varRow In .ItemsSelected
app.SaveAsText CLng(.Column(3, varRow)), .Column(1, varRow), ReturnDir & .Column(2, varRow) & "_" & .Column(1, varRow) & ".txt"
nObjWritten = nObjWritten + 1
Next varRow
nObjSelected = .ItemsSelected.Count
End With
app.Quit acQuitSaveNone
Set app = Nothing
MsgBox nObjSelected & " object(s) were selected." & vbCrLf _
& nObjWritten & " object(s) have been saved." & vbCrLf & vbCrLf _
& "From: " & Me!txtDb & vbCrLf _
& "To: " & Space(4) & ReturnDir, vbOKOnly, "Export Complete"
End If
Else
MsgBox "No objects selected.", vbOKOnly, "Objects as Text"
Me.lstObjects.SetFocus
End If

Exit_Handler:
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

I need to add code to each one so that the form activex progressbar works with them processing the files.

The following activex progressbar sub works on the form but only when you enter number of iterations in text box and click the command button. Which is not how I need it to work.

Dim inti As Integer
Dim dblPct As Double
Dim pgbar As ProgressBar
Set pgbar = Me.ProgressBar9.Object

fInLoop = True
fExitLoop = False
pgbar.Max = Me.txtNumIterations
pgbar.Scrolling = ccScrollingSmooth
pgbar.Appearance = cc3D
pgbar.Min = 0
pgbar = 0
Do Until inti > Me.txtNumIterations Or fExitLoop
pgbar.Value = inti
Me.txtI = inti
DoEvents
inti = inti + 1
Loop
fInLoop = False

Does someone have the experience to insert into my 2 functions above the necessary vba from the activex progressbar code so the 2 functions iterate the progress of the progressbar as they loop through the files.

Thank you

 

[vbajock]

I don't use that buggy progress bar, here's a technique I got from a poster here a long time ago that I've modified a little, it is simple and can be manipulated further in any number of ways (kudos to oharab for the original code frag). To see the technique, first, open a form in design view, and create two rectangles on your form.

Both will have the same height, let's just say .3" for now. Create a long rectangle with a width of say, 4", set the background color to white, name it BoxBottom. Create a narrow rectangle of the same height, with a starting width of like, .01", name it BoxTop, set the background color to black. Then drag the BoxTop rectangle on top of the long BoxBottom rectangle, at the left end of it. Then put this in a module:

Public Sub ProgressBox(ByRef frm As Form, ByVal iIncreasWidth)
Dim intMaxLength As Integer
intMaxLength = frm!boxBottom.Width

If frm!BoxTop.Width < intMaxLength Then
frm!BoxTop.Width = frm!BoxTop.Width + iIncreasWidth
frm.Repaint
end if


End Sub

Create a command button, put this in the click event:
Call ProgressBar(Me, 10)
You will note that every time you click it, the progress bar increments.

To put to use in your functions, plug this call into your function where ever you want the progress bar to increase:

Call ProgressBar(Me, 10) or whatever value suits your purpose.

There are all kinds of things you can do with it, increase the width of BottomBox elsewhere to keep it rolling, etc, turn it into a function with a boolean return value to turn the hourglass on and off, etc. Simple and easy and no Active X to worry about in future upgrades.

 

[PHV]

Anyway, why not simply use the Application.SysCmd method ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[vbajock]

Mostly for cosmetic reasons, I usually use a coded progress bar because it is presented directly to the user on the form they are using, the Status Bar can be hard to notice.

 

[patriciaxxx]

Thank you vbajock for your reply and code I have tried it, and yes, it works well as described.

 

[dhookom]

patriciaxxx,
Consider awarding vbajock a star for providing a suggestion that resolved your question. It both recognizes the contribution and marks the thread as resolved

Duane
Hook'D on Access
MS Access MVP