vba 将文件批量复制到 SharePoint 网站

Batch copy files to SharePoint site

提问by Gaffi

I searched SO, SU, and SP.SEfor a solution, but could not find what I needed. I'm looking for a solution which may be a script orsome other non-coding method/tool.

我在 SO、SU 和SP.SE 中搜索了解决方案，但找不到我需要的。我正在寻找一种解决方案，它可能是脚本或其他一些非编码方法/工具。

I am trying to write a script (to be used by others) or some other form of automation to upload various reports automatically to a SharePoint site. I have managed to get the following (VBScript) code to work, but only for text-based files -- .CSV in this case, though this also works for .TXT, etc.

我正在尝试编写一个脚本（供其他人使用）或某种其他形式的自动化来自动将各种报告上传到 SharePoint 网站。我设法使以下（VBScript）代码起作用，但仅适用于基于文本的文件——在这种情况下为 .CSV，尽管这也适用于 .TXT 等。

Option Explicit

Dim sCurPath
sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
UploadAllToSP sCurPath

Sub UploadAllToSP(sFolder)
    Dim fso, folder, fil
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(sFolder)
    For Each fil In folder.Files
        If fso.GetExtensionName(fil) = "csv" Then
            UploadFileToSP fil
        End If
    Next
End Sub

Sub UploadFileToSP(ofile)
    Dim xmlhttp
    Dim sharepointUrl
    Dim sharepointFileName
    Dim tsIn
    Dim sBody

    Set tsIn = ofile.openAsTextstream
    sBody = tsIn.readAll
    tsIn.close
    sharepointUrl = "http://SHAREPOINT URL HERE"

    sharepointFileName = sharepointUrl & ofile.name
    set xmlHttp = createobject("MSXML2.XMLHTTP.4.0")
    xmlhttp.open "PUT", sharepointFileName, false
    xmlhttp.send sBody
    If xmlhttp.status < 200 Or xmlhttp.status > 201 Then
        wscript.echo "There was a problem uploading " & ofile.name & "!"
    End If
End Sub

This only works for text files because it pipes the text data into a file on the SP site. However, if I want to transfer any kind of binary file (.XLS, .PDF), this results in garbage being uploaded.

这仅适用于文本文件，因为它将文本数据通过管道传输到 SP 站点上的文件中。但是，如果我想传输任何类型的二进制文件（.XLS、.PDF），这会导致垃圾被上传。

I tried to take a look at a Shell.Application==> .Namespace(), but this doesn't seem to work with a URL, but only a physical drive. Here's some of what else I tried (trimmed to show relevant pieces):

我试图查看 a Shell.Application==> .Namespace()，但这似乎不适用于 URL，而只能用于物理驱动器。这是我尝试过的其他一些内容（修剪以显示相关部分）：

Set oApp = CreateObject("Shell.Application")

If oApp.NameSpace(sharepointUrl) <> Null then ' Always Null!
    ' Copy here
    ' Some lines omitted
    oApp.NameSpace(sharepointUrl).CopyHere ofile.Name ' This also fails when not surrounded by the Null check
Else
    MsgBox "SharePoint directory not found!"
End If

I also tried a batch file using xcopy, but that can't connect to the http://either. I looked at this method, which may work for me, but I'd prefer not to deal with mapping/NET USE, since our company has multiple network shares, the mapping for which varies depending on who's logged in.

我还尝试了使用 xcopy 的批处理文件，但也无法连接到该批处理文件http://。我查看了这个方法，它可能对我有用，但我不想处理 mapping/ NET USE，因为我们公司有多个网络共享，其映射取决于登录的人。

Since none of these work quite the way I need: Is there a method to automate this kind of functionality?

由于这些都不是我需要的方式：是否有一种方法可以自动化这种功能？

I have experience with VBA/VBscript, so either a script like the above, or something built in to an MS Office application (Outlook is best, but I can probably adapt whatever I am given) would be preferable. That being said, I am open to any method that would allow me to do this, running natively in Windows or Office. However, I do not have access to Visual Studio, so I can't use any .NET functionality.

我有使用 VBA/VBscript 的经验，因此最好使用上述脚本或内置于 MS Office 应用程序中的内容（Outlook 是最好的，但我可能可以适应所提供的任何内容）。话虽如此，我对任何允许我这样做的方法持开放态度，在 Windows 或 Office 中本机运行。但是，我无权访问 Visual Studio，因此无法使用任何 .NET 功能。

