Hallo VBA Spezialisten,
ich habe da ein kleines Problem (hoffentlich). Das nachfolgende Makro funktioniert soweit, mit Ausnahme zweier Probleme:
Hier das Makro:
ich habe da ein kleines Problem (hoffentlich). Das nachfolgende Makro funktioniert soweit, mit Ausnahme zweier Probleme:
- Das Makro kopiert die Anhänge nicht in den vorgesehenen Ordner C:/Attachments, sonder meist in den Dokumente Ordner, kann aber auch passieren, dass er sie auf dem Desktop, oder in willkürlich anderen Ordnern ablegt.
- Er löscht die Anhänge am Schluss nicht aus dem Ordner in die er sie kopiert hat.
Hier das Makro:
Code:
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub PrintSelectedAttachments()
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection
Dim obj As Object
Set Exp = Application.ActiveExplorer
Set Sel = Exp.Selection
For Each obj In Sel
If TypeOf obj Is Outlook.MailItem Then
PrintAttachments obj
End If
Next
End Sub
Private Sub PrintAttachments(oMail As Outlook.MailItem)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
sDirectory = "C:\Attachments"
Set colAtts = oMail.Attachments
If colAtts.Count Then
For Each oAtt In colAtts
sFileType = LCase$(Right$(oAtt.FileName, 4))
Select Case sFileType
Case ".xls", ".doc", ".pdf"
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End Sub
