Automate Upload with Access

[SysDupe123]

I'm trying to use Access VBA to automate the upload of several files into several folders on Sharepoint. I found this code by Jeff Jones but I cannot get it to work.

-----Start Code---------
' Written by Jeff Jones 3-30-2004. Pure freeware, please redistribute.
'=================================

'Use this function call to upload a single file
WebUploadFile "C:\file.txt", "

http://server/folder/file.txt",

"domain\user", "password"

'Use this function call and constant to upload a directory and all it's subdirectories
Const basedir = "c:\temp"
WebUploadDir "", "

http://server/folder/",

"domain\user", "password"


'====================== WebDAV upload single file
Function WebUploadFile (file, url, user, pass)
Dim objXMLHTTP
Dim objADOStream
Dim arrbuffer
Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open
objADOStream.Type = 1
objADOStream.LoadFromFile file
arrbuffer = objADOStream.Read()
Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objXMLHTTP.open "PUT", url, False, user, pass
objXMLHTTP.send arrbuffer
End Function


'====================== WebDAV upload directroy
Function WebUploadDir (dir, baseUrl, usr, pwd)
Set fso = CreateObject("Scripting.FileSystemObject")
If dir = "" Then dir = basedir
Set srcFolder = fso.GetFolder(dir)

Dim fl
Set files = srcFolder.files
For Each fl in files
Dim relpath
relpath = Right(fl.path,Len(fl.path)-Len(basedir)-1)
relpath = Replace(relpath, "\", "/")
WebUploadFile fl.path, baseUrl & relpath, usr, pwd
Next

Dim sf
Set subfold = srcFolder.SubFolders
For Each sf in subfold
Set f = fso.GetFolder(sf)
relpath = Right(f,Len(f)-Len(basedir)-1)
relpath = Replace(relpath, "\", "/")
Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objXMLHTTP.open "MKCOL", baseUrl & relpath, False, usr, pwd
objXMLHTTP.send
WebUploadDir f , baseUrl, usr, pwd
Next
End Function
-----End Code------

I am getting a certificate authority is invalid or incorrect error. Does anyone know of a way to bypass this programmatically?

Thanks

 

[SysDupe123]

I've found out how to get around it. I'm posting this for others to reference.

In the code

Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")

objXMLHTTP.SetOption 2, objXMLHTTP.GetOption(2) <-------Add This Line

objXMLHTTP.open "PUT", url, False, user, pass
objXMLHTTP.send arrbuffer
End Function

This command ignores certificate errors.