mail exporteren en groep email (teams)

Public Sub Attachment_Projectbox()

Dim objNS       As Outlook.NameSpace
Dim olFolder    As Outlook.MAPIFolder
Dim Item        As Object
Dim fn          As Integer
Dim myFile      As String

Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim geadres As String
Dim sfolder As String
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

    On Error Resume Next
    Set objNS = GetNamespace("MAPI")
    'Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    'Set olFolder = objNS.Folders
    'Set olFolder = objNS.Folders("Team Bijlmer Noord").Folders("inbox")
    'Set olFolder = objNS.Folders("Groepen").Folders("Teams")
[COLOR="#FF0000"]    Set olFolder = objNS.Folders("groepen").Folders("VSG")[/COLOR]

                
    fn = FreeFile   'get handle to freefile
    Open "C:\Email\Post-IN\inbox.txt" For Append As #fn

    For Each Item In olFolder.Items
        If TypeOf Item Is Outlook.MailItem Then
            Dim oMail As Outlook.MailItem: Set oMail = Item
            Print #fn, oMail.ReceivedTime & ", " & oMail.Sender & ", " & oMail.Subject
            
            geadres = CStr(oMail.To)
            If InStr(1, geadres, ";") <> 0 Then
               geadres = Left(geadres, InStr(1, geadres, ";"))
            End If
            
            
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "_"
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
            vbUseSystem) & Format(dtDate, "-hhnn", _
            vbUseSystemDayOfWeek, vbUseSystem) & "_" & sName & "_(" & (oMail.Sender) & "-" & (geadres) & ")" & ".msg"
            ' vbUseSystemDayOfWeek, vbUseSystem) & "_" & NaamAfkorting(oMail.Sender) & "-" & NaamAfkorting(geadres) & "_" & sName & ".msg"

            sPath = "c:\Email\post-in"
            sfolder = sPath & sName: mkdir (sfolder)
            sfolder = sfolder & ""
            'oMail.SaveAs sPath & sName, olMSG
            oMail.SaveAs sfolder & sName, olMSG
            
            For Each Atmt In Item.Attachments
               FileName = sfolder & Atmt.FileName
               Atmt.SaveAsFile FileName
            Next Atmt
            Set Atmt = Nothing
        
        End If
        DoEvents
        
        sfolder = ""
    Next
    
    Close (fn)
    'MsgBox "done"
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

Function NaamAfkorting(P1 As String) As String
Dim tmp As Variant
    tmp = Split(P1, " ")
    NaamAfkorting = UCase(Left(tmp(LBound(tmp)), 1) & Left(tmp(UBound(tmp)), 2))
End Function