回答by Gaffi

Thanks to Sean Cheshirefor pointing me at the obvious answer that I did not see. Posting the relevant code, since I don't believe this yet exists on SO.

感谢Sean Cheshire指出我没有看到的明显答案。发布相关代码，因为我不相信这在 SO 上还存在。

Sub UploadFilesToSP(sFolder)

Dim sharepointUrl
Dim sharepointFileName
Dim LlFileLength
Dim Lvarbin()
Dim LobjXML
Dim LvarBinData
Dim PstrFullfileName
Dim PstrTargetURL
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr
Dim f

    'This has not been successfully tested using an "https" connection.
    sharepointUrl = "http://SHAREPOINT URL HERE"
    Set LobjXML = CreateObject("Microsoft.XMLHTTP")
    Set fldr = fso.GetFolder(sFolder)

    For Each f In fldr.Files
        sharepointFileName = sharepointUrl & f.Name

        PstrFullfileName = sFolder & f.Name
        LlFileLength = FileLen(PstrFullfileName) - 1

        ' Read the file into a byte array.
        ReDim Lvarbin(LlFileLength)
        Open PstrFullfileName For Binary As #1
        Get #1, , Lvarbin
        Close #1

        ' Convert to variant to PUT.
        LvarBinData = Lvarbin
        PstrTargetURL = sharepointFileName 

        ' Put the data to the server, false means synchronous.
        LobjXML.Open "PUT", PstrTargetURL, False

        ' Send the file in.
        LobjXML.Send LvarBinData
    Next f

Set LobjXML = Nothing
Set fso = Nothing

End Sub

This is VBA code, formatted to mostly work with VBScript, though I could not get this block to transfer properly. As VBA, this can be improved some by assigning data types, etc.

这是 VBA 代码，格式化为主要与 VBScript 一起使用，但我无法正确传输此块。作为 VBA，这可以通过分配数据类型等来改进。

' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1

回答by Dave Stuart

This is a very old post but a very useful one so thanks to everyone's contribution. This is my version with the early binding. I found that the previous posting didn't work due to VBA assumption of the none declared variable types.

这是一篇很老的帖子，但非常有用，所以感谢大家的贡献。这是我的早期绑定版本。我发现之前的帖子由于 VBA 假设没有声明的变量类型而不起作用。

Private Sub cmdUploadToApplicationsAndApprovals_Click()

    Dim strSharePointUrl As String
    Dim strSharePointFileName As String
    Dim lngFileLength As Long
    Dim bytBinary() As Byte
    Dim objXML As XMLHTTP
    Dim varBinData As Variant
    Dim strFullfileName As String
    Dim strTargetURL As String
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim folder As folder
    Dim file As file
    Dim strFolder As String
    
    strFolder = CurrentProject.Path & "\Upload\"
        
    'This has not been successfully tested using an "https" connection.
    strSharePointUrl = "http://sps.mysite.ca/subsite/DocLib/"
    Set objXML = New XMLHTTP 'CreateObject("Microsoft.XMLHTTP")
    Set folder = fso.GetFolder(strFolder)

    For Each file In folder.Files
        strSharePointFileName = strSharePointUrl & file.Name

        strFullfileName = strFolder & file.Name
        lngFileLength = FileLen(strFullfileName) - 1

        'Read the file into a byte array.
        ReDim bytBinary(lngFileLength)
        Open strFullfileName For Binary As #1
        Get #1, , bytBinary
        Close #1

        'Convert to variant to PUT.
        varBinData = bytBinary
        strTargetURL = strSharePointFileName

        'Put the data to the server, false means synchronous.
        objXML.Open "PUT", strTargetURL, False

        'Send the file in.
        objXML.Send varBinData
        
        'Now Update the metadata
        
        
    Next file

    'Clean up
    Set objXML = Nothing
    Set fso = Nothing
    MsgBox "Done"
End Sub

FYI the above code required 2 references. 1. Microsoft XML, v6.0 2. Microsoft Scripting Runtime

仅供参考，上述代码需要 2 个引用。1. Microsoft XML, v6.0 2. Microsoft Scripting Runtime

Hope this helps improve on the already brilliant answer!!

希望这有助于改进已经很棒的答案！！