Morten
05-05-2008, 06:51 AM
Hello, I've been trying to make a vba script that:
Select a particular inbox (not default).
Take out every pdf file from every mail in the inbox.
Send all the mails which have their pdf files saved into one folder
Send all the mails which have a predefined word as the first in subject field into another folder
Flag all mails that doesn't meet the criterias of the above with a red flag
Send a mail with all the pdf files.
Delete the temporary folder with contents.
The code I have made (later in the post) got a few problems
1) It seems like when I run the macro it only runs through half the mails.
2) When I use the command 'RmDir ("min/mappe")' it doesn't delete it for some reason. works fine if I do this command in a seperate macro.
3) It seems that if I run the macro and some action happens meanwhile, like recieving a mail, it just freezes
I'm sorry for any grammar spelling errors there might be.
I hope someone is able to help and that my censoring doesn't make it complicated, and thanks in front!
Here is the script I have made so far.
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim AtmtC, LocPdfC, PauseTime, Start As Integer
Sub NewPdfMail()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Addr1 = "navn@addres.se"
Addr2 = "navn@addres.se"
Const MailReciever As String = "en@mail.dk"
strPdfPath = "Min\Tempmappe\"
For Each Fold In GetNamespace("MAPI").Folders
If Fold.Name = "Postkasse - ikkestandartfolder" Then
For Each Folds In Fold.Folders
If Folds.Name = "Inbox" Then
Set Inbox = Folds
End If
Next
End If
Next
For Each Rec In GetNamespace("MAPI").Folders
If Rec.Name = "Postkasse - ikkestandartfolder" Then
For Each Recs In Rec.Folders
If Recs.Name = "ikke standartfolder" Then
Set A = Recs
End If
Next
End If
Next
For Each Sen In GetNamespace("MAPI").Folders
If Sen.Name = "Postkasse - ikkestandartfolder" Then
For Each Sens In Sen.Folders
If Sens.Name = "ikke standartfolder" Then
Set B = Sens
End If
Next
End If
Next
If Inbox.Items.Count = 0 Then
Exit Sub
End If
MkDir ("min\Tempmappe")
Dim NyMail As Outlook.MailItem
Set NyMail = olApp.CreateItem(olMailItem)
NyMail.To = MailReciever
NyMail.Subject = "en text" & Date & Time
For Each Item In Inbox.Items
If Item.FlagStatus <> olFlagMarked Then
If Left(Item.Subject, 7) = "text" Then
Item.Move (B)
Set Item = Nothing
ElseIf Item.FlagStatus <> olFlagMarked & Item.SenderEmailAddress <> Addr1 & Item.SenderEmailAddress <> Addr2 Then
AtmtC = Item.Attachments.Count
If AtmtC <> 0 Then
LocPdfC = 0
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Or Right(Atmt.FileName, 3) = "PDF" Then
On Error Resume Next
LocPdfC = LocPdfC + 1
End If
Next
End If
If LocPdfC <> 0 Then
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Or Right(Atmt.FileName, 3) = "PDF" Then
FileName = strPdfPath & Atmt.FileName
Atmt.SaveAsFile FileName
NyMail.Attachments.Add (FileName)
End If
Next
End If
Item.Move (B)
Set Item = Nothing
Else
Item.FlagStatus = olFlagMarked
Item.Save
End If
End If
Next
If LocPdfC > 0 Then
Set Item = Nothing
NyMail.Send
On Error GoTo 0
End If
Set objOL = Nothing
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
If Dir("min\Tempmappe\*") <> "" Then
Kill ("min\Tempmappe\*")
End If
RmDir ("min\Tempmappe")
End Sub
.
~Oorang
Select a particular inbox (not default).
Take out every pdf file from every mail in the inbox.
Send all the mails which have their pdf files saved into one folder
Send all the mails which have a predefined word as the first in subject field into another folder
Flag all mails that doesn't meet the criterias of the above with a red flag
Send a mail with all the pdf files.
Delete the temporary folder with contents.
The code I have made (later in the post) got a few problems
1) It seems like when I run the macro it only runs through half the mails.
2) When I use the command 'RmDir ("min/mappe")' it doesn't delete it for some reason. works fine if I do this command in a seperate macro.
3) It seems that if I run the macro and some action happens meanwhile, like recieving a mail, it just freezes
I'm sorry for any grammar spelling errors there might be.
I hope someone is able to help and that my censoring doesn't make it complicated, and thanks in front!
Here is the script I have made so far.
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim AtmtC, LocPdfC, PauseTime, Start As Integer
Sub NewPdfMail()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Addr1 = "navn@addres.se"
Addr2 = "navn@addres.se"
Const MailReciever As String = "en@mail.dk"
strPdfPath = "Min\Tempmappe\"
For Each Fold In GetNamespace("MAPI").Folders
If Fold.Name = "Postkasse - ikkestandartfolder" Then
For Each Folds In Fold.Folders
If Folds.Name = "Inbox" Then
Set Inbox = Folds
End If
Next
End If
Next
For Each Rec In GetNamespace("MAPI").Folders
If Rec.Name = "Postkasse - ikkestandartfolder" Then
For Each Recs In Rec.Folders
If Recs.Name = "ikke standartfolder" Then
Set A = Recs
End If
Next
End If
Next
For Each Sen In GetNamespace("MAPI").Folders
If Sen.Name = "Postkasse - ikkestandartfolder" Then
For Each Sens In Sen.Folders
If Sens.Name = "ikke standartfolder" Then
Set B = Sens
End If
Next
End If
Next
If Inbox.Items.Count = 0 Then
Exit Sub
End If
MkDir ("min\Tempmappe")
Dim NyMail As Outlook.MailItem
Set NyMail = olApp.CreateItem(olMailItem)
NyMail.To = MailReciever
NyMail.Subject = "en text" & Date & Time
For Each Item In Inbox.Items
If Item.FlagStatus <> olFlagMarked Then
If Left(Item.Subject, 7) = "text" Then
Item.Move (B)
Set Item = Nothing
ElseIf Item.FlagStatus <> olFlagMarked & Item.SenderEmailAddress <> Addr1 & Item.SenderEmailAddress <> Addr2 Then
AtmtC = Item.Attachments.Count
If AtmtC <> 0 Then
LocPdfC = 0
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Or Right(Atmt.FileName, 3) = "PDF" Then
On Error Resume Next
LocPdfC = LocPdfC + 1
End If
Next
End If
If LocPdfC <> 0 Then
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Or Right(Atmt.FileName, 3) = "PDF" Then
FileName = strPdfPath & Atmt.FileName
Atmt.SaveAsFile FileName
NyMail.Attachments.Add (FileName)
End If
Next
End If
Item.Move (B)
Set Item = Nothing
Else
Item.FlagStatus = olFlagMarked
Item.Save
End If
End If
Next
If LocPdfC > 0 Then
Set Item = Nothing
NyMail.Send
On Error GoTo 0
End If
Set objOL = Nothing
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
If Dir("min\Tempmappe\*") <> "" Then
Kill ("min\Tempmappe\*")
End If
RmDir ("min\Tempmappe")
End Sub
.
~Oorang