patriciaxxx
Programmer
The ‘For Each varFile In .SelectedItems’ loop in the function below worked perfectly until I added the ‘Do Until nObjSelected > .SelectedItems.Count’ loop. Now it only enters the first varFile. But the Do Until loop works perfect in this scenario.
So how do you modify the code so both loops work.
'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
Dim pgbar As ProgressBar
Set pgbar = Me.ProgressBar9.Object
pgbar.Max = .SelectedItems.Count
pgbar.Scrolling = ccScrollingStandard
pgbar.Appearance = cc3D
pgbar.Min = 0
nObjSelected = 0
Screen.MousePointer = 11
Dim dblPct As Double
For Each varFile In .SelectedItems
Do Until nObjSelected > .SelectedItems.Count
dblPct = nObjSelected / .SelectedItems.Count
Me.txtPctComplete = dblPct
pgbar.Value = nObjSelected
DoEvents
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.
Loop
Next varFile
app.Quit acQuitSaveNone 'Clean up.
Set app = Nothing
Screen.MousePointer = 1
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
pgbar = 0
Me!txtPctComplete.Value = "Ready"
End If
End With
Exit_Handler:
Exit Function
Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler
End Function
I am not experienced in VBA, I am very much a beginner, muddling my way through and learning as I go a long. So if I have the Do loop all wrong I apologise now and ask you to post the code the way it should be written.
So how do you modify the code so both loops work.
'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
Dim pgbar As ProgressBar
Set pgbar = Me.ProgressBar9.Object
pgbar.Max = .SelectedItems.Count
pgbar.Scrolling = ccScrollingStandard
pgbar.Appearance = cc3D
pgbar.Min = 0
nObjSelected = 0
Screen.MousePointer = 11
Dim dblPct As Double
For Each varFile In .SelectedItems
Do Until nObjSelected > .SelectedItems.Count
dblPct = nObjSelected / .SelectedItems.Count
Me.txtPctComplete = dblPct
pgbar.Value = nObjSelected
DoEvents
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.
Loop
Next varFile
app.Quit acQuitSaveNone 'Clean up.
Set app = Nothing
Screen.MousePointer = 1
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
pgbar = 0
Me!txtPctComplete.Value = "Ready"
End If
End With
Exit_Handler:
Exit Function
Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler
End Function
I am not experienced in VBA, I am very much a beginner, muddling my way through and learning as I go a long. So if I have the Do loop all wrong I apologise now and ask you to post the code the way it should be written.