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....

' 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

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

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