VBA Tools

Poniżej znajduje się kod, który zwraca w oknie immediate [Ctrl+G] nazwy folderów. Ciekawą w jej konstrukcji jest zapętlenie wywołania funkcji, która sama wywołuje „siebie”, aby pobrać dane folderu podrzędnego.

W czym kod ten może być przydatny? Otóż do tworzenia archiwizacji czy eksportu danych do baz danych z zachowaniem pełnej struktury zapisu.

Sub OutlookFolders()
 Dim olNamespace As Outlook.NameSpace
 Dim olFolder As Outlook.Folders
 Dim objFolder As Outlook.MAPIFolder

 Set olNamespace = Application.GetNamespace("MAPI")
 Set olFolder = olNamespace.Folders

 For Each objFolder In olFolder
   Call LoopFolders(objFolder.Folders)
 Next

 Set olNamespace = Nothing
 Set olFolder = Nothing
End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
 Dim Fold As Outlook.MAPIFolder

 For Each Fold In Folders
   Debug.Print Fold.FolderPath
   DoEvents
   If Fold.Folders.Count Then _
     LoopFolders Fold.Folders 
 Next
End Sub

Rys 1. Lista folderów.

Aby pobrać jedynie nazwę bez ścieżki należy zamiast FolderPath pobrać parametr Name lub w obecnym wymiarze pobrać funkcją InStrRev miejsce znaku „\”

