Страницы: 1
RSS
URLDownloadToFile не работает
 
Доброго всем дня! До обновления W10 прекрасно работал код для скачивания файлов с использованием winapi:
Код
Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

Function DownLoadFile(FromPathName As String, ToPathName As String) As Boolean
DownLoadFile = URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0
End Function
Sub download()
Dim lp As String, Filename As String

Set spn = ThisWorkbook.ActiveSheet  ' запоминаем лист
LR = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
For x = 2 To LR
lp = spn.Cells(x, 7)
kolvo = (Len(lp) - Len(replace(lp, "https", ""))) / Len("https")
r = 1
w = 1
For y = 1 To kolvo
lim = InStr(r, lp, "https")
lim2 = InStr(lim, lp, "jpg")
If lim2 = 0 Then
lim2 = InStr(lim, lp, "jpeg")
End If
If lim2 = 0 Then
lim2 = InStr(lim, lp, "png")
End If
Dim src As String
If InStr(w, lp, ".jpg") > 0 Then
src = Mid(lp, lim, lim2 - lim) & "jpg"
ElseIf InStr(w, lp, ".jpeg") > 0 Then
src = Mid(lp, lim, lim2 - lim) & "jpeg"
Else
src = Mid(lp, lim, lim2 - lim) & "png"
End If
'ppn = spn.Cells(x, 2)
'pic = spn.Cells(x, 2)
pic = spn.Cells(x, 17)
If y = 1 Then
Filename = "C:\1\" & pic & ".jpg"
Else: Filename = "C:\1\" & pic & "_" & y - 1 & ".jpg"
End If
If DownLoadFile(src, Filename) Then
End If
r = lim2
w = lim2
Next y
r = 1
Next x

End Sub

Но после обновления ничего качает, ошибок тоже не выдает. Lib "urlmon" зарегистрирована.
Подскажите что могло отключиться при обновлении. Офис 2016 стандарт.
На машине с 2007 офисом и W10 код скачивает файлы без проблем.
 
Цитата
написал:
На машине с 2007 офисом и W10 код скачивает файлы без проблем
так может проблема не в винде, а в том, что API Вы объявили только для 32-битной версии офиса?
Здесь есть пример кода: Как скачать файл из интернета по ссылке
Просто копируйте себе все строки с объявлением функции и все должно заработать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
так может проблема не в винде, а в том, что API Вы объявили только для 32-битной версии офиса?
Попробовал, не помогло. Да и офис у меня 32 битный.
Ошибок при исполнении не выдает.
Изменено: evgen032 - 06.02.2024 12:02:32
 
Цитата
написал:
офис у меня 32 битный
тогда проблема где-то глубже. Вполне возможны проделки антивируса или другого ПО.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Вызовите curl. Эта программа умеет всё.
Изменено: sokol92 - 06.02.2024 19:51:06
Владимир
 
Проверял дома - W11+офис2016 - работает, на работе из 4 машин w10+разные офисы - работает на 1. Все ОС и ПО лицензия, антивирус везде один. Пока не понятно почему так. Буду дальше разбираться. Может подскажете как вывести лог работы URLMONа? Насчет CURL пока повременю. За ссылку спасибо, но если есть ссылка на рабочий код, для разбора буду очень благодарен.
 
Цитата
sokol92 написал:
Вызовите  curl . Эта программа умеет всё.
Все таки пришлось переделать под CURL . С Urlmon- ом так и не установил причину. То что, он перестает работать после какого то обновления - это факт. Такая ситуация была летом, но тогда  откатился и все заработало. Вот только не записал обновление которое ломает загрузку. В общем пока идеи закончились.
 
evgen032, добрый день!

Не знаю, актуальна ли ещё тема.
Я в VBS-программах пользуюсь самописным загрузчиком (через MSXML2.XMLHTTP - по подсказкам из интернета), под VBA вроде тоже работает.
Код
Sub Test()
'On Error GoTo 0

    sFileUrl = "https://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=538267&am...;
    sFileTxt = "test.xlsx"
    
    Debug.Print "Сохранение файла:", sFileUrl, "->", sFileTxt
    If FileUrlSaveToFile(sFileUrl, sFileTxt) Then
        Debug.Print "Файл сохранён:", sFileTxt
    Else
        Debug.Print "Ошибка сохранения:", sFileTxt
    End If

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Загружает файл по URL-адресу sFileUrl в vsDest.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FileUrlSaveToFile(ByVal sFileUrl, ByRef vsDest): FileUrlSaveToFile = False: On Error Resume Next
    Dim aResponse
    aResponse = FileUrlRead(sFileUrl)
    If Not IsEmpty(aResponse) Then
        With CreateObject("ADODB.Stream")
            .Mode = 3 'adModeReadWrite
            .Type = 1 'adTypeBinary=1 Двоичные данные, adTypeText=2 По умолчанию. Текстовые данные
            .Open
            .Write aResponse
            .SaveToFile vsDest, 2 'adSaveCreateNotExist=1 По умолчанию. Создает новый файл, если файл не существует, adSaveCreateOverWrite=2 Заменяет файл с данными из текущего открытого объекта потока, если файл уже существует
            FileUrlSaveToFile = True 'FileExists(vsDest) - проверять на существование
        End With
    End If
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Возвращает содержимое файла по URL-адресу sFileUrl в виде массива байт.
' Empty в случае ошибки.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FileUrlRead(ByVal sFileUrl): On Error Resume Next
    With CreateObject("MSXML2.XMLHTTP") '"WinHttp.WinHttpRequest.5.1" - тормозит на больших файлах!
        .Open "GET", Replace(sFileUrl, "\", "/"), 0 '"GET", sFileUrl, 0, sLogin, sPassword
        .Send
        If .Status = 200 Then
            If Len(.responseBody) > 0 Then
                FileUrlRead = .responseBody
            End If
        End If
    End With
End Function
 
Спасибо, сработало. Но выдает не читаемый текс.
Простите за тупость, первый опыт работы с VBA
Изменено: Juggernaut_1 - 16.02.2024 13:48:48
 
Все спасибо, получилось решить проблему
Страницы: 1
Наверх