Akademia VBA – Oferta

Wyróżnione

Opublikowany przez
Odpowiedz

Tworzę i naprawiam aplikacje VBA/SQL/Makra. Moje aplikacje wyróżnia:

  • Dopasowanie do potrzeb klienta
  • Otwarty i dobrze skomentowany kod źródłowy
  • Instrukcja obsługi aplikacji
  • Szkolenia umożliwiające rozwijanie aplikacji własnymi siłami.

Mam 25 lat doświadczenia w szkoleniach i tworzeniu aplikacji dla biznesu. Tworzę aplikacje głównie w oparciu o środowisko Excel i VBA ale także SQL Server, Access i Power BI.

Pozdrawiam i zapraszam do współpracy

Dariusz Kolasa

Lista kwerend do tabeli Access

Opublikowany przez
Odpowiedz

Ostatnio musiałem przeanalizować dość złożoną bazę Access z kilkuset kwerendami
Oto jak sobie zrobić ich spis do okienka debuggera lub do tabeli
Jeżeli chcemy wrzucać dane do tabeli musimy ją najpierw utworzyć (nazwa tabeli jak i nazwy pól muszą być identyczne jak w kodzie)
Jeżeli nie chcemy wrzucać do tabeli to trzeba usunąć wszystkie linijki gdzie jest odwołanie do obiektu Recordset (rs)
Oczywiście aby wrzucić dane do okienka Debuggera trzeba je po pierwsze włączyć (Ctrl+G) a po drugie odkomentować linijkę z Debug.Print

Option Compare Database
Option Explicit
 
Sub lista_kwerend_do_tabeli()
    Dim db As DAO.Database
    Dim kw As DAO.QueryDef
    Set db = CurrentDb
    Dim Licznik_kw As Long
    Dim Typ_kw As String
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset("_tbSpisKwerend")
 
    For Each kw In db.QueryDefs
        Licznik_kw = Licznik_kw + 1
        Select Case kw.Type
            Case 0
                Typ_kw = "SELECT"
            Case 32
                Typ_kw = "DELETE"
            Case 48
                Typ_kw = "UPDATE"
            Case 64
                Typ_kw = "APPEND"
        End Select
        'Debug.Print Licznik_kw; kw.Name, Typ_kw, kw.Fields.Count
        rs.AddNew
        rs.Fields("Nazwa_kw").Value = kw.Name
        rs.Fields("Typ_kw").Value = Typ_kw
        rs.Fields("Liczba_pol").Value = kw.Fields.Count
        rs.Update
    Next
    Set db = Nothing
End Sub

Słownie z groszami w postaci ułamka

Opublikowany przez
2

Nowa wersja funkcji Slownie ma drugi parametr, który określa w jakiej postaci mają być grosze (zamiast True można wpisać 1 a zamiast False – 0)

Nawiasem mówiąc im nowszy WordPress tym gorszy do prowadzenia blogu programistycznego. Nie da się już użyć wtyczki do kolorowania kodu bez popsucia kodu 🙁
Wpisuje się to niestety w ogólny trend totalnego obniżania jakości i zarzucania użytkownika masą zbędnych i irytujących funkcji
Sytuację ratuje na szczęście wtyczka Classic Editor przywracająca starszą wersję edytora…

 
Option Explicit
 
