VBA Tools

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

Czy to już?

Jakiś czas temu D.Promeski (MVP Outlook), rozmawiała o pogłoskach dostępności nowego pakietu. To iż fakt ten miał miejsce pół roku temu (dokładnie w maju), to można było przypuszczać iż istnieje taka wersja, jednakże na „stole montażowym”. Ostatnio wykuta została wersja internetowa Office 386. i sądzić można by było że wersja stand-alone, nie pojawi się już więcej.

Otóż dziś jeden z forumowiczów na Technecie, wspomniał iż nie może sobie poradzić z transferem maili z wersji 2007 na nowego laptopa HP z pakietem Office 2012. Było by to dosyć przedwczesne. Zwykle producent z Redmond miał małe falstarty a tu początek roku. (czytaj dalej …)

Dodatek Telekwiaciarnia jest dodatkiem do aplikacji Excel dedykowanym dla firmy „Abrazo SC”.

Założenia aplikacji to uzupełnienie danych w plikach ODT obsługiwanym przez MS Word danymi zawartymi w pliku bazy XLS.

Uzupełnienie polega na wyszukaniu kodu produktu i zwrócenie jego opisu dla wszystkich plików ODT zwróconych przez mechanizm obcej firmy.

Aby zachować bezpieczeństwo pracy w Excelu produkt został dostarczony z cyfrowym podpisem autoryzacji kodu VBA, którym to projekt jest powiązany. Aby program uruchomić wcześniej należy go zainstalować. Opis instalacji przedstawiony w zgodnie z tym linkiem. Podpis ten powinien znaleźć się w repozytorium podpisów Excela. Dodatek będzie uruchomiony jeśli zabezpieczenia będą ustawiony na odpowiedni poziom. Został on zaprojektowany dla wersji Excel 2007/10.

Obsługa aplikacji jest bardzo prosta: Po uruchomieniu dodatku pojawia się menu aplikacji w sekcji Dodatki Ms Excel

Po uruchomieniu przycisku Telekwiaciarnia pojawi się interfejs aplikacji.

Aby mechanizm był użyteczny należy wskazać w jego konfiguracji miejsce przechowywania plików ODT jak i pliku bazy danych. Dobrze jest jeśli katalog taki jest specjalnie przygotowany, jedynie dedykowany plikom z zamówieniami.

Tworzymy wiec odrębny katalog i zapisujemy w nim pliki (nazwa katalogu może być dowolna).

Następnie osadzamy plik bazy danych (może być do tego samego katalogu).

Po wskazaniu miejsca docelowego zostaną automatycznie utworzone katalogi:

• Oryginalne (co do którego będą przenoszone pliki bez ingerencji mechanizmu)
• Przerobione (katalog plików uzupełnionych)

Po uruchomieniu przycisku „Uzupełnij pliki ODT” (możliwość użycia skrótów klawiszowych) mechanizm zrealizuje działanie w następujący sposób:

Proces ten wyszuka frazę „kod zewnętrzny” i pobierze jego symbol a następnie dopasuje zgodnie ze wcześniej pobraną tablicą i zwróci opis w linii poniżej. Po zakończeniu edycji pliku zapisze go i przejdzie do następnego dokumentu.

Po zrealizowaniu zadania użytkownik zostanie powiadomiony sygnałem dźwiękowym. W przypadku braku plików w zdefiniowanej lokalizacji pojawi się odpowiedni monit.

Aplikacja ta podlega ustawie o prawach autorskich co czyni iż kopiowanie czy nieautoryzowana instalacja bez zakupu licencji jest ustawowo zabroniona.

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

Wyobraźmy sobie wielką tabelę, w której mamy powiązane dane. Chcemy je rozdzielić tak aby można było wysłać je np e-mailem do grupy odpowiedzialnej za konkretną grupę.

Jedno kliknięcie i mamy rozwiązanie:

Rys1. Przykład podziału na osobne arkusze.

Poniżej przedstawiam procedurę realizującą zakładane działanie.

Option Explicit

