Ανανέωση ιστοσελίδας

[Dimi]

Καλημέρα σας και χρόνια πολλά , καλη φώτιση!

Υπάρχει κάποιος τρόπος στο Outlook, μετά τη λήψη κάποιου E Mail, να πραγματοποιεί
αυτόματη εξαγωγή συνημμένων σε συγκεκριμένο φάκελο, ανάλογα τον τύπο του
συνημμένου; Πχ. τα *.xls στο φάκελο XL, τα *.Doc στο φάκελο Word κτλ.

Μετά απ αυτή τη διαδικασία, υπάρχει τρόπος να διαγράφεται το συνημμένο από το μήνυμα;

Για κάθε βοήθεια θα σας ήμουν ευγνώμων.

Δημήτρης

[Tasos]

Φίλε Δημήτρη,
o παρακάτω κώδικας ελέγχει σε κάθε νέο μήνυμα αν υπάρχουν συνημμένα με κατάληξη *.xl* , *.db* , *.pp*, *.doc*, τα αποθηκεύει στον κατάλληλο φάκελο και στη συνέχεια τα διαγράφει (μόνο τα συνημμένα).

Αφού ανοίξεις με Alt + F11 τον VBE επικόλλησε στο "ThisOutlookSession" τον παρακάτω κώδικα:

Option Explicit
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveMyAttachments EntryIDCollection
End Sub

....και σε ένα νέο Module επικόλλησε αυτό:

Option Explicit
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
        ByVal lpPath As String) As Long

Sub SaveMyAttachments(eID$)
    Const xlFolder = "C:\ExcelAttachments\" 'Προσάρμοσε τις διαδρομές
    Const wdFolder = "C:\WordAttachments\"
    Const dbFolder = "C:\DBAttachments\"
    Const ppFolder = "C:\PPAttachments\"
    Dim oNewMail As MailItem, sfolder$, itm As Attachment, Ext$
    Set oNewMail = Application.Session.GetItemFromID(eID)
    With oNewMail
        For Each itm In .Attachments
            Ext = Right(itm.FileName, 4)
            If Ext Like "*" & "xl" & "*" Then
                sfolder = xlFolder
            ElseIf Ext Like "*" & "doc" & "*" Then
                sfolder = wdFolder
            ElseIf Ext Like "*" & "pp" & "*" Then
                sfolder = ppFolder
            ElseIf Ext Like "*" & "db" & "*" Then
                sfolder = dbFolder
            End If
            If sfolder <> vbNullString Then
                SaveAttachment oNewMail, itm.Index, sfolder
                sfolder = vbNullString
            End If
        Next
    End With
End Sub

Function SaveAttachment(theMail As MailItem, TheAttatchment%, WinFolder$)
    MakeSureDirectoryPathExists WinFolder
    With theMail
        .Attachments(TheAttatchment).SaveAsFile WinFolder _
        & "(" & Replace(Replace(.CreationTime, ":", "_"), "/", "_") & _
                ")_" & .Attachments(TheAttatchment).FileName
        .Attachments.Remove TheAttatchment
        .Save
    End With
End Function

Ελπίζω να σε βοήθησα!

Φιλικά

Τάσος

[Dimi]

Καλησπέρα.

Τάσο φίλε μου σε ευχαριστώ!

Ο κώδικας αυτός κάνει όλα όσα χρειάζομαι και μπόρεσα εύκολα να προσαρμόσω τα
ονόματα των φακέλων αποθήκευσης.

Πολύ μου άρεσε το "MakeSureDirectoryPathExists" καθώς και η δυνατότητα να αναγνωρίζει
τα αρχεία και του Office 2007.

Συγχαρητήρια στο φόρουμ!

Δημήτρης

[Chris]

Τασο καλησπερα
πως ενεργοποιω τον κωδικα γιατι εχω κανει οτι λες αλλα δεν ειδα να γινεται κατι.

[Tasos]

Γεια σου Χρήστο.
Ο κώδικας εκτελείται κάθε φορά που γίνεται παραλαβή νέου μηνύματος.

Αν υπάρχει συνημμένο με κάποια από τις προαναφερόμενες; επεκτάσεις, τότε αυτό θα αποθηκευτεί σε φάκελο και κατόπιν θα αφαιρεθεί από το μήνυμα.

Ο κώδικας αυτός δεν θα λειτουργήσει ή θα λειτουργήσει εν μέρει εάν:

• Οι μακροεντολές είναι απενεργοποιημένες.
• Υπάρχουν περιορισμοί στην εκτέλεση κώδικα από τον Administrator ή από κάποιο AntiVirus.
• Κάποια συνημμένα είναι μπλοκαρισμένα για λόγους ασφαλείας από το Outlook και δεν εμφανίζονται καν στον χρήστη.
• Σε κάποιες περιπτώσεις το όνομα του συνημμένου μπορεί να μην είναι αποδεκτό επιδή περιέχει χαραχτήρες όπως "/".

Τι μπορείς να κάνεις:

