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()
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: