|
| | | |
 • II.4. VBA - Konwersja tekstu [2] •
- 4.10 Jak przekonwertować tekst z jednej strony kodowej na inną ?
- 4.11 Jak rozpoznać, czy tekst jest kodowany jako WIN 1250, IBM-852, ISO-2 lub Mazovia ?
- 4.12 Jak przekonwertować tekst na (z) MAZOVIA, IBM, CP-852, WIN 1250,
ISO-2 lub NONE ?
- 4.13 Jak z tekstu postaci np. 23-734-34-2006 pobrać ciąg trzech znaków
o formacie 7## gdzie # to dowolna cyfra z przedzialu 0-9) ?
- 4.14 Jak zaszyfrować i odszyfrowac tekst ?
- 4.15 Jak pobrać pierwsze wystąpienie ciągu cyfr (liczbę) z wejściowego ciągu znaków ?
- 4.16 Jak po każdym znaku w wejściowym ciągu znaków wstawić spację lub dowolny inny pojedynczy znak ?
- 4.17 Jak posortować rosnąco lub malejąco tablicę typu String ?
- 4.18 Jak z tekstu usunąć wszystkie znaki inne niż małe i duże litery oraz spacje ?
- 4.19 Jak przyspieszyć ok. 100 razy generowanie strony Html, która ma zawierać tabelę z danymi (5 kolumn i 1000 wierszy) ?
- <• idź do str. 1 •>
<• idź do str. 3 •>
| | | | |
 |
