|
| | | |
 • II.6. VBA - Operacje na plikach [1] •
- 6.1 Jak pobrać (zmienić) bieżący folder i napęd ?
- 6.2 Jak otworzyć plik do odczytu (zapisu) ?
- 6.3 Jak pobrać plik (fragment pliku) do tablicy bajtów ?
- 6.4 Jak pobrać plik (fragment pliku) do zmiennej typu String ?
- 6.5 Jak sprawdzić ile linii zawiera plik ?
- 6.6 Jak pobrać kolejne linie z pliku ?
- 6.7 Jak usunąć kolejne linie z pliku ?
- 6.8 Jak zastąpić lub wstawić kolejne linie w pliku ?
- 6.9 Pomocnicza funkcja sprawdzająca poprawność argumentów używanych funkcji ?
- <<• idź do str. 2 •>>
| | | | |
 |
| | |
|
6.1 Jak pobrać (zmienić) bieżący folder i napęd ?
Private Sub btnTest_Click()
Dim sCurDirOld As String
Dim sCurDir As String
Dim sCurDrive As String
' • jak pobrać, (zmienić) bieżący folder:
sCurDirOld = CurDir
Debug.Print "1. stary bieżący folder: ", sCurDirOld
' • jak zmienić bieżący folder ( bieżący napęd nie ulega zmienia):
ChDir "D:\MojFolder"
sCurDrive = CurDir("D")
Debug.Print "2. nowy bieżący folder: ", sCurDrive
' • jak pobrać bieżący napęd:
sCurDrive = Left$(CurDir, 1)
Debug.Print "3. stary bieżący napęd: ", sCurDrive & ":\"
' jak widzimy bieżącym napędem jest dalej dysk C:\
' • jak zmienić bieżący napęd:
ChDrive "D"
sCurDrive = Left$(CurDir, 1)
Debug.Print "4. obecny bieżący napęd: ", sCurDrive & ":\"
' • przywracamy stare ustawienia:
ChDrive sCurDirOld
ChDir sCurDirOld
Debug.Print "5. stary bieżący folder: ", CurDir
Debug.Print "6. stary bieżący napęd: ", Left$(CurDir, 1) & ":\"
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.2 Jak otworzyć plik do odczytu (zapisu) ?
Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength]
pathname
| - wymagane, nazwa pliku, jeżeli nie zawiera oznaczenia ścieżki
i napędu, to otwierany jest plik w bieżącyn folderze |
mode
| - wymagane, słowo kluczowe określające tryb dostępu do pliku:
Append, Binary, Input, Output lub Random (tryb domyślny) |
access
| - słowo kluczowe określające rodzaj działania na pliku: Read, Write,
lub Read Write |
lock
| - słowo kluczowe określające rodzaj dostępu do pliku: Shared,
Lock Read, Lock Write, and Lock Read Write |
| filenumber | - wymagane, liczba określająca numer pliku (w zakresie 1 - 511) |
reclength
| - dla plików o dostępie bezpośrednim liczba określająca długość
rekordu (w bajtach), dla plików o dostępie bezpośrednim określa
długość bufora, (domyślnie 128 maksymalnie 32 767 bajtów),
ignorowany przy dostępie w trybie binarnym |
| wartości argumentu Mode: |
APPEND
| - dostęp sekwencyjny, nowe dane dopisywane są na końcu pliku,
jeżeli plik nie istnieje to zostanie utworzony |
BINARY
| - dostęp binarny do czytania i zapisu, jeżeli plik nie istnieje to
zostanie utworzony |
INPUT
| - dostęp sekwencyjny do czytania, jeżeli plik nie istnieje
generowany jest błąd |
OUTPUT
| - dostęp sekwencyjny do zapisu, przy otwarciu cała zawartość pliku
jest usuwana, jeżeli plik nie istnieje to zostanie utworzony |
RANDOM
| - dostęp bezpośredni do czytania i zapisu, jeżeli plik nie istnieje to
zostanie utworzony, (domyślny tryb otwarcia pliku) |
| wartości argumentu Access: |
| READ | otwarcie pliku tylko do odczytu |
| WRITE | otwarcie pliku tylko do zapisu |
| READ WRITE | otwarcie pliku tylko do odczytu i zapisu |
| wartości argumentu Lock: |
| SHARED | - każdy proces może wykonywać na pliku operacje odczytu i zapisu |
| LOCK READ | - żaden proces nie może wykonywać na pliku operacji odczytu |
| LOCK WRITE | - żaden proces nie może wykonywać na pliku operacji zapisu |
LOCK READ WRITE
| - żaden proces nie może wykonywać na pliku operacji odczytu
i zapisu |
ΔΔΔ | | | | |
|
|
| | |
|
6.3 Jak pobrać plik (fragment pliku) do tablicy bajtów ?
' Pobiera kolejne bajty z pliku, zwraca ilość pobranych bajtów, a w argumencie ByRef arrRetBytes(lStart To (ilość pobranych bajtów - 1)) As Byte zwraca tablicę odczytanych bajtów, przy błędzie zwraca 0 (False),
' • sFilePath - pełna ścieżka do pliku, plik musi istnieć i nie może być otwarty na wyłączność, jeżeli plik jest pusty funkcja zwraca -1 i pustą tablicę arrRetBytes()
' • lStart - numer bajtu od którego ma nastąpić odczyt, domyślnie = 1, jeżeli nr bajtu początkowego jest większy od ilości bajtów w pliku funkcja zwraca -1 i pustą tablicę arrRetBytes(),
' • lBytes - ilość bajtów do pobrania, dla domyślnej wartości -1 pobierane są wszystkie bajty, począwszy od bajtu startowego (lStart), jeżeli ilość bajtów do pobrania przekracza ilość dostępnych bajtów, funkcja zwraca wszystkie bajty od lStart do końca pliku,
Public Function zbFileToArray(ByVal sFilePath As String, _
arrRetBytes() As Byte, _
Optional ByVal lStart As Long = 1, _
Optional ByVal lBytes As Long = -1) As Long
Dim lLenFile As Long
Dim ff As Integer
If zbValidArgs(sFilePath, False, lStart, lBytes, , , _
"zbFileToArray(...)") = False Then
Exit Function
End If
lLenFile = FileLen(sFilePath)
If lStart > lLenFile Then
zbFileToArray = -1
Exit Function
End If
If lBytes = -1 Then
lBytes = lLenFile - lStart + 1
Else
If (lStart + lBytes) > lLenFile Then lBytes = lLenFile - lStart + 1
End If
ff = FreeFile
Open sFilePath For Binary Access Read As #ff
ReDim arrRetBytes(lStart To lStart + lBytes - 1)
Get #ff, lStart, arrRetBytes
Close #ff
zbFileToArray = lBytes
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim arrBytes() As Byte
Dim i As Long
Dim lRet As Long
On Error Resume Next
lRet = zbFileToArray("C:\Test.txt", arrBytes, 1, -1)
If lRet > 0 Then
Debug.Print "pobrano bajtów: " & lRet
For i = LBound(arrBytes) To UBound(arrBytes)
Debug.Print Chr(arrBytes(i));
Next
ElseIf lRet = 0 Then
Debug.Print "lRet = "; lRet,
Debug.Print Err.Number, Err.Description, Err.Source
Else
Debug.Print "lRet = "; lRet, "pusty lub za krótki plik"
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.4 Jak pobrać plik (fragment pliku) do zmiennej typu String ?
' Najprościej, to pobrać tablicę bajtów za pomocą wyżej opisanej zbFileToArray (...) i przekonwertować tablicę na ciąg znaków za pomocą wbudowanej funkcji StrConv (...)
' lRet = zbFileToArray("C:\Test.txt", arrBytes, 1, -1)
' sStringRet = StrConv(arrBytes, vbUnicode)
' Dla pliku zawierającego ok. 2 000 000 znaków metoda ta jest tylko 10% wolniejsza od przedstawionej niżej funkcji zbFileToString (...), ale wymaga zadeklarowania dodatkowej tablicy arrBytes() As Byte
' Pobiera kolejne znaki z pliku, zwraca ilość pobranych znaków, a w argumencie ByRef sRetString As String odczytany ciąg znaków, przy błędzie zwraca 0 (False),
' • sFilePath - pełna ścieżka do pliku, plik musi istnieć i nie może być otwarty na wyłączność, jeżeli plik jest pusty funkcja zwraca -1 i zerowej długości ciąg sRetString,
' • lStart - numer znaku od którego ma nastąpić odczyt, domyślnie = 1, jeżeli nr znaku początkowego jest większy od ilości znaków w pliku funkcja zwraca -1 i zerowej długości ciąg sRetString,
' • lChars - ilość znaków do pobrania, dla domyślnej wartości -1 pobierane są wszystkie znaki, począwszy od znaku startowego (lStart), jeżeli ilość znaków do pobrania przekracza ilość dostępnych znaków, funkcja zwraca wszystkie znaki od lStart do końca pliku,
Public Function zbFileToString( _
ByVal sFilePath As String, _
sRetString As String, _
Optional ByVal lStart As Long = 1, _
Optional ByVal lChars As Long = -1) As Long
Dim lLenFile As Long
Dim ff As Integer
If zbValidArgs(sFilePath, False, lStart, lChars, , , _
"zbFileToString(...)") = False Then
Exit Function
End If
lLenFile = FileLen(sFilePath)
If lStart > lLenFile Then
zbFileToString = -1
Exit Function
End If
If lChars = -1 Then
lChars = lLenFile - lStart + 1
Else
If (lStart + lChars) > lLenFile Then lChars = lLenFile - lStart + 1
End If
ff = FreeFile
Open sFilePath For Binary Access Read As #ff
sRetString = String(lChars, vbNullChar)
Get #ff, lStart, sRetString
Close #ff
zbFileToString = lChars
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sRet As String
Dim lRet As Long
Const MY_PATHFILE As String = "C:\MojPlik.txt"
On Error Resume Next
lRet = zbFileToString(MY_PATHFILE, sRet, 23, 25)
If lRet > 0 Then
Debug.Print "Pobrano: "; lRet; "znaków"
Debug.Print sRet
ElseIf lRet = 0 Then
Debug.Print "lRet = "; lRet, Err.Number,
Debug.Print Err.Description, Err.Source
Else
Debug.Print "lRet = "; lRet, "pusty lub za krótki plik"
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.5 Jak sprawdzić ile linii zawiera plik ?
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim vArray As Variant
Dim sLineEnd As String
Dim sTmp As String
Dim ff As Long
Dim lRet As Long
Dim sPath As String
sLineEnd = Chr$(13) ' vbNewLine
sPath = "C:\Test.txt"
' Metoda_1
' otwieramy plik w trybie Input, kolejno wczytujemy linie za pomocą: Line Input # i po wczytaniu każdej linii zwiększamy licznik o 1, Line Input # jako koniec linii traktuje znak Chr$(13) i pomija występujący po nim Chr$(10),
lRet = 0
ff = FreeFile
Open sPath For Input As #ff
Do While Not EOF(ff)
lRet = lRet + 1
Line Input #ff, sTmp
Loop
Close #ff
Debug.Print "Metoda_1 - Linii: ", lRet
' Metoda_2
' otwieramy plik w trybie Input, wczytujemy cały plik poprzez Input(LOF(ff), #ff) do funkcji Split(..., sLineEnd, ...) i odczytujemy UBound(vArray) + 1 tak otrzymanej tablicy elementów rozdzielonych znakiem końca linii, w przypadku gdy plik jest zakończony znakiem Chr$(13) lub Chr$(13) & Chr$(10), w celu zgodności z Metodą_1 musimy uzyskany wynik pomniejszyć o 1,
' Line Input # jako koniec linii traktuje znak Chr$(13) i pomija występujący po nim Chr$(10),
lRet = 0
ff = FreeFile
Open sPath For Input As #ff
vArray = Split(Input(LOF(ff), #ff), sLineEnd, , vbBinaryCompare)
Close #ff
lRet = UBound(vArray)
' plik nie jest pusty
If lRet <> -1 Then
If vArray(lRet) = "" Or vArray(lRet) = Chr$(10) Then lRet = lRet - 1
End If
lRet = lRet + 1
Debug.Print "Metoda_2 - Linii: ", lRet
' Metoda_3
' otwieramy plik w trybie Binary Access Read i wczytujemy plik do zmiennej sTmp, za pomocą funkcji Split(sTmp, sLineEnd, ...) otrzymujemy tablicę elementów rozdzielonych znakiem końca linii, następnie odczytujemy UBound(vArray) + 1 tak otrzymanej tablicy,
' w przypadku gdy plik jest zakończony znakiem Chr$(13) lub Chr$(13) & Chr$(10) w celu zgodności z Metodą_1 musimy uzyskany wynik pomniejszyć o 1,
lRet = 0
ff = FreeFile
Open sPath For Binary Access Read As #ff
sTmp = String(LOF(ff), vbNullChar)
Get #ff, , sTmp
vArray = Split(sTmp, sLineEnd, , vbBinaryCompare)
Close #ff
lRet = UBound(vArray)
' plik nie jest pusty
If lRet <> -1 Then
If vArray(lRet) = "" Or vArray(lRet) = Chr$(10) Then lRet = lRet - 1
End If
lRet = lRet + 1
Debug.Print "Metoda_3 - Linii: ", lRet
' Metoda_4 - opis poniżej,
lRet = zbCountLinesInStr(sPath)
Debug.Print "Metoda_4 - Linii: ", lRet
DoCmd.RunCommand acCmdDebugWindow
End Sub
' zbCountLinesInStr - zwraca ilość linii w pliku, gdy plik jest pusty zwraca -1, przy błędzie zwraca 0 (False),
' • sFilePath - pełna ścieżka do pliku, plik musi istnieć i nie może być otwarty na wyłączność,
' • sCharsEnd - znak końca linii, domyślnie vbCr=Chr$(13), można użyć także vbNewLine,
' • sposób działania:
' otwiera plik w trybie Binary Access Read, wczytuje cały plik do zmiennej sTmp, za pomocą funkcji InStr(lStart, sTmp, sCharsEnd, ...) zlicza kolejne wystąpienia znaków końca linii, w przypadku gdy plik jest zakończony znakiem końca linii w celu zgodności z Line Input # (Metoda_1) uzyskany wynik zostaje pomniejszony o 1, lub Chr$(13) & Chr$(10)
Public Function zbCountLinesInStr(ByVal sPath As String, _
Optional ByVal sCharsEnd As String = vbCr) As Long
Dim sTmp As String
Dim lLen As Long
Dim lStart As Long
Dim lInStr As Long
Dim ff As Long
Dim lCount As Long
If zbValidArgs(sPath, False, , , sCharsEnd, , _
"zbCountLinesInStr(...)") = False Then
Exit Function
End If
ff = FreeFile
Open sPath For Binary Access Read As #ff
sTmp = String(LOF(ff), vbNullChar)
Get #ff, , sTmp
Close #ff
If Len(sTmp) = 0 Then
' plik nie jest pusty
zbCountLinesInStr = -1
Exit Function
End If
lLen = Len(sCharsEnd)
' szukaj od początku
lInStr = InStr(1, sTmp, sCharsEnd, vbBinaryCompare)
Do Until lInStr = 0
lCount = lCount + 1
lStart = lInStr + lLen
lInStr = InStr(lStart, sTmp, sCharsEnd, vbBinaryCompare)
Loop
If StrComp(Right$(sTmp, lLen), sCharsEnd, _
vbBinaryCompare) <> 0 And _
StrComp(Right$(sTmp, 1), Chr$(10), _
vbBinaryCompare) <> 0 Then
lCount = lCount + 1
End If
zbCountLinesInStr = lCount
DoCmd.RunCommand acCmdDebugWindow
End Function
' Porównanie szybkości działania powyższych metod:
' • długość pliku = 1 769 472, wywołań = 1, linii = 65 536,
' czas: (Metoda_4 = 100%)
' Metoda_1 = 400%
' Metoda_2 = 710%
' Metoda_3 = 1690%
' Metoda_4 = 100%
' • długość pliku = 999, wywołań = 10 000, linii = 37,
' czas: (Metoda_4 = 100%)
' Metoda_1 = 150%
' Metoda_2 = 220%
' Metoda_3 = 130%
' Metoda_4 = 100%
ΔΔΔ | | | | |
|
|
| | |
|
6.6 Jak pobrać kolejne linie z pliku ?
' Pobiera kolejne linie z pliku, zwraca ilość pobranych linii, w argumencie ByRef arrRetLines(lStart To (ilość pobranych linii - 1)) As String zwraca tablicę odczytanych linii, przy błędzie zwraca 0 (False),
' • sFilePath - pełna ścieżka do pliku, plik musi istnieć i nie może być otwarty na wyłączność, jeżeli plik jest pusty funkcja zwraca -1 i pustą tablicę arrRetLines()
' • lStart - numer linii od której ma nastąpić odczyt, domyślnie = 1, jeżeli nr linii początkowej jest większy od ilości linii w pliku funkcja zwraca -1 i pustą tablicę arrRetLines(),
' • lLines - ilość linii do pobrania, dla domyślnej wartości -1 pobierane są wszystkie linie, począwszy od linii startowej (lStart), jeżeli ilość linii do pobrania przekracza ilość istniejących linii, funkcja zwraca wszystkie linie od lStart do końca pliku,
Public Function zbReadLines( _
ByVal sFilePath As String, _
arrRetLines() As String, _
Optional ByVal lStart As Long = 1, _
Optional ByVal lLines As Long = -1) As Long
Dim lLenFile As Long
Dim lLineEnd As Long
Dim sBff As String
Dim ff As Integer
Dim i As Long, j As Long
If zbValidArgs(sFilePath, False, lStart, lLines, , , _
"zbReadLines(...)") = False Then
Exit Function
End If
ff = FreeFile
Open sFilePath For Input As #ff
' czytaj do końca pliku
If lLines = -1 Then
j = lStart
Do While Not EOF(ff)
Line Input #ff, sBff
i = i + 1
If i >= lStart Then
ReDim Preserve arrRetLines(lStart To j)
arrRetLines(i) = sBff
j = j + 1
End If
Loop
i = j - 1
Else
' maksymalny górny wymiar tablicy
lLineEnd = lStart + lLines - 1
ReDim arrRetLines(lStart To lLineEnd)
Do While Not EOF(ff)
Line Input #ff, sBff
i = i + 1
If i >= lStart Then
If i > lLineEnd Then
i = i - 1
Exit Do
End If
arrRetLines(i) = sBff
End If
Loop
End If
Close #ff
If i >= lStart Then
' zredukuj górny wymiar tablicy
If i < lLineEnd Then ReDim Preserve arrRetLines(lStart To i)
zbReadLines = i - lStart + 1
Else
Erase arrRetLines
zbReadLines = -1
End If
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim arrRet() As String
Dim lRet As Long
Dim i As Long
Const MY_PATHFILE As String = "C:\MojPlik.txt"
On Error Resume Next
lRet = zbReadLines(MY_PATHFILE, arrRet(), 44, 23)
If lRet > 0 Then
Debug.Print "Pobrano linii: "; lRet
Debug.Print String(25, "=")
For i = LBound(arrRet()) To UBound(arrRet())
Debug.Print "Linia:"; i; arrRet(i)
Next
ElseIf lRet = 0 Then
Debug.Print "lRet = " & lRet
Debug.Print "Błąd nr: " & Err.Number
Debug.Print "Opis błędu: " & Err.Description
Debug.Print "Źródło błędu: " & Err.Source
Else
Debug.Print "lRet = "; lRet, "pusty lub za krótki plik"
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.7 Jak usunąć kolejne linie z pliku ?
' Usuwa kolejne linie z pliku począwszy od linii lStart, zwraca ilość usuniętych linii, przy błędzie zwraca 0 (False),
' • sFilePath - pełna ścieżka do pliku, plik musi istnieć i nie może być otwarty na wyłączność, jeżeli plik jest pusty funkcja zwraca -1
' • lStart - numer linii od której ma nastąpić usuwanie, domyślnie = 1, jeżeli nr linii początkowej jest większy od ilości linii w pliku funkcja zwraca -1,
' • lLines - ilość linii do usunięcia, dla domyślnej wartości -1 usuwane są wszystkie linie począwszy od linii startowej (lStart), jeżeli ilość linii do usunięcia przekracza ilość istniejących linii, funkcja usuwa wszystkie linie od lStart do końca pliku,
' • sCharsEnd - znak końca linii, wartość tego argumentu nie ma znaczenia przy odczycie pliku, ponieważ jako znak końca linii uznawany jest tylko znak Chr(13), może być znakiem Chr(13), Chr$(13) & Chr$(10) lub vbNewLine, a także ciągiem zerowej długości "", - wtedy usunięte zostaną wszystkie znaki końca linii,
Public Function zbDeleteLines(sFilePath As String, _
Optional ByVal lStart As Long = 1, _
Optional ByVal lLines As Long = -1, _
Optional ByVal sCharsEnd As String = vbNewLine) _
As Long
Dim lLenFile As Long
Dim sTmpPath As String
Dim arrTmp() As String
Dim lLinesCount As Long
Dim i As Long, j As Long
Dim ff As Long
' plik musi istnieć
Call zbValidArgs(sFilePath, False, , , vbNewLine, , _
"zbDeleteLines(...)")
' sprawdź poprawnośc argumentów
' i pobierz ścieżkę pliku tymczasowego
If zbValidArgs(sFilePath, True, lStart, lLines, sCharsEnd, _
sTmpPath, "zbDeleteLines(...)") = False Then
Exit Function
End If
If Len(sTmpPath) = 0 Then Exit Function
' sprawdź, czy plik zawiera dane
lLenFile = FileLen(sFilePath)
If lLenFile = 0 Then
zbDeleteLines = -1
Exit Function
End If
ff = FreeFile
' odczytaj wszystkie linie
Open sFilePath For Input As #ff
Do While Not EOF(ff)
i = i + 1
ReDim Preserve arrTmp(1 To i)
Line Input #ff, arrTmp(i)
Loop
Close #ff
lLinesCount = i
If lLines = -1 Then lLines = lLinesCount
' linia lStart jest poza zakresem
If lStart > i Then
zbDeleteLines = -1
Exit Function
End If
i = 1
ff = FreeFile
Open sTmpPath For Binary Access Write As #ff
Do While i < lStart - 1
Put #ff, , arrTmp(i)
Put #ff, , sCharsEnd
i = i + 1
Loop
If lStart > 1 Then
Put #ff, , arrTmp(i)
If lStart + lLines <= lLinesCount Then
Put #ff, , sCharsEnd
End If
i = i + 1
End If
j = lStart + lLines
Do While j <= UBound(arrTmp) - 1
Put #ff, , arrTmp(j)
Put #ff, , sCharsEnd
j = j + 1
i = i + 1
Loop
If j = UBound(arrTmp) Then
Put #ff, , arrTmp(j)
' Put #ff, , sCharsEnd
i = i + 1
End If
Close #ff
' zamień pliki i usuń plik tymczasowy
FileCopy sTmpPath, sFilePath
If Len(Dir(sTmpPath)) > 0 Then Kill sTmpPath
zbDeleteLines = lLinesCount - (i - 1)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim arrRet() As String
Dim lRet As Long
Dim i As Long
Const MY_PATHFILE As String = "C:\MojPlik.txt"
On Error Resume Next
' usuń (trzy) linie: nr 2, 3 i 4
lRet = zbDeleteLines(MY_PATHFILE, 2, 3)
If lRet > 0 Then
Debug.Print "Usunięto linii: "; lRet
Debug.Print String(25, "=")
ElseIf lRet = 0 Then
Debug.Print "lRet = " & lRet
Debug.Print "Błąd nr: " & Err.Number
Debug.Print "Opis błędu: " & Err.Description
Debug.Print "Źródło błędu: " & Err.Source
Else
Debug.Print "lRet = "; lRet, "pusty lub za krótki plik"
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.8 Jak zastąpić lub wstawić kolejne linie w pliku ?
' Zastępuje (wstawia) kolejne linie do pliku, począwszy od lStart, zwraca ilość zamienionych (wstawionych) linii, przy błędzie zwraca: 0 (False)
' • sFilePath pełna ścieżka do pliku, plik nie może być otwarty na wyłączność, jeżeli plik nie istnieje zostanie utworzony, jeżeli jest pusty linie zostaną wpisane na początku pliku,
' • arrLines() tablica zawierająca linie do zamiany (wstawienia),
' • fReplace - dla wartości True funkcja zastępuje linie, dla wartości False wstawia linie,
' • lStart - numer linii od której ma nastąpić zastępowanie (wstawianie), domyślnie = 1 jeżeli nr linii początkowej jest większy od ilości linii w pliku, linie zostaną dopisane na końcu pliku,
' • sCharsEnd - znak końca linii, wartość tego argumentu nie ma znaczenia przy odczycie pliku, ponieważ jako znak końca linii uznawany jest tylko znak Chr(13), może być znakiem Chr(13), Chr$(13) & Chr$(10) lub vbNewLine, a także ciągiem zerowej długości "", - wtedy usunięte zostaną wszystkie znaki końca linii,
Public Function zbReplaceInsertLines(sFilePath As String, _
arrLines() As String, fReplace As Boolean, _
Optional ByVal lStart As Long = 1, _
Optional ByVal sCharsEnd As String = vbNewLine) _
As Long
Dim arrTmp() As String
Dim lLenFile As Long
Dim lLineCount As Long
Dim sTmpPath As String
Dim lLb As Long, lUb As Long
Dim i As Long, j As Long
Dim ff As Long
' sprawdź poprawnośc argumentów
' i pobierz ścieżkę pliku tymczasowego
If zbValidArgs(sFilePath, True, lStart, , sCharsEnd, _
sTmpPath, "zbReplaceInsertLines(...)") = False Then
Exit Function
End If
If Len(sTmpPath) = 0 Then Exit Function
lLb = LBound(arrLines)
lUb = UBound(arrLines)
' plik istnieje
If Len(Dir(sFilePath)) > 0 Then
' sprawdź, czy plik zawiera dane
lLenFile = FileLen(sFilePath)
If lLenFile > 0 Then
ff = FreeFile
' odczytaj wszystkie linie
Open sFilePath For Input As #ff
Do While Not EOF(ff)
i = i + 1
ReDim Preserve arrTmp(1 To i)
Line Input #ff, arrTmp(i)
Loop
Close #ff
lLineCount = i
If lStart > i Then lStart = lLineCount + 1
i = 1
ff = FreeFile
' zacznij zapis
Open sTmpPath For Binary Access Write As #ff
Do While i < lStart
Put #ff, , arrTmp(i)
Put #ff, , sCharsEnd
i = i + 1
Loop
For j = lLb To lUb - 1
Put #ff, , arrLines(j)
Put #ff, , sCharsEnd
Next
If fReplace = True And lLb < lUb Then i = i + lUb - lLb - 1
If i <= UBound(arrTmp) Then
Put #ff, , arrLines(j)
Put #ff, , sCharsEnd
Else
Put #ff, , arrLines(j)
End If
If fReplace Then
i = i + 2
If lLb = lUb Then i = i - 1
End If
Do While i <= lLineCount - 1
Put #ff, , arrTmp(i)
Put #ff, , sCharsEnd
i = i + 1
Loop
If i <= UBound(arrTmp) Then Put #ff, , arrTmp(i)
Close #ff
End If
Else
' plik jest pusty lub nie istnieje - wpisz wszystkie linie
ff = FreeFile
Open sTmpPath For Binary Access Write As #ff
For i = lLb To lUb - 1
Put #ff, , arrLines(i)
Put #ff, , sCharsEnd
Next
Put #ff, , arrLines(i)
Close #ff
End If
' zamień pliki i usuń plik tymczasowy
FileCopy sTmpPath, sFilePath
If Len(Dir(sTmpPath)) > 0 Then Kill sTmpPath
zbReplaceInsertLines = lUb - lLb + 1
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim arrLines(0 To 2) As String
Dim lRet As Long
Dim i As Long
Const MY_PATHFILE As String = "C:\MojPlik.txt"
arrLines(0) = "1. Moja Linia 1"
arrLines(1) = "2. Moja Linia 2"
arrLines(2) = "3. Moja Linia 3"
On Error Resume Next
' wstaw trzy linie, zaczynając od lini nr 2
lRet = zbReplaceInsertLines( _
MY_PATHFILE, arrLines(), False, 2)
' zastąp trzy linie, zaczynając od lini nr 2
' lRet = zbReplaceInsertLines( _
MY_PATHFILE, arrLines(), True, 2)
If lRet > 0 Then
Debug.Print "Wstawiono (zamieniono) linii: "; lRet
Debug.Print String(35, "=")
ElseIf lRet = 0 Then
Debug.Print "lRet = " & lRet
Debug.Print "Błąd nr: " & Err.Number
Debug.Print "Opis błędu: " & Err.Description
Debug.Print "Źródło błędu: " & Err.Source
Else
Debug.Print "lRet = "; lRet, "pusty lub za krótki plik"
End If
On Error GoTo 0
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.9 Pomocnicza funkcja sprawdzająca poprawność argumentów używanych funkcji ?
' Sprawdza poprawność argumentów funkcji operujących na plikach, przy błędnym argumencie generuje błąd, przy powodzeniu zwraca True i (gdy fToWrite = True)
' w argumencie ByRef sRetPathTmp zwraca pełną ścieżkę pliku tymczasowego,
' • sFilePath - pełna ścieżka do pliku, plik nie może być otwarty na wyłączność, i musi istnieć dla operacji odczytu,
' • fToWrite - rodzaj operacji na pliku, jeżeli fToWrite = True to plik nie może mieć ustawionego atrybutu ReadOnly,
' • lStart - numer początkowego bajtu (znaku, linii) od którego ma być dokonana operacja odczytu lub zapisu, domyślnie = 1, nie może być < 0,
' • lCount - ilość bajtów, (znaków, linii) do operacji odczytu lub zapisu, domyślnie = -1 (wszystkie bajty, znaki, linie od pozycji lStart), nie może być mniejsze od -1 lub = 0
' • sCharsEnd - znak(i) określające koniec linii, tylko znak(i) Chr$(13), Chr$(13) & Chr$(10), ewentualnie (przy zapisie) ciąg zerowej długości "",
' • sRetPathTmp - ścieżka pliku tymczasowego zwracana ByRef, dla fToWrite = True,
' • sFnName - nazwa funkcji wywołującej, w przypadku wywołania błędu przekazywana do funkcji: Err.Raise jako Source := sFnName,
Public Function zbValidArgs(ByVal sFilePath As String, _
ByVal fToWrite As Boolean, _
Optional ByVal lStart As Long = 1, _
Optional ByVal lCount As Long = -1, _
Optional ByVal sCharsEnd As String = vbNewLine, _
Optional sRetPathTmp As String = "", _
Optional ByVal sFnName As String = "") As Boolean
Dim lLenFile As Long
Dim ff As Long
Dim lErrNumber As Long
Const ERR_FILE_NOTFOUND = vbObjectError + 100
Const ERR_INVALID_START = vbObjectError + 101
Const ERR_INVALID_COUNT = vbObjectError + 102
Const ERR_PERMISSION_DENIED = vbObjectError + 103
Const ERR_READ_ONLY = vbObjectError + 104
Const ERR_INVALID_END = vbObjectError + 105
' jeżeli odczytujemy z pliku, to plik musi istnieć
If Len(Dir(sFilePath)) = 0 Then
If fToWrite = False Then GoTo FILE_NOTFOUND
End If
If lStart < 1 Then GoTo INVALID_START
If lCount = 0 Or lCount < -1 Then GoTo INVALID_COUNT
' sprawdź poprawność znaku końca linii
If Len(sCharsEnd) > 0 Then
If Not (sCharsEnd = Chr$(13) Or sCharsEnd = vbNewLine) Then
GoTo INVALID_END
End If
Else
' przy odczycie końcem linii nie może być ciąg zerowej długości
If fToWrite = False Then GoTo INVALID_END
End If
' plik istnieje - sprawdź jego atrybuty
If Len(Dir(sFilePath)) > 0 Then
On Error Resume Next
ff = FreeFile
Open sFilePath For Binary Access Read Write As #ff
Close #ff
' zapamiętaj Nr błędu, bo zostanie wyzerowany
' po On Error GoTo 0
lErrNumber = Err.Number
If lErrNumber <> 0 Then On Error GoTo 0
Select Case lErrNumber
Case 0 ' nie ma błędu
Case 70
GoTo PERMISSION_DENIED
Case 75
' będzie zapis do pliku
If fToWrite = True Then GoTo READ_ONLY
Case Else
Err.Raise Err.Number
End Select
On Error GoTo 0
End If
If fToWrite = True Then
' utwórz śieżkę dla pliku tymczasowego
Randomize
sRetPathTmp = Environ$("TEMP") & "\~" & _
Int((99999 * Rnd) + 1) & ".tmp"
If Len(Dir(sRetPathTmp)) > 0 Then Kill sRetPathTmp
End If
zbValidArgs = True
Exit Function
FILE_NOTFOUND:
Err.Raise ERR_FILE_NOTFOUND, sFnName, "Plik: " & _
sFilePath & " nie istnieje !"
Exit Function
INVALID_START:
Err.Raise ERR_INVALID_START, sFnName, _
"Niewłaściwa wartość argumentu." & _
" Prawidłowo: [lStart] > 0"
Exit Function
INVALID_COUNT:
Err.Raise ERR_INVALID_COUNT, sFnName, _
"Niewłaściwa wartość argumentu." & _
vbNewLine & "Prawidłowo: [lCount = -1] lub [lCount > 0]"
Exit Function
PERMISSION_DENIED:
Err.Raise ERR_PERMISSION_DENIED, sFnName, _
"Brak dostępu do pliku!" & _
sFilePath & vbNewLine & _
"Plik jest otwarty na wyłączność !"
Exit Function
READ_ONLY:
Err.Raise ERR_READ_ONLY, sFnName, _
"Brak dostępu do pliku!" & _
sFilePath & vbNewLine & _
"Plik jest tylko do odczytu !"
Exit Function
INVALID_END:
Err.Raise ERR_INVALID_END, sFnName, _
"Niewłaściwa wartość argumentu." & vbNewLine & _
"Znakiem końca linii może być:" & vbNewLine & _
" • vbCr = Chr(13)" & vbNewLine & _
" • vbCrLf = Chr(13) & Chr(10)" & vbNewLine & _
" • vbNewLine" & vbNewLine & _
" • "" "" - ciąg zerowej długości (tylko przy zapisie do pliku)."
End Function
ΔΔΔ | | | | |
|
| |
