2

I have written VBA code that will upload a document to SharePoint 2010/2013. Then I get the record via ADODB using the document Name and update the metadata. This all working great, however this created 2 revisions as Versioning is on. How do I upload AND set the metadata in one transaction via VBA?

This is a sub-set of the code.

Set objXML = New XMLHTTP 'CreateObject("Microsoft.XMLHTTP")
Dim bytBinary() As Byte
Dim strSharePointUrl As String
Dim strSharePointFileName As String
Dim strFileName As String

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 ', username, password

On Error Resume Next
' Send the file in. Note that the Name field in SharePoint is updated with the filename.
objXML.send varBinData

'IMORTANT: The WILDCARD is % and NOT * because this is a SQL Table and ADO Connection!
rst.Open "SELECT * FROM [" & strListName & "] WHERE [Name] Like '%" &      strFileName & "%'", cnn, adOpenDynamic, adLockOptimistic

'Note that Manditory fields will cause the List/Library Item to check Out the item
'Not sure how to check in at the moment.
If Not rst.EOF Then
'Debug.Print "ID:" & rst("ID") & " Name:" & rst("Name")

'SharePoint Item Update
rst("Name") = strFileName
rst("Title") = !Title
rst("Originator") = !Originator
etc....
0

This is how I got things working! It took a lot of research but it works great. It takes the meta data and prepends it to the PDF file, or what ever file type it is that you're uploading. It's not 100% as I have found sometimes a file will not upload and the return value says it did. To check this I do a table refresh after all is uploaded and then compare what I uploaded to what is in SharePoint. Hope it helps you out. There is a lot more code before and after this but I think this will solve it for you. Just spend time stepping through it and understand how it works. Beware of meta data that contains characters like semi-colons as that may offset the metadata, so you need to compare the metadata in SharePoint against the metadata you intended on sending up. Finally I found some issues with the Dates not uploading correctly so I has to convert them to Universal Time. That function is also included below.

