Upload file and link file to SharePoint List using VBA

Like what I do? Donate

Did I help you? Did one of my tutorials save you sometime? 

You can say thank you by buying me a cup of coffee, I go through a lot of it.

Help keep Greater Good resources free for everyone. Please donate today. 

This page is not monitored so for questions please comment on the youtube video page. For suggestions email vbaa2z.team@gmail.com

All relevant materials for this topic/tutorial can be downloaded from here. Please support by subscribing to our channel and sharing them with your friends.

If you have any questions/feedback/tutorial request, please you can email me directly vbaa2z.team@gmail.com or comment on YouTube Video (blog comments are not actively monitored).

Channel Link: https://www.youtube.com/vbaa2z
SharePoint Automation with VBA:
https://www.youtube.com/watch?v=KdMM0hgp4q4&list=PLo0aMPtFIFDrcPiWbqJGb3qt3rkOmjDbN

Option Explicit

Function UploadToSharepoint() As Boolean

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Subscribe channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

'upload file to sp lib
Dim SharePointLib As String
Dim LocalAddress As String

On Error GoTo loadFailed
Dim objNet As Object
Dim FS As Object

[D11] = ""
SharePointLib = "\\lp-pc\LIB17\"
LocalAddress = [d6].Text

SharePointLib = SharePointLib & FileNameWithExt(LocalAddress)

Call FileCopy(LocalAddress, SharePointLib)
[D11] = "#http:" & Replace(SharePointLib, "\", "/") & "#"

UploadToSharepoint = True

Exit Function

loadFailed:
UploadToSharepoint = False

End Function

Sub addnewRec_ref_to_link()

'Visit: Youtube.com/VBAa2Z
'Re-use and change it as you like
'10:26 PM 2/12/2017
'by LP (vbaa2z@outlook.com)
'---------------------------------

'upload file to sp lib
'add new rec to sp list and link it to uploaded file
'add ref to ms activex data objects **.* library

Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset 'tb

Dim mySQL As String

Dim filecaption As String
Dim filelink As String

If UploadToSharepoint = False Then
    MsgBox "Sorry upload failed!"
    Exit Sub
End If

Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset

filelink = [D11].Text
filecaption = [D8].Text

mySQL = "SELECT * FROM [sptb];"

With cnt
    .ConnectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;DATABASE=http://YOUR SHAREPOINT SITE URL HERE;LIST={YOUR GUID HERE};"
    .Open
End With

rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic

rst.AddNew
    rst.Fields("Title") = Sheets("Form").Range("D4").Text
    rst.Fields("FileLink") = filecaption & filelink
rst.Update

If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing
MsgBox "Complete!"
End Sub

Public Function SeletedFile(PopUpDirName As String, msgstr As String) As String
'Ref to ms office **.* object Library
'This function will return selected file name
'This is function to browse the file var [PopUpDirNane] folder;
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
        With fldr
            .Title = msgstr
            .AllowMultiSelect = False
            .InitialFileName = PopUpDirName

            .Filters.Clear
            .Filters.Add "Templates", "*.*"
            .Filters.Add "All files", "*.*"
            .FilterIndex = 1

            If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
        End With
NextCode:
SeletedFile = sItem
Set fldr = Nothing
End Function

Sub SelectFile()
[d6] = SeletedFile(PopUpDirName:="D:\VbaA2z\img\fb_SlideShow\", _
            msgstr:="Please select the file")
End Sub

Function FilePath(strPath As String) As String
    FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function

Function FileNameWithExt(strPath As String) As String
    Dim strTemp As String
    FileNameWithExt = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function