| | |
|
4.10 Jak przekonwertować tekst z jednej strony kodowej na inną ?
Strona kodowa - zestaw znaków przypisanych poszczególnym kodom binarnym (kodom znaku). Różne strony kodowe przyjmują dla tego samego kodu
odmienne znaki, a ponadto różnią się samymi zestawami znaków.
Funkcja tekstCodePageToCodePage(...) umożliwia konwersję tekstu pomiędzy różnymi stronami kodowymi,
nie tylko jednobajtowymi zestawami ASCII ale również wielobajtowymi np. UTF8 ....
Przykład został trochę rozbudowany i przystosowany do 64-bitowego MS Access (VBA7).
Obecnie przykład znajduje się na stronie:
• Konwersja tekstu między różnymi stronami kodowymi (CodePage»»CodePage) •
ΔΔΔ | | | | |
|
|
| | |
|
4.11 Jak rozpoznać, czy tekst jest kodowany jako WIN 1250, IBM-852, ISO-2 lub Mazovia ?
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Const MY_NONE As Long = 0
Private Const MY_ISO_8859_2 As Long = 1
Private Const MY_WINDOWS_1250 As Long = 2
Private Const MY_IBM_CP852 As Long = 3
Private Const MY_MAZOVIA As Long = 4
' Próba rozpoznawania kodowania pliku tekstowego:
' • Dla krótkich ciągów znaków zawierających tylko niektóre "ogonki" identyfikacja kodowania może być niejednoznaczna,
' • Nie uwzlędnia strony kodowej ISO-1 (2859-1) gdyż tekst zawierający jedynie tylko "ogonki ó ; Ó" jest rozpoznawany jako WIN 1250 i ISO-2 (2859-2),
' • Przy powodzeniu zwraca kod tekstu w zmiennej Variant (podtyp Long),
' • Przy prawdobodobnym rozpoznaniu zwraca tablicę prawdopodobnych kodów,
' • Przy niepowodzeniu lub tekście "bezogonkowym" zwraca ZERO.
Private Function zbDetectCode(sText As String) As Variant
Dim aTextBytes() As Byte
Dim arrChr(0 To 255) As Byte
Dim bChr As Byte
Dim lLen As Long
Dim i As Long
lLen = Len(sText)
If lLen = 0 Then
zbDetectCode = 0
Exit Function
End If
' kopiuj ciąg znaków do tablicy bajtów
ReDim aTextBytes(0 To lLen - 1)
CopyMemory aTextBytes(0), ByVal sText, lLen
For i = 0 To UBound(aTextBytes)
bChr = aTextBytes(i)
' sprawdź indywidualne znaki kodowe
Select Case bChr
' ISO-8859-2
Case 172, 177, 182, 188
zbDetectCode = MY_ISO_8859_2
Exit For
' Windows 1250
Case 140, 159, 185
zbDetectCode = MY_WINDOWS_1250
Exit For
' IBM (CP852)
Case 136, 151, 157, 168, 169, 171, 189, 190, 224, 227, 228
zbDetectCode = MY_IBM_CP852
Exit For
' Mazovia
Case 144, 145, 146, 149, 158, 160, 167
zbDetectCode = MY_MAZOVIA
Exit For
End Select
' utwórz tablice dla potrzeb detekcji prawdopodobnej
arrChr(bChr) = 1
Next
' Jednoznacznie określono kod tekstu - wyjdź z funkcji
If Not IsEmpty(zbDetectCode) Then Exit Function
' sprawdzaj prawdopodobne znaki
' jeżeli jest jeden z poniższych znaków
' to próbuj identyfikować WIN 1250 lub ISO-2
If arrChr(175) = 1 Or arrChr(179) = 1 Or arrChr(191) = 1 Or _
arrChr(198) = 1 Or arrChr(202) = 1 Or arrChr(209) = 1 Or _
arrChr(211) = 1 Or arrChr(230) = 1 Or arrChr(234) = 1 Or _
arrChr(241) = 1 Or arrChr(243) = 1 Then
' ISO-8859-2 lub Win 1250
If arrChr(143) = 1 Or arrChr(156) = 1 Or arrChr(165) = 1 Then
zbDetectCode = MY_WINDOWS_1250
ElseIf arrChr(161) = 1 Or arrChr(166) = 1 Then
zbDetectCode = MY_ISO_8859_2
End If
End If
If Not IsEmpty(zbDetectCode) Then Exit Function
' sprawdź, czy Mazovia
If arrChr(134) = 1 Or arrChr(141) = 1 Or arrChr(152) = 1 Or _
arrChr(162) = 1 Or arrChr(164) = 1 Then
If arrChr(156) = 1 Or arrChr(161) = 1 Or arrChr(166) = 1 Then
zbDetectCode = MY_MAZOVIA
End If
End If
If Not IsEmpty(zbDetectCode) Then Exit Function
' określ w sposób przybliżony kod tekstu
If arrChr(198) = 1 Or arrChr(202) = 1 Or arrChr(209) = 1 Or _
arrChr(211) = 1 Or arrChr(175) = 1 Or arrChr(230) = 1 Or _
arrChr(234) = 1 Or arrChr(179) = 1 Or arrChr(241) = 1 Or _
arrChr(243) = 1 Or arrChr(191) = 1 Then
zbDetectCode = Array(MY_WINDOWS_1250, _
MY_ISO_8859_2)
ElseIf arrChr(134) = 1 Or arrChr(141) = 1 Or arrChr(152) = 1 Or _
arrChr(162) = 1 Or arrChr(164) = 1 Then
zbDetectCode = Array(MY_IBM_CP852, MY_MAZOVIA)
ElseIf arrChr(161) = 1 Or arrChr(166) = 1 Then
zbDetectCode = Array(MY_ISO_8859_2, MY_MAZOVIA)
ElseIf arrChr(165) = 1 Or arrChr(143) = 1 Then
zbDetectCode = Array(MY_WINDOWS_1250, _
MY_IBM_CP852, MY_MAZOVIA)
ElseIf arrChr(163) = 1 Then
zbDetectCode = Array(MY_WINDOWS_1250, _
MY_ISO_8859_2, MY_MAZOVIA)
ElseIf arrChr(156) = 1 Then
zbDetectCode = Array(MY_WINDOWS_1250, MY_MAZOVIA)
End If
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sTest(0 To 3) As String
Dim vRet As Variant
Dim sMsg As String
Dim i As Long, j As Long
sTest(0) = "łoś"
sTest(1) = Chr(179) & Chr(111) & Chr(182)
sTest(2) = Chr(136) & Chr(111) & Chr(152)
sTest(3) = Chr(146) & Chr(111) & Chr(158)
For j = 0 To 3
vRet = zbDetectCode(sTest(j))
If IsArray(vRet) Then
For i = LBound(vRet) To UBound(vRet)
sMsg = sMsg & Space(5) & i + 1 & ". " & _
Choose(vRet(i) + 1, "None", "ISO 8859-2", _
"WINDOWS 1250", "IBM CP-852", "MAZOVIA")
Next
sMsg = "Prawdopodobne kodowanie: " & sMsg
Else
If vRet = 0 Then
sMsg = "Bez ogonków, lub tekst nie został rozpoznany"
Else
sMsg = "Kodowanie: " & _
Choose(vRet + 1, "None", "ISO 8859-2", _
"WINDOWS 1250", "IBM CP-852", "MAZOVIA") & ", "
End If
End If
Debug.Print j + 1 & ". "; sTest(j), sMsg
sMsg = ""
Next
Debug.Print String(40, "_")
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.12 Jak przekonwertować tekst na (z) MAZOVIA, IBM, CP-852, WIN 1250,
ISO-2 lub NONE ?
grupa: pl.comp.bazy-danych.msaccess
w oparciu o wątek: Przypomnienie o FV
oraz funkcję konwertującą: knMazNaLat Krzysztofa Naworyty
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Const MY_NONE As Long = 0
Private Const MY_ISO_8859_2 As Long = 1
Private Const MY_WINDOWS_1250 As Long = 2
Private Const MY_IBM_CP852 As Long = 3
Private Const MY_MAZOVIA As Long = 4
Private Function ConvertText( _
sText As String, _
lCodeSource As Long, _
lCodeDest As Long) As String
' tablica zawierająca znaki do skonwertowania
Dim aFrom(0 To 17) As Byte
' tablica zawierająca znaki docelowe
Dim aTo(0 To 17) As Byte
' pomocnicza tablica zapełniona znakami docelowymi
Dim aFullChars(0 To 255) As Byte
' tablica bajtów tekstu do konwersji
Dim aTextBytes() As Byte
' długość tekstu
Dim lLen As Long
' licznik
Dim i As Long
lLen = Len(sText)
If lLen = 0 Then Exit Function
' kopiuj ciąg znaków do tablicy bajtów
ReDim aTextBytes(0 To lLen - 1)
CopyMemory aTextBytes(0), ByVal sText, lLen
' pobierz tablice znaków wejściowych do konwersji
zbArrConvChars lCodeSource, aFrom()
' pobierz tablice znaków docelowych do konwersji
zbArrConvChars lCodeDest, aTo()
' Doskonały pomysł Krzysztofa Naworyty: Przypomnienie o FV
' • zapełnij tablicę (0-255) znakami do konwersji:
For i = 0 To 17
aFullChars(aFrom(i)) = aTo(i)
Next
For i = 0 To UBound(aTextBytes())
' sprawdzaj kolejno wszystkie znaki
If aFullChars(aTextBytes(i)) <> 0 Then
aTextBytes(i) = aFullChars(aTextBytes(i))
End If
Next
CopyMemory ByVal sText, aTextBytes(0), lLen
ConvertText = sText
End Function
' w argumencie ByRef zwraca tablicę arrChr(0 To 17) zapełnioną
' odpowiednikami bajtowymi "ogonków" dla kodowania lCode,
Private Sub zbArrConvChars(lCode As Long, arrChr() As Byte)
Select Case lCode
Case MY_ISO_8859_2
arrChr(0) = 161: arrChr(1) = 198: arrChr(2) = 202
arrChr(3) = 163: arrChr(4) = 209: arrChr(5) = 211
arrChr(6) = 166: arrChr(7) = 172: arrChr(8) = 175
arrChr(9) = 177: arrChr(10) = 230: arrChr(11) = 234
arrChr(12) = 179: arrChr(13) = 241: arrChr(14) = 243
arrChr(15) = 182: arrChr(16) = 188: arrChr(17) = 191
Case MY_WINDOWS_1250
arrChr(0) = 165: arrChr(1) = 198: arrChr(2) = 202
arrChr(3) = 163: arrChr(4) = 209: arrChr(5) = 211
arrChr(6) = 140: arrChr(7) = 143: arrChr(8) = 175
arrChr(9) = 185: arrChr(10) = 230: arrChr(11) = 234
arrChr(12) = 179: arrChr(13) = 241: arrChr(14) = 243
arrChr(15) = 156: arrChr(16) = 159: arrChr(17) = 191
Case MY_IBM_CP852
arrChr(0) = 164: arrChr(1) = 143: arrChr(2) = 168
arrChr(3) = 157: arrChr(4) = 227: arrChr(5) = 224
arrChr(6) = 151: arrChr(7) = 141: arrChr(8) = 189
arrChr(9) = 165: arrChr(10) = 134: arrChr(11) = 169
arrChr(12) = 136: arrChr(13) = 228: arrChr(14) = 162
arrChr(15) = 152: arrChr(16) = 171: arrChr(17) = 190
Case MY_MAZOVIA
arrChr(0) = 143: arrChr(1) = 149: arrChr(2) = 144
arrChr(3) = 156: arrChr(4) = 165: arrChr(5) = 163
arrChr(6) = 152: arrChr(7) = 160: arrChr(8) = 161
arrChr(9) = 134: arrChr(10) = 141: arrChr(11) = 145
arrChr(12) = 146: arrChr(13) = 164: arrChr(14) = 162
arrChr(15) = 158: arrChr(16) = 166: arrChr(17) = 167
Case MY_NONE
arrChr(0) = 65: arrChr(1) = 67: arrChr(2) = 69
arrChr(3) = 76: arrChr(4) = 78: arrChr(5) = 79
arrChr(6) = 83: arrChr(7) = 90: arrChr(8) = 90
arrChr(9) = 97: arrChr(10) = 99: arrChr(11) = 101
arrChr(12) = 108: arrChr(13) = 110: arrChr(14) = 111
arrChr(15) = 115: arrChr(16) = 122: arrChr(17) = 122
End Select
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sTxtOut As String
Const MY_TEXT As String = _
"Właściwości źle ściągającej gżegżółki." & _
" ĄĆĘŁŃÓŚŹŻ ąćęłńóśźż"
Debug.Print "0. Text oryginalny:", MY_TEXT
' WIN 1250 => IBM-852
sTxtOut = ConvertText( _
MY_TEXT, _
MY_WINDOWS_1250, _
MY_IBM_CP852)
Debug.Print "1. WIN 1250 => IBM-852", sTxtOut
' IBM-852 => ISO-2
sTxtOut = ConvertText( _
sTxtOut, _
MY_IBM_CP852, _
MY_ISO_8859_2)
Debug.Print "2. IBM-852 => ISO-2", sTxtOut
' ISO-2 => MAZOVIA
sTxtOut = ConvertText( _
sTxtOut, _
MY_ISO_8859_2, _
MY_MAZOVIA)
Debug.Print "3. ISO-2 => MAZOVIA", sTxtOut
' MAZOVIA => WIN 1250
sTxtOut = ConvertText( _
sTxtOut, _
MY_MAZOVIA, _
MY_WINDOWS_1250)
Debug.Print "4. MAZOVIA => WIN 1250", sTxtOut
' sprawdzenie konwersji:"
' "WIN 1250 => IBM-852 => ISO-2 => MAZOVIA => WIN 1250
If StrComp(MY_TEXT, sTxtOut, vbBinaryCompare) = 0 Then
Debug.Print String(27, ">");
Debug.Print UCase(" Konwersja tekstu przebiegła prawidłowo")
Else
Debug.Print String(27, ">"); " BŁĄD konwersji !"
End If
' WIN 1250 => NONE
sTxtOut = ConvertText( _
"ĄĆĘŁŃÓŚŹŻ ąćęłńóśźż", _
MY_WINDOWS_1250, _
MY_NONE)
Debug.Print "5. WIN 1250 => NONE"
Debug.Print " ĄĆĘŁŃÓŚŹŻ ąćęłńóśźż => "; sTxtOut
Debug.Print String(90, "_")
Debug.Print: Debug.Print
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.13 Jak z tekstu postaci np. 23-734-34-2006 pobrać ciąg trzech znaków
o formacie 7## gdzie # to dowolna cyfra z przedzialu 0-9) ?
' <cyt>
' Hm... próbowałem to zrobić w jednej linii, ale chyba trzeba pomóc sobie
' dodatkową funkcją, np taką:
Public Function aa(znaki)
Dim zn
For Each zn In Split(znaki, "-")
If zn Like "7##" Then
aa = zn: Exit For
End If
Next
End Function
' [...]
' </cyt>
' Pozwoliłem sobie dostować funkcję Krzysztofa do swoich potrzeb.
' • wersja od A2k wzwyż
Public Function kpLikeInString_A2k(sText, sDelim As String, _
sFind As String) As String
Dim vZn As Variant
For Each vZn In Split(sText, sDelim, , vbBinaryCompare)
If vZn Like sFind Then
kpLikeInString_A2k = vZn
Exit For
End If
Next
End Function
' • wszystkie wersje, ale musisz pobrać funkcję zbSplit
Public Function kpLikeInString_A97(sText As String, sDelim As String, _
sFind As String) As String
Dim aRet() As String
Dim lRet As Long
Dim i As Long
If zbSplit(sText, aRet(), sDelim) <> -1 Then Exit Function
For i = LBound(aRet) To UBound(aRet)
If aRet(i) Like sFind Then
kpLikeInString_A97 = aRet(i)
Exit For
End If
Next
End Function
' przykładowe wywołanie
Private Sub btnTest_Click()
Dim sRet As String
' wywołanie dla Acc'97
Rem sRet = kpLikeInString_A97("73-734-34-2006", "-", "7##")
' wywołanie dla wersji od A2k wzwyż
sRet = kpLikeInString_A2k("73-734-34-2006", "-", "7##")
If Len(sRet) = 0 Then
MsgBox "Nie znaleziono ciągu znaków '7##' rozdzielonych separatorem '-'"
Else
MsgBox "Pierwszy ciąg znaków pasujący do wzorca '7##' = " & sRet
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.14 Jak zaszyfrować i odszyfrować tekst ?
<cyt>
Można skorzystać w tym celu z wbudowanych możliwości Windows.
Załączam napisaną przez siebie bibliotekę.
Zbyt jestem leniwy by umieścić ją w jakimś ogólnie dostępnym miejscu
ale każdy kto chciałby to zrobić ma moje błogosławieństwo :)
Pozdrawiam,
Tomasz Jastrzębski
</cyt>
'**********************************************************************************************
' Encrypt/Decrypt module
' by Tomasz Jastrzębski (tjastrzeb...@vbsoft.com.pl)
' based on "A Cryptographic Filter Box Class in Visual Basic" by Steve Kirk
' Microsoft Developer Network Technology Group - September 17, 1996
'**********************************************************************************************
Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" (phProv As Long, pszContainer As String, _
pszProvider As String, ByVal dwProvType As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal Algid As Long, ByVal hkey As Long, _
ByVal dwFlags As Long, phHash As Long) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal Algid As Long, ByVal hBaseData As Long, _
ByVal dwFlags As Long, phKey As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hHash As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" _
(ByVal hkey As Long) As Long
Private Declare Function CryptEncrypt Lib "advapi32.dll" _
(ByVal hkey As Long, ByVal hHash As Long, ByVal Final As Long, _
ByVal dwFlags As Long, ByVal pbData As String, _
ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32.dll" _
(ByVal hkey As Long, ByVal hHash As Long, ByVal Final As Long, _
ByVal dwFlags As Long, ByVal pbData As String, _
ByRef pdwDataLen As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
(ByVal hHash As Long, ByVal pbData As String, ByVal dwDataLen As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetDefaultProvider Lib "advapi32.dll" _
Alias "CryptGetDefaultProviderA" (ByVal dwProvType As Long, _
ByVal pdwReserved As Any, ByVal dwFlags As Long, _
ByVal pszProvName As String, ByRef pcbProvName As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
(ByVal hHash As Long, ByVal dwParam As Long, ByVal pbData As String, _
ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
'Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Private Const PROV_RSA_FULL As Long = 1
Private Const CRYPT_NEWKEYSET As Long = 8
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_RC2 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_TYPE_BLOCK As Long = 1536
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const CALG_MD5 As Long = _
(ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_RC2 As Long = _
(ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC2)
Private Const CALG_RC4 As Long = _
(ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_RC4)
Private Const CRYPT_MACHINE_DEFAULT As Long = 1
Private Const CRYPT_USER_DEFAULT As Long = 2
Private Const HP_HASHVAL As Long = 2
'<BraZby> - w celu zgodności z Acc'97
Rem Public Enum edEncryptAlgorithm
Rem edRC2 = CALG_RC2
Rem edRC4 = CALG_RC4
Rem End Enum
Private Const edRC2 = CALG_RC2
Private Const edRC4 = CALG_RC4
'</BraZby>
Private Const lErrorBase As Long = vbObjectError
Private Const sModuleName As String = "EncryptDecrypt"
Private Sub RaiseError(Optional Description As String)
Err.Clear
Err.Raise lErrorBase, sModuleName, Description
End Sub
Public Property Get DefaultProvider() As Variant
Dim sProvName As String
Dim lProvBufLen As Long
sProvName = vbNullString
DefaultProvider = Null
On Error GoTo error
' in case CryptGetDefaultProvider function is not implemented ... (eg. NT 4.0)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&, _
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
sProvName = String(lProvBufLen, vbNullChar)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&, _
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
DefaultProvider = Left$(Left$(sProvName, lProvBufLen), _
InStr(1, Mid(sProvName, 1, lProvBufLen), vbNullChar) - 1)
error:
End Property
Public Property Get DefaultProvider2() As Variant
Dim sProvName As String
Dim lProvBufLen As Long
sProvName = vbNullString
DefaultProvider = Null
On Error GoTo error
' in case CryptGetDefaultProvider function is not implemented ... (eg. NT 4.0)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&, _
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
sProvName = String(lProvBufLen, vbNullChar)
If Not CBool(CryptGetDefaultProvider(PROV_RSA_FULL, 0&, _
CRYPT_MACHINE_DEFAULT, sProvName, lProvBufLen)) Then Exit Property
DefaultProvider2 = Left$(Left$(sProvName, lProvBufLen), _
InStr(1, Mid(sProvName, 1, lProvBufLen), vbNullChar) - 1)
error:
End Property
'<BraZby> - w celu zgodności z Acc'97
' Public Function Encrypt(ByVal text, ByVal password As String, _
Optional EncryptAlgorithm As edEncryptAlgorithm = edRC2) As Variant
'</BraZby>
Public Function Encrypt(ByVal text, ByVal password As String, _
Optional EncryptAlgorithm As Long = edRC2) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lAlgid As Long
Dim sContainer As String
Dim sProvider As String
Dim sData As String
Dim lDataLen As Long
Dim lBufLen As Long
Dim sText As String
Dim sPassword As String
If IsNull(text) Then
Encrypt = Null: Exit Function
ElseIf text = "" Then
Encrypt = "": Exit Function
ElseIf LCase(TypeName(text)) <> "string" Then
Err.Clear: Err.Raise lErrorBase, sModuleName, "argument of wrong type"
Exit Function
End If
lAlgid = EncryptAlgorithm
sText = text
sPassword = password
' Get handle to the default provider
sContainer = vbNullString
sProvider = vbNullString
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
' Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
' Hash in the password data.
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
' Derive a session key from the hash object.
If Not CBool(CryptDeriveKey(lHProv, lAlgid, lHHash, 0, lHkey)) Then
RaiseError "error during CryptDeriveKey"
GoTo error
End If
' Destroy the hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
lHHash = 0
lDataLen = Len(sText)
lBufLen = lDataLen
If lAlgid And ALG_TYPE_BLOCK = ALG_TYPE_BLOCK Then
sData = vbNullString
lResult = CryptEncrypt(lHkey, 0, 1, 0, sData, lDataLen, lBufLen)
lBufLen = lDataLen
lDataLen = Len(sText)
End If
sData = String(lBufLen, vbNullChar)
LSet sData = sText
If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, sData, lDataLen, lBufLen)) Then
RaiseError "error during CryptEncrypt"
GoTo error
End If
' return encrypted string
Encrypt = Left$(sData, lDataLen)
error:
' Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
' Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
' Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function
'<BraZby> - w celu zgodności z Acc'97
'Public Function Decrypt(ByVal text, ByVal password, _
Optional EncryptAlgorithm As edEncryptAlgorithm = edRC2) As Variant
'</BraZby>
Public Function Decrypt(ByVal text, ByVal password, _
Optional EncryptAlgorithm As Long = edRC2) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim lAlgid As Long
Dim sContainer As String
Dim sProvider As String
Dim sData As String
Dim lBufLen As Long
Dim lCryptPoint As Long
Dim lPasswordPoint As Long
Dim lPasswordCount As Long
Dim sText As String
Dim sPassword As String
If IsNull(text) Then
Decrypt = Null: Exit Function
ElseIf text = "" Then
Decrypt = "": Exit Function
ElseIf LCase(TypeName(text)) <> "string" Then
RaiseError "argument of wrong type"
Decrypt = Null
Exit Function
End If
lAlgid = EncryptAlgorithm
sText = text
sPassword = password
' Get handle to the default provider.
sContainer = vbNullString
sProvider = vbNullString
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
' Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
' Hash in the password data.
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
' Derive a session key from the hash object.
If Not CBool(CryptDeriveKey(lHProv, lAlgid, lHHash, 0, lHkey)) Then
RaiseError "error during CryptDeriveKey"
GoTo error
End If
' Destroy the hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
lHHash = 0
' Prepare sData for CryptDecrypt
lBufLen = Len(sText)
sData = sText
' Decrypt data
If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sData, lBufLen)) Then
RaiseError "error during CryptDecrypt"
GoTo error
End If
' return decrypted string
Decrypt = Left$(sData, lBufLen)
error:
' Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
' Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
' Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function
Public Function HashData(ByVal text) As Variant
Dim lHProv As Long
Dim lHHash As Long
Dim lHkey As Long
Dim lResult As Long
Dim sContainer As String
Dim sProvider As String
Dim sData As String
Dim lDataLen As Long
Dim sText As String
If IsNull(text) Then HashData = Null: Exit Function
If LCase(TypeName(text)) <> "string" Then
RaiseError "argument of wrong type"
HashData = Null
Exit Function
End If
sText = text
sContainer = vbNullString
sProvider = vbNullString
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, 0)) Then
If Not CBool(CryptAcquireContext(lHProv, sContainer, _
sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
RaiseError "error during CryptAcquireContext"
GoTo error
End If
End If
' Create a hash object.
If Not CBool(CryptCreateHash(lHProv, CALG_MD5, 0, 0, lHHash)) Then
RaiseError "error during CryptCreateHash"
GoTo error
End If
' Hash in data.
If Not CBool(CryptHashData(lHHash, sText, Len(sText), 0)) Then
RaiseError "error during CryptHashData"
GoTo error
End If
' Get hash value.
sData = vbNullString
If Not CBool(CryptGetHashParam(lHHash, HP_HASHVAL, sData, lDataLen, 0)) Then
RaiseError "error during CryptGetHashParam"
GoTo error
End If
' sData = String(16, lDataLen)
sData = String(lDataLen, vbNullChar)
If Not CBool(CryptGetHashParam(lHHash, HP_HASHVAL, sData, lDataLen, 0)) Then
RaiseError "error during CryptGetHashParam"
GoTo error
End If
HashData = Left$(sData, lDataLen)
error:
' Destroy session key.
If lHkey Then lResult = CryptDestroyKey(lHkey)
' Destroy hash object.
If lHHash Then lResult = CryptDestroyHash(lHHash)
' Release provider handle.
If lHProv Then lResult = CryptReleaseContext(lHProv, 0)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sPSW As String
Dim sRet As String
Const MY_STRING As String = _
"Rzekł pajączek do pajączki:" & vbNewLine & _
"Popatrz, ja mam złote rączki!" & vbNewLine & _
"Już uprzędłem dla was nową" & vbNewLine & _
"Pajęczynę własnościową." & vbNewLine & _
"Będziesz pewnie bardzo rada," & vbNewLine & _
"Bo to cud, mucha nie siada!" & vbNewLine & _
"Na to ona z gniewem wrzaśnie:" & vbNewLine & _
"A ma, durniu, siadać właśnie!" & vbNewLine & _
" (Bogdan Brzeziński)" & vbNewLine & _
" ąćęłńóśżźĄĆĘŁŃŚŻŹ"
Const MY_PASSWORD As String = "Jakieś moje hasło"
sPSW = HashData(MY_PASSWORD)
' zaszyfruj
sRet = Encrypt(MY_STRING, sPSW)
Debug.Print sRet
' odszyfruj
sRet = Decrypt(sRet, sPSW)
Debug.Print sRet
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.15 Jak pobrać pierwsze wystąpienie ciągu cyfr (liczbę) z wejściowego ciągu znaków ?
' zwraca pierwsze wystąpienie ciągu cyfr w wejściowym ciągu
' znaków, gdy brak cyfr(y) zwraca ciąg zerowej długości
Public Function zbNumberInString(sStrIn As String) As String
Dim aBytes() As Byte
Dim sStrRet As String
Dim i As Long
Dim fIsNumeric As Boolean
sStrRet = ""
aBytes = StrConv(sStrIn, vbFromUnicode)
For i = LBound(aBytes) To UBound(aBytes)
Select Case aBytes(i)
Case 48 To 57
fIsNumeric = True
sStrRet = sStrRet & Chr$(aBytes(i))
Case Else
' koniec numerycznego ciągu znaków
If fIsNumeric = True Then Exit For
End Select
Next
zbNumberInString = sStrRet
End Function
' przykładowe wywołanie:
' jak pobrać z pełnej ścieżki pliku pierwsze
' wystąpienie ciągu cyfr w nazwie pliku
Private Sub btnTest_Click()
Dim aPath(0 To 4) As String
Dim lInStrRev As Long
Dim sRet As String
Dim i As Long
Const MY_SEP_PATH As String = "\"
aPath(0) = "C:\MojFolder\MojeTxt\ara0720s.txt"
aPath(1) = "C:\MojFolder\MojeTxt\era722ss.txt"
aPath(2) = "C:\MojFolder\MojeTxt\dge0724mm.txt"
aPath(3) = "C:\MojFolder\MojeTxt\gggAAAAm.txt"
aPath(4) = "C:\MojFolder\MojeTxt\_1234_X_567890_.txt"
For i = LBound(aPath) To UBound(aPath)
If StrComp(Right$(aPath(i), 1), MY_SEP_PATH, vbBinaryCompare) = 0 Then
Debug.Print i, "To jest folder"
Else
' szukaj od końca separatora tekstu
lInStrRev = InStrRev(aPath(i), MY_SEP_PATH, , vbBinaryCompare)
If lInStrRev > 0 Then
sRet = zbNumberInString(Mid$(aPath(i), lInStrRev + 1))
If Len(sRet) > 0 Then
Debug.Print i, sRet
Else
Debug.Print i, "Brak cyfr"
End If
Else
Debug.Print i, "Brak " & MY_SEP_PATH
End If
End If
Next
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.16 Jak po każdym znaku w wejściowym ciągu znaków wstawić spację lub dowolny inny pojedynczy znak ?
' Metoda I - przez pobieranie kolejno pojedynczych znaków i dodawania znaku separacji.
' Znak separacji sChar może być ciągiem dowolnej długości.
' Niestety, metoda ta (łączenia ciągów znaków) jest bardzo wolna.
Public Function zbAddCharInStringW_1(sStrIn As String, _
ByVal sChar As String) As String
Dim sStrRet As String
Dim lLen As Long
Dim i As Long
If Len(sStrIn) = 0 Then Exit Function
If Len(sChar) = 0 Then
zbAddCharInStringW_1 = sStrIn
Exit Function
End If
lLen = Len(sStrIn)
For i = 1 To lLen
sStrRet = sStrRet & Mid$(sStrIn, i, 1) & sChar
Next
zbAddCharInStringW_1 = sStrRet
End Function
' Metoda II - przez konwersję wejściowego ciągu znaków do tablicy typu Byte, utworzenie nowej
' (dwa razy większej) tablicy i przypisywanie odpowiednich bajtów do nowej tablicy
' Metoda jest bardzo szybka, ale obsługuje jedynie polskie znaki. Nie sprawdza się
' np. dla "cyrylicy", w miejsce niektórych znaków pojawiają się znaki ????
' • sChar - jednoznakowy separator, gdy argument ten zawiera więcej niż jeden znak,
' pobierany jest jako separator pierwszy znak.
Public Function zbAddCharInStringA_2(sStrIn As String, _
sChar As String) As String
Dim sSepChar As String * 1
Dim aBytes() As Byte
Dim aOut() As Byte
Dim bAscChar As Byte
Dim lLen As Long
Dim i As Long
If Len(sStrIn) = 0 Then Exit Function
If Len(sChar) = 0 Then
zbAddCharInStringA_2 = sStrIn
Exit Function
End If
' tylko jeden (pierwszy) znak
sSepChar = sChar
bAscChar = Asc(sSepChar)
lLen = Len(sStrIn)
aBytes = StrConv(sStrIn, vbFromUnicode)
' utwórz nowa tablice (dwa razy większą)
ReDim aOut(0 To 2 * (lLen))
For i = LBound(aOut) To UBound(aOut) - 1 Step 2
aOut(i) = aBytes((i + 1) \ 2)
aOut(i + 1) = bAscChar
Next
zbAddCharInStringA_2 = StrConv(aOut(), vbUnicode)
End Function
' Metoda III - przez konwersję wejściowego ciągu znaków do tablicy Integer, utworzenie nowej
' (dwa razy większej) tablicy typu Integer i przypisywanie odpowiednich elementów
' do nowej tablicy.
' Metoda jest bardzo szybka i uniwersalna, obsługuje wszystkie znaki Unicode
' Korzysta z nieudokumentowanych funkcji StrPtr i VarPtr oraz procedury CopyMemory (..)
' • sChar - jednoznakowy separator, gdy argument ten zawiera więcej niż jeden znak
' pobierany jest pierwszy znak, konwertowany on jest do liczby typu Integer.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Function zbAddCharInStringW_2(ByVal sStrIn As String, _
ByVal sChar As String) As String
Dim sSepChar As String * 1
Dim aIntegers() As Integer
Dim aOut() As Integer
Dim iWChar As Integer
Dim sStrRet As String
Dim lLen As Long
Dim i As Long
If Len(sStrIn) = 0 Then Exit Function
If Len(sChar) = 0 Then
zbAddCharInStringW_2 = sStrIn
Exit Function
End If
' tylko jeden znak
sSepChar = sChar
CopyMemory iWChar, ByVal StrPtr(sSepChar), 2
lLen = Len(sStrIn)
ReDim aIntegers(1 To lLen)
CopyMemory aIntegers(1), ByVal StrPtr(sStrIn), 2 * lLen
ReDim aOut(1 To 2 * lLen)
For i = LBound(aOut) To UBound(aOut) - 1 Step 2
aOut(i) = aIntegers((i + 1) \ 2)
aOut(i + 1) = iWChar
Next
sStrRet = String(4 * lLen, vbNullChar)
CopyMemory ByVal sStrRet, ByVal VarPtr(aOut(1)), ByVal (4 * lLen)
zbAddCharInStringW_2 = StrConv(sStrRet, vbFromUnicode)
End Function
' Metoda IV
' w oparciu o funkcję autorstwa Tajana: AddSpacesInString(sStrIn As String) As String
' - konwersja wejściowego ciągu znaków do tablicy Byte, utworzenie nowej (dwa razy większej)
' tablicy typu Byte i przypisywanie odpowiednich elementów do nowej tablicy.
' W metodzie tej kazdemu znakowi odpowiadaja dwa elemeny tablicy typu Byte
' • sChar - jednoznakowy separator, gdy argument ten zawiera więcej
' niż jeden znak, to zapisywane sa dwa bajty pierwszego znaku,
' Metoda jest szybka, uniwersalna i "elegancka", obsługuje wszystkie znaki Unicode
Public Function tjAddCharInString(sStrIn As String, _
sChar As String) As String
Dim aBytes() As Byte
Dim aOutput() As Byte
Dim aSep() As Byte
Dim i As Long
Dim j As Long
If Len(sStrIn) = 0 Then Exit Function
If Len(sChar) = 0 Then
tjAddCharInString = sStrIn
Exit Function
End If
' tablica bajtów (Unikodu) wejściowego ciągu znaków
aBytes() = sStrIn
' tablica bajtów (Unikodu) separatora - brane są pod
' uwagę jedynie dwa pierwsze bajty (pierwszy znak)
aSep() = sChar
ReDim aOutput(UBound(aBytes) * 2 + 1)
For i = LBound(aBytes) To UBound(aBytes) Step 2
j = 2 * i
aOutput(j) = aBytes(i)
aOutput(j + 1) = aBytes(i + 1)
aOutput(j + 2) = aSep(0)
aOutput(j + 3) = aSep(1)
Next
tjAddCharInString = aOutput
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Const MY_STRING As String = "Gżegżółka"
Const MY_SEP As String = "|"
Debug.Print zbAddCharInStringW_1(MY_STRING, MY_SEP)
Debug.Print zbAddCharInStringW_2(MY_STRING, MY_SEP)
Debug.Print zbAddCharInStringA_2(MY_STRING, MY_SEP)
Debug.Print tjAddCharInString(MY_STRING, MY_SEP)
DoCmd.RunCommand acCmdDebugWindow
End Sub
porównanie szybkości poszczególnych funkcji dla ciągu o długości ok. 45 000 znaków,
1. zbAddCharInStringW_1 ~ 1000 x wolniejsza,
2. zbAddCharInStringW_2 ~ 1,3 x wolniejsza, ale szybka, korzysta z StrPtr i VarPt,
3. zbAddCharInStringA_2 = 1, ale obsługuje tylko polskie znaki (ogonki),
4. tjAddCharInString ~ 1,8 x wolniejsza, połączenie szybkości z elegancją kodu ;-)
ΔΔΔ | | | | |
|
|
| | |
|
4.17 Jak posortować rosnąco lub malejąco tablicę typu String ?
' sortowanie rosnąco tablicy typu String,
' • w oparciu o procedurę QuickSort autorstwa Sławomira Żaboklickiego,
' • w argumencie ByRef arrStr() zwraca posortowaną tablicę,
Public Sub QuickSortStringAscd(arrStr() As String, lFromIdx As Long, lToIdx As Long)
Dim lMin As Long
Dim lMax As Long
Dim sMiddl As String
Dim sTmp As String
lMin = lFromIdx
lMax = lToIdx
sMiddl = arrStr((lMin + lMax) \ 2)
Do
Do While arrStr(lMin) < sMiddl
lMin = lMin + 1
Loop
Do While arrStr(lMax) > sMiddl
lMax = lMax - 1
Loop
If lMin <= lMax Then
sTmp = arrStr(lMin)
arrStr(lMin) = arrStr(lMax)
arrStr(lMax) = sTmp
lMin = lMin + 1
lMax = lMax - 1
End If
Loop While lMin <= lMax
If lMax > lFromIdx Then QuickSortStringAscd arrStr, lFromIdx, lMax
If lMin < lToIdx Then QuickSortStringAscd arrStr, lMin, lToIdx
End Sub
' sortowanie malejąco tablicy typu String,
' • w oparciu o procedurę QuickSort autorstwa Sławomira Żaboklickiego,
' • w argumencie ByRef arrStr() zwraca posortowaną tablicę,
Public Sub QuickSortStringDesc(arrStr() As String, lFromIdx As Long, lToIdx As Long)
Dim lMin As Long
Dim lMax As Long
Dim sMiddl As String
Dim sTmp As String
lMin = lFromIdx
lMax = lToIdx
sMiddl = arrStr((lMin + lMax) \ 2)
Do
Do While arrStr(lMin) > sMiddl
lMin = lMin + 1
Loop
Do While arrStr(lMax) < sMiddl
lMax = lMax - 1
Loop
If lMin <= lMax Then
sTmp = arrStr(lMin)
arrStr(lMin) = arrStr(lMax)
arrStr(lMax) = sTmp
lMin = lMin + 1
lMax = lMax - 1
End If
Loop While lMin <= lMax
If lMax > lFromIdx Then QuickSortStringDesc arrStr, lFromIdx, lMax
If lMin < lToIdx Then QuickSortStringDesc arrStr, lMin, lToIdx
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.18 Jak z tekstu usunąć wszystkie znaki inne niż małe i duże litery oraz spacje ?
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, ByVal Length As Long)
Private Declare Function IsCharAlphaNumeric Lib "user32" Alias _
"IsCharAlphaNumericA" (ByVal cChar As Byte) As Long
' zwraca ciąg znaków zawierający tylko znaki alfanumeryczne i spację
Public Function zbOnlyAlphaNumeric_1(ByVal sStrIn As String) As String
Dim aBytes() As Byte
Dim aBytesOut() As Byte
Dim i As Long, j As Long
Const MY_CHARS As String = _
" aąbcćdeęfghijklłmnńoópqrsśtuwyzżź" & _
"AĄBCĆDEĘFGHIJKLŁMNŃOÓPQRSŚTUWYZŻŹ" & _
"1234567890"
aBytes = StrConv(sStrIn, vbFromUnicode)
ReDim aBytesOut(0 To Len(sStrIn) - 1)
For i = LBound(aBytes) To UBound(aBytes)
If InStr(1, MY_CHARS, Chr$(aBytes(i)), vbBinaryCompare) > 0 Then
aBytesOut(j) = aBytes(i)
j = j + 1
End If
Next
CopyMemory ByVal sStrIn, aBytesOut(0), j
zbOnlyAlphaNumeric_1 = Left$(sStrIn, j)
End Function
' zwraca ciąg znaków zawierający tylko znaki alfanumeryczne i spację
Public Function zbOnlyAlphaNumeric_2(ByVal sStrIn As String) As String
Dim aBytes() As Byte
Dim aBytesOut() As Byte
Dim lLen As Long
Dim i As Long, j As Long
lLen = Len(sStrIn)
aBytes = StrConv(sStrIn, vbFromUnicode)
ReDim aBytesOut(0 To lLen - 1)
For i = LBound(aBytes) To UBound(aBytes)
If IsCharAlphaNumeric(aBytes(i)) = 1 Or aBytes(i) = 32 Then
aBytesOut(j) = aBytes(i)
j = j + 1
End If
Next
CopyMemory ByVal sStrIn, aBytesOut(0), j
zbOnlyAlphaNumeric_2 = Left$(sStrIn, j)
End Function
Private Sub btnTest_Click()
Dim sStr As String
sStr = "A!b$c ćw@i#erć^wał#e*k"
Debug.Print sStr
Debug.Print zbOnlyAlphaNumeric_1(sStr)
Debug.Print zbOnlyAlphaNumeric_2(sStr)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
4.19 Jak przyspieszyć ok. 100 razy generowanie strony Html, która ma zawierać tabelę z danymi (5 kolumn i 1000 wierszy) ?
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const MY_START_HTML As String = _
"<!doctype html public " & """" & _
"-//W3C//DTD HTML 4.01 Transitional//EN" & _
"""" & " & gt; " & "<html><head></head><body>" & _
"<table border='1'>"
Private Const MY_TD As String = "</td><td>"
Private Const MY_TEXT1 As String = "Dowolny tekst: kolumna 1 !"
Private Const MY_TEXT2 As String = "Dowolny tekst: kolumna 2 !"
Private Const MY_TEXT3 As String = "Dowolny tekst: kolumna 3 !"
Private Const MY_TEXT4 As String = "Dowolny tekst: kolumna 4 !"
Private Const MY_END_HTML As String = "</table></body></html>"
Private Const MY_FOR As Long = 1000
' tworzy w pętli For ... Next za pomocą konkatenacji kod Html i tak wygenerowany kod,
' po zakończeniu pętli, zapisywany jest do pliku w folderze tymczasowym jako *.htm
Private Sub zbCreateHtmlOnOnce()
Dim sHtmlFile As String
Dim sHtml As String
Dim lStart As Long
Dim ff As Integer
Dim i As Long
lStart = timeGetTime
' nagłówek strony i początek tabeli
sHtml = MY_START_HTML
' poszczególne wiersze tabeli
For i = 1 To MY_FOR
sHtml = sHtml & _
"<tr><td>" & _
CStr(i) & MY_TD & _
MY_TEXT1 & MY_TD & _
MY_TEXT2 & MY_TD & _
MY_TEXT3 & MY_TD & _
MY_TEXT4 & _
"</td></tr>"
Next
' koniec tabeli i strony
sHtml = sHtml & MY_END_HTML
' zapisujemy wygenerowany plik Html do folderu tymczasowego
sHtmlFile = Environ$("TEMP") & "\" & CStr(CLng(Now * 10000) + 1) & ".htm"
ff = FreeFile
Open sHtmlFile For Binary Access Write As #ff
Put #ff, , sHtml
Close #ff
lStart = timeGetTime - lStart
Debug.Print "Konkatenacja i zapis do pliku: "; lStart; " milisek."
' zapisany plik możemy już otworzyć, a później go usunąć
' ShellExecute 0&, "open", sHtmlFile, vbNullString, vbNullString, SW_SHOWMAXIMIZED
' If Len(Dir(sHtmlFile)) > 0 Then Kill sHtmlFile
End Sub
| Wyniki testu dla procedury zbCreateHtmlOnOnce |
|---|
| Ilość wierszy | Czas [milisek] | Ilość znaków |
| 100 | 559 | 16 126 |
| 1 000 | 10 473 | 161 027 |
| 5 000 | 292 438 | 809 027 |
' • 5 minut dla tabeli zawierającej 5 000 wierszy to moim zdaniem stanowczo za dużo,
' spróbujmy zrobić to trochę szybciej. Zamiast generować tekst Html'u w pamięci,
' by go potem zapisać na dysk, będziemy dopisywać kod każdego wiersza bezpośrednio
' na końcu utworzonego wcześniej pliku,
Public Sub zbCreateHtmlSuccessivePut()
Dim sHtmlFile As String
Dim sHtml As String
Dim lStart As Long
Dim ff As Integer
Dim i As Long
lStart = timeGetTime
' pobierz ścieżkę pliku tymczasowego
sHtmlFile = Environ$("TEMP") & "\" & CStr(CLng(Now * 10000) + 1) & ".htm"
ff = FreeFile
' utwórz plik tymczasowy
Open sHtmlFile For Binary Access Write As #ff
' zapisz część początkową Html'u
Put #ff, , MY_START_HTML
For i = 1 To MY_FOR
' sHtml = sHtml & '_
sHtml = "<tr><td>" & _
CStr(i) & MY_TD & _
MY_TEXT1 & MY_TD & _
MY_TEXT2 & MY_TD & _
MY_TEXT3 & MY_TD & _
MY_TEXT4 & _
"</td></tr>"
' sukcesywnie dopisuj wiersze tabeli
Put #ff, , sHtml
Next
Put #ff, , MY_END_HTML
Close #ff
lStart = timeGetTime - lStart
Debug.Print "Sukcesywny zapis do pliku: "; lStart; " milisek."
' zapisany plik możemy już otworzyć, a później go usunąć
' ShellExecute 0&, "open", sHtmlFile, vbNullString, vbNullString, SW_SHOWMAXIMIZED
' If Len(Dir(sHtmlFile)) > 0 Then Kill sHtmlFile
End Sub
| Porównanie wyników testu dla obu metod |
|---|
| Ilość wierszy | Metoda I | Metoda II | Met.I / Met. II | Ilość znaków |
| 100 | 559 ms | 12 ms | 46,6 x | 16 126 |
| 1 000 | 10 473 ms | 96 ms | 109,1 x | 161 027 |
| 5 000 | 292 438 ms | 394 ms | 742,2 x | 809 027 |
ΔΔΔ | | | | |
|
| |
