oulook bijlage opslaan (handmatig)

Status
Niet open voor verdere reacties.

thorry

Gebruiker
Lid geworden
14 nov 2008
Berichten
40
Goedendag,

Nou gebruik ik een vba scrip om mijn emails op te slaan per folder met bijlages.
Echter gaat hij elke keer weer opnieuw door alle emails heen.

Hoe kan ik deze scrip zo aanpassen dat ik deze handmatig kan toepassen door een druk op de knop en dat hij deze opslaat ipv van door alle email te doorlopen.

dus ik selecteer een email en activeer de scrip en de email met bijlage wordt opgeslagen in een folder.


Public Sub Attachment_Projectbox()
Code:
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)

        
    fn = FreeFile   'get handle to freefile
    Open "D:\Emailfolders"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"

            sPath = "D:\Emailfolders"
            sfolder = sPath & sName: mkdir (sfolder)
            sfolder = sfolder & ""
            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
 
Laatst bewerkt door een moderator:
Ik heb voor jou maar even de code tags om je vraag gezet.
Dat leest makkelijker voor de helpers.
Suc6 met je vraag verder.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan