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

[Flashgordon61]

Τάσο σ' ευχαριστώ πολύ.

Τώρα όμως με τα λεγόμενά σου (Μπορεις να παραμετροποιήσεις σχεδόν τα πάντα στο Outlook.)
μου άνοιξες την όρεξη.
Μια άλλη παραμετροποίηση που σκέφτηκα είναι με βάση τον αποστολέα του μυνήματος και αν αυτό μπορεί να γίνει με πολλούς αποστολείς. (να αποθηκεύονται δηλαδή σε διαφορετικούς φακέλους).
Περιμένοντας την απάντησή σου σ΄ευχαριστώ και πάλι.

Φιλικά
Γιώργος

[Tasos]

Καλημέρα!

Έτσι:

Option Explicit

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

Const BadChars = "\/:*?""<>|"

Sub SaveMyAttachments(eID$)
    Const RootFolder = "C:\My_Outlook_Attatchments\"
    Const xlFolder = "\Excel\"
    Const wdFolder = "\Word\"
    Const dbFolder = "\Databases\"
    Const ppFolder = "\PowerPoint\"
    Const SubjectText = "Reports"

    Dim oNewMail As MailItem, sfolder$, itm As Attachment, _
        Ext$, i%, msg$, AtsFilename$, FrientlySenderName$

    Set oNewMail = Application.Session.GetItemFromID(eID)
    msg = "Followed Attatchments have been moved to folder:" & vbCrLf
    With oNewMail
        Debug.Print .SenderEmailAddress
        Debug.Print .SenderName
        
        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
                    If Trim(.SenderName) <> vbNullString Then
                        FrientlySenderName = RemoveBadChars(.SenderName)
                    Else
                        FrientlySenderName = vbNullString
                        sfolder = Right(sfolder, Len(sfolder) - 1)
                    End If
                    MakeSureDirectoryPathExists RootFolder & FrientlySenderName & sfolder
                    AtsFilename = RootFolder & FrientlySenderName & 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

Function RemoveBadChars(ByRef theSenderName As String) As String
    Dim i As Integer
    For i = 1 To Len(theSenderName )
        If InStr(1, BadChars, Mid(theSenderName, i, 1)) > 0 Then
            theSenderName = Replace(theSenderName , Mid(theSenderName , i, 1), "_")
        End If
    Next
    theSenderName = Replace(theSenderName , " ", "_")
    RemoveBadChars = theSenderName 
End Function

Φιλικά

Τάσος

[Flashgordon61]

Μου βγάζει μύνημα
Run-time error '91':
Object variable or With block variable not set
Επιλέγοντας Debug μου κτρινίζει τη γραμμή κώδικα
Set oNewMail = Application.Session.GetItemFromID(itm.EntryID)
Τι δεν έχω κάνει καλά.

Γιώργος

[Tasos]

Καλησπέρα Γιώργο μου!

Άλλαξε το itm.EntryID με το eID.

Τάσος

[Flashgordon61]

Τάσο ευχαριστώ.
Κάτι τελευταίο, στη γραμμή του κώδικα που γράφει
msg = msg & itm.FileName & " at: " & sfolder & vbCrLf υπάρχει κάποι μπέρδεμα αλλά διόρθώνεται εύκολα. Πάρα ταύτα στο body του Mail δεν γράφει το πρόθεμα (CreationTime) που παίρνουν τα αρχεία.
Πως διορθώνεται αυτό.

Γιώργος

[Tasos]

Καλησπέρα Γιώργο!
Τώρα που βρήκα λίγο χρόνο έφτιαξα το παρακάτω:

Option Explicit

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

Const BadChars = "\/:*?""<>|"

Sub SaveMyAttachments(eID$)
    Const RootFolder = "C:\My_Outlook_Attatchments\"
    Const xlFolder = "\Excel\"
    Const wdFolder = "\Word\"
    Const dbFolder = "\Databases\"
    Const ppFolder = "\PowerPoint\"
    Const SubjectText = "Reports"

    Dim oNewMail As MailItem, sfolder$, itm As Attachment, _
        Ext$, i%, msg$, AtsFilename$, FrientlySenderName$
        
    Set oNewMail = Application.Session.GetItemFromID(eID)
    
    With oNewMail
    
        If .Subject Like "*" & SubjectText & "*" Then
            '        ή If .Subject = SubjectText Then  (για ακριβή αντιστοίχιση)
                FrientlySenderName = RemoveBadChars(.SenderName)

            msg = "Followed Attatchments have been moved to folder:&nbsp;<a href='" & _
                  RootFolder & FrientlySenderName & "'>" & _
                  IIf(FrientlySenderName = vbNullString, RootFolder, FrientlySenderName) _
                & "</a><br><ul>"

            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 RootFolder & FrientlySenderName & sfolder
                    
                    AtsFilename = RootFolder & FrientlySenderName & sfolder _
                                  & "(" & Replace(Replace(.CreationTime, ":", "_"), "/", "_") & ")_" _
                                  & itm.FileName

                    itm.SaveAsFile AtsFilename

                    msg = msg & "<li><a href='" & RootFolder & FrientlySenderName & sfolder & _
                          "'>" & Replace(sfolder, "\", vbNullString) & " : </a>&nbsp;<a href='" & _
                          AtsFilename & "'>" & itm.FileName & _
                          "</a>" & "</li>"  ' "&nbsp;Date:&nbsp;" & Now & "</li>"   'Αντικαθιστά το & "</li>" 
                                                                  'για να εμφανίζει την ημερομηνία & ώρα

                    .Attachments.Remove itm.Index
                End If
            Next
            
            If sfolder <> vbNullString Then
                .BodyFormat = olFormatHTML
                .HTMLBody = msg & vbCrLf & .HTMLBody
                .Save
            End If
            
        End If
        
    End With
End Sub

Δοκίμασε το και τα λέμε.

Φιλικά

Τάσος

[Flashgordon61]

Τάσο σ΄ ευχαριστώ πολύ.
Δουλεύει απόλυτα.
Το προσάρμοσα και για άλους τύπους αρχείων και όλα καλά.
Και πάλι σ' ευχαριστώ

Γιώργος