Аутентификация VBA SharePoint для сопоставления дисков

Question

У меня был успех с помощью VBA в Excel, чтобы сопоставить диск с экстрасети SharePoint для загрузки файлов, однако при развертывании он работает в одном месте, но не в другом (возможны разные условия). Мне любопытно, есть ли у кого-нибудь представление о том, какой пользователь или системный настрой вызовут это.

В приведенном ниже коде я пытаюсь сопоставить диск с SharePoint, если он вызывает ошибки, обработчик создает новый экземпляр excel и сохраняет его на сайте SharePoint. По своей природе это заставляет IE открывать и запрашивать у пользователя свои данные для входа, после того как он отправлен, он аутентифицирует их и загружает файл. Затем они смогут сопоставить диск с SharePoint. Проблема, с которой я сталкиваюсь в одной группе, это загрузить файл, однако они не остаются аутентифицированными для сопоставления диска. Даже страннее, пользователь регистрируется на сайте SharePoint в IE, пока я перехожу к этой процедуре.

Sub MapSharePoint() 
    Dim objNet as object 
    Dim strDriveLetter as String 
    Dim strSharePointDatabaseFolder as String 
    Set objNet = CreateObject("WScript.Network") 

    On Error GoTo AUTH_Connection: 
    strDriveLetter = <function to find open drive> 
    strSharePointDatabaseFolder = <SharePoint site> 
    objNet.MapNetworkDrive strDriveLetter, strSharePointDatabaseFolder 

    <do something with mapped drive> 

    Exit Sub 

AUTH_Connection: 

    Dim xlApp As New Excel.Application 
    Dim xlDoc As Workbook 
    On Error GoTo ErrHandler: 

    Set xlApp = CreateObject("Excel.Application") 
    Set xlDoc = xlApp.Workbooks.Add 
    ' Trying to upload the file below will force IE to open and prompt user for their Username and Password which will authenticate them 
    xlDoc.SaveAs FileName:="<SharePointSite>", FileFormat:=xlWorkbookNormal, AddToMru:=False 
    xlDoc.Close 
    xlApp.Quit 

    objNet.MapNetworkDrive strDriveLetter, strSharePointDatabaseFolder 
    Resume Next 
ErrHandler: 
    MsgBox Err.Code, Err.Description 

End Sub

UPDATE 1:

Использование кода ниже проблемы, я бегу в аутентификации SharePoint. В скобках catch я добавил строку кода ниже, чтобы открыть окно сообщения с конкретным текстом ошибки и получил значение 403: Запрещено. После загрузки Fiddler я вижу, что на сайте используется cookie проверки подлинности, который я читал, WebClient не поддерживает. Я пытался захватить cookie и аутентифицировать его, так что теперь я не получаю ошибку 403, но вместо этого я загружаю HTML-код из входа в веб-форму. Мне нужно выяснить, как отправить запрос на вход, захватить файл cookie auth, который возвращается, а затем использовать его при отправке запроса DownloadFile.

System.Windows.Forms.MessageBox.Show(ex.Message); 

Answer 1

Для чего стоит, вот код, который я использовал. Мне было легче учиться достаточно C# (первый раз, используя C#), чтобы сделать это, чем пытаться понять это с помощью VBA. Аргументы (файлы для загрузки) передаются в виде строки и разбиваются на массив. Надеюсь, поможет.

using System; 
using System.IO; 
using System.Net; 
using System.Text; 
using System.Collections; 
using System.Collections.Generic; 
using System.Data; 
using System.Diagnostics; 
using System.Linq; 
using System.Runtime.InteropServices; 
using RGiesecke.DllExport; 
using System.Windows.Forms; 