Good Luck and let me know if you have any questions. I fell like I'm a Guru at this now :-)

                ' http://stackoverflow.com/questions/3787870/vbscript-to-upload-file-to-sharepoint-doclib

            ' Find Front Page Server Extentions version here! Currently 15.0.0.4517
            ' http://websrvstg:2015/_vti_pvt/service.cnf
            ' http://intrwebsrvstg01:17404/_vti_pvt/service.cnf
            ' Good Atricle found here: http://thuansoldier.net/?p=4298

            ' http://websrvstg:2015/_vti_pvt/service.cnf -> returns this
            ' vti_encoding:SR|utf8-nl
            ' vti_extenderversion:SR|15.0.0.4517

            ' http://intrwebsrvstg01:17404/_vti_pvt/service.cnf -> returns this
            ' vti_encoding:SR|utf8-nl
            ' vti_extenderversion:SR|15.0.0.4763

            ' http://websrvstg:2015/_vti_inf.html -> View Source gets this
            ' <!-- FrontPage Configuration Information
            ' FPVersion = "15.00.0.000"
            ' FPShtmlScriptUrl = "_vti_bin/shtml.dll/_vti_rpc"
            ' FPAuthorScriptUrl = "_vti_bin/_vti_aut/author.dll"
            ' FPAdminScriptUrl = "_vti_bin/_vti_adm/admin.dll"
            ' TPScriptUrl = "_vti_bin/owssvr.dll"
            ' -->

            ' http://webdesign.about.com/library/bl_url_encoding_table.htm
            ' %3a as a colon :
            ' %2f is a slash /
            ' %5f is underscore _
            ' %7C is pipe |
            ' %3b is semi colon ;
            ' %3bSW%7c is ;SW|

            ' Adding Metadata explained below.
            ' Inside the above script, the metadata "vti_title" is added.
            ' You can add further metadata properties, by adding them inside the meta_info=[...] brackets.
            ' E.g. ";meta_info=[vti_title%3bSW%7c" + Escape(title) + ";project%3bSW%7c" + Escape(project) + "]]".
            ' You must have a custom field called project in the document library.
            ' "SW" for String
            ' "BW" for Boolean (true/false)
            ' "IW" for Integer
            ' "TR" for Date. Must use dd mmm yyyy hh:nn:ss format even if it's a Date Only field

            strMetaData = "vti_title" & "%3b" & "SW" & "%7c" & URLEncode(!Title, True) 'FixStringForSQL(strFileName)
            strMetaData = strMetaData & ";Originator" & "%3b" & "SW" & "%7c" & URLEncode(!Originator, True)
            strMetaData = strMetaData & ";Project" & "%3b" & "IW" & "%7c" & CStr(m_colProjects.Item(Trim(!ProjectNumber)))
            If Not IsNull(!TransmittalNumber) Then
                strMetaData = strMetaData & ";Transmittal+Number" & "%3b" & "SW" & "%7c" & URLEncode(!TransmittalNumber, True)
            End If
            If Len(Nz(!TransmittalDate, "")) > 0 Then
                strMetaData = strMetaData & ";Transmittal+Date" & "%3b" & "TR" & "%7c" & Format(ToUTC(Trim(!TransmittalDate)), "dd mmm yyyy hh:nn:ss")
            End If

            strDataID = Split(!DataID, "-")
            strMetaData = strMetaData & ";Data+ID" & "%3b" & "SW" & "%7c" & !DataID

            'Extract From JACOS Data ID This returns the ID of the Collection for the name fed in.
            strMetaData = strMetaData & ";Facility+Code" & "%3b" & "IW" & "%7c" & CStr(m_colFacilityCodes.Item(strDataID(0)))
            strMetaData = strMetaData & ";Area+Designation" & "%3b" & "IW" & "%7c" & CStr(m_colAreaDesignations.Item(strDataID(1)))
            strMetaData = strMetaData & ";Discipline+Code" & "%3b" & "IW" & "%7c" & CStr(m_colDisciplineCodes.Item(strDataID(2)))
            strMetaData = strMetaData & ";Document+Type" & "%3b" & "IW" & "%7c" & CStr(m_colDocumentTypes.Item(strDataID(3)))
            strMetaData = strMetaData & ";Sequence+Number" & "%3b" & "SW" & "%7c" & strJACODDataID(4)
            strMetaData = strMetaData & ";Sheet+Number" & "%3b" & "SW" & "%7c" + strJACODDataID(5)

            strMetaData = strMetaData & ";Document+Revision" & "%3b" & "SW" & "%7c" & !DocumentRevision

            If IsDate(!RevisionDate) Then
                strMetaData = strMetaData & ";Revision+Date" & "%3b" & "TR" & "%7c" & Format(ToUTC(!RevisionDate), "dd mmm yyyy hh:nn:ss")
            End If
            strMetaData = strMetaData & ";File+Status" & "%3b" & "IW" & "%7c" & CStr(m_colFileStatuses.Item(!FileStatus))
            strMetaData = strMetaData & ";Tag+Number" & "%3b" & "SW" & "%7c" & URLEncode(Nz(!TagNumber, ""), True)
            strMetaData = strMetaData & ";Cross+Reference" & "%3b" & "SW" & "%7c" & URLEncode(Nz(!CrossReference, ""), True)

            strHeader = "method=put+document%3a" & str_vti_extenderversion & _
            "&service_name=%2f" & _
            "&document=[document_name=" & FixStringForSQL(Replace(strListName, " ", "") & "/" & strFileName) & _
            ";meta_info=[" & strMetaData & "]]" & _
            "&put_option=overwrite,createdir,migrationsemantics" & _
            "&comment=" & _
            "&keep%5fchecked%5fout=false" & vbLf

            ByteArray = StringToByteArray(strHeader)

            Set Stream1 = New ADODB.Stream
            Stream1.Open
            Stream1.Type = adTypeBinary
            Stream1.Write ByteArray

            Set Stream2 = New ADODB.Stream
            Stream2.Open
            Stream2.Type = adTypeBinary
            Stream2.LoadFromFile strFullfileName
            Stream2.CopyTo Stream1
            Stream1.position = 0
            Stream2.Close

            strTargetURL = strSharePointFileName

            ' Upload the data to the server, false means synchronous.
            Set objXML = New MSXML2.XMLHTTP

            objXML.Open "POST", strSharePointUrl + "/_vti_bin/_vti_aut/author.dll", False
            objXML.setRequestHeader "Content-Type", "application/x-vermeer-urlencoded"
            objXML.setRequestHeader "X-Vermeer-Content-Type", "application/x-vermeer-urlencoded"
            objXML.setRequestHeader "User-Agent", "FrontPage"

            On Error Resume Next
            objXML.send Stream1

            Stream1.Close

            If Err.Number <> 0 Then
                'Release the handle on the files
                Set objXML = Nothing
                Set Stream1 = Nothing

                ErrorNumber = Err.Number
                ErrorMessage = Err.Description
                .Edit
                !ErrorMessage = !ErrorMessage & "File:" & strFileName & " (" & Format(dblFileSize, "#,###") & " KB) Error:" & ErrorMessage
                .Update
                g_rstADODB.Close
                GoTo ExitHereTechnicalData
            End If
            On Error GoTo ErrorHandler

            'Debug.Print "Upload: " & objXML.Status & " " & objXML.StatusText '& " :: " & objXML.responseText
            If objXML.Status = 200 Then
                If InStr(objXML.responseText, "successfully") = 0 And Len(objXML.responseText) > 0 Then
                    If objXML.responseText <> "" Then
                        .Edit
                        !ErrorMessage = !ErrorMessage & "File:" & strFileName & " Status:" & objXML.Status & " XML Error:" & objXML.responseText
                        .Update

                        'g_rstADODB.Close
                        GoTo ExitHereTechnicalData
                    Else
                        .Edit
                        !ErrorMessage = !ErrorMessage & "File:" & strFileName & " Status:" & objXML.Status & " Error: No Error returned. Check File in SharePoint!"
                        .Update
                        'Carry on!
                    End If
                Else

                    ' Check In Document whether it needs it or not!
                    strHeader = "method=checkin+document%3a" & str_vti_extenderversion & _
                    "&service_name=%2f" & _
                    "&document=[document_name=" & FixStringForSQL(Replace(strListName, " ", "") & "/" & strFileName) & _
                    "&comment=MS Access Check In" & _
                    "&keep%5fchecked%5fout=false" & vbLf

                     Set objXML = New MSXML2.XMLHTTP
                    objXML.Open "POST", strSharePointUrl + "/_vti_bin/_vti_aut/author.dll", False
                    objXML.setRequestHeader "Content-Type", "application/x-vermeer-urlencoded"
                    objXML.setRequestHeader "X-Vermeer-Content-Type", "application/x-vermeer-urlencoded"
                    objXML.setRequestHeader "User-Agent", "FrontPage"
                    objXML.send strHeader

                    'Debug.Print "CheckIn: " & objXML.Status & " " & objXML.StatusText

                    'At ths point we know the SharePoint Metadata was updated so update the temporary record
                    .Edit
                    !MetadataUpdated = True
                    !UpdateDate = Now
                    .Update

                End If

            Else
                .Edit
                !ErrorMessage = !ErrorMessage & "File:" & strFileName & " Status:" & objXML.Status & " XML Error:" & objXML.responseText
                .Update
                g_rstADODB.Close
                GoTo ExitHereTechnicalData
            End If

            'Clear Memory
            Set objXML = Nothing
            Set Stream1 = Nothing
            Set Stream2 = Nothing

            'At ths point we know the file was uploaded so update the temporary record
            .Edit
            !UploadedToSharePoint = True
            !FileSize = dblFileSize
            !UpdateDate = Now
            .Update

            DoEvents

            'Clear Memory
            Set g_rstADODB = Nothing

            'Keeping track of the uploads as we have intMaxDocsForUpload Set
            intUploadCounter = intUploadCounter + 1

