[VBA] Kasowanie po2jnej Poczty/Kontaktu

Pytania, problemy, uwagi związane ze starszymi wersjami Microsoft Outlook 2003, 2002 (XP), 2000, 98

Moderator: Moderatorzy

[VBA] Kasowanie po2jnej Poczty/Kontaktu

Postprzez OShon » So 05.05.2007 20:57

Zabrałem się wreszcie do planowanej wcześniej procedurki usunięcia po2jnej poczty.
Czasami się zdarzy że Outlook rozłączy sie z serwerem podczas synchronizacji; następnie połączy się i ponownie zacznie ściągać pocztę umieszczając ponownie wiadomości w folderach.

Identycznie jeżeli weźmiemy pod uwagę odzyskiwanie adresów ze starego PSTka i o jeden klik za daleko, nie nadpiszą się nam kontakty tylko zostaną powielone w folderze kontaktów.

Zauważyłem pewną niekonsekwencje w usuwaniu danych ... i nie wiem czym jest to spowodowane.

Poniżej załączam kody.
W wolnej chwili proszę Michu o przepatrzenie i poprawę.

p.s.
Struktura w sumie dla obu procedur identyczna - dla For Each przypisanie do stałej i przez następny w pętli i porównanie z poprzednikiem.
Śliskie to jakieś ... tak że proszę o poradę.
kwestie z barem czy z katalogiem z rejestru można zaniechać jednakże u mnie to ładniej wygląda i jest uniwersalne przy wyborze folderu docelowego.

p.s.2
Alternatywne programy robiące w założeniu podobne tricki mnie nie interesują. Pełno w nich dziadostwa począwszy od szpiegów skończywszy z niekończącym sie wykonywaniem procedury.

Kod: Zaznacz cały
Private Sub Usun_duplikaty_poczty_Click()
Me.Hide
    Dim oMailFolder As MAPIFolder
    Dim strFolderID, strStoreID
    Dim Item, x As Long
    Dim oMail As MailItem
   
    strFolderID = GetSetting(APPNAME, "Settings", "Folder_2poczty_Folder", "")
    strStoreID = GetSetting(APPNAME, "Settings", "Folder__2poczty_Store", "")
   
    Set oMailFolder = Application.GetNamespace("MAPI").GetFolderFromID(strFolderID, strStoreID)
Dim Tytul As String, Utworzono As Date, Wyslano As Date, Nadawca As String, Wielkosc As Long
Dim Tresc As Long, Dla As String, skasowano As Long, Ile As Long

With Bar
    .ProgressBar1.Visible = True
    .ProgressBar1.Value = 0
    .ProgressBar1.Max = oMailFolder.Items.Count
    .Show 0
End With

    Dim Msg, Style, Title, Response
Style = vbYesNo + vbExclamation + vbDefaultButton1
Title = APPNAME
   
On Error Resume Next
For Each Item In oMailFolder.Items
DoEvents
Ile = Ile + 1
With Bar
    .ProgressBar1.Value = Ile
    .Caption = Format(Ile / oMailFolder.Items.Count, "00%") & " " & oMail.SenderName
End With
                Set oMail = Item
                    If Not oMail Is Nothing Then
                        With oMail
                            If Trim(.Subject) = Trim(Tytul) And _
                                .CreationTime = Utworzono And _
                                .SentOn = Wyslano And _
                                .SenderName = Nadawca And _
                                .Size = Wielkosc And _
                                Len(.Body) = Tresc And _
                                .To = Dla Then
                         
Msg = .CreationTime & " | " & .Subject & vbCr _
     & Utworzono & " | " & Tytul & vbCr & vbCr _
     & "Jeżeli chce usunąć wiadomość naciśnij ''Tak''" & vbCr _
     & "aby pozostawić naciśnij ''Nie''"

    Response = MsgBox(Msg, Style, Title)
    If Response = vbYes Then
       skasowano = skasowano + 1
       .Delete
    End If
                           
                            End If
                        Tytul = ""
                        Utworzono = ""
                        Wyslano = ""
                        Nadawca = ""
                        Wielkosc = ""
                        Tresc = ""
                        Dla = ""
                       
                        Tytul = .Subject
                        Utworzono = .CreationTime
                        Wyslano = .SentOn
                        Nadawca = .SenderName
                        Wielkosc = .Size
                        Tresc = Len(.Body)
                        Dla = .To
                        End With
                    End If
