Akademia VBA

czyli jak uzyskać władzę nad światem … danych

ADO – i wszystkie bazy są nasze :)

Kategorie: Access VBA,Excel VBA,Office VBA,SQL Server — Darek Kolasa o 14:36, 23 Gru 2014

Od 2000 roku czyli już od kilkunastu lat Microsoft Office może bez problemu łączyć się w zasadzie z dowolnymi bazami danych, dzięki bibliotece ADO (Microsoft ActiveX Data Object XX Library). I od tych samych kilkunastu lat budzi to niezmiennie zdziwienie wśród moich klientów i studentów. Jak to? Excel może pobrać dane z Oracle?, SQL Servera? O! Może nawet je edytować?! No oczywiście, że może, i to od wielu lat…
Biblioteka ADO (w kodzie widoczna jako ADODB) jest domyślnie podłączana tylko w Accessie. We wszystkich innych produktach, w tym w Excelu trzeba ją wybrać w referencjach. Tools – References – Microsoft ActiveX Data Object XX Library, gdzie XX to numer wersji biblioteki, ja osobiście wybieram zwykle wersję 2.8
Drugi warunek to oczywiście poprawnie zainstalowany sterownik OLEDB do określonej bazy (http://en.wikipedia.org/wiki/OLE_DB_provider)

Poniżej przykład pobierający do Excela dane z Accessa 2003, ale uważny czytelnik zobaczy drogę pobierania z Accessa 2007/10/13 tudzież z SQL Servera. Wystarczy podmienić wartość właściwości ConnectionString obiektu Connection

Option Explicit
Public Const WERSJA As String = "ADO Klient v.0.1"
Public Const ARK_DANE As String = "Dane"
Public Const ZRODLO As String = "tbBrutto"
 
'Załozenia:
' - mamy arkusz o nazwie "Dane"
' - mamy bazę PodstawyVBA.mdb a w niej tabelę tbBrutto
' - mamy sterownik do mdb
 
'Access mdb
'==========
Public Const CN_STR As String = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.mdb;" & _
    "Persist Security Info=False"
 
 
'Ponizej przykłady konfiguracji dla innych baz
 
'Access accdb
'============
'Public Const CN_STR As String = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.accdb;" & _
    "Persist Security Info=False"
 
'SQL Server
'==========
'Public Const CN_STR As String = _
    "Provider=SQLOLEDB.1;Integrated Security=SSPI;" & _
    "Persist Security Info=False;" & _
    "Initial Catalog=Produkcyjna;" & _
    "Data Source=SKARBEKMC\SQLEXPRESS"
 
 
Sub OdczytDoExcela()
    Dim Zakres As Range
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Obsluga
 
    Sheets(ARK_DANE).Select
    Range("A1").Select
    Set Zakres = _
        Sheets(ARK_DANE).Range("A1").CurrentRegion
    Zakres.ClearContents
 
    cn.ConnectionString = CN_STR
    cn.Open
    rs.Open ZRODLO, cn
    Sheets(ARK_DANE).Range("A2").CopyFromRecordset rs
 
    'nagłówki
    Dim LK As Long, K As Long
    LK = rs.Fields.Count
    For K = 1 To LK
        Sheets(ARK_DANE).Cells(1, K) = rs.Fields(K - 1).Name
    Next
 
    Zakres.EntireColumn.AutoFit
 
Czyszczenie:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
Obsluga:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, WERSJA
    Resume Czyszczenie
End Sub

ADO – i wszystkie bazy są nasze :)

Kategorie: Access VBA,Excel VBA,Office VBA,SQL Server — Darek Kolasa o 14:36, 23 Gru 2014

