А как бы мне заменить dbf и процессе работы?

[Andrev]

Проблема: на форме есть Data контрол. Он работает с дбф файлом. Принажатии на кнопку из интернета скачивается обновленный файл в архиве, data1.recordsource обнуляю, файл разархивируется, старый файл прибивается, data1.recordsource ставлю на обновленный файл. Почему-то периодически (то есть не всегда) после data1.refresh вылетает сообщение "Microsoft Jet engine could not find the object". Перед рефрешем ставил doevents. Не помогло. Чем лечить? Посоветуйте.

[Viper]

Код в студию! Предварительный диагноз, файл не успевает загрузиться видимо

[Andrev]

Вот:

Код: Выделить всё

hOpen = InternetOpen("Nothing", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hConnection = InternetConnect(hOpen, FTP_Host, INTERNET_DEFAULT_FTP_PORT, FTP_Login, FTP_pwd, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
If hConnection = 0 Then
MsgBox "Не могу соединиться с сервером", vbCritical, "Сервер недоступен"
Else
sOrgPath = String(MAX_PATH, 0)
FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
status.Caption = "Подождите. Идет прием файла..."
DoEvents
FtpGetFile hConnection, "clients.dbf", App.path & "\clients.dbf", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0
If FtpGetFile(hConnection, "price.rar", App.path & "\price.rar", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0) Then
  status.Caption = "Новый прайс принят."
  InternetCloseHandle hConnection
  InternetCloseHandle hOpen
  DoEvents
  Data1.RecordSource = ""
  Data1.Refresh
  Kill App.path & "\newprice.dbf"
  Shell App.path & "\rar.exe e " & App.path & "\price.rar " & App.path & " -y"
  DoEvents
Else
  MsgBox "Новый прайс не принят.", vbCritical, "Не удается принять файл"
End If
End If
DoEvents

Data1.DatabaseName = App.path & "\"
Data1.RecordsetType = 2
DoEvents
Data1.RecordSource = "select count(*) from newprice"
DoEvents
Data1.Refresh


И вот после Data1.Refresh вылетает ошибка. Опять же повторюсь - она может вылетать, а может и не вылетать (но такое бывает редко)...

[S397]

Код: Выделить всё

Shell App.path & "\rar.exe e " & App.path & "\price.rar " & App.path & " -y"

Не успевает отработать, программа продолжает выполнятся
нужно что-то типа этого:

Код: Выделить всё

Const PROCESS_ALL_ACCESS& = &H1F0FFF
Const STILL_ACTIVE& = &H103&
Const INFINITE& = &HFFFF


Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Function IsRuning(ByVal lProgID As Long) As Long
    Dim lExitCode As Long
    Dim hdlProg As Long
   
    hdlProg = OpenProcess(PROCESS_ALL_ACCESS, False, lProgID)
    GetExitCodeProcess hdlProg, lExitCode
   
    Do While lExitCode = STILL_ACTIVE&
        DoEvents
        GetExitCodeProcess hdlProg, lExitCode
    Loop
    CloseHandle hdlProg
    IsRuning = lExitCode
End Function


и

Код: Выделить всё

    Dim iProg As Long
   
    iProg = Shell(App.path & "\rar.exe e " & App.path & "\price.rar " & App.path & " -y")
    Do While IsRuning(iProg): DoEvents: Loop


[Andrev]

Алилуйя!
Помогло, спасибо.