Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Загрузка файлов по ссылкам и сохранение их в отдельные папки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Загрузка файлов по ссылкам и сохранение их в отдельные папки (Макросы/Sub)
Загрузка файлов по ссылкам и сохранение их в отдельные папки
ares_dolbi12 Дата: Суббота, 13.03.2021, 16:10 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Здравствуйте!
Помогите, пожалуйста, решить вопрос загрузки файлов из интернета по списку ссылок и их сортировкой по папкам (имя папки - ФИО).
К сообщению приложен файл: Primer.xls(31.5 Kb)
 
Ответить
СообщениеЗдравствуйте!
Помогите, пожалуйста, решить вопрос загрузки файлов из интернета по списку ссылок и их сортировкой по папкам (имя папки - ФИО).

Автор - ares_dolbi12
Дата добавления - 13.03.2021 в 16:10
lebensvoll Дата: Суббота, 13.03.2021, 16:28 | Сообщение № 2
Группа: Проверенные
Ранг: Старожил
Сообщений: 1002
Репутация: 30 ±
Замечаний: 0% ±

Excel 2010
ares_dolbi12, My WebPage


Кто бы ты ни был, мир в твоих руках
 
Ответить
Сообщениеares_dolbi12, My WebPage

Автор - lebensvoll
Дата добавления - 13.03.2021 в 16:28
ares_dolbi12 Дата: Суббота, 13.03.2021, 19:30 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

lebensvoll, Спасибо!

мб кому надо (для таких же нубов как я):

Есть excel файл 23 тыщ. ссылок для 4.3 тыщ. ФИО

1. Создал папки по списку ФИО в папке C:\test\
[vba]
Код
Sub MDir()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
If Not IsEmpty(oCell) Then MkDir "C:\test\" & oCell
Next
End Sub
[/vba]
2. Чуть подправил код, чтобы он сохранял файлы в соответствующие папки My WebPage
[vba]
Код
'---------------------------------------------------------------------------------------
' File : mDownloadFileFromURL
' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке
'---------------------------------------------------------------------------------------
Option Explicit

'объявление функции API - URLDownloadToFile
' работает на любых ПК под управлением ОС Windows
' на MAC код работать не будет
#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
#If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
#Else 'для 32-разрядных операционных систем
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
#End If
#End If
'переменная для хранения пути к папке

Function CallDownload(sFileURL As String, sFileName As String,sFilePath As String)
' sFileURL - ссылка URL для скачивания файла
' sFileName - имя файла с расширением, которое будет присвоено после скачивания

Dim h
If sFilePath = "" Then
'диалоговое окно выбора папки
'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then
Exit Function
End If
sFilePath = .SelectedItems(1)
End With
End If

If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
'проверяем есть ли файл с таким же именем в выбранной папке
If Dir(sFilePath & sFileName, 16) = "" Then
'файла нет - скачиваем
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
Else
'файл есть - запрос на перезапись
If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then
'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно
'отменяем загрузку
If IsBookOpen(sFileName) Then
MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _
vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
Else
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
End If
End If
End If
CallDownload = h
End Function

'функция скачивания файла в выбранную папку
Function DownloadFileAPI(sFileURL, ToPathName)
' sFileURL - ссылка URL для скачивания файла
' ToPathName - полный путь с именем файла для сохранения

Dim h
Dim sFilePath As String
Dim sFileName As String
'вызов функции API для непосредственно скачивания
h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0)
'если h = False - файл не удалось скачать, показываем инф.окно
If h = False Then
MsgBox "Невозможно скачать файл." & vbNewLine & _
"Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _
"Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru"
Exit Function
Else 'файл успешно скачан
sFileName = Dir(ToPathName, 16)
sFilePath = Replace(ToPathName, sFileName, "")

End If
DownloadFileAPI = h
End Function
'Функция проверки - открыта ли книга с заданным именем
'подробнее:
' http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
Dim wbBook As Workbook
For Each wbBook In Workbooks
If Windows(wbBook.Name).Visible Then
If wbBook.Name = wbName Then IsBookOpen = True: Exit For
End If
Next wbBook
End Function
[/vba]

3. Использовал фу-цию CallDownload (B1 ссылка, A1 ФИО, 'D1&ПРАВСИМВ(B1;5)' имя файла с расширением типа .jpeg или .pdf)

[vba]
Код
=CallDownload(B1;D1&ПРАВСИМВ(B1;5);"C:\test\"&A1&"\")
[/vba]


Сообщение отредактировал ares_dolbi12 - Воскресенье, 14.03.2021, 03:10
 
Ответить
Сообщениеlebensvoll, Спасибо!

мб кому надо (для таких же нубов как я):

Есть excel файл 23 тыщ. ссылок для 4.3 тыщ. ФИО

1. Создал папки по списку ФИО в папке C:\test\
[vba]
Код
Sub MDir()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
If Not IsEmpty(oCell) Then MkDir "C:\test\" & oCell
Next
End Sub
[/vba]
2. Чуть подправил код, чтобы он сохранял файлы в соответствующие папки My WebPage
[vba]
Код
'---------------------------------------------------------------------------------------
' File : mDownloadFileFromURL
' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке
'---------------------------------------------------------------------------------------
Option Explicit

'объявление функции API - URLDownloadToFile
' работает на любых ПК под управлением ОС Windows
' на MAC код работать не будет
#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
#If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
#Else 'для 32-разрядных операционных систем
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
#End If
#End If
'переменная для хранения пути к папке

Function CallDownload(sFileURL As String, sFileName As String,sFilePath As String)
' sFileURL - ссылка URL для скачивания файла
' sFileName - имя файла с расширением, которое будет присвоено после скачивания

Dim h
If sFilePath = "" Then
'диалоговое окно выбора папки
'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then
Exit Function
End If
sFilePath = .SelectedItems(1)
End With
End If

If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
'проверяем есть ли файл с таким же именем в выбранной папке
If Dir(sFilePath & sFileName, 16) = "" Then
'файла нет - скачиваем
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
Else
'файл есть - запрос на перезапись
If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then
'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно
'отменяем загрузку
If IsBookOpen(sFileName) Then
MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _
vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
Else
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
End If
End If
End If
CallDownload = h
End Function

'функция скачивания файла в выбранную папку
Function DownloadFileAPI(sFileURL, ToPathName)
' sFileURL - ссылка URL для скачивания файла
' ToPathName - полный путь с именем файла для сохранения

Dim h
Dim sFilePath As String
Dim sFileName As String
'вызов функции API для непосредственно скачивания
h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0)
'если h = False - файл не удалось скачать, показываем инф.окно
If h = False Then
MsgBox "Невозможно скачать файл." & vbNewLine & _
"Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _
"Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru"
Exit Function
Else 'файл успешно скачан
sFileName = Dir(ToPathName, 16)
sFilePath = Replace(ToPathName, sFileName, "")

End If
DownloadFileAPI = h
End Function
'Функция проверки - открыта ли книга с заданным именем
'подробнее:
' http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
Dim wbBook As Workbook
For Each wbBook In Workbooks
If Windows(wbBook.Name).Visible Then
If wbBook.Name = wbName Then IsBookOpen = True: Exit For
End If
Next wbBook
End Function
[/vba]

3. Использовал фу-цию CallDownload (B1 ссылка, A1 ФИО, 'D1&ПРАВСИМВ(B1;5)' имя файла с расширением типа .jpeg или .pdf)

[vba]
Код
=CallDownload(B1;D1&ПРАВСИМВ(B1;5);"C:\test\"&A1&"\")
[/vba]

Автор - ares_dolbi12
Дата добавления - 13.03.2021 в 19:30
Pelena Дата: Суббота, 13.03.2021, 19:36 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 17625
Репутация: 3925 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
ares_dolbi12, оформите код тегами с помощью кнопки # в режиме правки поста


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
Сообщениеares_dolbi12, оформите код тегами с помощью кнопки # в режиме правки поста

Автор - Pelena
Дата добавления - 13.03.2021 в 19:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Загрузка файлов по ссылкам и сохранение их в отдельные папки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!