VBATools

Export do Excela zaznaczonych wiadomości lub wydarzeń kalendarzowych

by on May.18, 2011, under Excel, Outlook, Porady

Zwykle proste działania spędzają nam sen z powiek. Jednym z takich działań jest pobranie danych zaznaczonych obiektów i zapis np do Excela.

Poniżej przedstawiam dwa proste makra realizujące pow działania. Nie zawierają one elementów, które dla początkujących programistów mogą stawiać w zakłopotanie. Wywołać je należy ze środowiska developerskiego Outlooka. Można się na nich wzorować i odnieść do innego typu elementów.

Kod dla zaznaczonych maili:

Sub Export_zaznacznych_maili_do_excela()
'MVP OShon from VBATools.pl
Dim XLApp As Object, wkb As Object, wks As Object
Dim oItem As MailItem, x&

Set XLApp = CreateObject("Excel.Application")
XLApp.Visible = True
XLApp.Workbooks.Add
XLApp.Application.ScreenUpdating = False
Set wkb = XLApp.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate

For Each oItem In Application.ActiveExplorer.Selection
x = x + 1
With wks.Cells(x, 1)
.value = Format(oItem.CreationTime, "YYYY-MM-DD HH:MM")
.Offset(, 1) = oItem.Subject
.Offset(, 2) = oItem.SenderName
.Offset(, 3) = oItem.To
.Offset(, 4) = oItem.CC
.Offset(, 5) = oItem.BCC
.Offset(, 6) = oItem.Body
.Offset(, 6).RowHeight = 15
'itp...
End With
Next

With wks
 .Rows("1:1").Insert Shift:=xlDown
 .Range("A1").value = "Data"
 .Range("B1").value = "Tytuł wiadomości"
 .Range("C1").value = "Od (konto)"
 .Range("D1").value = "Do (adresaci)"
 .Range("E1").value = "Do wiadomości"
 .Range("F1").value = "UDW (ukryci)"
 .Range("G1").value = "Treść wiadomości"
 .Columns(1).Columns.AutoFit
End With

XLApp.Application.ScreenUpdating = True
Set wkb = Nothing
Set wks = Nothing
Set XLApp = Nothing
End Sub

Kod dla zaznaczonych wydarzeń kalendarzowych:

Sub Export_zaznacznych_wydarzen_do_excela()
'MVP OShon from VBATools.pl
 Dim XLApp As Object, wkb As Object, wks As Object
 Dim oItem As AppointmentItem, x&

Set XLApp = CreateObject("Excel.Application")
 XLApp.Visible = True
 XLApp.Workbooks.Add
 XLApp.Application.ScreenUpdating = False
 Set wkb = XLApp.ActiveWorkbook
 Set wks = wkb.Sheets(1)
 wks.Activate

 For Each oItem In ActiveExplorer.Selection
 x = x + 1
 With wks.Cells(x, 1)
 .value = Trim(oItem.Subject)
 .Offset(, 1) = oItem.Start
 .Offset(, 2) = oItem.End
 .Offset(, 3) = Trim(oItem.Location)
 .Offset(, 4) = oItem.IsRecurring
 If oItem.IsRecurring Then
   .Offset(, 5) = CLng(oItem.GetRecurrencePattern.PatternEndDate - oItem.Start)
   Select Case oItem.GetRecurrencePattern.RecurrenceType
     Case 1: .Offset(, 6) = "Co tydzień"
     Case 2: .Offset(, 6) = "Co miesiąc"
     Case 5: .Offset(, 6) = "Co rok"
   End Select
 If .Offset(, 5) < 900000 Then
  .Offset(, 7) = .Offset(, 1) + .Offset(, 5)
 Else
  .Offset(, 7) = "Brak końca"
 End If
'itd..
 End With
 Next

With wks
 .Rows("1:1").Insert Shift:=xlDown
 .Range("A1").value = "Nazwa terminu"
 .Range("B1").value = "Data początku"
 .Range("C1").value = "Data końca"
 .Range("D1").value = "Lokalizacja"
 .Range("E1").value = "Cykliczny"
 .Range("F1").value = "Przez il. dni"
 .Range("G1").value = "Ilość powróżeń"
 .Range("H1").value = "Do dnia"
 .Columns(1).Columns.AutoFit
End With

 XLApp.Application.ScreenUpdating = True
 Set wkb = Nothing
 Set wks = Nothing
 Set XLApp = Nothing
End Sub

Dla pobrania kolejnych dat cyklicznych wydarzeń można zastosować pętlę:

Dim oItem as AppointmentItem
For Each oItem In ActiveExplorer.Selection
 If oItem.IsRecurring = True Then
 Debug.Print oItem.Subject & _
 " | cykl " & oItem.GetRecurrencePattern.RecurrenceType & _
 " | start " & oItem.Start & _
 " | stop " & oItem.End & _
 " | koniec " & oItem.GetRecurrencePattern.PatternEndDate & _
 " | il dni " & CLng(oItem.GetRecurrencePattern.PatternEndDate - oItem.Start)

 If oItem.GetRecurrencePattern.PatternEndDate <> "4500-12-31 23:59:00" Then
 Dim Co_il_dni&, x&, dz_start As Date: dz_start = oItem.Start
  Select Case oItem.GetRecurrencePattern.RecurrenceType
   Case 1: Co_il_dni = 7
   Case 2: Co_il_dni = 30
   Case 5: Co_il_dni = 365
  End Select
 For x = 0 To CLng(oItem.GetRecurrencePattern.PatternEndDate - oItem.Start)
  Debug.Print DateAdd("d", x, dz_start) & " | " & Format(DateAdd("d", x, dz_start), "dddd")
  x = x + Co_il_dni - 1
 Next x
 End If
 End If
Next

Ostatni kod nie uwzględnia zmieniających się dni w miesięcu oraz zmieniających się ilości dni w roku przystępnym. Z czasem kod ten poprawię.

Eksport do MS Excel, jest  realizowany metodą “późnego wiązania”, bez konieczności podpinania kontrolki w referencjach projektu.

Realizacja działania kodem jest istotna w przypadku blokad administracyjnych (praca w domenie) a co za tym idzie, instalacji dodatków nie autoryzowanych przez dział IT danego przedsiębiorstwa.

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , ,

2 Comments for this entry

  • Kamil

    Witam, jest możliwość zmodyfikowania kodu tak aby po włączeniu makra wyskakiwał jakiś komunikat lub najlepiej okno w którym użytkownik zaznaczył by interesujące go maile ?

    • Profile photo of vbatools
      vbatools

      W kodzie jest pętla .ActiveExplorer.Selection czyli dla pozycji wcześniej zaznaczonych. Grupę zaznaczymy z Shiftem a wybiórczo z wciśniętym klawiszem Ctrl.

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała