Zapis wybranego maila w kolejnym wierszu excela

Pytania, uwagi, problemy związane z Microsoft Office Outlook, wersje 2007, 2010, 2013 i 2016.

Moderator: Moderatorzy

Zapis wybranego maila w kolejnym wierszu excela

Postprzez rplowas » Pn 04.12.2017 19:46

Witam,

Mam problem z jednym makrem w outlooku. Niestety walczę z tym już na tyle długo, że postanowiłem sięgnąć po pomoc na forum.

Makro ma działać w następujący sposób:

1. Zaznaczam maila który mnie interesuje
2. Uruchamiam makro
3. Dane m.in. od kogo mail, Tytul maila, czas wejscia itp. powinny się zapisywać w pliku excela.
4. Jeśli pliczek excela z mailami jest otwarty to program ma to odnaleźć, jeśli plik nie jest otwarty to ma go otworzyć.
5. Każdy kolejny mail jaki uruchomię ma zapisywac się w excelu pod poprzednim mailem.
6. Po wykonaniu tych czynności plik excela ma zostać zamknięty i zapisany.

Dodatkowo plik exela posiada nazwę "2017_xxTK_Obciazenie_programistow" Gdzie "xx" oznacza numer bieżącego tygodnia kaledarzowego.
W programie znajdują się trzy funkcje - Wyszukiwania nazwy, Określenia numeru tygodnia kalendarzowego i funkcja sprawdzająca czy Excel otwarty.

Niestety program nie zawsze działa. Często występuje błąd 91 lub 1004. Nie wiem dlaczego tak się dzieje. Podejrzewam, że przyczyną może być zle określenie przeze mnie w kodzie programu przejścia do excela.

Można sprawdzić działąnie programu w następujący sposób.

1. stwórz katalog "Obciążenie" na dysku "C".
2. utwórz jakiś plik exela gdzie w komórce B2 wpisz np "xxx", w komorce "B3" wpisz "Nazwisko imię", w komorce C3 "Projekt", w komorce D3 "czas",
3. uruchom makro z poziomu outlooka.
4. Błąd :)

Proszę o pomoc i informację gdzie popełniłem błąd. Poniżej kod.

Kod: Zaznacz cały
Dim SciezkaDoPliku As String
Public NazwaPlikuBazy As String

Sub ZapiszDaneZMailaWBazie()

 Dim xlApp As Object
 Dim xlWKB As Excel.Workbook
 Dim objOL As Outlook.Application
 Dim objMsg As Outlook.MailItem
 Dim objSelection As Outlook.Selection
 Dim NazwaMaila As String
 Dim DataMaila As String
 Dim OdKogoMail As String
 Dim OdKogoMailAdres As String
 Dim i As Long

    SciezkaDoPliku = "C:\Obciążenie\2017_" & NumerTygodnia(Now) & "TK_Obciazenie_programistow.xls"
    NazwaPlikuBazy = "2017_" & NumerTygodnia(Now) & "TK_Obciazenie_programistow.xls"

    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
 
    For Each objMsg In objSelection

      OdKogoMail = objMsg.Sender
      NazwaMaila = objMsg.TaskSubject
      DataMaila = objMsg.CreationTime
      OdKogoMailAdres = objMsg.SenderEmailAddress

    Next objMsg

    If WorkbookIsOpen(NazwaPlikuBazy) = True Then
        Set xlApp = GetObject(, "excel.application")
        Set xlWKB = xlApp.Application.Workbooks(NazwaPlikuBazy)
        xlWKB.Activate
    Else
        Set xlApp = CreateObject("excel.application")
        xlApp.Visible = True
        Set xlWKB = xlApp.Workbooks.Open(FileName:=SciezkaDoPliku)
        xlWKB.Activate
    End If
       
        With xlWKB
            .Worksheets("Arkusz1").Range("B2").Select
        End With

     SzukajKomorki ("Nazwisko imię")
     Selection = OdKogoMail
     SzukajKomorki ("Projekt")
     Selection = NazwaMaila
     SzukajKomorki ("czas")
     Selection = DataMaila
     
     xlWKB.Save
     xlWKB.Close
       
     Set xlApp = Nothing
     Set xlWKB = Nothing
     
End Sub

Public Function WorkbookIsOpen(wbname) As Boolean
' Zwraca wartość TRUE, jeżeli skoroszyt jest otwarty
Dim x As Object
Dim y As Object
On Error Resume Next
Set x = GetObject(, "Excel.Application")
    For Each y In x.Application.Workbooks
        If Err.Number = 0 Then
            Debug.Print Err.Number
            Debug.Print y.Name
            If y.Name = wbname Then
                WorkbookIsOpen = True
                Exit Function
            Else
                WorkbookIsOpen = False
            End If
        Else
            WorkbookIsOpen = False
        End If

    Next
