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

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

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

Option Explicit

Private UploadAttachmentsToSharePoint As UploadAttachmentsToSharePoint

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

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