Function Slownie(Kwota As Variant, UlamkoweGrosze As Boolean) As String
   '==================================
    ' UWAGA! Funkcja wymaga obu funkcji
    ' prywatnych zamieszczonych poniżej
    '==================================
 
    Const WERSJA As String = _
        "Funkcja Słownie v.1.03 (Akademia-VBA.pl)"
 
    Dim Opis(19) As String
    Dim DziesOpis(2 To 10) As String
    Dim SetOpis(1 To 9) As String
 
    Dim Zlotowki As String
    Dim Grosze As String
 
    Dim TrojkaZl As String
    Dim TrojkaTys As String
    Dim TrojkaMln As String
 
    Dim wynikGrosze As String
    Dim wynikZlote As String
    Dim Ujemna As Boolean
 
    On Error GoTo Obsluga
 
    'sprawdzenie czy puste
    If IsNull(Kwota) Or IsEmpty(Kwota) Then
        Slownie = "# Brak kwoty!"
        Exit Function
    End If
 
    'sprawdzenie czy liczba
    If Not IsNumeric(Kwota) Then
        Slownie = "# Nieprawidłowy typ wartości!"
        Exit Function
    End If
 
    'gdy ujemna
    If Kwota < 0 Then
        Ujemna = True
        Kwota = -Kwota
    End If
 
    'konwersja na stringi
    Zlotowki = CStr(Int(Kwota))
    Grosze = CStr(Kwota - Int(Kwota))
 
    'sprawdzenie, czy nie za duża, max 99 mln
    If Len(Zlotowki) > 9 Then
        Slownie = "# Kwota za duża, max 999 mln!"
        Exit Function
    End If
 
    'ewentualne zaokrąglenie do 2 msc po przecinku
    'tu drobna poprawka stąd wersja 1.01
    'było ...= CStr(Round(CDbl(Grosze) * 100, 2))
    If Len(Grosze) > 2 Then
        Grosze = CStr(Round(CDbl(Grosze), 2) * 100)
    End If
 
    'kod zasadniczy
    '==============
    Select Case Len(Zlotowki)
    Case 1 To 3
        wynikZlote = Trojka(Zlotowki) & _
            OpisRzeduWielkosci(CLng(Zlotowki), "zł", False)
    Case 4 To 6
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Left(Zlotowki, Len(Zlotowki) - 3)
        wynikZlote = Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    Case 7 To 9
        TrojkaZl = Right(Zlotowki, 3)
        TrojkaTys = Mid(Zlotowki, Len(Zlotowki) - 5, 3)
        TrojkaMln = Left(Zlotowki, Len(Zlotowki) - 6)
        wynikZlote = Trojka(TrojkaMln) & _
            OpisRzeduWielkosci(CLng(TrojkaMln), "mln", True) _
            & " " & Trojka(TrojkaTys) & _
            OpisRzeduWielkosci(CLng(TrojkaTys), "tys", True) _
            & " " & Trojka(TrojkaZl) & _
            OpisRzeduWielkosci(CLng(TrojkaZl), "zł", True)
    End Select
 
    If UlamkoweGrosze Then
        wynikGrosze = Format(Grosze, "00") & "/100"
    Else
        wynikGrosze = Trojka(Grosze) & _
           OpisRzeduWielkosci(CLng(Grosze), "gr", False)
 
        If wynikGrosze = "" Then wynikGrosze = "zero groszy"
    End If
    Slownie = IIf(Ujemna, "minus ", "") & _
        Trim(wynikZlote & " " & wynikGrosze)
 
    Exit Function
Obsluga:
    MsgBox Err & " - " & Err.Description, vbCritical, WERSJA
End Function
 
Private Function OpisRzeduWielkosci( _
        Liczba As Long, RzadWielkosci As String, _
        WiekszeTysiac As Boolean) As String
 
    Dim JestZero As Boolean
    Dim DwieOstatnie As Long
    Dim Ostatnia As Long
 
    If Liczba = 0 Then
        If WiekszeTysiac Then
            If RzadWielkosci = "zł" Then
                OpisRzeduWielkosci = "złotych"
            End If
        Else
            OpisRzeduWielkosci = ""
        End If
        Exit Function
    End If
 
    DwieOstatnie = CLng(Right(CStr(Liczba), 2))
    Ostatnia = CLng(Right(CStr(Liczba), 1))
 
    Select Case RzadWielkosci
    Case "gr"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " groszy"
        Case 1
            OpisRzeduWielkosci = " grosz"
        Case 2 To 4
            OpisRzeduWielkosci = " grosze"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " groszy"
            Case 2 To 4
                OpisRzeduWielkosci = " grosze"
            End Select
        End Select
    Case "zł"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " złotych"
        Case 1
            OpisRzeduWielkosci = " złoty"
        Case 2 To 4
            OpisRzeduWielkosci = " złote"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " złotych"
            Case 2 To 4
                OpisRzeduWielkosci = " złote"
            End Select
        End Select
    Case "tys"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " tysięcy"
        Case 1
            OpisRzeduWielkosci = " tysiąc"
        Case 2 To 4
            OpisRzeduWielkosci = " tysiące"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " tysięcy"
            Case 2 To 4
                OpisRzeduWielkosci = " tysiące"
            End Select
        End Select
    Case "mln"
        Select Case DwieOstatnie
        Case 0, 5 To 19
            OpisRzeduWielkosci = " milionów"
        Case 1
            OpisRzeduWielkosci = " milion"
        Case 2 To 4
            OpisRzeduWielkosci = " miliony"
        Case Is > 19
            Select Case Ostatnia
            Case 0, 1, Is > 4
                OpisRzeduWielkosci = " milionów"
            Case 2 To 4
                OpisRzeduWielkosci = " miliony"
            End Select
        End Select
    End Select