End Function

Public Function NumerTygodnia(data As Date) As Integer 'funkcja zwracajaca nr tygodnia kaledarzowego
    Dim temp As Long
    temp = DateSerial(Year(data - Weekday(data - 1) + 4), 1, 3)
    NumerTygodnia = Int((data - temp + Weekday(d2) + 5) / 7)
End Function

Public Function SzukajKomorki(Szukaj As String) As String
    'wyszukuje nazwe z arkumentu, znajduje komorke i przeskakuje w miejsce na koncu listy w dol
    Dim ZnajdzZlecenie As Range
        With ActiveWorkbook.ActiveSheet
            Set ZnajdzZlecenie = Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole)
        End With
    ZnajdzZlecenie.Select
    SzukajKomorki = ZnajdzZlecenie.Address
    Selection.End(xlDown).Offset(1, 0).Select

End Function
rplowas
 
Posty: 3
Dołączył(a): Pn 04.12.2017 18:23

Re: Zapis wybranego maila w kolejnym wierszu excela

Postprzez OShon » Wt 05.12.2017 00:09

Jutro nad tym usiądę dokładniej, ale jest parę kwiatków, które niepotrzebnie robisz, a co z pewnością odbija się na pracy kodu.
Napraszałeś się to masz za swoje :)

Jedną z nich jest zmienna obiektowa
Kod: Zaznacz cały
CreateObject("Outlook.Application")

Po co, jak uruchamiasz kod z Outlooka? Zamiast tego wystarczy Application. Było by ok jakbyś uruchamiał Excela.
Kod: Zaznacz cały
Set objSelection = Application.ActiveExplorer.Selection


Potem wywołujesz funkcję WorkbookIsOpen zanim nie rozpoznasz czy masz otwartego Excela.
Do tego służy GetObject a jak zwraca błąd to dopiero CreateObject
Kod: Zaznacz cały
Dim xlApp As Excel.Application

  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  On Error GoTo 0

  If xlApp Is Nothing Then
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
  End If


A to po co. Samo zaznaczenie komórki nic nie wnosi, poza tym klamry With stosuje się jak masz więcej odwołań, a nie jedno.
Im więcej kropek tym ogarniesz tym szybciej zadziała kod. Jedna - bez celu.
Kod: Zaznacz cały
With xlWKB
      .Worksheets("Arkusz1").Range("B2").Select
End With


Tutaj też mamy problem
Kod: Zaznacz cały
SzukajKomorki  ("Nazwisko imię")

Jak kod pokazuje ci dwie spacje, to sugeruje ci że tak nie powinieneś wywoływać polecenia. Poprawnie powinno być:
Kod: Zaznacz cały
Call SzukajKomorki ("Nazwisko imię")


A to do czego się odnosi? Jesteś przecież w Outlooku a tam Selection jest całkiem inne
Kod: Zaznacz cały
Selection = OdKogoMail


Funkcja SzukajKomorki też całkiem jak przeniesiona z Excela. Będąc w Outlooku musisz trzymać się deklaracji.
Skoro tworzyłeś xlWKB to brakuje xlWKS i dalej powinieneś się odwoływać do arkusza tego skoroszytu
Kod: Zaznacz cały
Dim xlWKS as Excel.Worksheet
set xlWKS = xlWKB.sheets("Arkusz1")

A potem nie Range..... ale xlWKS.Range

A może sam to już rozgryziesz?
I żadnych Select jak babcie kocham.
Obrazek
Oskar Shon - MVP Office System/Development 11/17, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9080
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: Zapis wybranego maila w kolejnym wierszu excela

Postprzez rplowas » Wt 05.12.2017 14:32

Zastosowałem się do rad. Dzięki wielkie za odpowiedź.
Kod działa jeżeli mam otwarty plik. Niestety jak jest zamknięty to nadal występuje błąd w funkcji "SzukajKomorki()".
Nie wiem jak miałbym wykonać instrukcję bez używania metody select. a także bez użycia "selection". chodzi mi o fragmenty poniżej wraz z funkcją "SzukajKomorki()". Jak mam zrobić by wyszukało nazwę, zrobilo end(xldown), gdy dotrze do tego miejsca to zeby wpisało co chcę i nie wyrzuciło błędu.

