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

[Δημήτρης2012]

Καλησπέρα κι απο μένα.
Αποθήκευση των μηνυμάτων μαζί με τα συννημένα αλλά χωρίς να διαγράφει το αρχικό (μήνυμα και συννημένο) γίνεται???

Ευχαριστώ πολύ εκ των προτέρων!

[Tasos]

Καλημέρα σε όλους!
Δημήτρη καλωσόρισες στο φόρουμ.

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

Για να αποθηκεύεις νέα εισερχόμενα μηνύματα σε φάκελο, πρόσθεσε Στον VBE, στο ThisOutlookSession το παρακάτω:

Option Explicit

Const BadChars = " *™½‰o‡†…·µ°®©§""±>=<+€¥¤£›‹""‚''΄΅¨¦~}|{`_^]\[@?;:/.,*)(&%$#'"
Const RootFolder = "C:\My_Outlook_Msg_Folder\" 'Φάκελος αποθήκευσης μηνυμάτων

'Const SubjectText = "Reports"
' Προαιρετικό. Δηλώνει το τμήμα συμβολοσειράς που περιέχεται στο θέμα.
'Χρησιμοποιείται σε περιπτώσεις που θέλουμε να αποθηκεύσουμε νέα μηνύματα
'που το θέμα τους (Subject) περιέχει πχ. "Reports"

Sub SaveMessageToFile(eID$)
    Dim fso As Object
    Dim oNewMail As MailItem, msgFilename As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oNewMail = Application.Session.GetItemFromID(eID)

    With oNewMail
'        If .Subject Like "*" & SubjectText & "*" Then
'        Μπορεί να ενεργοποιηθεί μόνο αν η σταθερά "SubjectText" είναι επίσης ενεργοποιημένη
            If Not fso.FolderExists(RootFolder) Then
                fso.CreateFolder (RootFolder)
            End If
            msgFilename = RootFolder & RemoveBadChars(.Subject) & "_" & _
                          Format(.CreationTime, "dd-MM-yy_hhmmss") & ".msg"
                          On Error Resume Next
            oNewMail.SaveAs Path:=msgFilename, Type:=OlSaveAsType.olMSG
            oNewMail.UnRead = True
'        End If
'        Μπορεί να ενεργοποιηθεί μόνο αν η σταθερά "SubjectText" είναι επίσης ενεργοποιημένη
    End With
End Sub

Function RemoveBadChars(strText)
    Dim i As Integer
    For i = 1 To Len(BadChars)
        strText = Replace(strText, Mid(BadChars, i, 1), "")
    Next
    RemoveBadChars = strText
End Function

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveMessageToFile EntryIDCollection
End Sub

Private Sub Application_Startup()
'
End Sub

Φρόντισε ο φάκελος που θα επιλέξεις να είναι προσβάσιμος από την εφαρμογή.

Φιλικά

Τάσος