Question : How to add a loading bar

Hi,

I have the below code which imports a spreadsheet into an Access table. Before it does, it makes some changes and deletes some rows. This can take 30 odd seconds. While it is happening the user is unaware of what is happening.

Is there code i can incorporate into my below code to display a laoding/progress bar?

Thanks,
Seamus

1:

Private Sub Command0_Click()


If IsNull(Me.txtFileName) Or Len(Me.txtFileName & "") = 0 Then
    MsgBox "please select the excel file"
    Me.cmdSelect.SetFocus
    Exit Sub
End If  'place the end if here


Dim xlApp As Object, xlWbSource As Object, xlWsSource As Object
Dim xlWbDest As Object, xlWsDest As Object
Dim LastR As Long, xlFile As String
 
Dim WbSourcePath As String
Dim WbDestPath As String
xlFile = Me.txtFileName
WbSourcePath = xlFile
WbDestPath = Left(xlFile, InStr(xlFile, ".xls") - 1) & "_Updated.xls"

Const WsSourceName As String = "BatchOutput" 'update
Const WsDestName As String = "Key Fields" 'update
Const xlUp As Long = -4162
 
Set xlApp = CreateObject("Excel.Application")
Set xlWbSource = xlApp.Workbooks.Open(WbSourcePath)
Set xlWsSource = xlWbSource.Worksheets(WsSourceName)
Set xlWbDest = xlApp.Workbooks.Add
Set xlWsDest = xlWbDest.Worksheets(1)
xlWsDest.Name = WsDestName
 
With xlWsSource
    LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
    .Range("c1:c" & LastR).Copy xlWsDest.[a1]
    .Range("g1:g" & LastR).Copy xlWsDest.[b1]
    .Range("j1:j" & LastR).Copy xlWsDest.[c1]
    .Range("k1:k" & LastR).Copy xlWsDest.[d1]
    .Range("l1:l" & LastR).Copy xlWsDest.[e1]
    .Range("m1:m" & LastR).Copy xlWsDest.[f1]
    .Range("n1:n" & LastR).Copy xlWsDest.[g1]
    .Range("o1:o" & LastR).Copy xlWsDest.[h1]
    .Range("ad1:ad" & LastR).Copy xlWsDest.[i1]
    .Range("ae1:ae" & LastR).Copy xlWsDest.[j1]
    .Range("af1:af" & LastR).Copy xlWsDest.[k1]
    .Range("ag1:ag" & LastR).Copy xlWsDest.[l1]
    .Range("ah1:ah" & LastR).Copy xlWsDest.[m1]
    .Range("ay1:ay" & LastR).Copy xlWsDest.[n1]
    .Range("az1:az" & LastR).Copy xlWsDest.[o1]
    .Range("ba1:ba" & LastR).Copy xlWsDest.[p1]
    .Range("bb1:bb" & LastR).Copy xlWsDest.[q1]
    .Range("bc1:bc" & LastR).Copy xlWsDest.[r1]
    .Range("bf1:bf" & LastR).Copy xlWsDest.[s1]
    .Range("bg1:bg" & LastR).Copy xlWsDest.[t1]
    .Range("bh1:bh" & LastR).Copy xlWsDest.[u1]
    .Range("bi1:bi" & LastR).Copy xlWsDest.[v1]
    .Range("bj1:bj" & LastR).Copy xlWsDest.[w1]
    .Range("ca1:ca" & LastR).Copy xlWsDest.[x1]
    .Range("cb1:cb" & LastR).Copy xlWsDest.[y1]
    .Range("cc1:cc" & LastR).Copy xlWsDest.[z1]
    .Range("cd1:cd" & LastR).Copy xlWsDest.[aa1]
    .Range("ce1:ce" & LastR).Copy xlWsDest.[ab1]
End With
 
xlWbSource.Close False
 
If xlApp.Version < 12 Then
    xlWbDest.SaveAs WbDestPath
Else
    xlWbDest.SaveAs WbDestPath, 56
End If
xlWbDest.Close False
 
Set xlWsSource = Nothing
Set xlWbSource = Nothing
Set xlWsDest = Nothing
Set xlWbDest = Nothing
xlApp.Quit
Set xlApp = Nothing
 

DoCmd.TransferSpreadsheet (acImport), acSpreadsheetTypeExcel9, "McLagan Import", WbDestPath
   
MsgBox "McLagan Data imported"

End Sub

Private Sub cmdQuit_Click()
    DoCmd.Quit
End Sub

Private Sub cmdSelect_Click()

    Dim strStartDir As String
   
    Dim strFilter As String
    Dim lngFlags As Long
   
    ' Lets start the file browse from our current directory
     
    strStartDir = CurrentDb.Name
    strStartDir = Left(strStartDir, Len(strStartDir) - Len(Dir(strStartDir)))

   
    strFilter = ahtAddFilterItem(strFilter, _
                        "Excel Files (*.xls)", "*.xls")
    Me.txtFileName = ahtCommonFileOpenSave(InitialDir:=strStartDir, _
                     Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
                     DialogTitle:="Select File")
       

End Sub

Private Sub Command1_Click()


On Error GoTo Err_Command1_Click


    DoCmd.Close

Exit_Command1_Click:
    Exit Sub

Err_Command1_Click:
    MsgBox Err.Description
    Resume Exit_Command1_Click

End Sub

Answer : How to add a loading bar

This kind of shortcoming is existent in SharePoint. Take a look at SharePoint AD Sync, which solves this as SUNILREPALE suggested above.