namespace sptHELPER { 
public class sptDL 
{ 
    [DllExport("getResources", System.Runtime.InteropServices.CallingConvention.StdCall)] 
    public static Int32 sptDownLoader(string sptURL, string sptItem, string sptTemp, string sptUser = "", string sptPass = "") 
    { 
     //System.Windows.Forms.MessageBox.Show("In function"); 
     int Result = 0; 
     Result = 0; 

     System.Net.NetworkCredential myCredentials = new System.Net.NetworkCredential(); 

     if (string.IsNullOrEmpty(sptUser)) 
     { 
      myCredentials = System.Net.CredentialCache.DefaultNetworkCredentials; 
     } 
     else 
     { 
      myCredentials.UserName = sptUser; 
      myCredentials.Password = sptPass; 
      myCredentials.Domain = ""; 
     } 

     // set a temporary Uri to catch an invalid Uri later 
     Uri mySiteSP = new Uri("http://www.defaultfallback"); 

     string myFile = null; 

     int iCount = 0; 
     string[] arr1 = sptItem.Split('*'); 
     arr1 = sptItem.Split('*'); 

     StandAloneProgressBar sp = new StandAloneProgressBar(); 

     for (iCount = arr1.GetLowerBound(0); iCount <= arr1.GetUpperBound(0); iCount++) 
     { 
      try 
      { 
       myFile = arr1[iCount]; 
       mySiteSP = new Uri(sptURL + "/" + myFile); 
       string dest = sptTemp + "/" + myFile; 
       dest = dest.Replace("/", "\\") ; 
       //System.Windows.Forms.MessageBox.Show(dest + " " + sptURL + "/" + myFile); 
       System.Net.WebClient mywebclient = new System.Net.WebClient(); 
       mywebclient.Credentials = myCredentials; 
       mywebclient.DownloadFile(mySiteSP, dest); 
      } 

      catch (Exception ex) 
      { 
       Result = ex.HResult; 
       break; 
      } 
     } 
     return Result; 
    } 
} 
} 

В VBA добавить модуль с помощью следующего кода, модифицированный в соответствии с вашими потребностями:

Option Explicit 

#If VBA7 Then ' Office 2010 or later (32/64 Bit)... 
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long 
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long 
Private Declare PtrSafe Function sptDL Lib "sptHELPER.dll" Alias "getResources" (ByVal sptURL As String, ByVal sptItem As String, ByVal sptTemp As String, ByVal sptUser As String, ByVal sptPass As String) As Integer 
#Else 
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long 
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long 
Private Declare Function sptDL Lib "sptHELPER.dll" Alias "getResources" (ByVal sptURL As String, ByVal sptItem As String, ByVal sptTemp As String, ByVal sptUser As String, ByVal sptPass As String) As Integer 
#End If 

Private Type sptSP_Data 
    sptURL As String 
    sptResourceNames As String 
    sptUserName As String 
    sptPassWord As String 
    sptdomain As String 
    sptDestination As String 
End Type 

' Purpose: 
' Get resources from sharepoint (or Website) 
Function getSharePointItems() As Boolean 

    Dim strTemp As String 
    Dim strRes() As String 
    Dim lLib As Long 
    Dim result As Double ' get error code 
    Dim sptData As sptSP_Data ' Private Type Above 

    ' 1. SharePoint Settings 
    sptData.sptURL = "<SharepointURL>" ' e.g. "http://testsp-mysite.cloudapp.net/sites/spTesting/" 
    sptData.sptUserName = "<UserName>" 
    sptData.sptPassWord = "<PassWord>" 
    sptData.sptdomain = "<Domain>" ' I left this blank 
    sptData.sptResourceNames = "strRes1*strRes2*strRes3*strRes4*strRes5" 
    sptData.sptDestination = "<PathToSaveTo>" ' should already be created 

    ' Use sptHELPER to fetch Resources 
    lLib = LoadLibrary(ThisWorkbook.Path & "\sptHELPER.dll") 
    result = sptDL(sptData.sptURL, sptData.sptResourceNames, sptData.sptDestination, sptData.sptUserName, sptData.sptPassWord) 
    Debug.Print result 
    FreeLibrary (lLib) 

    ' See if we were sucessful 
    Select Case result 
     Case 0 
      ' All good 
     Case 5385 ' Bad URL or No response from the WebServer 
      Debug.Print "Bad URL or No response from the WebServer" 

     Case 5431 ' URL is empty or not a valid format 
      Debug.Print "URL is empty or not a valid format, missing http://" 

     Case Else 
      ' unknown error 
      Debug.Print "Error: " & result & " in getSharePointItems" 
    End Select 

End Function