Question

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

电子表格中的数据就是这样设置的。宏将从列B中列出的路径复制图像，然后使用列A中的数据重命名图像并将其保存到桌面上的文件夹

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

谢谢，罗伊

编辑：工作的代码

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

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

1 个答案: