AW: Makro soll Dateien aus Outlook zusammenhängen
27.03.2014 10:30:35
Raphael
Hallo Pascal,
der Code müsste funktionieren, ich habe mich nicht gross mit einer Fehlerbehebung beschäftigt, das überlasse ich getrost dir.
Sub AnhängeSpeichern()
Dim mail As Object
Dim xl As Object
Dim arrG() As Variant
Dim arrM() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim Pfad As String
Set mail = Application.ActiveExplorer.Selection(1)
Set xl = CreateObject("Excel.Application")
Pfad = "C:\Temp\" 'hier einen Pfad eingeben, in dem die Dateien temporär gespeichert werden. _
Pfad vorher anlegen!
On Error GoTo Fehler
With mail
With .Attachments
If .Count > 0 Then
ReDim arrG(.Count)
ReDim arrM(.Count)
j = 0 'Array beginnt bei 0
For i = 1 To .Count
If Right(.Item(i).FileName, 5) = ".xlsx" Then
.Item(i).SaveAsFile Pfad & .Item(i).FileName
xl.workbooks.Open FileName:=Pfad & .Item(i).FileName
With xl.activeworkbook.activesheet
arrG(j) = .Range("G:G") 'Gesamte Spalte einlesen, da ich keine Mö _
glichkeit kenn die letzte Zeile ausfindig zu machen ohne die Excel Bibliothek mit einzubinden
arrM(j) = .Range("M:M")
End With
xl.activeworkbook.Close 'Workbook wieder schliessen
Kill Pfad & .Item(i).FileName 'Temporäre Datei wieder löschen
j = j + 1
End If
Next i
ReDim Preserve arrG(j - 1) 'j-1 damit das Array nur die Grösse der effektiven Daten _
hat
ReDim Preserve arrM(j - 1)
'Die Daten in ein neues WB schreiben
xl.workbooks.Add
With xl.activeworkbook.activesheet
For i = 0 To UBound(arrM)
For j = 1 To UBound(arrM(i))
If arrG(i)(j, 1) "" Then
k = k + 1
.cells(k, 1) = arrG(i)(j, 1)
.cells(k, 2) = arrM(i)(j, 1)
Else: Exit For
End If
Next j
Next i
.SaveAs Pfad & Date & ".xlsx"
xl.Quit
Exit Sub
End With
End If
End With
End With
Fehler:
xl.Quit
MsgBox "Irgendwas hat leider nicht geklappt"
End Sub
Hoffe es hilft dir.
Gruess
Raphael