请教下EXCEL导入ACCESS时用进度条显示(导入的进度)问题

经过了各位大哥的帮助下~~解决了导入,俺想加个显示导入的进度.(可惜代码老接不上去,至此导入时进度条只是跑了下,没有显示导入的状态.....)
(请各位大哥帮忙下)!!
Private Sub Command3_Click() 
Call OpenConn 
SQL = "select * from 商品信息" 
rs.Open SQL, cn, 1, 3 
Dim excela_app As Object 
Set excel_App = CreateObject("Excel.application") 
excel_App.Workbooks.Open FileName:=Text1.Text '打开选择好的EXCEL 
i = 2 
Do 
If Len(Trim$(excel_App.Workbooks(1).Worksheets(1).Cells(i, 1))) = 0 Then Exit Do   '如所取数据长度为0则退出 
rs.AddNew 
rs.Fields("商品编号") = Trim$(excel_App.Workbooks(1).Worksheets(1).Cells(i, 1)) 
rs.Fields("商品名称") = Trim$(excel_App.Workbooks(1).Worksheets(1).Cells(i, 2)) 
rs.Fields("规格型号") = Trim$(excel_App.Workbooks(1).Worksheets(1).Cells(i, 3)) 
rs.Fields("库存数量") = Trim$(excel_App.Workbooks(1).Worksheets(1).Cells(i, 4)) rs.Update 
Me.ProgressBar1.Visible = True
i = i + 1ProgressBar1.Value = ProgressBar1.Max
Loop
Me.ProgressBar1.Visible = 0excel_App.ActiveWorkbook.Close False      '不保存关闭Workbook 
MsgBox "共导入" & Format$(i - 2) & "种商品.", vbInformation, "提示:"