Доработка макроса

[Adar]

Добрый день,

у меня имеется макрос, который должен автоматически скачивать архив  "dea_com_xls_2011.zip" по ссылке http://www.cftc.gov/files/dea/history/dea_com_xls_2011.zip, далее распаковывать из архива файл "annualof.xls".

В макросе допущена ошибка, он скачивает файл, но в нём насколько я понимаю не зада параметр импорта данных из annualof.xls..

Кто поможет подправить?

Спасибо

Код Выделить Развернуть

Private Declare Function FindWindow _
     Lib "user32.dll" _
     Alias "FindWindowA" _
       (ByVal lpClassName As String, _
        ByVal lpWindowName As String) _
     As Long
         
  Private Declare Function GetWindowText _
     Lib "user32.dll" _
     Alias "GetWindowTextA" _
       (ByVal hWnd As Long, _
        ByVal lpString As String, _
        ByVal aint As Long) _
     As Long
         
  Private Declare Function GetWindow _
     Lib "user32.dll" _
       (ByVal hWnd As Long, _
        ByVal wCmd As Long) _
     As Long
       
   Private Declare Function SendMessage _
     Lib "user32.dll" _
     Alias "SendMessageA" _
       (ByVal hWnd As Long, _
        ByVal Msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) _
     As Long

  Private Declare Function ShellExecute _
    Lib "Shell32.dll" _
    Alias "ShellExecuteA" _
      (ByVal hWnd As Long, _
       ByVal lpOperation As String, _
       ByVal lpFile As String, _
       ByVal lpParameters As String, _
       ByVal lpDirectory As String, _
       ByVal nShowCmd As Long) _
    As Long

Private Declare Function URLDownloadToFile _
   Lib "urlmon.dll" _
   Alias "URLDownloadToFileA" _
     (ByVal pCaller As Long, _
      ByVal szURL As String, _
      ByVal szFileName As String, _
      ByVal dwReserved As Long, _
      ByVal lpfnCB As Long) _
   As Long
   
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   
Sub DownloadFilefromWeb()

  Const E_OUTOFMEMORY As Long = &H8007000E
  Const E_DOWNLOAD_FAILURE As Long = &H800C0002
  Const E_INVALID_LINK As Long = &H800C000D
 
  Dim Filespec As String
  Dim FolderPath As Variant
  Dim filename As String
  Dim RetVal As Long
  Dim xlFile As String
 
      URL = "http://www.cftc.gov/files/dea/history/dea_com_xls_2011.zip"
      filename = "dea_com_xls_2011.zip"
   
        FolderPath = Environ("TEMP")
     
        Filespec = FolderPath & "\" & filename
        If Dir(Filespec) <> "" Then Kill Filespec
       
        xlFile = FolderPath & "\" & Left(filename, Len(filename) - 4) & ".xls"
     
        RetVal = URLDownloadToFile(0&, URL, Filespec, 0&, 0&)

          Select Case RetVal
            Case 0
              'OK - No Error
            Case E_OUTOFMEMORY
              MsgBox URL & vbCrLf & "Error - Out of Memory"
            Case E_DOWNLOAD_FAILURE
              MsgBox URL & vbCrLf & "Error - Bad URL or Connection Interrupted"
            Case E_INVALID_LINK
              MsgBox URL & vbCrLf & "Error - Invalid Link or Protocol Not Supported"
            Case Else
              MsgBox URL & vbCrLf & "Error - Unknown = " & Hex(RetVal)
          End Select
       
        If RetVal <> 0 Then
           Exit Sub
        Else
           Unzip Filespec, FolderPath
        End If
         
End Sub

Private Function Unzip(ByVal Zip_Archive_Name As String, ByVal Dest_Folder As String) As Boolean

  Dim bytes() As Byte
  Dim flen As Long
  Dim file_list As String
  Dim filename As String
  Dim fnum As Integer
  Dim i As Long
  Dim Timeout As Long
 
     fnum = FreeFile
     flen = FileLen(Zip_Archive_Name)
     ReDim bytes(flen - 1)
     
     Open Zip_Archive_Name For Binary As #fnum
       Get #fnum, 1, bytes
     Close fnum
     
       If bytes(0) = 80 And bytes(1) = 75 And bytes(2) = 3 And bytes(3) = 4 Then
          FileNameLength = (bytes(27) * 256) Or bytes(26)
          For i = 30 To 30 + FileNameLength - 1
            filename = filename & Chr(bytes(i))
          Next i
       End If
     
     ' Command line String to Unzip a file
       cmdLine = "-min -e -o " & Chr$(34) & Zip_Archive_Name & Chr$(34) & " " & Dest_Folder
       
     ' UnZip the file and save it in the archive
       RetVal = ShellExecute(0&, "", "WinZip32.exe", cmdLine, Zip_Archive_Name, 1&)
     
  ' Stop this thread for 1 second to allow Winzip time to close
    Sleep 1000
    CloseTempFile
    Workbooks.Open Dest_Folder & "\" & filename
   
         