This is the URLEncode Function!

Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As   Boolean = False) As String
Dim bytes() As Byte
Dim b As Byte
Dim i As Integer
Dim Space As String

If SpaceAsPlus Then Space = "+" Else Space = "%20"

If Len(StringVal) > 0 Then
  With New ADODB.Stream
  .Mode = adModeReadWrite
  .Type = adTypeText
  .Charset = "UTF-8"
  .Open
  .WriteText StringVal
  .position = 0
  .Type = adTypeBinary
  .position = 3 ' skip BOM
  bytes = .Read
End With

ReDim Result(UBound(bytes)) As String

For i = UBound(bytes) To 0 Step -1
  b = bytes(i)
  Select Case b
    Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
      Result(i) = Chr(b)
    Case 32
      Result(i) = Space
    Case 0 To 15
      Result(i) = "%0" & Hex(b)
    Case Else
      Result(i) = "%" & Hex(b)
  End Select
Next i

URLEncode = Trim(Join(Result, ""))
End If
End Function

Universal Time Conversion

Public Function ToUTC(ByVal DateTime As Date) As Date
  Dim ftLoc@, ftUtc@
  ftLoc = (DateTime - #1/1/1601#) * 86400000
  LocalFileTimeToFileTime ftLoc, ftUtc
  ToUTC = ftUtc / 86400000# + #1/1/1601#
End Function

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.