Macro voor opslaan Outlook 2003 bijlagen werkt niet goed

lw87 · 20 jul 2010

Ik gebruik een macro om PDF bijlagen in een bepaalde Outlook 2003 map op de slaan en uit te printen. De verwerkte mails worden verwijderd.
Helaas werkt de macro niet goed: alleen de eerste helft van de mailtjes worden verwerkt. Ik moet de macro dus een paar keer herhalen.
Bijv. de eerste 8 van 16, dan de eerste 4 van 8, dan de eerste 2 van 4, enz.

Waar zit de fout in deze macro?

Sub BijlagenOpslaanPrinten()

'Deze macro controleert een voorgedefinieerde subfolder in Outlook op Attachments en slaat die met PDF-extensie op in een voorgedefinieerde map.
'De opgeslagen bestanden kunnen bekeken worden in Internet Explorer.
'De opgeslagen bestanden worden afgedrukt op de standaardprinter.

' Afvangen van fouten
On Error GoTo SaveAttachmentsToFolder_err

' Variabelen declareren
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String

Dim i As Integer
Dim varResponse As VbMsgBoxResult

Set ns = GetNamespace("MAPI")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("mail-met-bijlagen") 'GEEF HIER DE NAAM VAN DE SUBFOLDER IN OUTLOOK AAN.
i = 0

' Controleer de Subfolder op Attachments en sluit af als er niets gevonden wordt.
If SubFolder.Items.Count = 0 Then
MsgBox "Er zijn geen berichten met Attachments in de Subfolder mail-met-bijlagen.", vbInformation, _
"Niets gevonden"
Exit Sub
End If

' Controleer elk bericht op Attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments

' Controleer de filenaam van elke Attachment and sla die met "pdf" extensie op in voorgedefineerde map.
If Right(Atmt.FileName, 3) = "pdf" Then
FileName = "D:\bijlagen\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
'document printen
Shell """C:\Program Files\Adobe\Reader 9.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide

End If

Next Atmt

'remove next line if you don’t want the email be deleted automatically
Item.Delete

Next Item

' Laat een totaal van berichten zien
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\bijlagen\" _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")

' Open Windows Explorer om de opgeslagen bestanden te laten zien.
If varResponse = vbYes Then
Shell "Explorer.exe /e,D:\bijlagen\", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If

' Maak het geheugen leeg
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

' Foutverwerking
SaveAttachmentsToFolder_err:
MsgBox "Er is een fout opgetreden." _
& vbCrLf & "Rapporteer de volgende fout." _
& vbCrLf & "Macro Naam: SaveAttachmentsToFolder()" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit

End Sub

OctaFish · 20 jul 2010

Ik heb de macro (uiteraard met de noodzakelijke aanpassingen) uitgeprobeerd, maar hij loopt er redelijk netjes doorheen.
Dat hij steeds de helft van de mailtjes wist is wel logisch, omdat je bij elke verwijdering het totaal met één verlaagt. Daardoor klopt de pointer uiteraard niet meer; stel dat je 6 mailtjes hebt. Die worden (intern) genummerd van 1-6. Je wilt ze verwijderen, dus je begint met de lus, die het eerste mailtje verwijdert. Je hebt er nu 5 over, die weer 1-5 genummerd worden. In je verwijdercyclus heb je nummer 1 al verwijderd. De procedure gaat dus verder met mail 2. Als die is verwijderd, heb je er 4 over: 1-4. De teller is nu bij mail 3 aangekomen, die wordt verwijderd. Nummers 1 en 2 (opgeschoven vanuit de vorige verwijderingsactie) blijven staan. Aan het eind van de rit heb je dus de helft over....

Om dus goed te kunnen wissen, moet je van achteren naar voren werken:

Code:

'Tel het aantal mailtjes in de folder
iCount = SubFolder.Items.Count
For i = SubFolder.Items.Count To 1 Step -1
    SubFolder.Items.Item(i).Delete
    numDeleted = iCount - SubFolder.Items.Count
    If numDeleted Mod 100 = 0 Then
        MsgBox ("Deleted " & numDeleted & " items of " & iCount & ".")
    End If
Next
MsgBox ("Successfully deleted " & numDeleted & " items.")

Ik zou de Delete routine uit het extracten van de pdf-jes halen, en hem apart laten draaien. Doet het bij mij dan prima.

lw87 · 20 jul 2010

Hallo Octafish

Bedankt voor je reactie.

Het zit toch iets anders: de bijlagen worden opgeslagen. Uit de eerste 8 van 16 mailtjes krijg ik 8 bestanden, uit eerste 4 van de resteren 8 mailtjes de volgende 4 bestanden, enz. Juist door mijn manier van wissen houd ik de bestanden over waarvan de bijlagen nog niet zijn opgeslagen.
Waarom stopt de macro nadat de eerste helft van de mailtjes is bekeken?

Die teller

i

geeft het totaal aantal bijlagen weer, meestal één per mailtje.

De mailtjes worden bekeken met een For ... Next - lus

For Each Item In SubFolder.Items

Daarna worden de bijlagen opgeslagen, geteld en geprint:

For Each Atmt In Item.Attachments

Dit wordt afgesloten met

Next Atmt

Daarna volgt

Item.Delete

Next Item

en begint de Item lus opnieuw om na de helft van de Items te stoppen. In de For ... Next - lus zit geen teller, die moet doorlopen tot er geen maitljes meer over zijn.

Maar dat gebeurt dus niet.

OctaFish · 20 jul 2010

Hoi Loes,

Het zit precies zo als ik zei

De macro stopt niet, als wel dat hij de Pointer niet bijwerkt in de loop. Zoals ik al zei, doordat je steeds een mailtje wist, verandert de plaats van een mailtje in de rij: bij het verwijderen van het eerste mailtje word 3-2, 4-3 etc. Daarom gaf ik een oplossing waarbij je eerst de bijlagen opslaat/print, en daarna de map leegmaakt. Iets uitgebreider ziet het er dan zo uit:

Code:

' Controleer elk bericht op Attachments
For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
    ' Controleer de filenaam van elke Attachment and sla die met "pdf" extensie op in voorgedefineerde map.
        If Right(Atmt.FileName, 3) = "pdf" Then
            FileName = "H:\bijlagen\" & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
           'document printen
''            Shell """C:\Program Files\Adobe\Reader 9.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide
        End If
    Next Atmt