Next
Bar.Hide
Me.Show 0
                Set oMail = Nothing
Dim czego As String
Select Case skasowano
    Case 1
     czego = "wiadomość pocztową"
    Case 2 To 4
     czego = "wiadomości pocztowe"
    Case Is > 5
     czego = "wiadomości pocztowych"
End Select
If skasowano > 0 Then
    MsgBox "Skasowano " & skasowano & " " & czego & vbCr _
        & "i umieszczono w koszu.", vbInformation, APPNAME
 Else
    MsgBox "Nie usunięto żanych duplikatów wiadomosci", vbInformation, APPNAME
End If
End Sub


Kod: Zaznacz cały
Private Sub Usun_duplikaty_Click()
Dim oContactFolder As MAPIFolder
Dim Item
Dim Ile As Long, skasowano As Long
Dim oContact As ContactItem

    Dim strFolderID, strStoreID
    strFolderID = GetSetting(APPNAME, "Settings", "Folder_kontaktów_Folder", "")
    strStoreID = GetSetting(APPNAME, "Settings", "Folder_kontaktów_Store", "")
   
    Set oContactFolder = Application.GetNamespace("MAPI").GetFolderFromID(strFolderID, strStoreID)

With Bar
    .ProgressBar1.Visible = True
    .ProgressBar1.Value = 0
    .ProgressBar1.Max = oContactFolder.Items.Count
    .Show 0
End With

Dim Imie As String, Nazwisko As String, Adres As String, Telefon As String
Dim GSM As String, Firma As String
Dim Msg, Style, Title, Response
Style = vbYesNo + vbExclamation + vbDefaultButton1
Title = APPNAME

For Each Item In oContactFolder.Items
DoEvents
Ile = Ile + 1
Set oContact = Item

With Bar
    .ProgressBar1.Value = Ile
    .Caption = Format(Ile / oContactFolder.Items.Count, "00%") & " " & oContact.FullName
End With
               
                    If Not oContact Is Nothing Then
                        With oContact
                        If Trim(.Email1Address) = Adres And _
                           Trim(.FirstName) = Imie And _
                           Trim(.LastName) = Nazwisko And _
                           Trim(.BusinessTelephoneNumber) = Telefon And _
                           Trim(.MobileTelephoneNumber) = GSM And _
                           Trim(.CompanyName) = Firma Then

Msg = .FullName & " | " & .Email1Address & vbCr _
     & Imie & " | " & Adres & vbCr & vbCr _
     & "Jeżeli chce usunąć kontakt naciśnij ''Tak''" & vbCr _
     & "aby pozostawić naciśnij ''Nie''"

    Response = MsgBox(Msg, Style, Title)
    If Response = vbYes Then
       skasowano = skasowano + 1
       .Delete
    End If
                        End If
                            Imie = ""
                            Nazwisko = ""
                            Adres = ""
                            Telefon = ""
                            GSM = ""
                            Firma = ""
                       
                        On Error Resume Next
                        Imie = Trim(.FirstName)
                        Nazwisko = Trim(.LastName)
                        Adres = Trim(.Email1Address)
                        Telefon = Trim(.BusinessTelephoneNumber)
                        GSM = Trim(.MobileTelephoneNumber)
                        Firma = Trim(.CompanyName)
                        End With
                    End If
Next
                Set oContact = Nothing
                Set oContactFolder = Nothing
With Bar
    .Hide
End With
Me.Show 0
               
Dim czego As String
Select Case skasowano
    Case 1
     czego = "kontakt"
    Case 2 To 4
     czego = "kontakty"
    Case Is > 5
     czego = "kontaktów"
End Select
If skasowano > 0 Then
    MsgBox "Skasowano " & skasowano & " " & czego & vbCr _
        & "i umieszczono w koszu", vbInformation, APPNAME
 Else
    MsgBox "Nie usunięto żanych duplikatów kontaktów", vbInformation, APPNAME
End If
End Sub
Obrazek
Oskar Shon - MVP Office Dev. 11/20, 3x MCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 10434
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Projekt autorski VBATools.pl

Postprzez michu » Pn 07.05.2007 09:33

Tak na pierwszy rzut oka na pierwszą procedurę:

1. Najpierw robisz na elemencie .Delete, a potem przypisujesz do zmiennych wartości z tego elementu .Subject, .CreationTime, itd.