(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.

Zastanawiacie się jak można wykonać modyfikację pliku, tak aby użytkownik się nie zorientował? Jest wiele metod, począwszy od napisania dodatku który uruchomimy wraz z komputerem lub z autostartem Excela, można podmienić plik po GPO (komputer w domenie) lub uruchomić plik polecenia skryptowego.

Ta porada będzie właśnie poświęcona wykorzystaniem języka skryptowego do modyfikacji istniejącego pliku Excela.

Poniżej znajdziemy treść pliku tekstowego z rozszerzeniem vbs, który z łatwością po odpaleniu zrozumie nasz procesor działający w systemie Windows.

'MVP OShon from VBATools.pl
Dim XLApp 'As Object 'Excel.Application
Dim wkb 'As Object
Dim wks 'As Object
Dim sciezka 'As String
sciezka = "c:\temp\test.xlsx"
Set XLApp = CreateObject("Excel.Application")
 XLApp.Visible = False
 XLApp.Workbooks.Open sciezka
 Set wkb = XLApp.ActiveWorkbook
 Set wks = wkb.Sheets(1)
 wks.Cells(1,1) = "Hello Word"
 wkb.Close True
 XLApp.Quit
 Set wkb = Nothing
 Set wks = Nothing
 Set XLApp = Nothing

Co on właściwie robi?

Otwiera aplikacje Excel w trybie ukrytym, następnie odwołuje się do pierwszego arkusza i modyfikuje komórkę A1 wstawiając tam stringa. Po zakończeniu operacji wyłącza aplikację i czyści pamięć. Można zauważyć że w języku skryptowym nie odwołujemy się określając zmienne – pozostawiamy to procesorowi. Niestety taka forma nie jest mile widziana ani w VB ani VBA, gdzie prędkość działania jest uzależniona od prawidłowej deklaracji.

Aby uruchomić plik *.vbs należy go zapisać i albo umieścić stosowną komendę ze ścieżką jego przetrzymywania w rejestrze użytkownika:

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce

„C:\jakis_katalog\plik.vbs” /nosplash /minimized

albo umieścić plik lub jego link w autostarcie (zwracając uwagę na późniejszą dezintegracje pliku, aby proces ten nie powtarzał się za każdym razem podczas uruchomienia komputera).

Option Explicit
Sub wlaczanie_przypomninia()
'MVP OShon from VBATools.pl
Dim msg$, Response$, q&

msg = "Procedura włączenia przypomnień do terminów w kalendarzu Outlooka" & vbCr & vbCr _
& "Aby kontynuować naciśnij ''Tak''" & vbCr _
& "Aby anulować operacje naciśnij ''Nie''"
On Error GoTo blad
Response = MsgBox(msg, vbYesNo + vbExclamation + vbDefaultButton2, " Aktualizacja dzwoneczków")
If Response = vbYes Then
  Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
  OutApp.Session.Logon
  Dim oApptFolder As MAPIFolder
    Set oApptFolder = OutApp.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Dim oCalendar As AppointmentItem
Dim olApp As Items
  Set olApp = oApptFolder.Items
  For q = 1 To olApp.Count
    DoEvents
    Set oCalendar = olApp.Item(q)
    If Not oCalendar.Categories = "" _
      And oCalendar.ReminderSet = False _
      And oCalendar.Start >= Now Then
      'Jeśli nie określimy nazwy dla kategorii należy zmienić pow. warunek.
      oCalendar.ReminderSet = True
      oCalendar.Save
    End If
  Set oCalendar = Nothing
Next q
MsgBox "Dzwoneczki uaktywnione!", vbInformation, "O'Shon machine from VBATools."
Set OutApp = Nothing
Set oApptFolder = Nothing
End If
Exit Sub

blad:
MsgBox "Błąd: " & Err.Number & vbCr & Err.Description, vbExclamation
End Sub

Ten prosty przykład uzmysłowi wam jak działa pasek postępu. Elementarnym czynnikiem jest określenie wartości maksymalnej dla paska. W czasie przekazywania kolejnych parametrów, wartość paska będzie „dochodzić” do tej wartości.

Poniżej można znaleźć kod, który otwiera w zadeklarowanym katalogu pliki jakie spełniają określony warunek. Użyta w kodzie metoda FSO pozwala na przekazanie nazwy kolejnego pliku w pętli. Pliki są otwierane i zamykane bez zapisu. Parametr .value jest przekazywany.

Oto prosty przykład jak działa pasek postępu.

rys 1. Pasek postępu przypisany do otwieranych kolejno plików.

Option Explicit
Private Sub UserForm_Initialize()
'Taki sposób nie jest dobry ponieważ kod zacznie działać zanim forma się wyświetli
'Call test_4progres
End Sub

Private Sub CommandButton1_Click()
'to jest dobry sposób - wymuszenie przyciskiem
Call test_4progres
End Sub

Private Sub UserForm_Activate()
'to jest dobry sposób - zadziała zaraz po wywołaniu formy
Call test_4progres
End Sub

Sub test_4progres()
'MVP OShon from VBATools.pl
Const sciezka$ = "C:\Temp\"
Dim ob As Object, pliki As Object, plik As Object
Dim folder As Object, r&

Set ob = CreateObject("Scripting.FilesystemObject")
Set folder = ob.GetFolder(sciezka)
Set pliki = ob.GetFolder(folder).Files

ProgressBar1.Value = 0 'zerujemy pasek
ProgressBar1.Max = 9   'określamy maximum postępu 

With Application
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .DisplayAlerts = False
 For Each plik In pliki
  DoEvents 'kluczowy parametr dzięki któremu będziemy widzieć postęp paska
  If Mid(LCase(plik), InStrRev(plik, ".") + 1, 3) = "xls" Then
    Workbooks.Open Filename:=(sciezka & plik.Name) 'otwieramy tylko pliki XLS
    ProgressBar1.Value = r 'przekazujemy kolejny parametr
    r = r + 1
    ActiveWorkbook.Close False
    If r = 10 Then GoTo przerwij
  End If
 Next plik
przerwij:
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
 .EnableEvents = True
End With

Set ob = Nothing
Set folder = Nothing
Set pliki = Nothing
End Sub

Taką metodę można zastosować w Excelu, Outlooku, jak i w innych aplikacjach pakietu Office.

(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.

Kopiowanie przyrostowe często wpędza w zakłopotanie. Jak wykonać działanie szybko i bez konieczności szukania, zaznaczania zakresów, przechodzenia pomiędzy skoroszytami etc.

Poniżej przedstawiam drobny kod, który pokazuje jak otworzyć plik, zadeklarować obszar, odnaleźć w docelowym arkuszu ostatnią wypełnioną komórkę i do następnej import danych z zakresu pliku źródłowego. Zakładamy w nim iż plik źródłowy ma jeden lub pierwszy arkusz z danymi jakie nas interesują. Drugim założeniem jest iż kopiujemy wszystkie dane z zakresu kolumny A (może być zakres wielu kolumn).

Sub open_copy_paste_n_close()
'MVP OShon from VBATools.pl
Const nazwapliku$ = "c:\Temp\1.xlsx" 'Nazwa pliku do otwarcia
Dim thiswkb As Workbook, wkb As Workbook, min_row&
Set thiswkb = ActiveWorkbook
Call BlockEvScreenCalc(False, "Import danych...")
 Workbooks.Open Filename:=nazwapliku
Set wkb = ActiveWorkbook

Dim rng1 As Range, rng2 As Range
With wkb.Sheets(1)
 Set rng1 = .Range("a1:a" & .Cells(Rows.Count, "a").End(xlUp).Row)
End With
With thiswkb.Sheets("Arkusz1") 'arkusz docelowy
 min_row = .Cells(Rows.Count, "a").End(xlUp).Row
 If Len(.Range("a1")) > 0 Then min_row = min_row + 1 'jeśli mamy nagłówek
 Set rng2 = .Range("a" & min_row)
End With
rng1.Copy rng2
koniec:
On Error Resume Next
wkb.Close False
Set rng1 = Nothing
Set rng2 = Nothing
Set thiswkb = Nothing
Set wkb = Nothing
Call BlockEvScreenCalc(True) 
Exit Sub
blad:
Call BlockEvScreenCalc(True)
 MsgBox "Error: " & Err.Number & vbCr & Err.Description, vbCritical, "VBATools.pl"
Resume koniec
End Sub

Public Sub BlockEvScreenCalc(Optional ByVal bWlacz As Boolean, Optional Status As String)
 On Error Resume Next
 With Application
 If bWlacz Then
 .EnableEvents = True
 .Calculation = xlCalculationAutomatic
 .StatusBar = ""
 .ScreenUpdating = True
 .Cursor = xlDefault
 Else
 .ScreenUpdating = False
 .Calculation = xlCalculationManual
 .EnableEvents = False
 .StatusBar = Status
 .Cursor = xlWait
 End If
 End With
End Sub

(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.

Już jakiś czas temu, miałem dostęp do Windows 8  Developer preview. Jest to wersja dla programistów wydana dla jednostki przygotowanej do pracy w x64.

Wpierw instalacja jej na notebooku nie powiodła się, ponieważ domyślnie wsparcie dla procesora nie było włączone, jednakże później już bez problemów dała się okiełznać na VirtualBox.

Następną niespodzianką okazała się konieczność posiadania konta na WindowsLive. To on będzie kontrolował co używamy i kiedy instalujemy. On też od niedawna zintegrowany jest ze Skype, Outlook comunity addin, a dalej Facebook, Twiter i inne. Integracja z „social” nieunikniona. (czytaj dalej …)

Tematem tej porady jest potrzeba przeniesienia wiadomości po jej usunięciu z folderu elementy wysłane do folderu skrzynki, z której został on wysłany. Konta IMAP można skonfigurować tak, aby wskazać kierunek poczty przychodzącej oraz utworzyć regułę na skopiowanie wiadomości w obrębie struktury dostępnych folderów. Niestety usunięcie z przeniesieniem nie jest możliwe.

Proces ten nie jest skomplikowany ale wymaga utworzenia programu w VBA. Zaprogramowanie go, będzie opierało się na odrębnej procedurze. Powodem jest fakt iż Outlook nie posiada procedury zdarzeniowej, która by wywoływała czynność po usunięciu obiektu.

Rys 1. Opis schematu postępowania w strukturze folderów IMAP (przesłany przez Capacitor).

Poniżej umieszczone makro ma na zadanie przenieść wskazany lub otwarty mail, jednakże wywołanie tej procedury musi być podłączone do odrębnego przycisku. Dzięki mechanizmowi „Dostosowanie wstążki” dostępnego w opcjach Outlooka, jest możliwość dodania przycisku z podpiętym makrem. Samo podpięcie realizuje się po przez wybrania polecenia z grupy „Makra” a następnie w sekcji”Dostosuj wstążkę” utworzyć nową grupę i dopiero do niej dodać kod. Dodatkowo możemy zmienić nazwę wyświetlaną i dodać obrazek ikony.

Rys 2. Utworzenie skrótu do procedury VBA

Rys 3. Dostosowanie widoku

Sub Przenies_do_kosza_konta_imap()
'MVP OShon from VBATools.pl
Dim oMail  As MailItem, oFolder As MAPIFolder
On Error GoTo blad
Select Case TypeName(Application.ActiveWindow)
Case "Explorer":  Set oMail = ActiveExplorer.Selection.Item(1)
Case "Inspector": Set oMail = ActiveInspector.CurrentItem
Case Else: Exit Sub
End Select
 Dim konto As String: konto = oMail.SendUsingAccount
 Set oFolder = Application.GetNamespace("MAPI").Folders(konto).Folders("Deleted Items")
 oMail.Move oFolder
koniec:
 If Not oFolder Is Nothing Then Set oFolder = Nothing
 If Not oMail Is Nothing Then Set oMail = Nothing
Exit Sub
blad:
MsgBox Err.Number & " " & Err.Description, vbExclamation, "VBATools.pl"
Resume koniec
End Sub

Podobnie modyfikuje się wstążkę dla otwartej wiadomości.

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

Aby zastosować listę poprawności z innej lokalizacji w arkuszu należy użyć nazwy zakresu. Wywołuje się jej nadanie po przez [Ctrl+F3], a następnie wstawienie jej w pola adresu listy. Jeśli jednak chodzi o położenie danych jaką chcemy zastosować w liście poprawności, która znajduje się w osobnym pliku, należy zastosować procedurę VBA.

Wygląda to w następujący sposób.

 Option Explicit

Sub Validation_2ndFile_range()
'MVP OShon from VBATools.pl
 Dim a$, el As Range, wkb As Workbook, wks As Worksheet
 Dim rng1 As Range
 Set wkb = Workbooks("1.xlsx") 'inny skoroszyt
 Set wks = wkb.Sheets("Arkusz1") 'arkusz skoroszytu
 Set rng1 = wks.Range("a1:a10")
 For Each el In rng1
  a = a & el.Value & ","
 Next
 With Range("A1").Validation 'docelowa lista
  .Delete
  .Add Type:=xlValidateList, Formula1:=a
 End With
 Set rng1 = Nothing
 Set wks = Nothing
 Set wkb = Nothing
End Sub

Oto widok zastosowania:

(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.

Zastanawiacie się jak szybko połączyć dane z zakresów? Możecie oczywiście skorzystać z formuły złącz.teksty() jednakże kiedy mamy do czynienia z większymi zakresami musielibyście wykonać kopie formuły na całym zakresie w osobnej komunie, zamienić wynik na wartości, a następnie usunąć poprzednio wykorzystane w formule kolumny.

Poniżej można znaleźć metodę wykorzystującą unie zakresów, dzięki której szybko pobierzecie dane do pamięci, a w następnym kroku w miejsce danych wstawi połączone z zakresów dane.

Sub polaczenie_zakresow()
 Const kol1 As String = "C" 'dane z kolumny C
 Const kol2 As String = "D" 'dane z kolumny D
 Dim RR As Range, n As Long, x As Long, last_row&
 last_row = Cells(Rows.Count, kol1).End(xlUp).Row
 Set RR = Application.Union(Range(kol1 & "1:" & kol1 & last_row), _
 Range(kol2 & "1:" & kol2 & last_row))
 For x = 1 To RR.Count Step 2
   n = n + 1
   Cells(n, kol1) = RR(x) & RR(x + 1)
   Cells(n, kol2).ClearContents
 Next x
 Set RR = Nothing
End Sub

Zastosowanie makra ilustruje poniższy rysunek:

(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.

Często podczas automatyzacji chcemy się odwołać do treści wiadomości, jednak jak ją podglądnąć? Aby przetestować kontent najlepiej jest wyświetlić treść w oknie immediate. Samo okno wywołujemy przy pomocy skrótu klawiszowego [Ctrl+G] lub wybieramy z menu developera VBA.

Poniższa procedura pobiera dla zaznaczonej wiadomości lub otwartej i aktywnie wskazanej treść w postaci czystego tekstu lub kodu PHP, jaki stosowany jest w wiadomościach HTML.

Sub kotku_co_masz_w_srodku()
'MVP OShon from VBATools.pl
 Dim oMail As MailItem
 On Error GoTo koniec
 Select Case TypeName(Application.ActiveWindow)
 Case "Explorer":  Set oMail = ActiveExplorer.Selection.Item(1)
 Case "Inspector": Set oMail = ActiveInspector.CurrentItem
 Case Else: Exit Sub
 End Select
If oMail.BodyFormat = olFormatHTML Then
 Debug.Print oMail.HTMLBody
Else
 Debug.Print oMail.Body
End If
 Set oMail = Nothing
 Exit Sub
koniec:
 MsgBox Err.Number & " " & Err.Description, vbExclamation, "VBATools.pl"
End Sub

Dalsza obróbka może być przeprowadzona przy pomocy funkcji instr(), operatora like lub przekazania wartości przełącznika dla podjęcia dalszych działań.

(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