End Function
 
Private Function Trojka(strLiczba As String) As String
    Dim lngLiczba As Long
    Dim lngOstatnia As Long
    Dim lngDwieOstatnie As Long
 
    Dim Opis(19) As String
    Dim DziesOpis(10) As String
    Dim SetOpis(9) As String
 
    If CLng(strLiczba) = 0 Then
        Trojka = ""
        Exit Function
    End If
 
    Opis(0) = "zero"
    Opis(1) = "jeden"
    Opis(2) = "dwa"
    Opis(3) = "trzy"
    Opis(4) = "cztery"
    Opis(5) = "pięć"
    Opis(6) = "sześć"
    Opis(7) = "siedem"
    Opis(8) = "osiem"
    Opis(9) = "dziewięć"
    Opis(10) = "dziesięć"
    Opis(11) = "jedenaście"
    Opis(12) = "dwanaście"
    Opis(13) = "trzynaście"
    Opis(14) = "czternaście"
    Opis(15) = "piętnaście"
    Opis(16) = "szesnaście"
    Opis(17) = "siedemnaście"
    Opis(18) = "osiemnaście"
    Opis(19) = "dziewiętnaście"
 
    DziesOpis(0) = "zero"
    DziesOpis(1) = "dziesięć"
    DziesOpis(2) = "dwadzieścia"
    DziesOpis(3) = "trzydzieści"
    DziesOpis(4) = "czterdzieści"
    DziesOpis(5) = "pięćdziesiąt"
    DziesOpis(6) = "sześćdziesiąt"
    DziesOpis(7) = "siedemdziesiąt"
    DziesOpis(8) = "osiemdziesiąt"
    DziesOpis(9) = "dziewięćdziesiąt"
 
    SetOpis(0) = "zero"
    SetOpis(1) = "sto"
    SetOpis(2) = "dwieście"
    SetOpis(3) = "trzysta"
    SetOpis(4) = "czterysta"
    SetOpis(5) = "pięćset"
    SetOpis(6) = "sześćset"
    SetOpis(7) = "siedemset"
    SetOpis(8) = "osiemset"
    SetOpis(9) = "dziewięćset"
 
    lngLiczba = CLng(strLiczba)
 
    'tu policzymy ostatnią
    lngOstatnia = CLng(Right(strLiczba, 1))
 
    Select Case lngLiczba
    Case Is < 20
        Trojka = Opis(lngLiczba)
    Case Is < 100
        If lngLiczba Mod 10 = 0 Then
            Trojka = DziesOpis(lngLiczba / 10)
        Else
            Trojka = DziesOpis((lngLiczba - lngOstatnia) / 10) _
                & " " & Opis(lngOstatnia)
        End If
    Case Else 'trzycyfrowa
        If lngLiczba Mod 100 = 0 Then
            Trojka = SetOpis(lngLiczba / 100)
        Else
            'tu policzymy dwie ostatnie
            lngDwieOstatnie = CLng(Right(strLiczba, 2))
 
            If lngLiczba Mod 10 = 0 Then
                Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                    & " " & DziesOpis(lngDwieOstatnie / 10)
            Else
                If lngDwieOstatnie < 20 Then
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & Opis(lngDwieOstatnie)
                Else
                    Trojka = SetOpis((lngLiczba - lngDwieOstatnie) / 100) _
                        & " " & DziesOpis((lngDwieOstatnie - lngOstatnia) / 10) _
                        & " " & Opis(lngOstatnia)
                End If
            End If
        End If
    End Select
