Helpmij.nl
Helpmij.nl
Helpmij.nl

Quote

Weergeven resultaten 1 tot 2 van 2

Onderwerp: oulook bijlage opslaan (handmatig)

  1. #1
    Vraag is niet opgelost

    oulook bijlage opslaan (handmatig)

    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 aangepast door puppie : 15 september 2020 om 16:00

  2. #2
    Hoofdmoderator
    Verenigingslid
    puppie's avatar
    Geregistreerd
    19 maart 2003
    Locatie
    Enschede
    Ik heb voor jou maar even de code tags om je vraag gezet.
    Dat leest makkelijker voor de helpers.
    Suc6 met je vraag verder.

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl

Regels
Help

Helpmij.nl en business

Partners
Sponsoren