Sub rozdziel_na_arkusze()
'MVP Oskar Shon www.VBATools.pl
If Selection.Columns.Count > 1 Then GoTo zakres
 Dim strName$, w&, T$, c&, co$, Ren As Range
 'pierwsza komórka w obszarze bedzie wierszem nagłówka = true
 Dim Naglowek As Boolean: Naglowek = True
 w = Selection.Column
 T = ActiveWorkbook.ActiveSheet.Name
 If Naglowek = True Then
 On Error GoTo zakres
 c = Split(Selection.EntireRow.Address(0, 0, xlA1, 0), ":")(0)
 co = Range(Split(Selection.Address, ":")(0)).Value
 End If
On Error GoTo blad
Application.ScreenUpdating = False
 For Each Ren In Selection.Rows
 strName = Left$(znaki_pliku(Ren.Value), 31)
 If Naglowek = True And strName = co Then GoTo dalej
 If Len(strName) Then If Not ShExists(ActiveWorkbook, strName) Then _
 ActiveWorkbook.Sheets.Add.Name = strName
 If Len(strName) = 0 Then GoTo dalej
 If Naglowek = True Then Worksheets(T).Rows(c).Copy _
 Destination:=Worksheets(strName).Rows(1)
 With Worksheets(T).Rows(Ren.Row)
 If Len(Worksheets(strName).Cells(Rows.Count, w).End(xlUp).Value) = 0 Then
 .Copy Destination:=Worksheets(strName).Rows(1)
 Else
 .Copy Destination:=Worksheets(strName).Rows(Worksheets(strName). _
 Cells(Rows.Count, w).End(xlUp).Row + 1)
 End If
 End With
dalej:
 Next
 Sheets(T).Select
 Beep
Application.ScreenUpdating = True
Exit Sub
zakres:
MsgBox "Zaznacz obszar komórek w pojedynczej kolumnie, nie kolumnę!", _
 vbExclamation, "MVP OShon VBATools.pl"
Exit Sub
blad:
Application.ScreenUpdating = True
MsgBox "Numer błędu: " & Err.Number & vbCr & _
 "Opis błędu: " & Err.Description, _
 vbExclamation, "MVP OShon VBATools.pl"
End Sub
Private Function ShExists(Wkb As Workbook, ByVal strNazwa As String) As Boolean
 On Error Resume Next
 ShExists = Len(Wkb.Sheets(strNazwa).Name)
End Function
Private Function znaki_pliku(Filename As String)
Dim F%
 For F = 1 To Len(Filename)
 Filename = Replace(Filename, Mid$("\/:?""<>|*", F, 1), vbNullString)
 Next
 znaki_pliku = Filename
End Function

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

Jeśli zastanawiasz się jak utworzyć listę poprawności z wielu zakresów oto przykład zastosowania.

Wystarczy zdefiniować odpowiednio zakresy w kodzie VBA.

 Option Explicit

Sub Validation_two_ranges()
 Dim a$, el As Range
 Dim rng1 As Range, rng2 As Range
 Set rng1 = Range("c3:c5") 'możesz przypisać nazwę zakresu
 Set rng2 = Range("d3:d5")
 For Each el In rng1 'pierwszy zakres
 a = a & el.Value & ","
 Next
 For Each el In rng2 '2 drugi
 a = a & el.Value & ","
 Next
 With Range("A1").Validation 'docelowa lista
 .Delete
 .Add Type:=xlValidateList, Formula1:=a
 End With
 Set rng1 = Nothing
 Set rng2 = Nothing
End Sub

Oto widok:

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

Dużym problemem jest fakt odbierania niechcianej poczty. Czy tego chcemy czy nie nasze adresy są sprzedawane lub pozyskiwane w inny sposób przez firmy reklamujące swoje usługi. Firmy tworzące programy antywirusowe prześcigają się w mechanizmach realizujących modyfikacje wiadomości tak, aby w dużym prawdopodobieństwie użytkownik miał świadomość, iż odebrana poczta nie pochodzi od nikogo, z kim wcześniej korespondujemy.

Można do tego tematu podejść z innej strony. Na kształt naszych reakcji, gdy podczas odbierania rozmowy z telefonu komórkowego spoglądamy, kto do nas dzwoni i tak potraktujemy pocztę przychodzącą. W większości nasza korespondencja jest zorientowana na osoby, jakie mamy w folderze kontakty.

Rys 1. Widok oznaczenia niechcianej poczty w konfiguracji POP3

