thảo luận [Office VBA] Chia sẻ với mọi người thư viện được viết bằng VBA giúp tương tác với SharePoint

NguyenDang95

Senior Member
Xin chào mọi người. Chúc mọi người cuối tuần vui vẻ.
Tiếp nối tinh thần của bài viết này: [Office VBA] Tương tác với SharePoint và giải quyết một số yêu cầu thường thấy của người dùng
Hôm nay mình xin chia sẻ với mọi người thư viện hoàn chỉnh SharePoint API được viết hoàn toàn bằng VBA. Nhìn chung thư viện này tuy có chút hơi hướng cá nhân (mình có chọn lọc, không thêm vào những phương thức mà VBA khó có thể thực hiện được, vd: nhận thông báo đẩy theo thời gian thực, v.v.), tuy nhiên phần trình bày vẫn tuân thủ tài liệu hướng dẫn của Microsoft.

Working with SharePoint sites in Microsoft Graph - Microsoft Graph v1.0 | Microsoft Learn

Về phần xác thực, thư viện này tiến hành xác thực OAuth2 với Permission là dạng Delegated. Để tìm hiểu thêm về cách thức triển khai như tạo tài khoản Azure, chọn tenant (single tenant hay multi-tenant), người dùng có thể tham khảo hai bài viết này:

Get access on behalf of a user
Microsoft Graph permissions reference

Ví dụ: Tạo một List mới trên SharePoint site

Giả sử người dùng có một trang (site) với URL là danghome.sharepoint.com/sites/CompanyNews và người dùng muốn tạo một List tên là Books với hai cột lần lượt là Title (mặc định có sẵn khi tạo List mới) và Author.

Tiến hành đọc tài liệu.
1676108880715.png


Đầu tiên, lấy mã Id của site cần tạo List.
1676108897942.png


Tiếp theo, tạo định dạng JSON theo hướng dẫn của tài liệu. Trong thư viện hỗ trợ tạo định dạng JSON thông qua các class module được tạo sẵn và với sự trợ giúp của thư viện JsonConverter của tác giả timhall: VBA-JSON.
1676108947542.png


Code:
Option Explicit

Private Function GetSession() As MicrosoftGraphOAuth2
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = New MicrosoftGraphOAuth2
    With objMicrosoftGraphOAuth2
        .ApplicationName = "SharePoint API"
        .ClientId = "client-id"
        .Scope = Array("files.readwrite.all", "sites.readwrite.all", "sites.fullControl.all")
        .Tenant = Common
        .AuthorizeOAuth2
    End With
    Set GetSession = objMicrosoftGraphOAuth2
End Function

Private Sub CreateList()
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = GetSession
    Dim strSiteId As String
    strSiteId = objMicrosoftGraphOAuth2.SiteResource.GetSiteByServerRelativePath("danghome.sharepoint.com", "sites/CompanyNews", "$select=id").Id
    Dim objList As List
    Set objList = New List
    objList.DisplayName = "Books"
    Dim objTitleCol As ColumnDefinition, objAuthorCol As ColumnDefinition
    Dim objTextColumn As TextColumn
    Set objTextColumn = New TextColumn
    Set objTitleCol = New ColumnDefinition
    With objTitleCol
        .Name = "Title"
        Set .Text = objTextColumn
    End With
    objList.Columns.Add objTitleCol.ToJson
    Set objAuthorCol = New ColumnDefinition
    With objAuthorCol
        .Name = "Author"
        Set .Text = objTextColumn
    End With
    objList.Columns.Add objAuthorCol.ToJson
    Dim objNewList As List
    Set objNewList = objMicrosoftGraphOAuth2.ListResource.CreateList(strSiteId, objList)
End Sub

Kết quả sau khi chạy macro: Một List mới tên là Books được tạo trên site, với hai cột Title và Author.
1676109243440.png

1676109394309.png