• Έλεγξε αν οι μακροεντολές είναι ενεργοποιημένες (Εργαλεία >Μακροεντολή>Ασφάλεια και επίλεξε: "Να μην γίνονται έλεγχοι ασφαλείας των μακροεντολών"
• Πρόσθεσε στο ThisOutlookSession το παρακάτω:
  Private Sub Application_Startup()
  End Sub
• Σιγουρέψου ότι τα συνημένα που θέλεις να αποθηκεύεις δεν είναι μπλοκαρισμένα από το Outlook.
• Χρησιμοποίησε την λίγο διαφορετική συνάρτηση για να αποκλείσεις το ενδεχόμενο
  ότι θα προκληθεί λάθος επειδή το όνομα του αρχείου προς αποθήκευση ίσως να μήν είναι έγκυρο.
  
  Δοκίμασε το και τα λέμε...

Τάσος

[Chris]

Φιλε Τασο καλημερα

ΟΚ το δοκιμασα και επαιξε.
Θελω να προτεινω κατι αν μπορει να γινει οταν αποθηκευει τα συνημμενα να βγαζει καποιο Msgbox και στο μηνυμα να δειχνει οτι περιειχε συνημμενο. Επισης παρατηρησα οτι αν το μηνυμα περιεχει πανω απο ενα συνημμενο αποθηκευει μονο το πρωτο, τα υπολοιπα παραμενουν στο μηνυμα.

[Tasos]

Αγαπητέ φίλε Χρήστο καλημέρα,

Αυτός Ο κώδικας δεν προοριζόταν για να αποθηκεύει περισσότερα συνημμένα.

Ο παρακάτω όμως κάνει αυτή τη δουλειά και πρωτοκολλεί μέσα στο ίδιο το μήνυμα
τα αρχεία που αποθηκεύτηκαν με τις διαδρομές τους:

Option Explicit
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
        ByVal lpPath As String) As Long

Sub SaveMyAttachments(eID$)
    Const xlFolder = "C:\ExcelAttachments\"
    Const wdFolder = "C:\WordAttachments\"
    Const dbFolder = "C:\DBAttachments\"
    Const ppFolder = "C:\PPAttachments\"
    Dim oNewMail As MailItem, sfolder$, itm As Attachment, _
            Ext$, i%, msg$, AtsFilename$
    Set oNewMail = Application.Session.GetItemFromID(eID)
    msg = "Followed Attatchments have been moved to folder:" & vbCrLf
    With oNewMail
        For i = .Attachments.Count To 1 Step -1
            Set itm = .Attachments(i)
            Ext = Right(itm.FileName, 4)
            If Ext Like "*" & "xl" & "*" Then
                sfolder = xlFolder
            ElseIf Ext Like "*" & "doc" & "*" Then
                sfolder = wdFolder
            ElseIf Ext Like "*" & "pp" & "*" Then
                sfolder = ppFolder
            ElseIf Ext Like "*" & "db" & "*" Then
                sfolder = dbFolder
            Else
                sfolder = vbNullString
            End If
            If sfolder <> vbNullString Then
                MakeSureDirectoryPathExists sfolder
                AtsFilename = sfolder & "(" & Replace(Replace( _
                        .CreationTime, ":", "_"), "/", "_") & ")_" & itm.FileName
                itm.SaveAsFile AtsFilename
                msg = msg & itm.FileName & " at: " & sfolder & vbCrLf
                .Attachments.Remove itm.Index
            End If
        Next
        If sfolder <> vbNullString Then
            .Body = msg & vbCrLf & .Body
            .Save
        End If
    End With
End Sub

Φιλικά

Τάσος

ΥΓ.

[Chris]

OK Τασο ο κωδικας επαιξε τελεια

Ευχαριστω

[Flashgordon61]

Καλησπέρα σε όλους
Μήπως υπάρχει δυνατότητα παραμετροποίησης (δηλ. να αποθηκεύει μόνο τα επισυναπτόμενα αρχεία που περιέχονται σε Mail με θέμα (Subject) Reports πχ)
Ευχαριστώ
Γιώργος

[Tasos]

Καλησπέρα Γιώργο!
Μπορεις να παραμετροποιήσεις σχεδόν τα πάντα στο Outlook.

Δες:

Option Explicit
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
                                             ByVal lpPath As String) As Long
                                            
Sub SaveMyAttachments(eID$)

Const xlFolder = "C:\ExcelAttachments\"
Const wdFolder = "C:\WordAttachments\"
Const dbFolder = "C:\DBAttachments\"
Const ppFolder = "C:\PPAttachments\"
Const SubjectText = "Reports"

    Dim oNewMail As MailItem, sfolder$, itm As Attachment, _
        Ext$, i%, msg$, AtsFilename$
    Set oNewMail = Application.Session.GetItemFromID(eID)
    msg = "Followed Attatchments have been moved to folder:" & vbCrLf
    With oNewMail
        If .Subject Like "*" & SubjectText & "*" Then  'ή If .Subject = SubjectText Then  (για ακριβή αντιστοίχιση)
            For i = .Attachments.Count To 1 Step -1
                Set itm = .Attachments(i)
                Ext = Right(itm.Filename, 4)
                If Ext Like "*" & "xl" & "*" Then
                    sfolder = xlFolder
                ElseIf Ext Like "*" & "doc" & "*" Then
                    sfolder = wdFolder
                ElseIf Ext Like "*" & "pp" & "*" Then
                    sfolder = ppFolder
                ElseIf Ext Like "*" & "db" & "*" Then
                    sfolder = dbFolder
                Else
                    sfolder = vbNullString
                End If
                If sfolder <> vbNullString Then
                    MakeSureDirectoryPathExists sfolder
                    AtsFilename = sfolder & "(" & Replace(Replace( _
                                  .CreationTime, ":", "_"), "/", "_") & ")_" & itm.Filename
                    itm.SaveAsFile AtsFilename
                    msg = msg & itm.Filename & " at: " & sfolder & vbCrLf
                    .Attachments.Remove itm.Index
                End If
            Next
            If sfolder <> vbNullString Then
                .Body = msg & vbCrLf & .Body
                .Save
            End If
        End If
    End With
End Sub

Καλή συνέχεια

Φιλικά
Τάσος