Od 2000 roku czyli już od kilkunastu lat Microsoft Office może bez problemu łączyć się w zasadzie z dowolnymi bazami danych, dzięki bibliotece ADO (Microsoft ActiveX Data Object XX Library). I od tych samych kilkunastu lat budzi to niezmiennie zdziwienie wśród moich klientów i studentów. Jak to? Excel może pobrać dane z Oracle?, SQL Servera? O! Może nawet je edytować?! No oczywiście, że może, i to od wielu lat…
Biblioteka ADO (w kodzie widoczna jako ADODB) jest domyślnie podłączana tylko w Accessie. We wszystkich innych produktach, w tym w Excelu trzeba ją wybrać w referencjach. Tools – References – Microsoft ActiveX Data Object XX Library, gdzie XX to numer wersji biblioteki, ja osobiście wybieram zwykle wersję 2.8
Drugi warunek to oczywiście poprawnie zainstalowany sterownik OLEDB do określonej bazy (http://en.wikipedia.org/wiki/OLE_DB_provider)

Poniżej przykład pobierający do Excela dane z Accessa 2003, ale uważny czytelnik zobaczy drogę pobierania z Accessa 2007/10/13 tudzież z SQL Servera. Wystarczy podmienić wartość właściwości ConnectionString obiektu Connection

Option Explicit
Public Const WERSJA As String = "ADO Klient v.0.1"
Public Const ARK_DANE As String = "Dane"
Public Const ZRODLO As String = "tbBrutto"
 
'Załozenia:
' - mamy arkusz o nazwie "Dane"
' - mamy bazę PodstawyVBA.mdb a w niej tabelę tbBrutto
' - mamy sterownik do mdb
 
'Access mdb
'==========
Public Const CN_STR As String = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.mdb;" & _
    "Persist Security Info=False"
 
 
'Ponizej przykłady konfiguracji dla innych baz
 
'Access accdb
'============
'Public Const CN_STR As String = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.accdb;" & _
    "Persist Security Info=False"
 
'SQL Server
'==========
'Public Const CN_STR As String = _
    "Provider=SQLOLEDB.1;Integrated Security=SSPI;" & _
    "Persist Security Info=False;" & _
    "Initial Catalog=Produkcyjna;" & _
    "Data Source=SKARBEKMC\SQLEXPRESS"
 
 
Sub OdczytDoExcela()
    Dim Zakres As Range
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Obsluga
 
    Sheets(ARK_DANE).Select
    Range("A1").Select
    Set Zakres = _
        Sheets(ARK_DANE).Range("A1").CurrentRegion
    Zakres.ClearContents
 
    cn.ConnectionString = CN_STR
    cn.Open
    rs.Open ZRODLO, cn
    Sheets(ARK_DANE).Range("A2").CopyFromRecordset rs
 
    'nagłówki
    Dim LK As Long, K As Long
    LK = rs.Fields.Count
    For K = 1 To LK
        Sheets(ARK_DANE).Cells(1, K) = rs.Fields(K - 1).Name
    Next
 
    Zakres.EntireColumn.AutoFit
 
Czyszczenie:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
Obsluga:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, WERSJA
    Resume Czyszczenie
End Sub

ADO – i wszystkie bazy są nasze :)

Kategorie: Access VBA,Excel VBA,Office VBA,SQL Server — Darek Kolasa o 14:36, 23 Gru 2014