Lưu ý:
  • Thư viện đính kèm theo bài viết này có thể chứa lỗi, mong mọi người xem qua và góp ý giúp mình.
  • Mặc dù trọng tâm là SharePoint, tuy vậy mình có thêm vào thư viện một số phương thức giúp tương tác với OneDrive, cho nên mọi người cũng có thể viết macro tương tác với OneDrive bằng chính thư viện này cũng được.
  • Mọi người nên tạo tài khoản Microsoft 365 E5 Developer để chạy thử code trước khi đưa vào sử dụng thực tế.
Bài viết còn quá sơ sài do lượng kiến thức cần trình bày là khá lớn, mong mọi người bỏ qua cho. :D
Mọi người có bàn luận gì về SharePoint API nói chung và việc sử dụng macro VBA tương tác với SharePoint nói riêng, xin vui lòng để lại bình luận dưới bài viết này.
Xin cảm ơn.
 

Attachments

  • SharePointAPI-VBA.zip
    760.6 KB · Views: 42
Last edited:
Cập nhật: Bổ sung thêm khả năng làm việc với Excel Online (tức là tương tác với các tệp Excel (chỉ hỗ trợ phần mở rộng .xlsx) trên SharePoint.
Tài liệu tham chiếu: Working with Excel in Microsoft Graph
1676515507596.png


Mọi người có thể tìm thấy macro đính kèm theo bài viết này.
 

Attachments

  • MicrsoftGraph-SharePoint_Excel.zip
    178.1 KB · Views: 36
Một ví dụ thực tế về việc sử dụng macro VBA tương tác với SharePoint và Excel Online:

Một người dùng đưa ra yêu cầu như sau:

1676517497606.png


Với đề bài như trên, sử dụng Power Automate là phương pháp nhanh, gọn nhất.

1676517504849.png




Tuy vậy, nếu người dùng mong muốn làm trực tiếp trên Outlook thì VBA có sẵn trong Outlook có thể xử lý được việc này.

Trình tự viết macro có thể như sau:
  • Đầu tiên, để macro tự động chạy mỗi khi nhận được email mới, ta sẽ tạo một class module tên là UploadAttachmentsToSharePoint.
  • Trong ThisOutlookSession, khai báo class module trên để nó tự động chạy khi Outlook đã hoàn thành xong quá trình đăng nhập tài khoản email (sự kiện Application.MAPILogonComplete).
  • Trong class module UploadAttachmentsToSharePoint chứa code với nhiệm vụ:
  • Lưu tệp tin đính kèm của email vào thư mục tạm trên máy tính.
  • Tự động tạo thư mục trên SharePoint (trong trường hợp này tạo thư mục theo địa chỉ email của người gửi).
  • Thu thập dữ liệu cần thiết và đẩy lên tệp Excel có sẵn trên SharePoint.
  • Cuối cùng, tải tất cả tệp đính kèm của email lên thư mục trên SharePoint và dọn dẹp.
Trên SharePoint, tạo sẵn một thư mục cha tên là Email Attachments để chứa tệp đính kèm và tệp Excel tên là ExcelData.xlsx chứa dữ liệu từ email nhận được.

1676517555409.png




Nội dung tệp Excel, gồm một bảng tên là Tbl_EmailData.

1676517562465.png




UploadAttachmentsToSharePoint:

Code:
Option Explicit

Private WithEvents colItems As Outlook.Items

Private Sub Class_Initialize()
    Dim objStore As Outlook.Store
    Set objStore = Application.Session.Stores.Item("[email protected]")
    Dim objInboxFolder As Outlook.Folder
    Set objInboxFolder = objStore.GetDefaultFolder(olFolderInbox)
    Set colItems = objInboxFolder.Items
End Sub

Private Sub colItems_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    If TypeOf Item Is Outlook.MailItem Then
        Set objMail = Item
        Call InsertMailDataIntoSharePointSpreadsheet(objMail)
        If objMail.Attachments.Count > 0 Then
            On Error Resume Next
            Dim strSharePointFolder As String
            strSharePointFolder = objMail.SenderEmailAddress
            Const strSharePointParentFolder As String = "Email Attachments"
            Dim strSharePointFolderPath As String
            strSharePointFolderPath = strSharePointParentFolder & "/" & strSharePointFolder
            If DriveItemExists(strSharePointFolder, , strSharePointParentFolder) = False Then
                Const strSiteId As String = "danghome.sharepoint.com,c773430b-c290-4256-b4bb-4b0911a2d039,a4b48b25-7a6c-4ca4-9c6a-556f343bfae0"
                Call CreateSharePointFolder(strSiteId, strSharePointFolder, , strSharePointParentFolder)
            End If
            If Err.Number <> 0 Then
                Debug.Print Err.Description
                Err.Clear
            End If
            Dim i As Long
            Dim objAtt As Outlook.Attachment
            For i = 1 To objMail.Attachments.Count
                Set objAtt = objMail.Attachments.Item(i)
                Call SaveAndUploadAttachmentToSharePoint(objAtt, strSiteId, , strSharePointFolderPath)
                If Err.Number <> 0 Then
                    Debug.Print Err.Description
                    Err.Clear
                End If
            Next
        End If
    End If
End Sub

Private Sub CreateSharePointFolder(SiteId As String, Name As String, Optional ParentItemId As String, Optional ParentItemPath As String)
    Dim objMicrosoftOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftOAuth2 = GetSession
    Dim objDriveItem As DriveItem
    Set objDriveItem = New DriveItem
    Dim objDriveFolder As DriveFolder
    Set objDriveFolder = New DriveFolder
    With objDriveItem
        .Name = Name
        .ConflictBehavior = "rename"
        Set .Folder = objDriveFolder
    End With
    On Error Resume Next
    If ParentItemPath <> vbNullString Then
        objMicrosoftOAuth2.FilesResource.CreateFolder Destination:=DestinationSite, DriveItem:=objDriveItem, SiteId:=SiteId, ParentItemPath:=ParentItemPath
    Else: objMicrosoftOAuth2.FilesResource.CreateFolder Destination:=DestinationSite, DriveItem:=objDriveItem, SiteId:=SiteId, ParentItemId:=ParentItemId
    End If
    If Err.Number <> 0 Then
        Debug.Print Err.Description
        Err.Clear
    End If
End Sub

Private Sub SaveAndUploadAttachmentToSharePoint(ByVal Attachment As Outlook.Attachment, ByVal SiteId As String, Optional ByVal ParentItemId As String, Optional ByVal ParentItemPath As String)
    Dim strTempFolder As String
    strTempFolder = Environ$("TEMP") & "\MailAttachments_Tmp"
    Dim objFSO As Scripting.FileSystemObject
    Set objFSO = New Scripting.FileSystemObject
    If objFSO.FolderExists(strTempFolder) = False Then objFSO.CreateFolder strTempFolder
    Dim strFile As String
    strFile = strTempFolder & "/" & Attachment.FileName
    Attachment.SaveAsFile strTempFolder & "/" & Attachment.FileName
    Dim objMicrosoftOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftOAuth2 = GetSession
    On Error Resume Next
    Const strSiteId As String = "danghome.sharepoint.com,c773430b-c290-4256-b4bb-4b0911a2d039,a4b48b25-7a6c-4ca4-9c6a-556f343bfae0"
    If BytesToMegabytes(objFSO.GetFile(strFile).Size) < 4 Then
        If ParentItemPath <> vbNullString Then
            objMicrosoftOAuth2.FilesResource.UploadFileInSingleRequest objFSO.GetFile(strFile), DestinationSite, , ParentItemPath & "/" & Attachment.FileName, SiteId
        Else: objMicrosoftOAuth2.FilesResource.UploadFileInSingleRequest objFSO.GetFile(strFile), DestinationSite, ParentItemId & "/" & Attachment.FileName, , SiteId
        End If
    Else
        If ParentItemPath <> vbNullString Then
            objMicrosoftOAuth2.FilesResource.UploadFileInChunks objFSO.GetFile(strFile), DestinationSite, , ParentItemPath & "/" & Attachment.FileName, SiteId
        Else: objMicrosoftOAuth2.FilesResource.UploadFileInChunks objFSO.GetFile(strFile), DestinationSite, ParentItemId & "/" & Attachment.FileName, , SiteId
        End If
    End If
    objFSO.DeleteFile strFile
End Sub

Private Sub InsertMailDataIntoSharePointSpreadsheet(ByVal MailItem As Outlook.MailItem)
    Dim arrMailData(0 To 0, 0 To 5) As Variant
    With MailItem
        arrMailData(0, 0) = .Subject
        arrMailData(0, 1) = .SenderEmailAddress
        arrMailData(0, 2) = .CC
        arrMailData(0, 3) = .ReceivedTime
        arrMailData(0, 4) = .Body
        arrMailData(0, 5) = .Attachments.Count
    End With
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = GetSession
    On Error Resume Next
    Const strSiteId As String = "danghome.sharepoint.com,c773430b-c290-4256-b4bb-4b0911a2d039,a4b48b25-7a6c-4ca4-9c6a-556f343bfae0"
    objMicrosoftGraphOAuth2.WorkbookTableResource.CreateRow Values:=arrMailData, TableIdOrName:="Tbl_EmailData", TableLocation:=InWorkbook, Location:=LocationSite, SiteId:=strSiteId, ItemPath:="Email Attachments/EmailData.xlsx"
    If Err.Number <> 0 Then
        Debug.Print Err.Description
        Err.Clear
    End If
End Sub

Private Function DriveItemExists(ByVal Name As String, Optional ByVal ParentItemId As String, Optional ByVal ParentItemPath As String) As Boolean
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = GetSession
    Const strSiteId As String = "danghome.sharepoint.com,c773430b-c290-4256-b4bb-4b0911a2d039,a4b48b25-7a6c-4ca4-9c6a-556f343bfae0"
    Dim colResults As Collection
    If ParentItemPath <> vbNullString Then
        Set colResults = objMicrosoftGraphOAuth2.FilesResource.ListChildren(Destination:=DestinationSite, SiteId:=strSiteId, ItemPath:=ParentItemPath, ItemId:=ParentItemId, ODataQuery:="$filter=name eq '" & Name & "'")
    Else: Set colResults = objMicrosoftGraphOAuth2.FilesResource.ListChildren(Destination:=DestinationSite, SiteId:=strSiteId, ItemId:=ParentItemId, ODataQuery:="$filter=name eq '" & Name & "'")
    End If
    If colResults.Count > 0 Then
        Dim i As Long
        For i = 1 To colResults.Count
            If Name = colResults.Item(i).Name Then
                DriveItemExists = True
                Exit Function
            End If
        Next
    End If
End Function

Private Function BytesToMegabytes(Bytes As Double) As Double
    BytesToMegabytes = Bytes / 1024 / 1024
End Function

ThisOutlookSession:
Code:
Option Explicit

Private UploadAttachmentsToSharePoint As UploadAttachmentsToSharePoint

Private Sub Application_MAPILogonComplete()
    Set UploadAttachmentsToSharePoint = New UploadAttachmentsToSharePoint
End Sub

Module:
Code:
Option Explicit

Public Function GetSession() As MicrosoftGraphOAuth2
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = New MicrosoftGraphOAuth2
    With objMicrosoftGraphOAuth2
        .ApplicationName = "SharePoint API"
        .ClientId = "client_id"
        .Scope = Array("files.readwrite.all", "sites.readwrite.all")
        .Tenant = Organizations
        .AuthorizeOAuth2
    End With
    Set GetSession = objMicrosoftGraphOAuth2
End Function

Public Sub LogOut()
    Dim objMicrosoftGraphOAuth2 As MicrosoftGraphOAuth2
    Set objMicrosoftGraphOAuth2 = New MicrosoftGraphOAuth2
    With objMicrosoftGraphOAuth2
        .ApplicationName = "SharePoint API"
        .ClientId = "client_id"
        .LogOut
    End With
End Sub

Tiến hành chạy thử để xem kết quả:
 
Last edited:
Back
Top