End Function

Proste w użyciu operacje na plikach

Opublikowany przez
1

Mało kto wie, że VBA ma fajne i proste w użyciu funkcje do odczytywania podstawowych informacji o pliku. Poniżej przykłady wykonania z debuggera:

?FileDateTime("C:\Users\dariu\Desktop\kotek.png")
2018-10-30 21:14:47

Oczywiście zwraca datę ostatniej modyfikacji pliku

?FileLen("C:\Users\dariu\Desktop\kotek.png")
135590

Zwraca wielkość pliku w bajtach.

Także znajomość niezwykle praktycznej funkcji FileCopy jest mocno ograniczona. Jej działanie jest chyba jasne 🙂

FileCopy "C:\Users\dariu\Desktop\kotek.png", _
        "C:\Users\dariu\Desktop\kotek2.png"

Podstawy SQL – Kolejność klauzul w SELECT

Opublikowany przez
Odpowiedz

Poważna aplikacja VBA z często korzysta z jakiejś bazy danych aby odczytać, dopisać a czasem zaktualizować lub usunąć jakieś dane. Dlatego warto poznać co najmniej podstawy języka SQL. Jest to język dość prosty jeżeli chodzi o podstawy, ale oczywiście jeżeli mamy nietrywialne potrzeby, zapytania też się komplikują. Co musisz wiedzieć na pewno to jak odczytać dane z bazy. Z artykułu o ADO wiesz, że z VBA można nawiązać połączenie z Access i SQL Server. Tam jako źródło zapytania jest po prostu podana nazwa tabeli. Ale oczywiście zamiast tego możemy podać dowolne wyrażenie typu SELECT. I tu na początek trzeba wiedzieć kilka rzeczy. Po pierwsze kolejność klauzul jest ściśle określona i jest następująca:

 SELECT pole1, pole2, poleN...
 FROM tabela (tabela1 JOIN tabela2 ON klucz1 = klucz2)
 WHERE warunek1 AND/OR warunek2...

Tak wygląda najprostszy select bez grupowania i wyliczeń. Zasadą jest, że piszemy najpierw FROM a potem wypisujemy pola w SELECT, bo tylko wtedy dobry edytor kodu SQL może nam podpowiedzieć nazwy pól. We FROM podajemy nazwę pojedynczej tabeli lub wiele tabel ale wtedy musimy wiedzieć po jakich polach kluczowych trzeba je połączyć. Sytuacja komplikuje się gdy chcemy w zapytaniu grupować dane i coś wyliczać dla tych grup:

 SELECT pole1, pole2, SUM(pole3) AS Razem
 FROM tabela (tabela1 JOIN tabela2 ON klucz1 = klucz2)
 WHERE warunek1 AND/OR warunek2...
 GROUP BY pole1, pole2
 HAVING SUM(pole3) > 1000
 ORDER BY Razem DESC

Jak widać użyliśmy w SELECT funkcji SUM, która współpracuje z klauzulą GROUP BY definiującą dla jakich grup chcemy policzyć sumy. Dodatkowo w klauzuli HAVING informujemy, że interesują nas tylko sumy przekraczające 1000. ORDER BY to oczywiście sortowanie, w tym wypadku po sumach w porządku malejącym (DESC jak descending). W SELECT za polem trzecim mamy as Razem co oznacza jak chcemy nazwać to wyliczane pole. I tu ciekawostka. Skoro już nazwaliśmy to pole Razem to czemu wykorzystaliśmy tą nazwę tylko w ORDER BY Razem DESC ale już nie w HAVING gdzie ponownie użyliśmy wyrażenia SUM(pole3) > 1000?. Otóż wynika z ważnej zasady, że kolejność pisania klauzul w SELECT nie odpowiada kolejności przetwarzania ich przez serwer! Okazuje się, że klauzula SELECT jest przetwarzana dopiero jako piąta!

 SELECT pole1, pole2, SUM(pole3) AS Razem              --5!!!
 FROM tabela (tabela1 JOIN tabela2 ON klucz1 = klucz2) --1
 WHERE warunek1 AND/OR warunek2...                     --2
 GROUP BY pole1, pole2                                 --3
 HAVING SUM(pole3) > 1000                              --4
 ORDER BY Razem DESC                                   --6

I dlatego tylko klauzula ORDER BY jako jedyna przetwarzana po SELECT może użyć zdefiniowanej w niej nazwy pola!

ADOX

Opublikowany przez
Odpowiedz

Bardzo stara i bardzo fajna biblioteka do obsługi struktury bazy. Na liście referencji nazywa się Microsoft ADO Ext. XX for DDL and Security. Potrzebna jest też biblioteka ADO do nawiązania połączenia. Kluczowy jest ADOX.Catalog, który pozwala na iterowanie po tabelach, polach itp.
Poniższy kod wymaga tzw. connection string (stała CN_STR), których przykłady są w artykule o ADO – i wszystkie bazy są nasze

Sub Lista_Tabel_Kolumn()
    Dim cn As New ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim tb As ADOX.Table
    Dim k As ADOX.Column
 
    cn.ConnectionString = CN_STR 'dodaj swoje ustawienia!
    cn.Open
 
    Set cat.ActiveConnection = cn
 
    For Each tb In cat.Tables
        For Each k In tb.Columns
            Debug.Print tb.Name, k.Name
        Next
    Next
End Sub

Funkcja do sprawdzania sprawdzania poprawności

Opublikowany przez
Odpowiedz

Czasem możemy chcieć sprawdzić czy w danej komórce ustawiono sprawdzanie poprawności (walidację), np. aby jej nie popsuć wklejaniem
Poniżej funkcja logiczna, która to sprawdza

Function JestSprawdzaniePoprawnosci(KomSprawdzania As Range) As Boolean
    Dim Typ As Long
 
    On Error GoTo Obsluga
 
    Typ = KomSprawdzania.Validation.Type
    JestSprawdzaniePoprawnosci = True
    Exit Function
 
Obsluga:
    JestSprawdzaniePoprawnosci = False
 
End Function

Wysyłanie wiadomosci e-mail z VBA

Opublikowany przez
1

Collaboration Data Objects (CDO) to biblioteka umożliwiająca wysyłanie wiadomosci e-mail. Była dedykowana dla Windows 2000 ale działa do dziś 🙂

Kod oczywiście wymaga poprawek w zakresie adresów e-mail jak i danych serwera wysyłającego pocztę. Niektóre serwery (np Gmail) mogą wymagać dodatkowych ustawień dla użycia przez CDO

'Wymaga biblioteki Microsoft CDO for Windows 2000 Library
 
Sub WyslijMail_CDO()
    Dim Wiadomosc As CDO.Message
    Dim Konfiguracja As CDO.Configuration
 
    Set Wiadomosc = New CDO.Message
    Set Konfiguracja = New CDO.Configuration
 
    Const ADRES_KONFIGURACJI As String = "http://schemas.microsoft.com/cdo/configuration/"
 
    Konfiguracja.Load cdoDefaults
 
    With Konfiguracja.Fields
        .Item(ADRES_KONFIGURACJI & "sendusername") = "login"          'login
        .Item(ADRES_KONFIGURACJI & "sendpassword") = "hasło"          'hasło
        .Item(ADRES_KONFIGURACJI & "smtpserver") = "poczta.o2.pl"     'serwer SMTP
        .Item(ADRES_KONFIGURACJI & "smtpserverport") = 465            'port
        .Item(ADRES_KONFIGURACJI & "sendusing") = cdoSendUsingPort    'metoda wysyłania
        .Item(ADRES_KONFIGURACJI & "smtpauthenticate") = cdoBasic     'metoda autentykacji
        .Item(ADRES_KONFIGURACJI & "smtpusessl") = 1                  'kodowany kanał
        .Update
    End With
 
    Set Wiadomosc.Configuration = Konfiguracja
 
    Wiadomosc.From = "adres1@o2.pl"
    Wiadomosc.To = "adres2@gmail.com"
    Wiadomosc.Subject = "Test CDO"
    Wiadomosc.TextBody = "Hej" & vbNewLine & "To jest test biblioteki CDO" & _
        vbNewLine & vbNewLine & "Pozdrawiam" & vbNewLine & "Darek"
 
    Wiadomosc.Send
 
End Sub