Next
'Tel het aantal mailtjes in de folder
origCount = SubFolder.Items.Count
For i = SubFolder.Items.Count To 1 Step -1
    SubFolder.Items.Item(i).Delete
    numDeleted = origCount - SubFolder.Items.Count
    If numDeleted Mod 100 = 0 Then
        MsgBox ("Deleted " & numDeleted & " items of " & origCount & ".")
    End If
Next
MsgBox ("Successfully deleted " & numDeleted & " items.")

Het zal vast wel mogelijk zijn om de twee procedures ineen te vlechten, mits je uiteraard nog steeds van achteren naar voren werkt...

lw87 · 20 jul 2010

Gelukt!

Hallo Octafish

Ik heb je voorstellen uitgevoerd en het werkt! Enorm bedankt.

Dit is de vernieuwde macro:

Sub BijlagenOpslaanPrinten()

'Deze macro controleert een voorgedefinieerde subfolder in Outlook op Attachments en slaat die met PDF-extensie op in een voorgedefinieerde map.
'De opgeslagen bestanden kunnen bekeken worden in Internet Explorer.
'De opgeslagen bestanden worden afgedrukt op de standaardprinter.

' Afvangen van fouten
On Error GoTo SaveAttachmentsToFolder_err

' Variabelen declareren
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String

Dim i As Integer
Dim varResponse As VbMsgBoxResult

Set ns = GetNamespace("MAPI")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("mail-met-bijlagen") 'GEEF HIER DE NAAM VAN DE SUBFOLDER IN OUTLOOK AAN.
i = 0

' Controleer de Subfolder op Attachments en sluit af als er niets gevonden wordt.
If SubFolder.Items.Count = 0 Then
MsgBox "Er zijn geen berichten met Attachments in de Subfolder mail-met-bijlagen.", vbInformation, _
"Niets gevonden"
Exit Sub
End If

' Controleer elk bericht op Attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Controleer de filenaam van elke Attachment and sla die met "pdf" extensie op in voorgedefineerde map.
If Right(Atmt.FileName, 3) = "pdf" Then
FileName = "D:\bijlagen\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
'document printen
'Shell """C:\Program Files\Adobe\Reader 9.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide
End If
Next Atmt
Next

' Laat een totaal van berichten zien
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\bijlagen\" _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")

' Open Windows Explorer om de opgeslagen bestanden te laten zien.
If varResponse = vbYes Then
Shell "Explorer.exe /e,D:\bijlagen\", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If

'Tel het aantal mailtjes in de folder
origCount = SubFolder.Items.Count
For i = SubFolder.Items.Count To 1 Step -1
SubFolder.Items.Item(i).Delete
numDeleted = origCount - SubFolder.Items.Count
If numDeleted Mod 100 = 0 Then
MsgBox ("Deleted " & numDeleted & " items of " & origCount & ".")
End If
Next
MsgBox ("Successfully deleted " & numDeleted & " items.")

' Maak het geheugen leeg
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

' Foutverwerking
SaveAttachmentsToFolder_err:
MsgBox "Er is een fout opgetreden." _
& vbCrLf & "Rapporteer de volgende fout." _
& vbCrLf & "Macro Naam: SaveAttachmentsToFolder()" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit

End Sub

Macro voor opslaan Outlook 2003 bijlagen werkt niet goed

lw87

Gebruiker

OctaFish

Verenigingslid

lw87

Gebruiker

OctaFish

Verenigingslid

lw87

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy