VBATools

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