Excel宏将图像从网络驱动器复制到其他文件夹

Question

我对VBA编码非常陌生，并且试图帮助尝试拥有一个将从网络驱动器下载/复制多个图像的宏的朋友，将它们重命名为并将它们保存到桌面上的文件夹中。

电子表格中的数据按此设置。 宏将图像从B列中列出的路径复制，然后重命名与列的数据图像，并将其保存到一个文件夹在桌面上

column A -   column B  -    column C 

3487458 - N:/path1/image1.jpg - http://www.website.com/data.pdf 

5412132 - N:/path2/image2.jpg - http://www.website.com/data2.pdf 

我有这个，在列的数据工作C是html链接，但我需要它来处理列B中作为网络驱动器路径的数据。

Const TargetFolder = "C:\Users\XXXX\Desktop\Output\" 
Private Declare PtrSafe 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 


Sub Test() 
    For Each Hyperlink In ActiveSheet.Hyperlinks 
     LocalFileName = ActiveSheet.Cells(Hyperlink.Range.Row, 1).Value & 
".pdf" 
    Call HTTPDownloadFile(Hyperlink.Address, TargetFolder & LocalFileName) 
    Next Hyperlink 
End Sub 

谢谢，罗伊

编辑：CODE奏效

Sub copythem() 
Dim rw As Long, start_row As Long, end_row As Long 
Dim destination_folder As String 
Dim suffix As String 

suffix = ".jpg" 

With ActiveSheet 
    start_row = 1 
    end_row = .Cells(.Rows.Count, "B").End(xlUp).Row 

    destination_folder = "C:\Users\XXXX\Desktop\Output\" ' Set destination as user's desktop 

    For rw = start_row To end_row 
     If Dir(.Cells(rw, 2)) <> "(.Cells(rw, 2))" Then 
      FileCopy .Cells(rw, 2), destination_folder & .Cells(rw, 1) & suffix 
     Else 
      MsgBox "File: " & .Cells(rw, 2) & " is not found." 
     End If 
    Next 

End With 
End Sub 

Answer 1

不是很多去，而是让在路上几个假设，如文件类型（suffix），当你说的'桌面' - 你的意思是在最近版本的Windows上的桌面..

Sub copythem() 
    Dim rw As Long, start_row As Long, end_row As Long 
    Dim destination_folder As String 
    Dim suffix As String 

    suffix = ".jpg" 

    With ActiveSheet 
     start_row = 1 
     end_row = .Cells(.Rows.Count, "B").End(xlUp).Row 

     destination_folder = Environ("homedrive") & Environ("homepath") & "\desktop\output\" ' Set destination as output folder in user's desktop 

     For rw = start_row To end_row 
      If Dir(.Cells(rw, 2)) <> "" Then 
       FileCopy .Cells(rw, 2), destination_folder & .Cells(rw, 1) & suffix 
      Else 
       MsgBox "File: " & .Cells(rw, 2) & " is not found." 
      End If 
     Next 

    End With 
End Sub