Hallo Detlev,

Danke für Deine schnelle Antwort. Mit dem Programm möchte ich markierte Emails mit PDF-Anhänge öffnen und eine Bestell-Nr. finden, kopieren und im Dateiname speichern. Der zu speichernde Dateiname sollte sich dann aus dem Namen der Datei des PDF-Anhangs und der gesuchten Bestell-Nr. aus dem PDF-Anhang zusammen setzen. Der zu speichernde Dateiname wird im VBA-Programm richtig zusammen gesetzt, jedoch nicht gespeichert. Wäre schön, wenn Du noch `ne Idee hättest.

Danke und gruss mab

Hier der Code:

Public Sub SaveFiles()

'Variants for OL-Attachments
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim myOLItm As Outlook.MailItem
Dim myOLAtt As Outlook.Attachments

Dim Save_pth As String, fln_ext As String
Dim old_fln As String, new_fln As String

Dim i As Integer 'counter
Dim x As Integer 'counter
   
'Variants for PDF-Readings
Dim ProgFileVar As String
Dim ProgFileVar2 As String
Dim FileOpenVar As String

Dim search_str As String
Dim search_txt As String
Dim search_pos As Integer
Dim search_res As String

Dim MyClipb As Object
Dim TaskID As Long

Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
         
Save_pth = "C:\OL_Anhänge\"

    For x = 1 To myOlSel.Count
        Set myOLItm = myOlSel.Item(x)
        Set myOLAtt = myOLItm.Attachments
   
        For i = 1 To myOLAtt.Count
            myOLAtt.Item(i).SaveAsFile Save_pth & myOLAtt.Item(i).FileName
            
            ProgFileVar = "C:\Program Files\Adobe\Reader 8.0\Reader\AcroRd32.exe"
            FileOpenVar = Save_pth & myOLAtt.Item(i).FileName
            TaskID = Shell(ProgFileVar & " " & FileOpenVar, vbNormalFocus) 'TaskID for application correspondence
           
            AppActivate TaskID
           
            SendKeys "^{a}"  'mark
            SendKeys "^{c}"  'copy
            SendKeys "%{F4}" 'close
           
            Set MyClipb = New DataObject
            MyClipb.GetFromClipboard
            If MyClipb.GetFormat(1) Then
            search_txt = MyClipb.GetText(1)
            End If
           
            search_str = "Bestellnr.:"
            search_pos = InStr(1, search_txt, search_str)
            search_res = Mid(search_txt, search_pos + 12, 10)
           
            keybd_event VK_NUMLOCK, 1, 0, 0
            keybd_event VK_NUMLOCK, 1, KEYEVENTF_KEYUP, 0
           
            fln_ext = "_" & search_res & ".pdf"
           
            old_fln = Save_pth & myOLAtt.Item(i).FileName
            new_fln = Save_pth & Left(myOLAtt.Item(i).FileName, Len(myOLAtt.Item(i).FileName) - 4) & fln_ext
           
            Sleep 3000 'ensure existing file to kill

            Kill old_fln

            myOLAtt.Item(i).SaveAsFile new_fln
            Set MyClipb = Nothing
        Next i
       
        Set myOLItm = Nothing
        Set myOLAtt = Nothing
    Next x

Set myOlExp = Nothing
Set myOlSel = Nothing

MsgBox "Dateien wurden erfolgreich gespeichert !"

End Sub