)Anexez codurile pe care le-am utilizat pentru a rezolva problema, si pentru a se putea pastra totusi o arhiva de mail-uri intrate/trimise.
Pe scurt, codurile fac urmatoarele operatii: cand intra un mesaj il salveaza ca fisier.msg intr-o locatie aleasa pe orice partitie din PC (dupa ce verifica si elimina din numele fisierului simbolurile neacceptate intr-un nume de fisier).
La mesajele trimise , daca s-a mentionat in mesaj ca se anexeaza un document si numarul de anexe este 0, afiseaza un avertisment, dupa care salveaza mesajul trimis (cu tot cu anexe) sub forma fisier.msg in destinatia aleasa anterior, apoi la inchiderea Outlook se face si sincronizarea acestor fisiere intre posturile de lucru din retea (se verifica intai daca sunt disponibile in retea, si se copiaza doar fisierele noi). Partea de sincronizare este mai greu de implementat, trebuie facute inainte setarile permisiunilor pe fiecare calculator (pentru sincronizare foldere pe acelasi calculator, functioneaza fara probleme si poate fi utilizat si in alte aplicatii VB- excel, de ex). Am completat codul cu trimiterea unei copii a mesajelor trimise de pe orice statie de lucru catre o alta adresa de mail.
Cod: Selectaţi tot
Option Explicit
Public Enum TipSalvare
SalvareCaTxt = 0
SalvareCaRTF = 1
SalvareCaMsg = 3
End Enum
Private WithEvents Items As Outlook.Items
Private Const Mail As String = "E:\Mail" 'Creeaza un folder "Mail" _
intr-o locatie aleasa de tine, si introdu aici adresa acestui folder nou creat
Private Const Mail1 As String = "\\PC1\Mail"
Private Const Mail2 = "\\PC2\Mail"
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal MesajNou As Object)
On Error Resume Next
If Len(Dir(Mail & "\Intrate", vbDirectory)) = 0 Then MkDir Mail & "\Intrate"
Dim Eroare
Eroare = Err.Description
If Eroare = "Path not found" Then
MsgBox "Destinatia de salvare a mesajelor intrate nu exista, " & vbNewLine & _
"Modificati in cod adresa: " & vbNewLine & Mail & vbNewLine & _
" cu o adresa valida, de preferat sa nu fie pe aceeasi partitie cu sistemul de operare!"
Exit Sub
End If
If TypeOf MesajNou Is Outlook.MailItem Then
SalveazaIntrari MesajNou, SalvareCaMsg, Mail & "\Intrate\"
End If
End Sub
Private Sub Application_ItemSend(ByVal Mesaj As Object, _
Cancel As Boolean)
On Error Resume Next
If Len(Dir(Mail & "\Trimise", vbDirectory)) = 0 Then MkDir Mail & "\Trimise"
Dim Eroare
Eroare = Err.Description
If Eroare = "Path not found" Then
Cancel = True
MsgBox "Destinatia de salvare a mesajelor trimise nu exista, " & vbNewLine & _
"Modificati in cod adresa: " & vbNewLine & Mail & vbNewLine & _
" cu o adresa valida, de preferat sa nu fie pe aceeasi partitie cu sistemul de operare!"
Exit Sub
End If
'MsgBox Mesaj.Attachments.Count
Dim CuvinteCheie As New Collection
CuvinteCheie.Add "tasament"
CuvinteCheie.Add "ta?ament"
CuvinteCheie.Add "atasat"
CuvinteCheie.Add "ata?at"
CuvinteCheie.Add "Atasat"
CuvinteCheie.Add "Ata?at"
CuvinteCheie.Add "Anexat"
CuvinteCheie.Add "anex"
CuvinteCheie.Add "Anex"
'CuvinteCheie.Add "Anex?" 'Se mai pot adauga alte cuvinte cheie, stergeti apostroful _
din fata liniei pentru a activa linia, sau adauga alta linie
'MsgBox Mesaj.Attachments.Count
If CautaCuvinteCheie(CuvinteCheie, Mesaj.Body) And (Mesaj.Attachments.Count = 0) Then
If MsgBox("Lipsesc fisierele anexate, continuati trimiterea mesajului?", vbYesNo) = vbNo Then
Cancel = True
Exit Sub
End If
End If
If Mesaj.Class = olMail Then
SalveazaIesiri Mesaj, SalvareCaMsg, Mail & "\Trimise\"
MsgBox "Mesajul catre: " & vbNewLine & Mesaj.To & vbNewLine & "a fost salvat in arhiva!", vbInformation, Title:="Salvare mesaje trimise"
Mesaj.DeleteAfterSubmit = True
End If
End Sub
Private Function CautaCuvinteCheie(ListaCuvinteCheie As Collection, Text As String) As Boolean
Dim CuvintCheie As Variant
CautaCuvinteCheie = False
For Each CuvintCheie In ListaCuvinteCheie
If (InStr(1, Text, CuvintCheie, vbTextCompare) > 0) Then
CautaCuvinteCheie = True
Exit Function
End If
Next
End Function
Private Sub SalveazaIesiri(Mesaj As Outlook.MailItem, _
Tip As TipSalvare, Destinatie As String)
Dim dtDate As Date
Dim Nume As String
Dim Ext As String
Select Case Tip
Case SalvareCaTxt: Ext = ".txt"
Case SalvareCaMsg: Ext = ".msg"
Case SalvareCaRTF: Ext = ".rtf"
Case Else: Exit Sub
End Select
Nume = Mesaj.Subject
InlocuiesteSimboluri Nume
'MsgBox Mesaj.SenderName & Mesaj.To
dtDate = Mesaj.ReceivedTime
Nume = Format(dtDate, "dd-mm-yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & " Ora " & Format(dtDate, "hh-mm", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & "Catre-" & Mesaj.To & "-" & Nume & Ext
Mesaj.SaveAs Destinatie & Nume, Tip
On Error Resume Next
If Len(Dir(Destinatie & Nume, vbDirectory)) = 0 Then
MsgBox "Eroare..."
Exit Sub
Else
Dim OtlApp As Object
Dim OtlMail As Object
Set OtlApp = CreateObject("Outlook.Application")
Set OtlMail = OtlApp.CreateItem(olMailItem)
With OtlMail
.Subject = " Mesaj trimis de " & Environ("UserName") & " catre: " & Mesaj.To & ", " & Mesaj.CC & " la data " & Mesaj.ReceivedTime
.To = "xxxxxxxxxx@gmail.com"
.Body = " Mesaj trimis de " & Environ("UserName") & " catre: " & Mesaj.To & ", " & Mesaj.CC & " la data " & Mesaj.ReceivedTime
.Attachments.Add Destinatie & Nume
.DeleteAfterSubmit = True
End With
OtlMail.Send
OtlMail.DeleteAfterSubmit = True
Set OtlApp = Nothing
Set OtlMail = Nothing
End If
End Sub
Private Sub SalveazaIntrari(Mesaj As Outlook.MailItem, _
Tip As TipSalvare, _
Destinatie As String _
)
Dim dtDate As Date
Dim Nume As String
Dim Ext As String
Select Case Tip
Case SalvareCaTxt: Ext = ".txt"
Case SalvareCaMsg: Ext = ".msg"
Case SalvareCaRTF: Ext = ".rtf"
Case Else: Exit Sub
End Select
Nume = Mesaj.Subject
InlocuiesteSimboluri Nume
dtDate = Mesaj.ReceivedTime
Nume = Format(dtDate, "dd-mm-yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & " Ora " & Format(dtDate, "hh-mm", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & "De la-" & Mesaj.SenderAddress & "-" & Nume & Ext
Mesaj.SaveAs Destinatie & Nume, Tip
End Sub
Private Sub InlocuiesteSimboluri(Nume As String)
Dim Simbol As Variant
For Each Simbol In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦", "|", ";")
Nume = Replace(Nume, Simbol, "")
Next Simbol
End Sub
Private Sub Application_Quit()
Dim FSO
Dim Path, Path1, Path2, Path3 As String
Dim Test1, Test2, Test3 As Integer
Path1 = Mail
Path2 = Mail1
Path3 = Mail2
If Right(Path1, 1) = "\" Then
Path1 = Left(Path1, Len(Path1) - 1)
End If
If Right(Path2, 1) = "\" Then
Path2 = Left(Path2, Len(Path2) - 1)
End If
If Right(Path3, 1) = "\" Then
Path3 = Left(Path3, Len(Path3) - 1)
End If
Test1 = 0
Test2 = 0
Test3 = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(Path1) = True Then
Test1 = 1
Else
MsgBox Path1 & " nu este accesibil in retea, calculatorul este probabil inchis..."
End If
If FSO.FolderExists(Path2) = True Then
Test2 = 1
Else
MsgBox Path2 & " nu este accesibil in retea, calculatorul este probabil inchis..."
End If
If FSO.FolderExists(Path3) = True Then
Test3 = 1
Else
MsgBox Path3 & " nu este accesibil in retea, calculatorul este probabil inchis..."
End If
If Test1 = 1 And Test2 = 1 Then
Call CopieDosarComplet(Path1, Path2)
Call CopieDosarComplet(Path2, Path1)
MsgBox "Sincronizare reusita pentru " & vbNewLine _
& Path1 & " cu: " & vbNewLine & Path2
End If
If Test1 = 1 And Test3 = 1 Then
Call CopieDosarComplet(Path1, Path3)
Call CopieDosarComplet(Path3, Path1)
MsgBox "Sincronizare reusita pentru " & vbNewLine _
& Path1 & " cu: " & vbNewLine & Path3
End If
If Test2 = 1 And Test3 = 1 Then
Call CopieDosarComplet(Path2, Path3)
Call CopieDosarComplet(Path3, Path2)
MsgBox "Sincronizare reusita pentru " & vbNewLine _
& Path2 & " cu: " & vbNewLine & Path3
End If
End Sub
Public Sub CopieDosarComplet(ByVal Sursa As String, ByVal Destinatie As String)
Dim SubFolder, DestSubFolder, Fisier
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each SubFolder In FSO.GetFolder(Sursa).SubFolders
If FSO.FolderExists(Destinatie & "\" & SubFolder.Name) = True Then
Set DestSubFolder = FSO.GetFolder(Destinatie & "\" & SubFolder.Name)
Call CopieDosarComplet(SubFolder.Path, DestSubFolder.Path)
Else
Set DestSubFolder = FSO.CreateFolder(Destinatie & "\" & SubFolder.Name)
Call CopieDosarComplet(SubFolder.Path, DestSubFolder.Path)
End If
Next
For Each Fisier In FSO.GetFolder(Sursa).Files
If Len(Dir$(Destinatie & "\" & Fisier.Name)) = 0 Then _
FileCopy Fisier.Path, Destinatie & "\" & Fisier.Name
Next
End Sub