End Function

Private Sub CloseTempFile()

  Const HWND_NEXT As Long = 2
  Const SC_CLOSE As Long = &HF060
  Const WM_SYSCOMMAND As Long = &H112
 
  Dim cch As Long
  Dim Folder As String
  Dim hWnd As Long
  Dim Title As String
 
    hWnd = FindWindow("CabinetWClass", vbNullString)
   
      Do Until hWnd = 0
        Title = String(512, Chr(0))
        cch = GetWindowText(hWnd, Title, 512)
        If Left(Title, cch) = "Temp" Then
           RetVal = SendMessage(hWnd, WM_SYSCOMMAND, SC_CLOSE, 0)
           Exit Do
        End If
        hWnd = GetWindow(hWnd, HWND_NEXT)
      Loop
 
End Sub

[nilem]

Разбираться в коде, имхо, бесполезно. Зато у Чипа и Джона наших Пирсона и Уокенбаха нашел такие коды. Только проверьте папки и пути. См. файл, зеленая кнопка.

[kuklp]

Вы уверены, что у Вас установлен WinZip?
To Nilem: Николай, добавил описания переменных, поставил винзип и все работает.

[Adar]

ок попробую, спасибо

[Adar]

Вы уверены, что у Вас установлен WinZip?

установлен winrar, я в этом уверен.

To Nilem:
это немного не то, тут макрос просто скачивает файл, а необходимо чтобы данные из скачанного файла (там 1 лист заполнен) импортировались на лист с которого запускается макрос.

[Adar]

Говоря про макрос в начале темы: у меня выдаёт ошибку 1004. не может найти файл C:\Users\Nikita\AppData\Temp\annualof.xls
дебагер ссылается на строку: Workbooks.Open Dest_Folder & "\" & filename

стал смотреть, я в папке AppData не могу найти папку Temp...до Temp иной путь C:\Users\Nikita\AppData\Local\Temp\

может стоить изменить параметр макроса FolderPath = Environ("TEMP") ?

[nilem]

To Nilem:
это немного не то, тут макрос просто скачивает файл, а необходимо чтобы данные из скачанного файла (там 1 лист заполнен) импортировались на лист с которого запускается макрос.

А если так. Копирует на Лист2 этой книги.

[kuklp]

установлен winrar, я в этом уверен.

А при чем тут винрар? Здесь:
RetVal = ShellExecute(0&, "", "WinZip32.exe", cmdLine, Zip_Archive_Name, 1&)
программа пытается запустить WinZip32.exe. В винраре(у меня так точно) его нет. Запустите поиск файла WinZip32.exe. Он у Вас вообще-то есть в системе?

[Adar]

установлен winrar, я в этом уверен.

А при чем тут винрар? Здесь:
RetVal = ShellExecute(0&, "", "WinZip32.exe", cmdLine, Zip_Archive_Name, 1&)
программа пытается запустить WinZip32.exe. В винраре(у меня так точно) его нет. Запустите поиск файла WinZip32.exe. Он у Вас вообще-то есть в системе?

с поставил winzip, проверил был WinZip32.exe, но ошибка такая же

[Adar]

To Nilem:
это немного не то, тут макрос просто скачивает файл, а необходимо чтобы данные из скачанного файла (там 1 лист заполнен) импортировались на лист с которого запускается макрос.

А если так. Копирует на Лист2 этой книги.

Спасибо, то что надо, мне в другой файл надо все модули переносить или какойто один?

[nilem]

Рабочие модули: modDownloadFile и Module1.
Module2 можно убрать - пытался еще докрутить функций, но, вроде, и так работает.

[Adar]

Рабочие модули: modDownloadFile и Module1.
Module2 можно убрать - пытался еще докрутить функций, но, вроде, и так работает.

а можно ли сделать настройку чтобы экспорт данных происходил на защищённый паролем лист?

[nilem]

Предположим, пароль на листе "123". в коде меняем этот кусочек:

Код Выделить Развернуть

...
With GetObject(ZipFolder & f)
    Sheets("Лист2").Unprotect "123"
    .Sheets(1).UsedRange.Copy Sheets("Лист2").Range("A1")
    .Close (False)
    Sheets("Лист2").Protect "123"
End With
...