Od 2000 roku czyli już od kilkunastu lat Microsoft Office może bez problemu łączyć się w zasadzie z dowolnymi bazami danych, dzięki bibliotece ADO (Microsoft ActiveX Data Object XX Library). I od tych samych kilkunastu lat budzi to niezmiennie zdziwienie wśród moich klientów i studentów. Jak to? Excel może pobrać dane z Oracle?, SQL Servera? O! Może nawet je edytować?! No oczywiście, że może, i to od wielu lat…
Biblioteka ADO (w kodzie widoczna jako ADODB) jest domyślnie podłączana tylko w Accessie. We wszystkich innych produktach, w tym w Excelu trzeba ją wybrać w referencjach. Tools – References – Microsoft ActiveX Data Object XX Library, gdzie XX to numer wersji biblioteki, ja osobiście wybieram zwykle wersję 2.8
Drugi warunek to oczywiście poprawnie zainstalowany sterownik OLEDB do określonej bazy (http://en.wikipedia.org/wiki/OLE_DB_provider)

Poniżej przykład pobierający do Excela dane z Accessa 2003, ale uważny czytelnik zobaczy drogę pobierania z Accessa 2007/10/13 tudzież z SQL Servera. Wystarczy podmienić wartość właściwości ConnectionString obiektu Connection

Option Explicit
Public Const WERSJA As String = "ADO Klient v.0.1"
Public Const ARK_DANE As String = "Dane"
Public Const ZRODLO As String = "tbBrutto"
 
'Załozenia:
' - mamy arkusz o nazwie "Dane"
' - mamy bazę PodstawyVBA.mdb a w niej tabelę tbBrutto
' - mamy sterownik do mdb
 
'Access mdb
'==========
Public Const CN_STR As String = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.mdb;" & _
    "Persist Security Info=False"
 
 
'Ponizej przykłady konfiguracji dla innych baz
 
'Access accdb
'============
'Public Const CN_STR As String = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=D:\kursy\AC04\PodstawyVBA.accdb;" & _
    "Persist Security Info=False"
 
'SQL Server
'==========
'Public Const CN_STR As String = _
    "Provider=SQLOLEDB.1;Integrated Security=SSPI;" & _
    "Persist Security Info=False;" & _
    "Initial Catalog=Produkcyjna;" & _
    "Data Source=SKARBEKMC\SQLEXPRESS"
 
 
Sub OdczytDoExcela()
    Dim Zakres As Range
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
 
    On Error GoTo Obsluga
 
    Sheets(ARK_DANE).Select
    Range("A1").Select
    Set Zakres = _
        Sheets(ARK_DANE).Range("A1").CurrentRegion
    Zakres.ClearContents
 
    cn.ConnectionString = CN_STR
    cn.Open
    rs.Open ZRODLO, cn
    Sheets(ARK_DANE).Range("A2").CopyFromRecordset rs
 
    'nagłówki
    Dim LK As Long, K As Long
    LK = rs.Fields.Count
    For K = 1 To LK
        Sheets(ARK_DANE).Cells(1, K) = rs.Fields(K - 1).Name
    Next
 
    Zakres.EntireColumn.AutoFit
 
Czyszczenie:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
Obsluga:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, WERSJA
    Resume Czyszczenie
End Sub

Sprawdzenie dostępności pliku

Kategorie: Access VBA,Excel VBA,Office VBA,Ogólne,Podstawy VBA — Dariusz Kolasa o 1:11, 19 Lip 2012

Czasem chcielibyśmy wiedzieć, czy plik na którym chcemy wykonać jakąś operację, jest dla nas dostępny. Np gdy jest otwarty przez innego użytkownika próba jego użycia może powodować błąd. Ponadto wcześniej należy sprawdzić czy dany plik w ogóle istnieje. Można to sprawdzić przy pomocy poniższych funkcji:

Sub TestFunkcji()
    Const NAZWA_PLIKU As String = "C:\EX04\Baza.xls"
    If BrakPliku(NAZWA_PLIKU) Then Exit Sub
    If PlikNiedostepny(NAZWA_PLIKU) Then Exit Sub
    MsgBox "Plik jest dostępny, można coś z nim robić ;)", vbInformation
End Sub
 
Function PlikNiedostepny(NazwaPliku As String) As Boolean
    Dim NrPliku As Long
 
    On Error GoTo Obsluga
 
    NrPliku = FreeFile()
    Open NazwaPliku For Binary Access Read Write Lock Read Write As #NrPliku
    Close #NrPliku
    Exit Function
Obsluga:
    Select Case Err
    Case 70
        MsgBox "Plik jest obecnie otwarty przez inny proces", vbExclamation
    Case Else
        MsgBox "Przy próbie otwarcia pliku zgłaszany jest błąd: " _
            & Err & " - " & Err.Description, vbCritical
    End Select
    PlikNiedostepny = True
End Function
 
Function BrakPliku(PelnaNazwaPliku As String) As Boolean
    If Dir(PelnaNazwaPliku) = "" Then
        MsgBox "Brak pliku", vbCritical, WERSJA
        BrakPliku = True
    End If
End Function

Jak dopisać nowy rekord na podformularzu

Kategorie: Access VBA — Dariusz Kolasa o 10:06, 10 Kwi 2012

To dość często pojawiające się pytanie, więc odpowiedź upubliczniam :). Załóżmy, że podformularz nazywa się fmPozycjeFaktur i zawiera pola tekstowe TowarID i Ilosc. Procedura dodania rekordu na takim podformularzu wyglądałaby tak:

    Me.fmPozycjeFaktur.SetFocus
    DoCmd.GoToRecord , , acNewRec
    Me.fmPozycjeFaktur.Form.TowarID = 5
    Me.fmPozycjeFaktur.Form.Ilosc = 2

Funkcja mediana w Access

Kategorie: Access 2010,Access VBA — Dariusz Kolasa o 21:42, 12 Mar 2012

Znalezione na stronach MS. Działa :)

Kod funkcji mediana (DMedian)

Kolejne zastosowanie rekordsetu DAO :)
Funkcja działa jak standardowa accessowa funkcja agregacji domeny, a więc wymaga argumentów typu string np – DMedian(„pole”, „domena”)
opcjonalnie jako trzeci argument można też podać string z kryterium filtrowania domeny np – „[pole] > 1000”

