Мой работодатель поручил мне найти способ автоматизировать загрузку/обновление списков SharePoint с сервера SharePoint 2013, использующего проверку подлинности NTLM. Возможными средствами для этого являются VBA или Powershell. Список, который я хочу получить, принадлежит деловому партнеру моей компании и содержит текущее состояние документов, которые должны быть написаны, проверены и опубликованы. Экспортированный список используется для сравнения между их базой данных (сервер SharePoint) и нашей (на базе Oracle).
Сначала я попытался использовать Powershell, но не смог выполнить аутентификацию NTLM и, следовательно, не смог получить какие-либо данные списка. Из того, что я читал в Интернете, мне нужно было иметь учетные данные администратора, которых у меня нет.
После этого я попытался использовать макрос VBA. Я вручную экспортировал список в Excel и, следовательно, имел соединение, которое я думал использовать для извлечения данных списка:
Sub UpdateandExport()
ActiveWorkbook.RefreshAll
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len (CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:="Export", FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
ThisWorkbook.Close True
End Sub
Этот код работает для меня, но он предлагает мне вручную ввести свои учетные данные, чего я не хочу делать.
Поэтому я попытался сначала пройти аутентификацию, прежде чем вытаскивать данные списка:
Sub Export()
Dim user As String
Dim Password As String
user = "DOMAIN\USERNAME" 'I enter my credentials here
Password = "PASSWORD" 'I enter my credentials here
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "https://aaaa.bbbbbbbb.cc/dd-ee/ffffffffff/_vti_bin/", False
.setRequestHeader "Authorization", "NTLM" + Base64Encode(user + ":" + Password)
.Send
End With
ActiveWorkbook.RefreshAll
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:="Export", FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
ThisWorkbook.Close True
End Sub
Function Base64Encode(sText)
Dim oXML, oNode
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.CreateElement("base64")
oNode.DataType = "bin.base64"
oNode.nodeTypedValue = Stream_StringToBinary(sText)
Base64Encode = oNode.Text
Set oNode = Nothing
Set oXML = Nothing
End Function
Function Stream_StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1
'Create Stream object
Dim BinaryStream 'As New Stream
Set BinaryStream = CreateObject("ADODB.Stream")
'Specify stream type - we want To save text/string data.
BinaryStream.Type = adTypeText
'Specify charset For the source text (unicode) data.
BinaryStream.Charset = "us-ascii"
'Open the stream And write text/string data To the object
BinaryStream.Open
BinaryStream.WriteText Text
'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
'Ignore first two bytes - sign of
BinaryStream.Position = 0
'Open the stream And get binary data from the object
Stream_StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
Function Stream_BinaryToString(Binary)
Const adTypeText = 2
Const adTypeBinary = 1
'Create Stream object
Dim BinaryStream 'As New Stream
Set BinaryStream = CreateObject("ADODB.Stream")
'Specify stream type - we want To save text/string data.
BinaryStream.Type = adTypeBinary
'Open the stream And write text/string data To the object
BinaryStream.Open
BinaryStream.Write Binary
'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeText
'Specify charset For the source text (unicode) data.
BinaryStream.Charset = "us-ascii"
'Open the stream And get binary data from the object
Stream_BinaryToString = BinaryStream.ReadText
Set BinaryStream = Nothing
End Function
Это также успешно извлекает данные списка с сервера, но мне все еще приходится вручную вставлять свои учетные данные.
Поскольку я далеко не профессионал в VBA, я не могу придумать никакого другого обходного пути и поэтому полностью полагаюсь на ваши знания, чтобы удовлетворить пожелания моих работодателей.
Подводя итог: я ищу сценарий VBA для извлечения данных с сервера SharePoint 2013 с помощью NTLM без передачи учетных данных вручную. У меня нет прав администратора на сервере, и я не могу создать автоматический черновик с сервера.