Kod: Zaznacz cały
     Call SzukajKomorki("Nazwisko imię technologa")
     Selection = OdKogoMail
     Call SzukajKomorki("Projekt")
     Selection = NazwaMaila
     Call SzukajKomorki("czas")
     Selection = DataMaila

Public Function SzukajKomorki(Szukaj As String) As String
    Dim ZnajdzZlecenie As String
    ZnajdzZlecenie = xlWKS.Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole).Address
    SzukajKomorki = xlWKS.Range(ZnajdzZlecenie).Select
    xlWKS.Range(ZnajdzZlecenie).End(xlDown).Offset(1, 0).Activate


Poniżej nowy kod w całości.

Kod: Zaznacz cały

Dim SciezkaDoPliku As String
Public NazwaPlikuBazy As String
Public xlApp As Object
Public xlWKB As Excel.Workbook
Public xlWKS As Excel.Worksheet
Public DataMaila As String
Public OdKogoMail As String
Public OdKogoMailAdres As String

Sub ZapiszDaneZMailaWBazie()

 Dim xlApp As Object
 Dim objMsg As Outlook.MailItem
 Dim objSelection As Outlook.Selection
 Dim NazwaMaila As String
 Dim DataMaila As String
 Dim OdKogoMail As String
 Dim OdKogoMailAdres As String
 Dim i As Long

    SciezkaDoPliku = "C:\Obciążenie\2017_" & NumerTygodnia(Now) & "TK_Obciazenie_programistow.xls"
    NazwaPlikuBazy = "2017_" & NumerTygodnia(Now) & "TK_Obciazenie_programistow.xls"

    Set objSelection = Application.ActiveExplorer.Selection
 
    For Each objMsg In objSelection

      OdKogoMail = objMsg.Sender
      NazwaMaila = objMsg.TaskSubject
      DataMaila = objMsg.CreationTime
      OdKogoMailAdres = objMsg.SenderEmailAddress

    Next objMsg
   
    '!!!!!
     On Error Resume Next
      Set xlApp = GetObject(, "Excel.Application")
      On Error GoTo 0
   
      If xlApp Is Nothing Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
      End If
    '!!!!!
   
    'sprawdzic ta konstrukcje IF i poprawic w razie znalezienia bledow!!!!!!!!!!!!!!!!!
    If WorkbookIsOpen(NazwaPlikuBazy) = True Then
        Set xlApp = GetObject(, "Excel.Application")
        Set xlWKB = xlApp.Application.Workbooks(NazwaPlikuBazy)
        xlWKB.Activate
    Else
        Set xlApp = CreateObject("excel.application")
        xlApp.Visible = True
        Set xlWKB = xlApp.Workbooks.Open(FileName:=SciezkaDoPliku)
        xlWKB.Activate
    End If
       
       Set xlWKS = xlWKB.Worksheets("Arkusz1")
     
     Call SzukajKomorki("Nazwisko imię technologa")
     Selection = OdKogoMail
     Call SzukajKomorki("Projekt")
     Selection = NazwaMaila
     Call SzukajKomorki("czas")
     Selection = DataMaila
     
'     xlWKB.Save
'     xlWKB.Close
'     xlApp.Close
     
     Set xlApp = Nothing
     Set xlWKB = Nothing
     
End Sub

Public Function SzukajKomorki(Szukaj As String) As String
    Dim ZnajdzZlecenie As String
    ZnajdzZlecenie = xlWKS.Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole).Address
    SzukajKomorki = xlWKS.Range(ZnajdzZlecenie).Select
    xlWKS.Range(ZnajdzZlecenie).End(xlDown).Offset(1, 0).Select

End Function

Public Function NumerTygodnia(data As Date) As Integer 'funkcja zwracajaca nr tygodnia kaledarzowego
    Dim temp As Long
    temp = DateSerial(Year(data - Weekday(data - 1) + 4), 1, 3)
    NumerTygodnia = Int((data - temp + Weekday(d2) + 5) / 7)
End Function
'
Public Function WorkbookIsOpen(wbname) As Boolean
' Zwraca wartość TRUE, jeżeli skoroszyt jest otwarty
Dim x As Object
Dim y As Object
On Error Resume Next
Set x = GetObject(, "Excel.Application")
    For Each y In x.Application.Workbooks
        If Err.Number = 0 Then
            Debug.Print Err.Number
            Debug.Print y.Name
            If y.Name = wbname Then
                WorkbookIsOpen = True
                Exit Function
            Else
                WorkbookIsOpen = False
            End If
        Else
            WorkbookIsOpen = False
        End If

    Next
End Function
rplowas
 
