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
|