|
| | | |
 • II.5. VBA - Operacje na liczbach [2] •
- 5.10 Jak zamienić liczbę typu Long na postać dwójkową za pomocą kodu VBA oraz jak to zrobić za pomocą kwerendy (bez użycia funkcji zewnętrznych) ?
- 5.11 Jak przyspieszyć od 2 do 12 razy kopiowanie tablicy zawierającej dane liczbowe ?
- 5.12 Jak przyspieszyć od 3 do 15 razy wstawianie tablicy do tablicy z danymi liczbowymi ?
- 5.13 Jak przekonwertować czas uniwersalny UTC na czas lokalny i odwrotnie ?
- 5.14 Jak pobrać separator daty, format daty krótkiej, ilość dni w miesiącu, nazwy miesięcy, nazwy dni tygodnia, pierwszy pełny tydzień w roku ?
- <<• idź do str. 1 •>>
| | | | |
 |
| | |
|
5.10 Jak zamienić liczbę typu Long na postać dwójkową za pomocą kodu VBA oraz jak to zrobić za pomocą kwerendy (bez użycia funkcji zewnętrznych) ?
• Metoda I - Za pomocą kodu VBA
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
' funkcja konwertuje liczbę na postać dwójkową (ciąg znaków "0" lub "1") określających stan poszczególnych bitów liczby
Public Function zbLongToBin(lNumber As Long) As String
Dim aAsc01(0 To 31) As Byte
Static aExp(0 To 31) As Long
Static sZeroString As String
Dim i As Long
Const MY_ASC_1 As Long = 49
' jednorazowo (przy pierwszym wywołaniu funkcji) zapełnij tablicę aExp() i ustaw zmienną sZeroString (obie typu Static),
If Len(sZeroString) = 0 Then
sZeroString = String(32, "0")
' zapełnij tablicę wartościami potęg liczby 2
For i = 0 To 30
aExp(i) = (2 ^ i)
Next
End If
' resetuj tablicę aAsc01 wartościami Asc("0")
CopyMemory aAsc01(0), ByVal sZeroString, 32
For i = 30 To 0 Step -1
' dla ustawionych bitów, zmień wartość elementu
' tablicy na wartość Asc("1")
If (lNumber And aExp(i)) > 0 Then
aAsc01(31 - i) = MY_ASC_1
End If
Next
' dla liczb ujemnych ustaw wartość elementu tablicy
' określający bit znaku na Asc("1")
If lNumber < 0 Then aAsc01(0) = MY_ASC_1
zbLongToBin = StrConv(aAsc01(), vbUnicode)
End Function
' funkcja konwertuje postać dwójkową liczby (ciąg znaków "0" i "1") na liczbę
Public Function zbBinToLong(sBinString As String) As Long
Dim aBits(0 To 31) As Byte
Dim sBaseString As String
Dim i As Long
Const MY_ASC_0 As Long = 48
Const MY_ASC_1 As Long = 49
If Len(sBinString) = 0 Or Len(sBinString) > 32 Then Exit Function
sBaseString = String(32, "0")
' wpisz do ciągu bazowego wejściowy ciąg bitów liczby
Mid$(sBaseString, 32 - Len(sBinString) + 1) = sBinString
CopyMemory aBits(0), ByVal sBaseString, Len(sBaseString)
For i = 1 To 31
Select Case aBits(i)
' dopuszczalne tylko Asc("0") lub Asc("1")
Case MY_ASC_0, MY_ASC_1
zbBinToLong = 2 * zbBinToLong + (aBits(i) - MY_ASC_0)
Case Else
' niedozwolony znak, zeruj funkcję
zbBinToLong = 0
Exit Function
End Select
Next
' jeżeli liczba ujemna, to ustaw bit znaku na 1
If aBits(0) = MY_ASC_1 Then
zbBinToLong = zbBinToLong Or &H80000000
End If
End Function
• Metoda II - Za pomocą kwerendy
SELECT
tNumbers.tValue,
[tValue]<0 AS tSign,
IIf([tSign]<0,[tValue]+1,[tValue]) AS MyValue,
IIf([tSign]<0,([MyValue]\2^0 Mod 2) +1, ([MyValue]\2^0 Mod 2)) AS B0,
IIf([tSign]<0,([MyValue]\2^1 Mod 2) +1, ([MyValue]\2^1 Mod 2)) AS B1,
IIf([tSign]<0,([MyValue]\2^2 Mod 2) +1, ([MyValue]\2^2 Mod 2)) AS B2,
IIf([tSign]<0,([MyValue]\2^3 Mod 2) +1, ([MyValue]\2^3 Mod 2)) AS B3,
IIf([tSign]<0,([MyValue]\2^4 Mod 2) +1, ([MyValue]\2^4 Mod 2)) AS B4,
IIf([tSign]<0,([MyValue]\2^5 Mod 2) +1, ([MyValue]\2^5 Mod 2)) AS B5,
IIf([tSign]<0,([MyValue]\2^6 Mod 2) +1, ([MyValue]\2^6 Mod 2)) AS B6,
IIf([tSign]<0,([MyValue]\2^7 Mod 2) +1, ([MyValue]\2^7 Mod 2)) AS B7,
IIf([tSign]<0,([MyValue]\2^8 Mod 2) +1, ([MyValue]\2^8 Mod 2)) AS B8,
IIf([tSign]<0,([MyValue]\2^9 Mod 2) +1, ([MyValue]\2^9 Mod 2)) AS B9,
IIf([tSign]<0,([MyValue]\2^10 Mod 2) +1, ([MyValue]\2^10 Mod 2)) AS B10,
IIf([tSign]<0,([MyValue]\2^11 Mod 2) +1, ([MyValue]\2^11 Mod 2)) AS B11,
IIf([tSign]<0,([MyValue]\2^12 Mod 2) +1, ([MyValue]\2^12 Mod 2)) AS B12,
IIf([tSign]<0,([MyValue]\2^13 Mod 2) +1, ([MyValue]\2^13 Mod 2)) AS B13,
IIf([tSign]<0,([MyValue]\2^14 Mod 2) +1, ([MyValue]\2^14 Mod 2)) AS B14,
IIf([tSign]<0,([MyValue]\2^15 Mod 2) +1, ([MyValue]\2^15 Mod 2)) AS B15,
IIf([tSign]<0,([MyValue]\2^16 Mod 2) +1, ([MyValue]\2^16 Mod 2)) AS B16,
IIf([tSign]<0,([MyValue]\2^17 Mod 2) +1, ([MyValue]\2^17 Mod 2)) AS B17,
IIf([tSign]<0,([MyValue]\2^18 Mod 2) +1, ([MyValue]\2^18 Mod 2)) AS B18,
IIf([tSign]<0,([MyValue]\2^19 Mod 2) +1, ([MyValue]\2^19 Mod 2)) AS B19,
IIf([tSign]<0,([MyValue]\2^20 Mod 2) +1, ([MyValue]\2^20 Mod 2)) AS B20,
IIf([tSign]<0,([MyValue]\2^21 Mod 2) +1, ([MyValue]\2^21 Mod 2)) AS B21,
IIf([tSign]<0,([MyValue]\2^22 Mod 2) +1, ([MyValue]\2^22 Mod 2)) AS B22,
IIf([tSign]<0,([MyValue]\2^23 Mod 2) +1, ([MyValue]\2^23 Mod 2)) AS B23,
IIf([tSign]<0,([MyValue]\2^24 Mod 2) +1, ([MyValue]\2^24 Mod 2)) AS B24,
IIf([tSign]<0,([MyValue]\2^25 Mod 2) +1, ([MyValue]\2^25 Mod 2)) AS B25,
IIf([tSign]<0,([MyValue]\2^26 Mod 2) +1, ([MyValue]\2^26 Mod 2)) AS B26,
IIf([tSign]<0,([MyValue]\2^27 Mod 2) +1, ([MyValue]\2^27 Mod 2)) AS B27,
IIf([tSign]<0,([MyValue]\2^28 Mod 2) +1, ([MyValue]\2^28 Mod 2)) AS B28,
IIf([tSign]<0,([MyValue]\2^29 Mod 2) +1, ([MyValue]\2^29 Mod 2)) AS B29,
IIf([tSign]<0,([MyValue]\2^30 Mod 2) +1, ([MyValue]\2^30 Mod 2)) AS B30,
IIf([tValue]<0,1,0) AS B31,
[B31] & [B30] & [B29] & [B28] & [B27] & [B26] & [B25] & [B24] &
[B23] & [B22] & [B21] & [B20] & [B19] & [B18] & [B17] & [B16] &
[B15] & [B14] & [B13] & [B12] & [B11] & [B10] & [B9] & [B8] &
[B7] & [B6] & [B5] & [B4] & [B3] & [B2] & [B1] & [B0] AS BitString
FROM tNumbers;
ΔΔΔ | | | | |
|
|
| | |
|
5.11 Jak przyspieszyć od 2 do 12 razy kopiowanie tablicy zawierającej dane liczbowe ?
' Kopię tablicy każdego typu możemy wykonać przechodząc w pętli For Next po wszystkich elementach tablicy wejściowej i skopiować te elementy do tablicy docelowej, którą następnie zwrócimy ByRef w arumencie arrRet().
' Funkcja przy powodzeniu zwraca ilość elementów tablicy, przy niepowodzeniu Zero
Public Function zbCopyArrayForNext(arrIn() As Long, arrRet() As Long) As Long
Dim i As Long
' sprawdź, czy tablica jest zainicjowana
On Error Resume Next
i = UBound(arrIn)
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
On Error GoTo 0
ReDim arrRet(LBound(arrIn) To UBound(arrIn))
For i = LBound(arrIn) To UBound(arrIn)
arrRet(i) = arrIn(i)
Next
zbCopyArrayForNext = (UBound(arrRet) - LBound(arrRet) + 1)
End Function
' jeżeli chcemy przyspieszyć kopiowanie tablic, ale tylko tablic zawierających dane numeryczne, musimy proces ten częściowo wykonać bezpośrednio na blokach w pamięci, do czego potrzebne będą poniższe funkcje API:
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
' tworzy kopię tablicy wejściowej, którą zwraca ByRef w arumencie arrRet(), przy powodzeniu zwraca ilość elementów tablicy, w przeciwnym razie Zero
Public Function zbCopyArrayInMem( _
arrIn() As Long, _
arrRet() As Long) As Long
| Dim hMem As Long | ' uchwyt bloku pamięci |
| Dim pMem As Long | ' wskaźnik do bloku pamięci |
| Dim lSizeArrIn As Long | ' ilość elementów w tablicy bazowej |
| Dim lVarSize As Long | ' długość w bajtach elementu tablicy |
| Dim lLenData As Long | ' długość w bajtach danych w tablicy |
' sprawdź, czy tablica jest zainicjowana
On Error Resume Next
lSizeArrIn = (UBound(arrIn) - LBound(arrIn) + 1)
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
On Error GoTo 0
Select Case VarType(arrIn(LBound(arrIn)))
Case vbByte
lVarSize = 1
Case vbInteger, vbBoolean
lVarSize = 2
Case vbLong, vbSingle
lVarSize = 4
Case vbDouble, vbCurrency, vbDate
lVarSize = 8
Case Else
Exit Function
End Select
lLenData = lSizeArrIn * lVarSize
' alokuj blok w pamięci i pobierz jego uchwyt
hMem = GlobalAlloc(GMEM_MOVEABLE, lLenData)
' zablokuj blok pamięci i pobierz wskaźnik do pierwszego bajta
pMem = GlobalLock(hMem)
' ustaw rozmiar tablicy zwracanej
ReDim arrRet(LBound(arrIn) To UBound(arrIn))
' kopiuj tablicę do bloku pamięci
CopyMemory ByVal pMem, arrIn(LBound(arrIn)), lLenData
' kopiuj zawartość bloku pamięci do tablicy arrRet()
CopyMemory arrRet(LBound(arrIn)), ByVal pMem, lLenData
Call GlobalUnlock(hMem)
Call GlobalFree(hMem)
If (UBound(arrRet) - LBound(arrRet) + 1) = lSizeArrIn Then
zbCopyArrayInMem = lSizeArrIn
End If
End Function
| Porównanie szybkości obu funkcji dla tablicy 1 000 000 elementowej |
|---|
| Typ danych | zbCopyArrayForNext | zbCopyArrayInMem | Met.I/Met.II |
| Byte | 426 ms | 35 ms | 12,2 |
| Integer | 447 ms | 70 ms | 6,4 |
| Boolean | 448 ms | 72 ms | 6,2 |
| Long | 496 ms | 145 ms | 3,4 |
| Single | 447 ms | 142 ms | 3,1 |
| Double | 562 ms | 283 ms | 2,0 |
| Date | 572 ms | 282 ms | 2,0 |
| Currency | 563 ms | 283 ms | 2,0 |
• Jak widać szybkość funkcji zbCopyArrayForNext jest w niewielkim stopniu zależna od wielkości danych (426 ms dla 1 bajta i 560 ms dla 8 bajtów) o tyle szybkość funkcji zbCopyArrayInMem jest proporcjonalna do wielkości zmiennej. I tak dla 1 bajta 35 ms, dla 2 bajtów 70 ms, dla 4 bajtów 140 ms, a dla 8 bajtów 280 ms).
' w przypadku gdy musimy wykonać kopię tablicy typu Byte to możemy to zrobić jeszcze ok. 2x szybciej od zbCopyArrayInMem stosując bezpośrednie przypisanie
Public Function zbCopyArrayBytes( _
arrIn() As Byte, _
arrRet() As Byte) As Long
On Error Resume Next
' nawet nie musimy ustawiać wymiarów tablicy
arrRet() = arrIn()
zbCopyArrayBytes = (UBound(arrRet) - LBound(arrRet) + 1)
On Error GoTo 0
End Function
ΔΔΔ | | | | |
|
|
| | |
|
5.12 Jak przyspieszyć od 3 do 15 razy wstawianie tablicy do tablicy z danymi liczbowymi ?
' przy powodzeniu zwraca ilość elementów tablicy arrRet zwracanej w argumencie ByRef, przy niepowodzeniu zwraca wartość mniejszą od 1;
' - 3 "niezainicjowane obie tablice" i niezainicjowaną tablicę arrRet,
' - 2 "niezainicjowana tablica arrInsert()" i tablicę arrRet będącą kopią tablicy arrBase(),
' - 1 "niezainicjowana tablica arrBase()" i tablicę arrRet będącą kopią tablicy arrInsert(),
' 0 "nieprzewidziany błąd" i nieokreślony stan tablicy arrRet,
' • arrBase() - tablica bazowa, do której będziemy wstawiali drugą tablicę
' • arrInsert() - tablica wstawiana do pierwszej tablicy
' • lBefore - nr elementu (nie Index) tablicy, przed którym ma być wstawiona tablica
Public Function zbArrayIntoArrayForNext( _
arrBase() As Long, arrInsert() As Long, _
arrRet() As Long, lBefore As Long) As Long
Dim lSizeArrBase As Long
Dim lSizeArrIns As Long
Dim i As Long
Dim j As Long
' sprawdź, czy tablice są zainicjowane
On Error Resume Next
lSizeArrBase = (UBound(arrBase) - LBound(arrBase) + 1)
lSizeArrIns = (UBound(arrInsert) - LBound(arrInsert) + 1)
On Error GoTo 0
' obie niezainicjowane
If lSizeArrBase = 0 And lSizeArrIns = 0 Then
zbArrayIntoArrayForNext = -3
Exit Function
End If
' pierwsza tablica niezainicjowana, zwróć drugą tablicę
If lSizeArrBase = 0 Then
Call zbCopyArrayForNext(arrInsert, arrRet)
zbArrayIntoArrayForNext = -1
Exit Function
End If
' druga tablica niezainicjowana, zwróć pierwszą tablicę
If lSizeArrIns = 0 Then
Call zbCopyArrayForNext(arrBase, arrRet)
zbArrayIntoArrayForNext = -2
Exit Function
End If
' sprawdź poprawność miejsca wprowadzania drugiej tablicy
If lBefore < 1 Then lBefore = 1
If lBefore > lSizeArrBase Then lBefore = lSizeArrBase + 1
ReDim arrRet(LBound(arrBase) To LBound(arrBase) + _
lSizeArrBase + lSizeArrIns - 1)
' I - kopiuj pierwszą część
For i = LBound(arrBase) To LBound(arrBase) + lBefore - 2
arrRet(i) = arrBase(i)
Next
' II - kopiuj całą tablicę wstawianą
For j = LBound(arrInsert) To UBound(arrInsert)
arrRet(i) = arrInsert(j)
i = i + 1
Next
' III - kopiuj końcową cześć tablicy bazowej
For j = LBound(arrBase) + lBefore - 1 To UBound(arrBase)
arrRet(i) = arrBase(j)
i = i + 1
Next
If (UBound(arrRet) - LBound(arrRet) + 1) = _
lSizeArrBase + lSizeArrIns Then
zbArrayIntoArrayForNext = lSizeArrBase + lSizeArrIns
Else
zbArrayIntoArrayForNext = 0
End If
End Function
' jeżeli chcemy przyspieszyć wstawianie tablicy do tablicy, ale tylko dla tablic zawierających dane numerycznę, musimy proces ten częściowo wykonać bezpośrednio na blokach w pamięci, do czego potrzebne będą poniższe funkcje API:
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
' przy powodzeniu zwraca ilość elementów tablicy arrRet zwracanej w argumencie ByRef
' przy niepowodzeniu zwraca wartość mniejszą od 1;
' - 4 "nieobsługiwany typ zmiennej" i niezainicjowaną tablicę arrRet
' - 3 "niezainicjowane obie tablice" i niezainicjowaną tablicę arrRet
' - 2 "niezainicjowana tablica arrInsert()" i tablicę arrRet będącą kopią tablicy arrBase()
' - 1 "niezainicjowana tablica arrBase()" i tablicę arrRet będącą kopią tablicy arrInsert()
' 0 "nieprzewidziany błąd" i nieokreślony stan tablicy arrRet
' • arrBase() - tablica bazowa, do której będziemy wstawiali drugą tablicę
' • arrInsert() - tablica wstawiana do pierwszej tablicy
' • lBefore - nr elementu (nie Index) tablicy, przed którym ma być wstawiona tablica
Public Function zbArrayIntoArrayMem( _
arrBase() As Long, arrInsert() As Long, _
arrRet() As Long, lBefore As Long) As Long
| Dim lSizeArrBase As Long | ' ilość elementów w tablicy bazowej |
| Dim lSizeArrIns As Long | ' ilość elementów w tablicy wstawianej |
| Dim lMaxSizeBlock As Long | ' najdłuższy ciąg elementów do kopiowania |
| Dim lLenStart As Long | ' długość początkowej części tablicy bazowej |
| Dim lLenIns As Long | ' długość tablicy wstawianej |
| Dim lLenEnd As Long | ' długość końcowej części tablicy bazowej |
| Dim lVarSize As Long | ' długość w bajtach elementu tablicy |
| Dim hMem As Long | ' uchwyt bloku pamięci |
| Dim pMem As Long | ' wskaźnik do bloku pamięci |
| Dim lLBBase As Long | ' najniższy dopuszczalny Indeks tablicy bazowej |
' sprawdź, czy tablice są zainicjowane
On Error Resume Next
lSizeArrBase = (UBound(arrBase) - LBound(arrBase) + 1)
lSizeArrIns = (UBound(arrInsert) - LBound(arrInsert) + 1)
On Error GoTo 0
' obie niezainicjowane
If lSizeArrBase = 0 And lSizeArrIns = 0 Then
zbArrayIntoArrayMem = -3
Exit Function
End If
' pierwsza tablica niezainicjowana, zwróć drugą tablicę
If lSizeArrBase = 0 Then
Call zbCopyArrayInMem(arrInsert, arrRet)
zbArrayIntoArrayMem = -1
Exit Function
End If
' druga tablica niezainicjowana, zwróć pierwszą tablicę
If lSizeArrIns = 0 Then
Call zbCopyArrayInMem(arrBase, arrRet)
zbArrayIntoArrayMem = -2
Exit Function
End If
Select Case VarType(arrBase(LBound(arrBase)))
Case vbByte
lVarSize = 1
Case vbInteger, vbBoolean
lVarSize = 2
Case vbLong, vbSingle
lVarSize = 4
Case vbDouble, vbCurrency, vbDate
lVarSize = 8
Case Else
zbArrayIntoArrayMem = -4
Exit Function
End Select
' sprawdź poprawnowść miejsca wprowadzania drugiej tablicy
If lBefore < 1 Then lBefore = 1
If lBefore > lSizeArrBase Then lBefore = lSizeArrBase + 1
lLenStart = (lBefore - 1) * lVarSize
lLenIns = lSizeArrIns * lVarSize
lLenEnd = (lSizeArrBase - lBefore + 1) * lVarSize
' oblicz wielkość najmniejszego potrzebnego bloku pamięci
lMaxSizeBlock = lSizeArrIns * lVarSize
If lLenStart > lMaxSizeBlock Then lMaxSizeBlock = lLenStart
If lLenEnd > lMaxSizeBlock Then lMaxSizeBlock = lLenEnd
lLBBase = LBound(arrBase)
' ustaw rozmiar tablicy zwracanej
ReDim arrRet(lLBBase To lLBBase + lSizeArrBase + lSizeArrIns - 1)
' alokuj blok w pamięci i pobierz jego uchwyt
hMem = GlobalAlloc(GMEM_MOVEABLE, lMaxSizeBlock)
' zablokuj blok pamięci i pobierz wskaźnik do pierwszego bajta
pMem = GlobalLock(hMem)
' I - kopiuj pierwszą część tablicy do bloku pamięci
CopyMemory ByVal pMem, arrBase(lLBBase), lLenStart
' kopiuj zawartość bloku pamięci do arrRet()
CopyMemory arrRet(lLBBase), ByVal pMem, lLenStart
' II - kopiuj całą tablicę wstawianą do bloku pamięci
CopyMemory ByVal pMem, arrInsert(LBound(arrInsert)), lLenIns
lLBBase = lLBBase + lBefore - 1
' kopiuj zawartość bloku pamięci do arrRet()
CopyMemory arrRet(lLBBase), ByVal pMem, lLenIns
If lLenEnd > 0 Then
' III - kopiuj końcową cześć tablicy bazowej do bloku pamięci
CopyMemory ByVal pMem, arrBase(lLBBase), lLenEnd
' kopiuj zawartość bloku pamięci do arrRet()
CopyMemory arrRet(lLBBase + lSizeArrIns), _
ByVal pMem, lLenEnd
End If
Call GlobalUnlock(hMem)
Call GlobalFree(hMem)
If (UBound(arrRet) - LBound(arrRet) + 1) = _
lSizeArrBase + lSizeArrIns Then
zbArrayIntoArrayMem = lSizeArrBase + lSizeArrIns
Else
zbArrayIntoArrayMem = 0
End If
End Function
| Porównanie szybkości obu funkcji dla tablicy 1 000 000 elementowej |
|---|
| Typ | zbArray....ForNext | zbArray....Mem | Met.I/Met.II |
| Byte | 523 ms | 33 ms | 15,8 |
| Integer | 575 ms | 68 ms | 8,5 |
| Long | 581 ms | 131 ms | 4,4 |
| Double | 648 ms | 235 ms | 2,8 |
ΔΔΔ | | | | |
|
|
| | |
|
5.13 Jak przekonwertować czas uniwersalny UTC na czas lokalny i odwrotnie ?
Private Declare Function SystemTimeToFileTime Lib _
"kernel32" _
(lpSystemTime As SYSTEMTIME, _
lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib _
"kernel32" _
(lpFileTime As FILETIME, _
lpLocalFileTime As FILETIME) As Long
Private Declare Function LocalFileTimeToFileTime Lib _
"kernel32" _
(lpLocalFileTime As FILETIME, _
lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib _
"kernel32" _
(lpFileTime As FILETIME, _
lpSystemTime As SYSTEMTIME) As Long
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
' konwertuje czas uniwersalny UTC na czas lokalny
Public Function zbUTCDateToLocalDate(ByVal dt As Date) As Date
Dim st As SYSTEMTIME
Dim ftUTC As FILETIME
Dim ftLocal As FILETIME
' konwertuj DateTime na SYSTEMTIME
With st
.wYear = Year(dt)
.wMonth = Month(dt)
.wDay = Day(dt)
.wHour = Hour(dt)
.wMinute = Minute(dt)
.wSecond = Second(dt)
End With
' konwertuj SYSTEMTIME na FILETIME
SystemTimeToFileTime st, ftUTC
' konwertuj czas UTC na lokalny czas
FileTimeToLocalFileTime ftUTC, ftLocal
' konwertuj FILETIME na SYSTEMTIME
FileTimeToSystemTime ftLocal, st
' konwertuj SYSTEMTIME na DateTime
zbUTCDateToLocalDate = CDate( _
CDbl(DateSerial( _
st.wYear, st.wMonth, st.wDay)) + _
CDbl(TimeSerial( _
st.wHour, st.wMinute, st.wSecond)))
End Function
' konwertuje czas lokalny na czas uniwersalny UTC
Public Function zbLocalDateToUTCDate(ByVal dt As Date) As Date
Dim st As SYSTEMTIME
Dim ftUTC As FILETIME
Dim ftLocal As FILETIME
' konwertuj DateTime na SYSTEMTIME
With st
.wYear = Year(dt)
.wMonth = Month(dt)
.wDay = Day(dt)
.wHour = Hour(dt)
.wMinute = Minute(dt)
.wSecond = Second(dt)
End With
' konwertuj SYSTEMTIME na FILETIME
SystemTimeToFileTime st, ftLocal
' konwertuj czas lokalny na czas UTC
LocalFileTimeToFileTime ftLocal, ftUTC
' konwertuj FILETIME na SYSTEMTIME
FileTimeToSystemTime ftUTC, st
' konwertuj SYSTEMTIME na DateTime
zbLocalDateToUTCDate = CDate( _
CDbl(DateSerial( _
st.wYear, st.wMonth, st.wDay)) + _
CDbl(TimeSerial( _
st.wHour, st.wMinute, st.wSecond)))
End Function
ΔΔΔ | | | | |
|
|
| | |
|
5.14 Jak pobrać separator daty, format daty krótkiej, ilość dni w miesiącu, nazwy miesięcy, nazwy dni tygodnia, pierwszy pełny tydzień w roku ?
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_SDATE = &H1D
Private Const MY_SIZE_BUFFER As Long = 255
' zwraca separator krótkiego formatu Daty
Public Function zbGetShDtSep() As String
Dim lRet As Long
zbGetShDtSep = String(MY_SIZE_BUFFER, vbNullChar)
lRet = GetLocaleInfo(LOCALE_USER_DEFAULT, _
LOCALE_SDATE, _
zbGetShDtSep, MY_SIZE_BUFFER)
zbGetShDtSep = Left$(zbGetShDtSep, lRet - 1)
End Function
' jeżeli nie chcemy korzystać z API możemy spróbować pobrać znak separatora z ciągu znaków będącm odpowiednio sformatowaną datą
Public Function zbGetShDtSep_1() As String
' pobierz separator daty (trzeci znak za dwucyfrowym oznaczeniem dnia)
zbGetShDtSep_1 = Mid$(Format$(DateSerial(12, 12, 12), _
"dd/MM/yy"), 3, 1)
End Function
' zwraca pełną nazwę miesiąca
Public Function NameMonth(iMonth As Integer) As String
NameMonth = Format$((DateSerial(Year(Now()), _
iMonth, 1)), "MMMM")
End Function
' zwraca pełną nazwę dnia tygodnia
Public Function NameDay(dt As Date) As String
NameDay = Format$((DateSerial(Year(dt), _
Month(dt), Day(dt))), "dddd")
End Function
' zwraca ilość dni w danym miesiącu
Public Function DaysOfMonth(iYear As Integer, _
iMonth As Integer) As Integer
DaysOfMonth = Day(DateSerial(iYear, _
iMonth + 1, 0))
End Function
' zwraca w postaci opisowej (dd.MM.rr) format daty krótkiej
Public Function zbGetShDateFormat() As String
Dim sDtSep As String * 1
Dim aRet() As String
Dim sDtFormat As String
Dim lLen As Long
Dim i As Long
' pobierz separator daty
sDtSep = Mid$(Format$(DateSerial(12, 12, 12), "dd/MM/yy"), 3, 1)
' rozdziel elementy daty w/m separatora daty
' zbSplit DateSerial(3, 2, 1), aRet(), sDtSep, , vbTextCompare
aRet = Split(DateSerial(3, 2, 1), sDtSep, , vbTextCompare)
' sprawdzaj kolejno elementy składowe daty
For i = LBound(aRet) To UBound(aRet)
If IsNumeric(aRet(i)) Then
Select Case CLng(Right$(aRet(i), 2))
Case 1 ' dzień 1
sDtFormat = sDtFormat & String(Len(aRet(i)), "d") & sDtSep
Case 2 ' miesiąc luty
sDtFormat = sDtFormat & String(Len(aRet(i)), "M") & sDtSep
Case 3 ' rok 2003
sDtFormat = sDtFormat & String(Len(aRet(i)), "r") & sDtSep
Case Else
End Select
Else
' literowe oznaczenie miesiąca 'lut' lub 'luty'
lLen = Len(aRet(i)): If lLen > 4 Then lLen = 4
sDtFormat = sDtFormat & String(lLen, "M") & sDtSep
End If
Next
zbGetShDateFormat = Left$(sDtFormat, Len(sDtFormat) - 1)
End Function
' zwraca datę dla tygodnia zaczynający się od dnia iFirstDayOfWeek,
' począwszy od daty wejściowej, jeżeli szukany tydzień wypada
' na przełomie lat to zwraca datę pierwszego dnia tygodnia w następnym roku
Function zbGetFullWeekDate(dtIn As Date, _
Optional iFirstDayOfWeek As Integer = vbSunday) As Date
Dim dtCheckDate As Date
Dim iYear As Integer
Dim iDay As Integer
iYear = Year(dtIn)
dtCheckDate = dtIn
iDay = WeekDay(dtCheckDate, iFirstDayOfWeek)
Do Until iDay = 1
dtCheckDate = dtCheckDate + 1
iDay = WeekDay(dtCheckDate, iFirstDayOfWeek)
Loop
' może to być ostatni tydzień na przełomie roku
If Month(dtCheckDate) = 12 Then
' dodaj sześć dni i jeżeli styczeń, to dodaj do daty tydzień
If Month(dtCheckDate + 6) = 1 Then
dtCheckDate = dtCheckDate + 7
End If
End If
zbGetFullWeekDate = dtCheckDate
End Function
' przykładowe wywołania:
Private Sub btnTest_Click()
Dim i As Long
Dim dt As Date
Debug.Print "separator daty krótkiej: "; zbGetShDtSep
Debug.Print "separator daty krótkiej: "; zbGetShDtSep_1
Debug.Print "format daty krótkiej: "; zbGetShDateFormat
' wyświetl nazwy miesięcy
For i = 1 To 12
Debug.Print i; NameMonth(CInt(i));
Debug.Print ", dni: "; DaysOfMonth(Year(Now), CInt(i))
Next
' pobierz pierwszy pełny tydzień roku (od poniedziałku)
dt = zbGetFullWeekDate(#1/1/2009#, vbMonday)
Debug.Print "pierwszy poniedziałek w roku 2009 ", dt
' wyświetl nazwy dni tygodnia
For i = 0 To 6
Debug.Print i + 1, NameDay(dt + i)
Next
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
| |