Posty: 3
Dołączył(a): Pn 04.12.2017 18:23

Re: Zapis wybranego maila w kolejnym wierszu excela

Postprzez OShon » Śr 06.12.2017 11:23

Wpierw ustaw sobie linijkę na początku modułu. Da ona kontrolę użycia zmiennych w tym module.
Kod: Zaznacz cały
Option Explicit

Zlikwiduj zmienne wymienione w procedurze na rzecz zmiennych globalnych (ponad procedurami, które udostępniają wartości doń przypisane innym procedurom). Public spełnia taką samą funkcję jak Dim.
xlApp, OdKogoMail, OdKogoMailAdres
Wkleiłeś kod jaki ci dałem do przypisania do xlApp Excela, ale zostawiłeś swój kawałek kodu, który jest bez sensu.
Tak uważam ponieważ wywołujesz w nim funkcję WorkbookIsOpen która znowu sprawdza obiekty Excela, a potem znowu chcesz przypisywać do xlApp.

Zrób to jeden raz.
Czyli wpierw sprawdź (masz mój wzór) czy Excel jest otwarty GetObject, jeśli nie to CreateObject. Więcej tej instrukcji nie używaj bo raz przypisana wystarczy.
Potem skoro GetObject (nie przed, ale w tym warunku) sprawdzisz czy jest już plik SciezkaDoPliku otwarty. Przy CreateObject nie ma to sensu. Z tym cię zostawię abyś sobie to opracował, zrozumiał jak to działa. Funkcja WorkbookIsOpen wprost przekopiowana z Excela nie jest tutaj przydatna w takiej formie. Do niej musisz przekazać xlApp a nie tworzyć nowe przypisanie i to do jakiegoś x

Nie wiem po co te instrukcje. Prawdopodobnie pozostałość funkcji. Usuń to:
Kod: Zaznacz cały
Selection = OdKogoMail
Selection = NazwaMaila
Selection = DataMaila

Poprawnie to do czego miał by się odnosić selection (przypominam że jesteś w Outlooku). Jeśli to z Excela to gdzie jest przypisanie do obiektu arkusza?
Zastąpimy to inaczej tworząc kod, ale o tym dalej.

Jeśli chodzi o samą funkcję, to też ci coś zasugeruję bo to poniżej jest źle.
Kod: Zaznacz cały
Public Function SzukajKomorki(Szukaj As String) As String
    Dim ZnajdzZlecenie As String
    ZnajdzZlecenie = xlWKS.Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole).Address
    SzukajKomorki = xlWKS.Range(ZnajdzZlecenie).Select
    xlWKS.Range(ZnajdzZlecenie).End(xlDown).Offset(1, 0).Select
End Function

Po co pobierasz adres i po co zaznaczasz komórkę. Zaznaczanie spowalnia wykonanie kodu.
Dwie linijki kodu można wsadzić w trzecią (zmienną można zlikwidować).
Po drugie wiem że użyłeś globalnej zmiennej dla arkusza. Ale tak się nie robi w przypadku obiektów. Te lepiej przekazać w parametrach wejściowych funkcji. Twoje funckcja SzukajKomorki nie szuka danych, ale miejsca do zapisu, a więc nie może zwracać Stringa, ale komórkę docelową (czyli Range), ostatnią +1 w szukanej kolumnie i tam przekazać to co pobrałeś z Outlooka. W tym przypadku całkowicie zrezygnował bym z funkcji, ale zastąpił to procedurą: Np tak
Kod: Zaznacz cały
Sub wpisz_do_excela(r As Excel.Worksheet, Szukaj As String, wpisz As String)
Dim SzukajKomorki As Excel.Range
On Error GoTo brak
    SzukajKomorki = r.Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole).End(xlDown).Offset(1, 0)
    If SzukajKomorki Is Nothing Then GoTo brak
    SzukajKomorki.value = wpisz
Exit Sub
brak:
    MsgBox "Brak danych " & Szukaj & " w arkuszu " & r.Name, vbExclamation
End Sub

No i dwie zmiany w wywołaniu. Zamiast Call SzukajKomorki("Nazwisko imię technologa") bo chcesz te dane gdzieś przypisać (czyli zapewne twoje selection), do konkretnych komórek arkusza. Po tych sugestiach powinno to wyglądać tak (wywołujemy procedurę podając jej dane gdzie ma szukać, co ma szukać, co ma wpisać):
Kod: Zaznacz cały
     Call wpisz_do_excela(xlWKS, "Nazwisko imię technologa", OdKogoMail)
     Call wpisz_do_excela(xlWKS, "Projekt", NazwaMaila)
     Call wpisz_do_excela(xlWKS, "czas", DataMaila)

No i na dokładkę - jeśli chcesz wyjść z zapisem to wystarczy jedna linia, a po niej dopiero wyłączenie excela i zerowanie zmiennej (choć z tym sobie Windows już radzi).
Kod: Zaznacz cały
xlWKB.Close True
Obrazek
Oskar Shon - MVP Office System/Development 11/17, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9080
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: Zapis wybranego maila w kolejnym wierszu excela

Postprzez rplowas » Śr 06.12.2017 20:31

Witam,

Dzieki za pomoc OShon :) Sprawdzałem i działa dobrze, chociaż nie wiem czy o to Tobie chodziło z tym "GetObject" i "CreateObject". Teraz mogę zająć się dalszą częścią kodu :) To mój pierwszy program w outlooku więc nie do końca potrafilem zrozumieć jak z poziomu Outlooka uzupełniać dane w Excelu. Trochę mi rozjaśniłeś umysł, aczkolwiek jeszcze mam sporo do wykonania więc możliwe, że zajrzę tu niedługo z nowym tematem :D

Poniżej działający kod.

Kod: Zaznacz cały
Option Explicit

Public xlApp As Object
Public SciezkaDoPliku As String
Public NazwaPlikuBazy As String
Public OdKogoMail As String
Public NazwaMaila As String
Public DataMaila As String
Public OdKogoMailAdres As String

Sub ZapiszDaneZMailaWBazie()

 Dim xlWKB As Excel.Workbook
 Dim xlWKS As Excel.Worksheet
 Dim objMsg As Outlook.MailItem
 Dim objSelection As Outlook.Selection
 Dim i As Long

    SciezkaDoPliku = "n:\!!PRACA\2017\Obciążenie\2017_49TK_Obciazenie_programistow.xls"
    NazwaPlikuBazy = "2017_49TK_Obciazenie_programistow.xls"

    Set objSelection = Application.ActiveExplorer.Selection
 
    For Each objMsg In objSelection

      OdKogoMail = objMsg.Sender
      NazwaMaila = objMsg.TaskSubject
      DataMaila = objMsg.CreationTime
      OdKogoMailAdres = objMsg.SenderEmailAddress

    Next objMsg

     On Error Resume Next
      Set xlApp = GetObject(, "Excel.Application")
      Set xlWKB = xlApp.Workbooks.Open(FileName:=SciezkaDoPliku)
      xlApp.Visible = True
     On Error GoTo 0
   
      If xlApp Is Nothing Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlWKB = xlApp.Workbooks.Open(FileName:=SciezkaDoPliku)
      End If
       
       Set xlWKS = xlWKB.Worksheets("Arkusz1")
     
        Call wpisz_do_excela(xlWKS, "Nazwisko imię technologa", OdKogoMail)
        Call wpisz_do_excela(xlWKS, "Projekt", NazwaMaila)
        Call wpisz_do_excela(xlWKS, "czas", DataMaila)
         
'     xlWKB.Close true
     
End Sub

Sub wpisz_do_excela(r As Excel.Worksheet, Szukaj As String, wpisz As String)

Dim SzukajKomorki As Excel.Range
On Error GoTo brak
    Set SzukajKomorki = r.Range("A:CZ").Find(what:=Szukaj, MatchCase:=True, lookat:=xlWhole).End(xlDown).Offset(1, 0)
    If SzukajKomorki Is Nothing Then GoTo brak
    SzukajKomorki.Value = wpisz
Exit Sub
brak:
    MsgBox "Brak danych " & Szukaj & " w arkuszu " & r.Name, vbExclamation
End Sub
rplowas
 
Posty: 3
Dołączył(a): Pn 04.12.2017 18:23

Re: Zapis wybranego maila w kolejnym wierszu excela

Postprzez OShon » Cz 07.12.2017 08:25

No wygląda już ładnie. Gdzieś zgubiłeś w boju funkcję NumerTygodnia, ale z tym sobie poradzisz.
Super się z tobą współpracowało. Mam nadzieje że nie odpuścisz przy następnych projektach.
Moim zdaniem podpowiedzi lepiej się sprawdzają dla tych, którzy chcą troszkę więcej satysfakcji wyciągnąć z tego iż sami napisali całą procedurę.
Super. Powodzenia.
Obrazek
Oskar Shon - MVP Office System/Development 11/17, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9080
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl


Powrót do Microsoft Outlook 2007 / 2010 / 2013 / 2016

Kto przegląda forum

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