Mail automatisch abspeichern
16.10.2016 15:21:45
Roland
Stehe wieder mal vor einem Problem.
Habe mit google und foren nun ein Modul zusammengestoppelt, wo ich mails aus outlook per knopfdruck im richtigen pfad speichern möchte.
Mein Problem ist nun das das ganze an einer Stelle hängenbleibt "Laufzeitfehler 13, Typen unverträglich" aber ich komme nicht dahinter
Das ganze Modul habe ich in Outlook 2010 reinkopoiert.
Kurz zur erklärung: Das makro lest aus dem betreff anhand der ersten 16 zeichen eine Projektnummer aus, (Die kann entweder zbsp so 16-1234 oder so 16-A123 aussehen) nach dieser nummer wird dann der Projektordner in einer ordnerstruktur gesucht, und da soll dann das mail gespeichert werden.
Ausführen muss man das Makro MailSpeichern()
Vielleicht kann mir jemand helfen... Danke schon mal!
Public SpeicherprojNr As String
Public ProjJahr As String
Public Verzeichnis As String
Public arr_ordner As Variant
Public arr_pfad As Variant
Public Speicherpfad As String
Public MailBetreff As String
Private i As Long
Public Sub Ordner_und_unterordner()
Dim j As Long
'Alle Ordner und Unterordner ins Array schreiben
In_Array_schreiben
'Ordner und Unterordner auflisten
For j = LBound(arr_ordner) To UBound(arr_ordner)
If arr_pfad(j) = "" Then GoTo keinpfadgefunden
MsgBox "Ordner: " & arr_ordner(j) & Chr(10) & "Ganzer pfad: " & arr_pfad(j)
Speicherpfad = arr_pfad(j)
Next j
MsgBox Speicherpfad
Exit Sub
keinpfadgefunden:
MsgBox "kein_pfad_gefunden"
End Sub
Private Sub In_Array_schreiben()
Dim Fso As FileSystemObject ' Verweis Microsoft Scripting Runtime muss aktiviert sein
Dim Fld As Folder
Dim SubFld As Folder
i = 0
ReDim arr_ordner(i)
ReDim arr_pfad(i)
' On Local Error GoTo Fehler
MsgBox Verzeichnis
Set Fso = New FileSystemObject
' da passiert der fehler:
'Laufzeitfehler 13 Typen unverträglich
'
Set Fld = Fso.GetFolder(CStr(Verzeichnis))
For Each SubFld In Fld.SubFolders
If LCase(SubFld.Name) Like SpeicherprojNr Then
ReDim Preserve arr_ordner(i)
ReDim Preserve arr_pfad(i)
arr_ordner(i) = SubFld.Name
arr_pfad(i) = SubFld.path
i = i + 1
End If
Unterordner (SubFld.path)
Next SubFld
Exit Sub
Fehler:
End Sub
Private Sub Unterordner(pfad As String)
Dim Fso As FileSystemObject
Dim Fld As Folder
Dim SubFld As Folder
On Local Error GoTo Fehler
Set Fso = New FileSystemObject
Set Fld = Fso.GetFolder(CStr(pfad))
For Each SubFld In Fld.SubFolders
If LCase(SubFld.Name) Like SpeicherprojNr Then
ReDim Preserve arr_ordner(i)
ReDim Preserve arr_pfad(i)
arr_ordner(i) = SubFld.Name
arr_pfad(i) = SubFld.path
i = i + 1
End If
Unterordner (SubFld.path)
Next SubFld
Exit Sub
Fehler:
End Sub
Public Function getprojnr()
Dim objRegEx As Object
Dim mymatch As Object
Dim Betreff As String
Dim Betreffkurz As String
Dim SpeicherprojNr As String
Betreff = MailBetreff
Betreffkurz = Left(Betreff, 16)
'// Objekt für reguläre Ausdrücke erzeugen
Set objRegEx = CreateObject("vbscript.regexp")
With objRegEx
.Global = True
.IgnoreCase = True
'// Suchmuster angeben
.Pattern = "\d{2}-\d{4}"
'// Zeichenkette durchsuchen
Set mymatch = objRegEx.Execute(Betreffkurz)
'// Wenn es einen Treffer gab, den ersten Treffer ausgeben
If mymatch.Count > 0 Then getprojnr = mymatch.Item(0)
End With
End Function
Public Function getAprojnr()
Dim objRegEx As Object
Dim mymatch As Object
Dim Betreff As String
Dim Betreffkurz As String
Dim SpeicherprojNr As String
Betreff = MailBetreff
Betreffkurz = Left(Betreff, 16)
'// Objekt für reguläre Ausdrücke erzeugen
Set objRegEx = CreateObject("vbscript.regexp")
With objRegEx
.Global = True
.IgnoreCase = True
'// Suchmuster angeben
.Pattern = "\d{2}-A\d{3}"
'// Zeichenkette durchsuchen
Set mymatch = objRegEx.Execute(Betreffkurz)
'// Wenn es einen Treffer gab, den ersten Treffer ausgeben
If mymatch.Count > 0 Then getAprojnr = mymatch.Item(0)
End With
End Function
Public Sub MailSpeichern()
If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
Set obj = Application.ActiveWindow
Set obj = obj.Selection(1)
Else
Set objInspector = ActiveInspector
objInspector.Activate
If objInspector.IsWordMail Then
Set obj = Application.ActiveInspector.CurrentItem
End If
End If
MailBetreff = obj.Subject
MsgBox "Betreff:" & MailBetreff
Dim a As String
Dim b As String
a = getprojnr
b = getAprojnr
If a = "" And b = "" Then GoTo keineProjNrgefunden
If Trim(Len(a)) >= 1 And Trim(Len(b)) >= 1 Then GoTo keineProjNrgefunden
If a = "" Then SpeicherprojNr = "*" & b & "*"
If b = "" Then SpeicherprojNr = "*" & a & "*"
MsgBox SpeicherprojNr
ProjJahr = Mid(SpeicherprojNr, 2, 2)
MsgBox ProjJahr
'