2. Pętla:
Kod: Zaznacz cały
For Each Item in oFolder.Items

Nie jestem pewien jak zachowuje się tutaj odwołanie oFolder.Items, czy przez przypadek VB nie robi jakieś optymalizacji i nie cachuje kolekcji Items. Jeśli tak to oznaczałoby to, że pracujesz z nieaktualną kolekcją bo nie jest ona odświeżana w każdej pętli. Ale prawdę mówiąc nie jestem pewien, jak to jest, nie jestem specjalistą od VB... :D

Nie bardzo mam czas żeby wgryzać się w cały kod...
Pozdrawiam
Michu
michu
 
Posty: 4190
Dołączył(a): N 05.02.2006 17:49
Lokalizacja: Jelenia Góra

Postprzez OShon » Pn 07.05.2007 19:11

michu napisał(a):Najpierw robisz na elemencie .Delete, a potem przypisujesz do zmiennych wartości z tego elementu .Subject, .CreationTime, itd.

chm... ale ja nie chce kasować kontaktu (na razie) chce tylko go porównać o ile w przypadku poczty zapisane pod stałymi dane są równe następnymi w pętli, użytkownik podejmie decyzje czy kontakt zduplikowany usunąć czy nie....
w sumie to na siłę oczywiście że mógłbym je usuwać (bo po co duplikat) ale nie znajduje mi rzeczywistych duplikatów (może to być efektem jakiegoś nie posortowania kolekcji) lub znajduje mi rzekomo duplikat (msg to pokazuje) który faktycznie nim nie jest ....

Kod: Zaznacz cały
If Trim(.Subject) = Trim(Tytul) And _
.CreationTime = Utworzono And _
.SentOn = Wyslano And _
.SenderName = Nadawca And _
.Size = Wielkosc And _
Len(.Body) = Tresc And _
.To = Dla Then
Msg = .CreationTime & " | " & .Subject & vbCr _
     & Utworzono & " | " & Tytul & vbCr & vbCr _
     & "Jeżeli chce usunąć wiadomość naciśnij ''Tak''" & vbCr _
     & "aby pozostawić naciśnij ''Nie''"

    Response = MsgBox(Msg, Style, Title)
    If Response = vbYes Then
       skasowano = skasowano + 1
       .Delete
    End If


Chciałem zamienić For Each na
Kod: Zaznacz cały
For x = oMailFolder.Items.Count To 0 Step -1

ale też coś tam nie grało i w efekcie nie dokończyłem tej myśli....(nie mogłem pobrać wartości rzeczywistego x dla danego item) może coś podpowiesz.

Z tym mi sie nie śpieszy (tak bardzo)
Jak byś był uprzejmy i sprawdził na swojej książce adresowej lub jakimś katalogu maili; czy prosto skopiowana do tego samego folderu wiadomość czy kontakt zostanie przez pętle wyłapane (poprawnie).

W linku forma z pełnym kodem (aby ułatwić sprawę), oraz barek na którym widać postęp szukania.
http://oskar.veracomp.pl/Pliki/Outlook_Usprawnienia.rar
Obrazek
Oskar Shon - MVP Office Dev. 11/20, 3x MCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 10434
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Projekt autorski VBATools.pl

Postprzez michu » Wt 08.05.2007 17:33

Wybacz, ale nie uda mi się znaleźć czasu na testowanie, czy przeglądanie sporego objętościowi kodu :beer:
Pozdrawiam
Michu
michu
 
Posty: 4190
Dołączył(a): N 05.02.2006 17:49
Lokalizacja: Jelenia Góra

Postprzez OShon » Wt 08.05.2007 18:56

No trudno - szkoda bo fajny temat.
jak uda mi sie coś w temacie to sie podzielę.
pozd.
Obrazek
Oskar Shon - MVP Office Dev. 11/20, 3x MCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 10434
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Projekt autorski VBATools.pl

Postprzez michu » Wt 08.05.2007 19:22

Ok, dzięki.
Pozdrawiam
Michu
michu
 
Posty: 4190
Dołączył(a): N 05.02.2006 17:49
Lokalizacja: Jelenia Góra


Powrót do Microsoft Outlook

Kto przegląda forum

Użytkownicy przeglądający ten dział: Google [Bot] i 5 gości