|
| | | |
 • II.5. VBA - Operacje na liczbach [1] •
- 5.1 Jak zaokrąglić liczbę do n cyfr po przecinku, bo funkcja Round(...) źle działa ?
- 5.2 Czy zawsze np. (2,3 - 2,3) = 0 ?
- 5.3 Dlaczego jak przypisuję do zmiennej Long wynik iloczynu (255 * 255) Access zgłasza błąd "Przepełnienia" ?
- 5.4 Jak pobrać systemowy separator dziesiętny ?
- 5.5 Jak obliczyć silnię liczby (max. 27) oraz jak obliczyć liczbę, której silnią jest liczba X ?
- 5.6 Jak pobrać ze zmiennej typu Long młodsze i starsze słowo oraz młodszy i starszy bajt z każdego słowa ?
- 5.7 Jak przekonwertować liczbę do postaci Hexadecymalnej i odwrotnie ?
- 5.8 Jak przypisać do zmiennej Variant (podtyp Decimal) liczbe przekraczajacą zakres
typu Long np. 10888869450418352160768000000 ?
- 5.9 Jak pobrać ilość dni w miesiącu dla danego roku ?
- <<• idź do str. 2 •>>
| | | | |
 |
| | |
|
5.1 Jak zaokrąglić liczbę do n cyfr po przecinku, bo funkcja Round(...) źle działa ?
' wykonajmy mały test funkcja Round (...) :
Private Sub btnTest_Click()
Debug.Print "Round"
Debug.Print 1.015, Round(1.015, 2) ' zwraca 1.01
Debug.Print 1.025, Round(1.025, 2) ' zwraca 1.02
Debug.Print 1.075, Round(1.075, 2) ' zwraca 1.08
Debug.Print 1.085, Round(1.085, 2) ' zwraca 1.08
' Jak widać funkcja Round(...) nie zwraca takich wartości jakie byśmy oczekiwali.
' No cóż, trudno... , zawsze możesz spróbowac użyć funkcji Błażeja,
' lub zajrzeć na http://www.access.vis.pl/af0808.htm - Function Zaokr2(...)
Call btnTest1_Click
DoCmd.RunCommand acCmdDebugWindow
End Sub
Private Sub btnTest1_Click()
Debug.Print "bs_Round"
Debug.Print 1.015, bs_Round(1.015, 2) ' zwraca 1.02
Debug.Print 1.025, bs_Round(1.025, 2) ' zwraca 1.03
Debug.Print 1.075, bs_Round(1.075, 2) ' zwraca 1.08
Debug.Print 1.085, bs_Round(1.085, 2) ' zwraca 1.09
End Sub
<cyt>
Public Function bs_Round(Number As Variant, _
NumDigitsAfterDecimal As Long) As Double
If Not IsNumeric(Number) Then Err.Raise 5
bs_Round = Sgn(Number) * Int(CDec(Abs(Number)) * _
(10 ^ NumDigitsAfterDecimal) + 0.5) / _
(10 ^ NumDigitsAfterDecimal)
End Function
</cyt>
ΔΔΔ | | | | |
|
|
| | |
|
5.2 Czy zawsze np. (2,3 - 2,3) = 0 ?
' I tak, i nie. Zobacz sam ;-)
Private Sub btnTest_Click()
Debug.Print "1. = "; 2.3 - (23 / 10)
Debug.Print "2. = "; CSng(2.3) - (23 / 10)
Debug.Print "3. = "; (2.3) - CSng(23 / 10)
Debug.Print "4. = "; CSng(2.3) - CSng(23 / 10)
Debug.Print "5. = "; (2.3) - CDbl(23 / 10)
Debug.Print "6. = "; CDbl(2.3) - CDbl(23 / 10)
Debug.Print "7. = "; (2.3) - CDec(23 / 10)
DoCmd.RunCommand acCmdDebugWindow
End Sub
Podobny problem został poruszony:
ΔΔΔ | | | | |
|
|
| | |
|
5.3 Dlaczego jak przypisuję do zmiennej Long wynik iloczynu (255 * 255) Access zgłasza błąd "Przepełnienia" ?
Private Sub btnTest_Click()
Dim lRet As Long
On Error Resume Next
' wystąpi błąd przepełnienia
lRet = 255 * 255
Debug.Print lRet;
If Err.Number <> 0 Then Debug.Print "- "; Err.Description
On Error GoTo 0
' nie będzie błędu
lRet = CLng(255) * 255
Debug.Print lRet
Debug.Print "====================="
' dzieje się tak ponieważ domyślnym typem liczby jest typ Integer. Błąd przepełnienia wystąpi również, gdy zadeklarujemy zmienną jako Byte i pomnożymy ją przez siebie, a wynik będzie przekraczał zakres typu Byte:
Dim b As Byte
b = 16
lRet = 0 ' czyścimy zmienną
On Error Resume Next
' wystąpi błąd przepełnienia
lRet = b * b
Debug.Print lRet;
If Err.Number <> 0 Then Debug.Print "- "; Err.Description
On Error GoTo 0
' nie będzie błędu
lRet = CInt(b) * b
Debug.Print lRet
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.4 Jaki pobrać systemowy separator dziesiętny ?
Private Declare Function GetLocaleInfo Lib "kernel32" _
Alias "GetLocaleInfoA" _
(ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long
Private Const LOCALE_USER_DEFAULT = &H400
Private Const LOCALE_SDECIMAL = &HE
' Metoda I - sestemowy separator dziesiętny pobierzemy używając funkcji API
Private Function zbGetDecSep1() As String
Dim lRet As Long
Dim sBffInfo As String
Const MY_SIZEBUFFER As Long = 255
sBffInfo = String(cSizeBff, vbNullChar)
lRet = GetLocaleInfo(LOCALE_USER_DEFAULT, _
LOCALE_SDECIMAL, _
sBffInfo, MY_SIZEBUFFER)
zbGetDecSep1 = Left$(sBffInfo, lRet - 1)
' • jeżeli użytkownik ustawił w Panelu sterowania separator dziesiętny w postaci kilku znaków (w Win98 możliwe jest wstawienie trzech znaków) to funkcja ta zwróci nam błędny wynik w postaci ciągu wpisanych znaków,
' • wielkość bufora jest zdecydowanie za duża, teoretycznie powinna wystarczyć wartość 3 (max. trzy znaki), a vbNullChar doda sam VBA, ale dla mniejszych wartości funkcja GetLocaleInfo(...) może zwrócić ZERO
End Function
' pobierzmy więc tylko pierwszy znak zwracanego ciągu separatora dziesiętnego
Private Function zbGetDecSep2() As String
Dim lRet As Long
Const MY_SIZEBUFFER As Long = 255
zbGetDecSep2 = vbNullChar
lRet = GetLocaleInfo(LOCALE_USER_DEFAULT, _
LOCALE_SDECIMAL, _
zbGetDecSep2, _
MY_SIZEBUFFER)
If lRet = 0 Then zbGetDecSep2 = ""
End Function
' Metoda II - pl.comp.bazy-danych.msaccess - Piotr Lipski
' separator dziesiętny jest drugim znakiem w ilorazie 1/2 = 0,5)
Private Function accGetDecSep() As String
accGetDecSep = Mid$(CStr((1 / 2)), 2, 1)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Debug.Print "1. zbGetDecSep1 = ", zbGetDecSep1
Debug.Print "2. zbGetDecSep2 = ", zbGetDecSep2
Debug.Print "3. accGetDecSep = ", accGetDecSep
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.5 Jak obliczyć silnię liczby (max. 27) oraz jak obliczyć liczbę, której silnią jest liczba X ?
Private Const ERR_ARG_SILNIA = vbObjectError + 100
Private Const ERR_ARG_ANTYSILNIA = vbObjectError + 101
' dla i = 0 zwraca 1, przy błędnej wartości zwraca -1
' przy przekroczniu zakresu i > 27 generuje błąd
Function knSilnia(i As Byte) As Variant
knSilnia = -1
If i > 27 Then
Err.Raise ERR_ARG_SILNIA, "knSilnia", _
"Wartość argumentu funkcji knSilnia(...)" & _
vbNewLine & "nie może być większa od 27"
End If
If i <2 Then
knSilnia = 1
Else
knSilnia = CDec(knSilnia(i - 1) * i)
End If
End Function
'<KN>
' działa do 27!
' powyżej tej liczby dzielenie musisz robić samodzielnie,
' tak jak Cię uczono w szkole, słupkowo
'</KN>
' dla k = 0; k = 1 zwraca 1, przy błędnej wartości zwraca -1
' przy przekroczniu dopuszczlnego zakresu generuje błąd,
Function knAntySilnia(ByVal k As Variant) As Variant
Dim i As Integer
knAntySilnia = -1
If k - CDec("10888869450418352160768000000") > 0 Then
Err.Raise ERR_ARG_ANTYSILNIA, "knSAntyilnia", _
"Wartość argumentu funkcji knAntySilnia(...)" & _
vbNewLine & "nie może być większa od:" & _
vbNewLine & _
"10888869450418352160768000000"
End If
If k = 0 Or k = 1 Then
knAntySilnia = 1
Exit Function
End If
Do Until k = 1
i = i + 1
k = k / i
If k - Int(k) > 0 Then Exit Function
Loop
knAntySilnia = i
End Function
przykładowe wywołanie:
Private Sub btnTest_Click()
On Error GoTo ErrHandler
Dim i As Byte
Dim lRet As Variant
For i = 0 To 27
lRet = knSilnia(i)
Debug.Print i; lRet;
Debug.Print knAntySilnia(lRet + 1)
Next
DoCmd.RunCommand acCmdDebugWindow
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & vbNewLine & _
Err.Description
Resume ExitHere
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.6 Jak pobrać ze zmiennej typu Long młodsze i starsze słowo oraz młodszy
i starszy bajt z każdego słowa ?
' Metoda I - opisana w MSDN,
' Tip 22: Converting DWords, Words, and Bytes
' Artykuły w Bazie Wiedzy Microsoft - 189170
' How To Package HiWord / LoWord Values Into a Long Parameter
' Artykuły w Bazie Wiedzy Microsoft - 112651
' How to Mimic HIWORD, LOWORD, HIBYTE, LOBYTE C Macros in VB
z poprawkami: Krzysztofa Naworyty
grupa: pl.comp.lang.vbasic
wątek: HiWord LoWord
Private Function MakeDWord( _
ByVal iHiWord As Integer, _
ByVal iLoWord As Integer) As Long
MakeDWord = (iHiWord * &H10000) Or (iLoWord And &HFFFF)
End Function
Private Function MakeWord( _
ByVal bHiByte As Byte, _
ByVal bLoByte As Byte) As Integer
'<KN>
If bHiByte < &H80 Then
MakeWord = (bHiByte * &H100) Or bLoByte
Else
MakeWord = (bHiByte Or &HFF00) * &H100& Or bLoByte
End If
'</KN>
End Function
Private Function HiWord(ByVal DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
Private Function LoWord(ByVal DWord As Long) As Integer
If DWord And &H8000& Then
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function
Private Function HiByte(ByVal Word As Integer) As Byte
'<KN>
HiByte = (Word And &HFF00&) \ &H100&
'</KN>
End Function
Private Function LoByte(ByVal Word As Integer) As Byte
LoByte = Word And &HFF
End Function
' Metoda II - z użyciem funkcji CopyMemory (...)
' jest ok. 2x szybsza od metody MSDN i moim zdaniem bardziej
' uniwersalna, aczkolwiek wymagająca deklarowania tablic,
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Function zbMakeDWord( _
HiWord As Integer, _
LoWord As Integer) As Long
Dim aInt(0 To 1) As Integer
aInt(0) = LoWord: aInt(1) = HiWord
CopyMemory zbMakeDWord, aInt(0), 4
End Function
Private Function zbMakeWord( _
HiByte As Byte, _
LoByte As Byte) As Integer
Dim aByte(0 To 1) As Byte
aByte(0) = LoByte: aByte(1) = HiByte
CopyMemory zbMakeWord, aByte(0), 2
End Function
' zwraca DWord z przekazanej tablicy zawierającej cztery bajty,
' bez konieczności tworzenia starszego i młodszego słowa
Private Function zbHiLoByteToDWord(aByte() As Byte) As Long
CopyMemory zbHiLoByteToDWord, aByte(0), 4
End Function
' zwraca ByRef w tablicy aWord() starsze i młodsze słowo
' i ByRef w tablicy aByte() wszystkie bajty,
Private Sub zbRetHiLoWordByte( _
lDWord As Long, _
aWord() As Integer, _
aByte() As Byte)
CopyMemory aWord(0), lDWord, 4
CopyMemory aByte(0), lDWord, 4
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim bHiByte_Hi As Byte, bHiByte_Lo As Byte
Dim bLoByte_Hi As Byte, bLoByte_Lo As Byte
Dim iHiWord As Integer, iLoWord As Integer
Dim aWords(0 To 1) As Integer
Dim aBytes(0 To 3) As Byte
Dim lDWord As Long
' ustawmy poszczególne bajty
bHiByte_Hi = 9: bHiByte_Lo = 8
bLoByte_Hi = 7: bLoByte_Lo = 6
' Metoda I - MSDN + poprawki Krzysztofa Naworyty
Debug.Print String(20, "="); " MSDN "; String(29, "=")
iHiWord = MakeWord(bHiByte_Hi, bHiByte_Lo)
iLoWord = MakeWord(bLoByte_Hi, bLoByte_Lo)
lDWord = MakeDWord(iHiWord, iLoWord)
Debug.Print "HiWord ="; iHiWord, _
"Hi_HiByte"; bHiByte_Hi, "Hi_LoByte"; bHiByte_Lo
Debug.Print "LoWord ="; iLoWord, _
"Lo_HiByte"; bLoByte_Hi, "Lo_LoByte"; bLoByte_Lo
Debug.Print "DWord ="; lDWord
Debug.Print String(20, "="); " CopyMemory "; String(23, "=")
' Metoda II - za pomocą funkcji CopyMemory
iHiWord = zbMakeWord(bHiByte_Hi, bHiByte_Lo)
iLoWord = zbMakeWord(bLoByte_Hi, bLoByte_Lo)
lDWord = zbMakeDWord(iHiWord, iLoWord)
Debug.Print "HiWord ="; iHiWord, _
"Hi_HiByte"; bHiByte_Hi, "Hi_LoByte"; bHiByte_Lo
Debug.Print "LoWord ="; iLoWord, _
"Lo_HiByte"; bLoByte_Hi, "Lo_LoByte"; bLoByte_Lo
Debug.Print "DWord ="; lDWord
Debug.Print ; String(20, "="); " DWord => CopyMemory ";
Debug.Print ; String(14, "=")
' Test - spróbujmy ze zmiennej lDWord odczytać starsze
' i młodsze słowo oraz starsze i młodsze bajty za pomocą
' funkcji CopyMemory
zbRetHiLoWordByte lDWord, aWords(), aBytes()
Debug.Print "DWord ="; lDWord
Debug.Print "HiWord ="; aWords(1), _
"Hi_HiByte"; aBytes(3), "Hi_LoByte"; aBytes(2)
Debug.Print "LoWord ="; aWords(0), _
"Lo_HiByte"; aBytes(1), "Lo_LoByte"; aBytes(0)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.7 Jak przekonwertować liczbę do postaci Hexadecymalnej i odwrotnie ?
grupa: pl.comp.bazy-danych.msaccess
wątek: Konwersja z HEX
w oparciu o artykuł: Krzysztofa Naworyty
Private Sub btnTest_Click()
Dim sHex As String
Const MY_TEST As Long = 2141234547
' Dec => Hex
sHex = Hex$(MY_TEST)
' Hex => Dec
Debug.Print "Dec: "; MY_TEST; "=> Hex: "; sHex; _
" => knHexToDec: "; knHexToDec(sHex)
DoCmd.RunCommand acCmdDebugWindow
End Sub
Private Function knHexToDec(sHex As String) As Long
knHexToDec = CLng("&H" & sHex)
End Function
' komentarz Krzysztofa Czuryło:
' <cyt>
Prostota tego rozwiązania jest urzekająca! :-)
</cyt>
ΔΔΔ | | | | |
|
|
| | |
|
5.8 Jak przypisać do zmiennej Variant (podtyp Decimal) liczbe przekraczajacą zakres typu Long np. 10888869450418352160768000000 ?
<cyt>
' Musi być wartość funkcji CDec w cudzysłowiu,
' inaczej argumet jest konwertowany do Double,
' czyli:
Debug.Print CDec("10888869450418352160768000001") - _
CDec("10888869450418352160768000000")
</cyt>
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim v1 As Variant, v2 As Variant
v1 = CDec("10888869450418352160768000001")
v2 = CDec("10888869450418352160768000000")
Debug.Print v1; "-"; v2; " = "; v1 - v2
DoCmd.RunCommand acCmdDebugWindow
End Sub
' pozwolę sobie dodać komentarz Krzysztofa Naworyty
' <cyt>
' Zważywszy, że CDec() istnieje od a'97 (czyli mniej więcej od 8-u lat!) jest dla mnie niesamowitością kompletną, że dopiero teraz dowiaduję się o pewnych "smaczkach" !
</cyt>
ΔΔΔ | | | | |
|
|
| | |
|
5.9 Jak pobrać ilość dni w miesiacu dla danego roku ?
' zwraca ilość dni w miesiącu określonego roku
Private Function rpDaysInMonth(iYear As Integer, _
iMonth As Integer) As Integer
rpDaysInMonth = Day(DateSerial(iYear, iMonth + 1, 1) - 1)
End Function
' - na podstawie HELP Access' 97:
' zwraca ilość dni w miesiącu dla określonej daty
Function DaysInMonth(dteInput As Date) As Integer
Dim intDays As Integer
' dodaj miesiąc i pobierz różnicę
intDays = DateSerial(Year(dteInput), Month(dteInput) + 1, _
Day(dteInput)) - DateSerial(Year(dteInput), _
Month(dteInput), Day(dteInput))
DaysInMonth = intDays
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim intDays As Integer
' HELP Access' 97
intDays = DaysInMonth(#2/1/04#) ' 01 luty 2004
Debug.Print "1. "; "#2/1/04# ", , intDays
' zależne od ustawień regionalnych
intDays = DaysInMonth("1-2-2004")
Debug.Print "2. "; "1-2-2004 ", , intDays
' zależne od wersji językowej
' intDays = DaysInMonth("February 1, 2004")
' zależne od wersji językowej
intDays = DaysInMonth("Luty 1, 2004")
Debug.Print "3. "; "Luty 1, 2004 ", intDays
' Rafał Posmyk
Debug.Print "4. "; "rpDaysInMonth: ", rpDaysInMonth(2004, 2)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
| |