Powyżej przedstawiony sposób, który pokazuje jak możemy, przy wyciągnięciu pola kategorie oznaczyć te wiadomości, jakich wcześniej nie dodaliśmy do kontaktów. Taka modyfikacja wiadomości daje nam dodatkowe możliwości: np. sortowanie po danej kolumnie, gdzie z góry możemy spodziewać się że w węźle „ALIEN” będzie sama niezautoryzowana poczta.

Podczas umieszczania kodu w developerze VBA, należy wiedzieć, iż dla kont IMAP/Exchange wiadomości nie mogą być modyfikowane. Struktura i założenia tych kont pozwala jedynie synchronizować wiadomość z miejscem jego alokacji. Wszelkie modyfikacje treści, tematu czy innych pól standardowych nie powiedzie się. W tym celu najlepszym sposobem jest przesuniecie wiadomości do innego folderu (w przykładzie folder „Wiadomości-śmieci”, który to może być zamieniony na inny, utworzony przez użytkownika folder).

Sub Incoming_contact_found(oMail As MailItem)
'MVP OShon form VBATools.pl
If oMail.Class <> olMail Then Exit Sub
Dim adres$, oContactFolder As MAPIFolder
Dim oItems As Items, oContact As ContactItem
'Dim oDestFolder As Outlook.Folder 'for Imap/Exchange account
'Set oDestFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderJunk)

adres = oMail.SenderEmailAddress 'Recipients(1).Address 'for oldest version
 Set oContactFolder = Application.GetNamespace("MAPI"). _
 GetDefaultFolder(olFolderContacts)
 Set oItems = oContactFolder.Items

 FindContact = False
 adres = """" & adres & """"

 Set oContact = oItems.Find("[Email1Address] =" & adres & " or " & _
 "[Email2Address] =" & adres & " or [Email3Address] =" & adres & "")

If oContact Is Nothing Then 
 oMail.Categories = "ALIEN" 'only for POP3Account
 oMail.Save
 'oMail.Move oDestFolder    'for Imap/Exchange transfer to another folder
end if
 'Set oDestFolder = Nothing
 Set oContactFolder = Nothing
 Set oContact = Nothing
 Set oItems = Nothing
End Sub

Procedurę umieszczamy w module [Alt+F11]/Menu/Insert/Module a następnie zapisujemy nasz projekt.

Rys 2. Podłączenie reguły w Outlooku

Rysunek nr 2. pokazuje jak podpiąć sparametryzowaną procedurę, jako regułę ze skryptem.
Powyższą procedurę możemy rozszerzyć np. o nadanie koloru wiadomości, przesłać na inne konto lub przesunąć wprost do folderu „Elementy usunięte”. Możemy też poddać sprawdzenia wiadomości przychodzącej z inną książką adresową, lub z kilkoma.

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

W niektórych przypadkach chcemy oznaczyć wydarzenia w arkuszu, bazując na aktualnym kalendarzu.

Poniższy sposób przedstawia jak taki kalendarz wykonać kodem VBA:

Rys: Wygląd utworzonego kalendarza w arkuszu.

Sub tworz_kalendarz_w_arkuszu()
'MVP Shon Oskar from VBATools.pl
Dim i%, x&, kon_msca&, miesiac$, dzientyg$, nrtyg&, Rok&
On Error GoTo blad_rok
ponownie:
With Application
Rok = .INPUTBOX("Podaj rok, dla którego będzie utworzony kalendarz:", _
 "Rysownie kalendarza w arkuszu:", Year(Now), Type:=2)
On Error GoTo blad
If Rok = 0 Then GoTo koniec
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .StatusBar = "Tworzenie kalendarza..."
 For i = 1 To 12
 kon_msca = Day(DateSerial(Rok, i + 1, 1) - 1)
 miesiac = Format(DateSerial(Rok, i, 1), "mmmm")
 For x = 1 To 31
 nrtyg = WeekDay(DateSerial(Rok, i, x), vbUseSystemDayOfWeek)
 dzientyg = WeekdayName(nrtyg)
 Cells(i, x).value = x & " " & miesiac & " " & Rok & vbNewLine & dzientyg
 If nrtyg > 5 Then Cells(i, x).Interior.ColorIndex = 15
 If x = kon_msca Then Exit For
 Next x
 Next i
koniec:
 .StatusBar = False
 .EnableEvents = True
 .Calculation = xlCalculationAutomatic
 .ScreenUpdating = True
End With
Beep
Exit Sub
blad_rok:
 Resume ponownie
Exit Sub
blad:
 MsgBox "Błąd:" & Err.Number & vbCr & Err.Description
 Resume koniec
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.

ACTA – To nowa forma ograniczenia wolności dedykowana osobom, które pobierają i publikują treści w internecie.

Po wprowadzeniu ustawy, która będzie opierać się na założeniach ACTA czy będziesz mógł zamieścić zacytowane treści, umieścić kawałek filmu, piosenki, fragment z gry? Definitywnie nie. Jak będą wyglądały prace naukowe, recenzje czy opisy wydarzeń, skoro będzie można każdego poddać intelektualnej lustracji. Jak będzie działać autoryzacja zamieszczonej treści? Czy osoby ścigające nie będą miały zbyt wielkich uprawnień? Czy będą mogły zamknąć portal/domenę/serwer, który zawiera również mechanizmy funkcjonowania przedsiębiorstwa płacącego podatki?  Jak daleko posuniemy się w interpretacji przepisów? (czytaj dalej …)

Jesteś ciekawy jak działa bankomat? Chciałbyś zbudować maszynkę do efektywnego wydawania reszty?

Oto prosty przykład przestawiający okno odpytujące o kwotę do wydania.

a oto wynik:

Przy zastosowaniu tablic można zagregować nominały aby pokazywać ich sumę, jednakże pow forma przedstawia sposób kolejnego doboru bilonów. Możesz to wykorzystać i zbudować interfejs wyposażony w zdjęcia bilonów i monet, a dzięki animacji przedstawić proces wydania, lub podłączyć procedurę do portu RS i przenieść proces wydania w rzeczywistość.

Sub ile_banknotow()
'wartość zostanie przeliczona na dane z tablicy i kolejno zaproponowane
'MVP OShon from VBATools.pl
Dim liczba As Currency, y&, do_wydania$, pyt
Dim tablica As Variant, skarbonka As Currency
tablica = Array(500, 200, 100, 50, 20, 10, 5, 2, 1, 0.5, 0.2, 0.1, 0.05, 0.02, 0.01)
pyt = InputBox("Wpisz wartość liczbową aby uzyskać " & _
 "informacje o banknotach składających się na tą wartość:", _
 "Bankomat VBATools.pl", "1234,56")
If Len(pyt) = 0 Then Exit Sub
If IsNumeric(pyt) = False Then MsgBox "Wartość " & Chr(34) & pyt & Chr(34) & _
 " nie jest spodziewaną wartością pieniężną!", vbExclamation, _
 " VBATools.pl": Exit Sub
liczba = CCur(pyt)

On Error GoTo Blad
Do While skarbonka < liczba
nowy_banknot:
 If skarbonka + tablica((y)) > liczba Then
 y = y + 1
 GoTo nowy_banknot
 Else
 skarbonka = skarbonka + tablica((y))
 do_wydania = do_wydania & tablica((y)) & " +"
 If skarbonka = liczba Then Exit Do
 End If
Loop
Debug.Print skarbonka & " = " & do_wydania
MsgBox "Aby wydać wartość " & skarbonka & " należy wydać kolejno: " _
 & vbCr & Left$(do_wydania, Len(do_wydania) - 2), _
 vbInformation, "Bankomat VBATools.pl"
Exit Sub
Blad:
MsgBox "Podana wartość " & pyt & " nie jest postaci walutowej!", _
 vbExclamation, " VBATools.pl"
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.

Nasz portal szykuje się do przeprowadzki. Ostatnie niepożądane czynności jakie zostały zafundowane przez obecnego ISP przechyliły szalę wcześniejszemu rozważaniu o słuszności migracji. Będziemy realizować działania migracji zasobów na początku przyszłego msca. Takie zmiany zwykle nie powinny odbić się niekorzystnie na użytkownikach portalu, jednakże nauczeni doświadczeniem chcemy aby dostępność do rozwiązań była możliwa również z poziomu innych dostawców usług.

(czytaj dalej …)