www.Cursuri-Excel.ro     www.Cursuri-Access.ro     www.Cursuri-Powerpoint.ro     www.Cursuri-Outlook.ro     www.Cursuri-Word.ro     www.CursuriProject.ro    

Verificare, Arhivare Mail-uri si sincronizare arhiva

trucuri, sfaturi si alte idei pentru imbunatatirea lucrului cu Outlook

Verificare, Arhivare Mail-uri si sincronizare arhiva

Mesajde Catalin B. » Vin Apr 27, 2012 10:26 am

Am dat recent peste o problema destul de neobisnuita: un birou al unei agentii din ministerul agriculturii utilizeaza un cont la un furnizor de mail, cont cu o capacitate maxima de 100 Mb (!?). Evident ca dupa cateva fisiere anexate si trimise, nu se mai putea trimite sau primi mesaje (era sa scriu masaje :lol: )
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
Probleme să fie, că soluţii se găsesc...
Catalin B.
Moderator
Moderator
 
Mesaje: 748
Membru din: Vin Sep 09, 2011 4:05 pm
Localitate: Iaşi

Re: Verificare, Arhivare Mail-uri si sincronizare arhiva

Mesajde Dr.Windows » Mar Mai 01, 2012 11:42 am

100 MB... :shock:
Eu sunt curios si cat platesc pentru un astfel de serviciu...
Cred ca ar trebui sa le povestesi despre Office 365... ;)

Oricum este de apreciat cata munca s-a putut depune in codul VBA pentru a rezolva totusi o astfel de problema.
Dr.Windows
Site Admin
Site Admin
 
Mesaje: 4498
Membru din: Vin Iul 31, 2009 7:32 am

Re: Verificare, Arhivare Mail-uri si sincronizare arhiva

Mesajde Catalin B. » Mar Mai 01, 2012 12:00 pm

Chiar nu cunosc pretul, dar ce pot spune cu certitudine, e ca Office 365 ar trebui sa fie free ca sa prezinte interes pentru cei in cauza... ;)
Probleme să fie, că soluţii se găsesc...
Catalin B.
Moderator
Moderator
 
Mesaje: 748
Membru din: Vin Sep 09, 2011 4:05 pm
Localitate: Iaşi


Înapoi la Tips and tricks in Outlook (indiferent de versiune)

Cine este conectat

Utilizatorii ce navighează pe acest forum: Niciun utilizator înregistrat şi 1 vizitator