Jak zabezpieczyć kod w Access 2010

Kategorie: Access 2010,Access VBA,Office 2010 — Dariusz Kolasa o 23:59, 2 Lut 2012

Kiedyś było w menu Narzędzia bazy danych – Utwórz plik mde. W Accessie 2010 jest w Plik – Zapisz i publikuj – Utwórz plik ACCDE. Jedno i drugie powoduje wyprodukowanie pliku z usuniętym kodem źródłowym i z blokadą projektów formularzy i raportów. Nie blokuje dostępu do projektów kwerend i tabel. Proszę zauważyć, że nikt łącznie z autorem nie ma już w tym pliku możliwości modyfikacji kodu lub projektu formularza czy raportu! Trzeba koniecznie zachować oryginał accdb!

Konwersja kwot amerykańskich na polskie

Kategorie: Access VBA — Dariusz Kolasa o 19:46, 5 Paź 2011

Bardzo często przy imporcie czy linkowaniu plików txt w Accessie mamy problem z niepolskimi separatorami w kwotach np 1,000.00. Z niewiadomych przyczyn Excel ma narzędzie do prawidłowego rozpoznawania separatora tysięcy a Access nie. Stąd w Accessie musimy w specyfikacji importu/łącza ustawić taką kolumnę jako tekstową a następnie przerobić w niej separatory np przy pomocy poniższej funkcji (powinna być wgrana do modułu publicznego aby można jej używać w dowolnej kwerendzie):

Function KwotaUSA2PL(KwotaUSA As String) As Currency
    Dim NrZnaku As Long
    Dim Znak As String
    Dim t As String
    Dim txtKwota As String
    t = Trim(KwotaUSA)
    For NrZnaku = 1 To Len(t)
        Znak = Mid(t, NrZnaku, 1)
        If Znak = "." Then
            txtKwota = txtKwota & ","
        Else
            If Znak <> "," Then
                txtKwota = txtKwota & Znak
            End If
        End If
    Next
    KwotaUSA2PL = CCur(txtKwota)
End Function

W komentarzach pojawiła się ciekawa dyskusja, jak tą funkcję zastąpić wyrażeniem z użyciem funkcji Replace

Co się stało z DAO w Access 2007/2010?

Kategorie: Access VBA,Office 2007,Office 2010 — Dariusz Kolasa o 21:17, 11 Cze 2011

Otóż zostało ono wbudowane w bibliotekę Accessa 2007/2010! Nie wiem po co ale tak właśnie się stało. nawet nie próbuj ustawiać referencji do klasycznego DAO 3.6, nie da się włączyć. Wywala komunikat o konflikcie. Na szczęście nie trzeba tego robić, po prostu biblioteka DAO jest dostępna bez tego, co widać w kodzie na liście IntelliSense.

Odwieczny problem: Funkcja Slownie

Kategorie: Access VBA,Excel VBA,Uniwersalne VBA — Dariusz Kolasa o 13:38, 24 Kwi 2011

Jak na razie to największy kawałek kodu na tej stronie. Funkcja Slownie, czyli zamieniająca kwotę na jej słowny odpowiednik nie jest dostępna w Excelu ani w żadnej innej aplikacji Microsoft Office (o ile mi wiadomo).

I tu korekta (jak sądzę). W komentarzu pod tym artykułem znajduje się funkcja działająca w SQL Server Reporting Services. Komentarz autorstwa Pana Adama.

Oczywiście w Sieci można znaleźć wiele przykładów jej implementacji ale cóż warta byłaby strona o VBA, gdyby jej tu nie można było znaleźć. Wszelkie wytknięte błędy i konstruktywne uwagi krytyczne będą mile widziane (dwa błędy już zostały wykryte i poprawione). Funkcja korzysta z dwóch pomocniczych funkcji prywatnych, bez których nie będzie działać. Oto kod:

 
Option Explicit
 
Function Slownie(Kwota As Variant) As String
   '==================================
    ' UWAGA! Funkcja wymaga obu funkcji
    ' prywatnych zamieszczonych poniżej
    '==================================
 
    Const WERSJA As String = _
        "Funkcja Słownie v.1.02 (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
 
    wynikGrosze = Trojka(Grosze) & _
        OpisRzeduWielkosci(CLng(Grosze), "gr", False)
 
    If wynikGrosze = "" Then wynikGrosze = "zero groszy"
 
    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
Wcześniejsze wpisy »