'********************************************************************************************************** ' Nazwa: printujDoPlikuTekstowego ' Autor: mielk | 2012-12-06 ' ' Opis: Funkcja printująca podaną zawartość (tekst lub tablicę) do podanego ' pliku tekstowego. ' ' Argumenty: ' tresc Treść, która ma zostać wyprintowana w podanym pliku tekstowym. ' sciezkaDoPliku Ścieżka do pliku, w którym ma zostać wyprintowana podana treść. ' czyNadpisywac Argument opcjonalny. ' Określa czy podana zawartość ma zostać dopisana do dotychczasowej zawartości ' wskazanego pliku tekstowego czy też ma nadpisać tę zawartość. ' ' Zwraca: ' Boolean True - jeżeli podana zawartość została pomyślnie wyprintowana do wskazanego pliku ' tekstowego. ' False - jeżeli wystąpił któryś z opisanych poniżej wyjątków i podana zawartość nie ' mogła zostać wyprintowana. ' ' ' Wyjątki: ' NiedozwolonyObiekt Zwracany, kiedy zmienna [tresc] jest obiektem. ' ' NiedozwolonaLiczbaWymiarow Zwracany, kiedy zmienna [tresc] jest tablicą posiadającą więcej niż ' dwa wymiary. ' ' BrakDostepuDoPliku Zwracany, kiedy użytkownik nie może zapisywać pod podaną ścieżką (np. ' nie ma prawa do zapisu lub podana ścieżka nie istnieje). ' ' NiemozliweStworzenieFolderu Zwracany, kiedy nie jest możliwe stworzenie folderu nadrzędnego, ' w którym miałby się znaleźć docelowy plik. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-06 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function printujDoPlikuTekstowego(tresc As Variant, sciezkaDoPliku As String, _ Optional czyNadpisywac As Boolean = False) As Boolean Const NAZWA_METODY As String = "printujDoPlikuTekstowego" '------------------------------------------------------------------------------------------------------ 'Obiekty nie mogą być printowane, ponieważ nie posiadają reprezentacji tekstowej, dlatego zwracany 'jest wyjątek NiedozwolonyObiekt. If VBA.IsObject(tresc) Then GoTo NiedozwolonyObiekt 'Funkcja sprawdza czy podana ścieżka jest dostępna i aktualny użytkownik ma uprawnienia, 'aby do niej zapisywać. If Not czyMozliwyZapisDoPlikuTekstowego(sciezkaDoPliku) Then GoTo BrakDostepuDoPliku 'Funkcja tworzy folder nadrzędny dla wskazanej ścieżki do pliku, o ile nie był on jeszcze stworzony. 'Jeśli nie jest możliwe stworzenie folderu, kod jest przenoszony do labelu NiemozliweStworzenieFolderu. If utworzFolder(getParentFolder(sciezkaDoPliku)) Is Nothing Then GoTo NiemozliweStworzenieFolderu 'Jeżeli argument czyNadpisac jest ustawiony na True, procedura kasuje dotychczasowy plik (o ile 'taki istnieje). Podczas zapisu, w dalszej części procedury, zostanie on utworzony na nowo. If czyNadpisywac Then Call usunPlik(sciezkaDoPliku) 'Funkcja wywołuje oddzielne podprocedury dla tablic i zmiennych prostych, dlatego sprawdza ----------| 'czy funkcja jest tablicą. '| If VBA.IsArray(tresc) Then '| '| 'Procedury printowania różnią się dla tablic jedno- i dwuwymiarowych, dlatego ---------------| '| 'zastosowana jest konstrukcja Select Case, która sprawdza ile wymiarów posiada tablica, '| '| 'a następnie wywołuje odpowiednią podprocedurę. '| '| Select Case liczWymiary(tresc) '| '| Case 1: Call printujDoPlikuTekstowego_Tablica1D(tresc, sciezkaDoPliku) '| '| Case 2: Call printujDoPlikuTekstowego_Tablica2D(tresc, sciezkaDoPliku) '| '| Case Else '| '| 'Tablic posiadających więcej wymiarów nie da się printować, dlatego '| '| 'wywoływany jest wyjątek NiedozwolonaLiczbaWymiarow. '| '| GoTo NiedozwolonaLiczbaWymiarow '| '| End Select '| '| '--------------------------------------------------------------------------------------------| '| '| Else '| '| 'Jeżeli zmienna zawartosc nie jest tablicą ani obiektem, może być ona już tylko zmienną '| 'typu prostego. W takiej sytuacji wywoływana jest podprocedura doPlikuTekstowego_TypProsty. '| Call doPlikuTekstowego_TypProsty(tresc, sciezkaDoPliku) '| '| End If '| '----------------------------------------------------------------------------------------------------| 'Jeżeli wykonywanie kodu dotarło do tego miejsca, oznacza to, że podana zawartość została pomyślnie 'wyprintowana do pliku tekstowego i funkcja zwraca wartość True. printujDoPlikuTekstowego = True '========================================================================================================== PunktWyjscia: Exit Function '---------------------------------------------------------------------------------------------------------- NiedozwolonyObiekt: '(...) 'Obsługa błędów dla przypadku, jeśli parametr podany do funkcji jest obiektem i nie można zamienić go 'na typ tekstowy. GoTo PunktWyjscia NiedozwolonaLiczbaWymiarow: '(...) 'Obsługa błędów dla przypadku, kiedy parametr wejściowy [tresc] jest tablicą, ale posiada więcej 'niż dwa wymiary. GoTo PunktWyjscia BrakDostepuDoPliku: '(...) 'Obsługa błędów dla przypadku, kiedy użytkownik nie ma prawa zapisu pod podaną ścieżką lub podana 'ścieżka nie istnieje. GoTo PunktWyjscia NiemozliweStworzenieFolderu: '(...) 'Obsługa błędów dla przypadku, kiedy niemożliwe jest stworzenie folderu nadrzędnego, w którym miałby 'się znaleźć plik z podaną ścieżką. GoTo PunktWyjscia End Function '********************************************************************************************************** ' Nazwa: printujDoPlikuTekstowego_TypProsty ' ' Opis: Podfunkcja printująca wartości prymitywne do podanego pliku tekstowego. '********************************************************************************************************** Private Sub doPlikuTekstowego_TypProsty(tresc As Variant, sciezkaPliku As String) Const NAZWA_METODY As String = "doPlikuTekstowego_TypProsty" '------------------------------------------------------------------------------------------------------ Dim intNumerPliku As Integer '------------------------------------------------------------------------------------------------------ intNumerPliku = VBA.FreeFile() Open sciezkaPliku For Append As #intNumerPliku Print #intNumerPliku, tresc Close intNumerPliku End Sub '********************************************************************************************************** ' Nazwa: printujDoPlikuTekstowego_Tablica1D ' ' Opis: Podprocedura printująca dla tablic jednowymiarowych. '********************************************************************************************************** Private Sub printujDoPlikuTekstowego_Tablica1D(tresc As Variant, sciezkaDoPliku As String) Const NAZWA_METODY As String = "printujDoPlikuTekstowego_Tablica1D" '------------------------------------------------------------------------------------------------------ Dim iNumerPliku As Integer Dim lngWiersz As Long '------------------------------------------------------------------------------------------------------ iNumerPliku = VBA.FreeFile() Open sciezkaDoPliku For Append As #iNumerPliku For lngWiersz = LBound(tresc, 1) To UBound(tresc, 1) Print #iNumerPliku, tresc(lngWiersz) Next lngWiersz Close iNumerPliku End Sub '********************************************************************************************************** ' Nazwa: printujDoPlikuTekstowego_Tablica2D ' ' Opis: Podprocedura printująca dla tablic dwuwymiarowych. '********************************************************************************************************** Private Sub printujDoPlikuTekstowego_Tablica2D(tresc As Variant, sciezkaDoPliku As String) Const NAZWA_METODY As String = "printujDoPlikuTekstowego_Tablica2D" 'Stała definiująca separator, który będzie użyty do oddzielenia od siebie wartości w poszczególnych 'kolumnach printowanej tablicy. Const SEPARATOR As String = ";" '------------------------------------------------------------------------------------------------------ Dim iNumerPliku As Integer Dim lngWiersz As Long Dim lngKolumna As Long Dim strKolumna As String '------------------------------------------------------------------------------------------------------ iNumerPliku = VBA.FreeFile() Open sciezkaDoPliku For Append As #iNumerPliku For lngWiersz = LBound(tresc, 1) To UBound(tresc, 1) 'Przed przetworzeniem każdego kolejnego wiersza źródłowej tablicy zawartość tymczasowej zmiennej 'strKolumna jest czyszczona, aby nie zawierała danych z poprzednich wierszy. strKolumna = "" 'Pętla dołącza do tymczasowej zmiennej [strKolumna] wartości wszystkich komórek leżących w danym 'wierszu tablicy źródłowej, oddzielając je od siebie znakiem lub ciągiem znaków określonym przez 'stałą [SEPARATOR]. For lngKolumna = LBound(tresc, 2) To UBound(tresc, 2) strKolumna = strKolumna & tresc(lngWiersz, lngKolumna) & SEPARATOR Next lngKolumna 'Separator dodany po wartości z ostatniej kolumny jest usuwany. If VBA.Len(strKolumna) Then strKolumna = VBA.Left$(strKolumna, VBA.Len(strKolumna) - 1) End If 'Wreszcie tak przetworzony tekst jest printowany w pliku tekstowym. Print #iNumerPliku, strKolumna Next lngWiersz Close iNumerPliku End Sub '********************************************************************************************************** ' Nazwa: czyMozliwyZapisDoPlikuTekstowego ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja sprawdzająca czy możliwe jest zapisywanie danych do pliku tekstowego o ' podanej ścieżce. Jeżeli plik o takiej ścieżce jeszcze nie istnieje, funkcja ' sprawdza czy możliwe jest utworzenie pliku o takiej ścieżce. ' ' Argumenty: ' sciezka Ścieżka do pliku, która ma być sprawdzony przez funkcję. ' ' Zwraca: ' Boolean True - jeżeli możliwe jest zapisywania do pliku tekstowego o podanej ścieżce. ' False - jeżeli użytkownik nie ma uprawnień do zapisu w folderze, w którym znajduje ' się dany plik tekstowy lub plik ten nie istnieje, ale przy obecnym poziomie ' uprawnień niemożliwe jest jego stworzenie. ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function czyMozliwyZapisDoPlikuTekstowego(sciezka As String) As Boolean Const NAZWA_METODY As String = "czyMozliwyZapisDoPlikuTekstowego" 'Stała definiująca dopuszczalne rozszerzenia plików tekstowych. Dim ROZSZERZENIE_TXT As Variant: ROZSZERZENIE_TXT = Array("txt", "csv") '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strNazwaDysku As String Dim strFolderBazowy As String Dim strFolderNadrzedny As String Dim strRozszerzenie As String '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| With objFSO 'Sprawdź czy istnieje plik tekstowy o podanej ścieżce. Jeżeli tak sprawdź czy nie jest ----------| 'chroniony przed zapisem. '| If .FileExists(sciezka) Then '| '| czyMozliwyZapisDoPlikuTekstowego = Not (VBA.GetAttr(sciezka) And VBA.vbReadOnly) '| '| Else '| '| 'Sprawdź czy istnieje dysk określony w podanej ścieżce. ---------------------------------| '| strNazwaDysku = .GetDriveName(sciezka) '| '| If .DriveExists(strNazwaDysku) Then '| '| '| '| 'Sprawdź czy rozszerzenie podanego pliku jest zgodne z którymś ze textfile. -----| '| '| 'zdefiniowanych rozszerzeń plików tekstowych. '| '| '| strRozszerzenie = .GetExtensionName(sciezka) '| '| '| If czyJestWTablicy(strRozszerzenie, ROZSZERZENIE_TXT, False) Then '| '| '| '| '| '| 'Uzyskaj folder bazowy tego pliku tekstowego. ---------------------------| '| '| '| strFolderNadrzedny = .GetParentFolderName(sciezka) '| '| '| '| strFolderBazowy = .GetParentFolderName(sciezka) '| '| '| '| Do Until .FolderExists(strFolderBazowy) '| '| '| '| strFolderBazowy = .GetParentFolderName(strFolderBazowy) '| '| '| '| Loop '| '| '| '| '------------------------------------------------------------------------| '| '| '| '| '| '| '| '| '| '------------------------------------------------------------------------| '| '| '| If VBA.StrComp(strFolderBazowy, strFolderNadrzedny, vbTextCompare) = 0 _ Then '| '| '| '| 'Folder docelowy już istnieje. '| '| '| '| czyMozliwyZapisDoPlikuTekstowego = _ czyMozliwyZapisDoFolderu(strFolderNadrzedny) '| '| '| '| Else '| '| '| '| 'Folder docelowy musi zostać stworzony. '| '| '| '| czyMozliwyZapisDoPlikuTekstowego = _ czyMoznaDodawacPodfoldery(strFolderBazowy) '| '| '| '| End If '| '| '| '| '------------------------------------------------------------------------| '| '| '| '| '| '| '| '| '| Else '| '| '| '| '| '| 'Rozszerzenie pliku nie pasuje do definicji pliku tekstowego. '| '| '| czyMozliwyZapisDoPlikuTekstowego = False '| '| '| '| '| '| End If '| '| '| '---- [If .FileExists(sciezka) Then] --------------------------------------------| '| '| '| '| Else '| '| '| '| 'Dysk określony w podanej ścieżce nie istnieje. '| '| czyMozliwyZapisDoPlikuTekstowego = False '| '| '| '| End If '| '| '-------- [If .FileExists(sciezka) Then] ------------------------------------------------| '| '| End If '| '------------ [If .FileExists(sciezka) Then] ----------------------------------------------------| End With End Function '********************************************************************************************************** ' Nazwa: czyJestWTablicy ' Autor: mielk | 2011-07-19 ' ' Opis: Funkcja sprawdzająca czy podany tekst bazowy znajduje się w danej tablicy. ' ' Argumenty: ' wartosc Tekst bazowy, który będzie poszukiwany w tablicy. ' tablica Tablica wartości tekstowych, do której będzie porównywany podany tekst bazowy. ' Parametr [tablica] musi być tablicą jednowymiarową, która zawiera tylko wartości ' typów prostych (dopuszczalne są wartości innego typu niż String), nie może zawierać ' obiektów (w takiej sytuacji zwrócony zostanie wyjątek ObiektyWTablicy). ' wielkoscZnakowMaZnaczenie ' Argument opcjonalny typu Boolean. ' Decyduje o tym, czy przy sprawdzaniu zgodności początku tekstu bazowego z podanym ' ciągiem znaków, funkcja bierze pod uwagę wielkość liter. ' Domyślne ustawienie tego parametru to False, co oznacza, że funkcja nie rozróżnia ' wielkości znaków. ' ' Zwraca: ' Boolean True - jeżeli tekst bazowy znajduje się w podanej tablicy. ' False - jeżeli żaden z elementów tablicy nie jest równy podanemu tekstowi bazowemu. ' ' Wyjątki: ' NieTablica Zwracany, kiedy przekazany do funkcji argument wejściowy [tablica] nie ' jest tablicą lub jest tablicą mającą więcej niż jeden wymiar. ' ObiektyWTablicy Zwracany w sytuacji, gdy przekazana do funkcji tablica oprócz wartości ' typów prostych, zawiera jakikolwiek obiekt. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2011-07-19 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function czyJestWTablicy(wartosc As String, tablica As Variant, _ Optional wielkoscZnakowMaZnaczenie As Boolean = False) As Boolean Const NAZWA_METODY As String = "startsWith" Dim SEPARATOR As String: SEPARATOR = VBA.Chr(0) '------------------------------------------------------------------------------------------------------ Dim tempStr As String Dim uMetodaPorownania As VBA.VbCompareMethod '------------------------------------------------------------------------------------------------------ 'Funkcja sprawdza czy podany argument [tablica] jest tablicą 1D. ------------------------------------| If liczWymiary(tablica) <> 1 Then GoTo NieTablica '| '----------------------------------------------------------------------------------------------------| 'Zamienia podany przez użytkownika parametr typu Boolean [wielkoscZnakowMaZnaczenie] na jedną ze ----| 'stałych enumeracji [VbCompareMethod]. '| If wielkoscZnakowMaZnaczenie Then '| uMetodaPorownania = VBA.vbBinaryCompare '| Else '| uMetodaPorownania = VBA.vbTextCompare '| End If '| '----------------------------------------------------------------------------------------------------| 'Funkcja próbuje przekonwertować podaną tablicę na ciąg tekstowy przy użyciu wbudowanej funkcji -----| 'VBA Join. Jeżeli wśród elementów tablic jest jakiś obiekt, zostanie wygenerowany błąd '| 'ObiektyWTablicy. '| On Error GoTo ObiektyWTablicy '| tempStr = SEPARATOR & VBA.Join(tablica, SEPARATOR) & SEPARATOR '| On Error GoTo 0 '| '----------------------------------------------------------------------------------------------------| czyJestWTablicy = VBA.InStr(1, tempStr, SEPARATOR & wartosc & SEPARATOR, uMetodaPorownania) '========================================================================================================== PunktWyjscia: Exit Function '----------------------------------------------- NieTablica: 'Obsługa błędów dla przypadku, kiedy podany argument [tablica] nie jest tablicą lub posiada więcej niż 'jeden wymiar. GoTo PunktWyjscia ObiektyWTablicy: 'Obsługa błędów dla przypadku, jeżeli w tablicy [tablica] znajduje się jakikolwiek obiekt, który nie 'może zostać przekonwertowany na typ String. GoTo PunktWyjscia End Function '********************************************************************************************************** ' Nazwa: liczWymiary ' Autor: mielk | 2012-03-03 ' ' Opis: Funkcja zwraca liczbę wymiarów podanej tablicy VBA. ' ' Argumenty: ' tablica Tablica, której liczba wymiarów ma zostać zwrócona. ' ' Zwraca: ' Integer Liczba wymiarów podanej tablicy VBA. ' Jeżeli podana wartość nie jest tablicą lub jest zadeklarowana jako tablica ' dynamiczna, ale nie przypisano jeszcze do niej liczby wymiarów, zwracana ' jest wartość 0. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-03-03 mielk Utworzenie funkcji ' 2014-06-15 mielk Zwracany typ zmieniony na Integer, żeby umożliwić zwracanie wartości -1, ' jeżeli podany parametr nie jest w ogóle tablicą. '********************************************************************************************************** Public Function liczWymiary(tablica As Variant) As Integer Const NAZWA_METODY As String = "liczWymiary" '------------------------------------------------------------------------------------------------------ Dim granica As Long '------------------------------------------------------------------------------------------------------ If VBA.IsArray(tablica) Then On Error GoTo NieistniejacyWymiar Do granica = UBound(tablica, liczWymiary + 1) liczWymiary = liczWymiary + 1 Loop Else liczWymiary = -1 End If '---------------------------------------------------------------------------------------------------------- NieistniejacyWymiar: End Function '********************************************************************************************************** ' Nazwa: czyMozliwyZapisDoFolderu ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja sprawdzająca czy aktualny użytkownik ma prawo do zapisu w danym folderze, ' a więc może dodawać, usuwać i modyfikować pliki w tym folderze. ' ' Argumenty: ' sciezkaDoFolderu Ścieżka folderu, który ma zostać sprawdzony pod kątem możliwości zapisu. ' ' Zwraca: ' Boolean True - jeżeli użytkownik ma uprawnienia aby dodawać, usuwać i modyfikować pliki ' w danym folderze. ' False - w innym przypadku. ' ' Wyjątki: ' NieistniejacyFolder Zwracany, jeżeli folder podany jako argument wejściowy nie istnieje. ' ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function czyMozliwyZapisDoFolderu(sciezkaDoFolderu As String) As Boolean Const NAZWA_METODY As String = "czyMozliwyZapisDoFolderu" Const NAZWA_PLIKU_TEMP As String = "TestFile.txt" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strPlikTemp As String '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| 'Sprawdź czy podany folder w ogóle istnieje. --------------------------------------------------------| If objFSO.FolderExists(sciezkaDoFolderu) Then '| '| 'Stwórz pełną ścieżkę do pliku pomocniczego. '| strPlikTemp = sciezkaDoFolderu '| If Not VBA.right$(sciezkaDoFolderu, 1) = "\" Then strPlikTemp = strPlikTemp & "\" '| strPlikTemp = unikatowaSciezka(strPlikTemp & NAZWA_PLIKU_TEMP) '| '| '| 'Spróbuj utworzyć plik pomocniczy. ------------------------------------------------------| '| On Error Resume Next '| '| Call objFSO.CreateTextFile(strPlikTemp) '| '| On Error GoTo 0 '| '| '----------------------------------------------------------------------------------------| '| '| '| 'Funkcja sprawdza czy tymczasowy plik został utworzony. Jeżeli tak, oznacza to, że ------| '| 'użytkownik ma uprawnienia do zapisu do podanego folderu. '| '| 'W takiej sytuacji funkcja zwraca wartość True i kasuje plik tymczasowy. '| '| If objFSO.FileExists(strPlikTemp) Then '| '| czyMozliwyZapisDoFolderu = True '| '| Call objFSO.usunPlik(strPlikTemp) '| '| End If '| '| '----------------------------------------------------------------------------------------| '| '| Else '| '| GoTo NieistniejacyFolder '| '| End If '| '-------- [If objFSO.FolderExists(sciezkaDoFolderu) Then] -------------------------------------------| '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NieistniejacyFolder: 'Obsługa błędów dla sytuacji, kiedy podany folder nie istnieje. GoTo ExitPoint End Function '********************************************************************************************************** ' Nazwa: unikatowaSciezka ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja przekształca podaną ścieżkę do pliku, tak aby była ona unikatowa. ' ' Argumenty: ' sciezka Ścieżka do pliku, która ma być przetworzona przez funkcję. ' ' Zwraca: ' String Podana ścieżka, przekształcona do postaci unikatowej ścieżki do pliku. ' ' Jeżeli plik o podanej ścieżce nie istnieje, zwracana jest oryginalna ' ścieżka do pliku. ' ' Jeżeli plik o podanej ścieżce istnieje, zwracana jest oryginalna ścieżka po ' uprzednim dodaniu do nazwy pliku liczby porządkowej w nawiasie. ' ' ' Przykład: ' --------------------------------------------------------------------------------- ' * Jeżeli funkcja została wywołana dla ścieżki C:\test.txt, a w systemie plików nie ' ma jeszcze takiego pliku, zwracana jest ścieżka w oryginalnej postaci ' (C:\test.txt). ' * Jeżeli jednak istnieje już plik o takiej nazwie, leżący w tym samym folderze, ' zwrócona zostanie ścieżka C:\test (1).txt. ' * Jeżeli również taki plik już istnieje, zwrócona ścieżka będzie miała ' postać: C:\test (2).txt, itd. ' ' ' Uwaga: Funkcja nie sprawdza czy podana ścieżka do pliku jest prawidłowo skonstruowana. ' W przypadku, gdy do funkcji jest przekazywana niepoprawna ścieżka, jest ona ' zwracana bez żadnych zmian, ponieważ funkcja ustali, że plik o podanej ścieżce ' nie istnieje (w końcu nie może istnieć, skoro jest to nieprawidłowa ścieżka) i nie ' ma podstaw, żeby w jakikolwiek sposób ją zmieniać. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function unikatowaSciezka(sciezka As String) As String Const NAZWA_METODY As String = "unikatowaSciezka" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strRozszerzeniePliku As String Dim strNazwaPliku As String Dim strFolderNadrzedny As String Dim strTempSciezka As String Dim intLicznik As Integer '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| With objFSO 'Sprawdź czy plik o podanej ścieżce już istnieje. -----------------------------------------------| If .FileExists(sciezka) Then '| '| 'Jeżeli podana ścieżka już istnieje, funkcja przekształca ścieżkę wejściową w ten sposób, '| 'że dołącza do niej kolejne liczby w nawiasie. '| strFolderNadrzedny = .GetParentFolderName(sciezka) '| If Not VBA.right$(strFolderNadrzedny, 1) = "\" Then strFolderNadrzedny = _ strFolderNadrzedny & "\" '| strNazwaPliku = .GetBaseName(sciezka) '| strRozszerzeniePliku = "." & .GetExtensionName(sciezka) '| '| '------------------------------------------------------------------------------------| '| Do '| '| intLicznik = intLicznik + 1 '| '| strTempSciezka = strFolderNadrzedny & strNazwaPliku & _ " (" & intLicznik & ")" & strRozszerzeniePliku '| '| Loop While .FileExists(strTempSciezka) '| '| '------------------------------------------------------------------------------------| '| '| unikatowaSciezka = strTempSciezka '| '| Else '| '| 'Jeżeli nie znaleziony został plik o podanej nazwie, oznacza to, że nie istnieje, więc '| 'ścieżka wejściowa może być zwrócona bez dokonywania jakichkolwiek zmian. '| unikatowaSciezka = sciezka '| '| End If '| '-------- [If .FileExists(sciezka) Then] --------------------------------------------------------| End With End Function '********************************************************************************************************** ' Nazwa: czyMoznaDodawacPodfoldery ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja sprawdzająca czy aktualny użytkownik ma uprawnienia, żeby dodawać ' podfoldery do danego folderu. ' ' Argumenty: ' sciezkaDoFolderu Ścieżka do folderu, który ma zostać sprawdzony. ' ' Zwraca: ' Boolean True - jeżeli do danego folderu można dodawać podfoldery. ' False - w innym przypadku. ' ' Wyjątki: ' NieistniejacyFolder Wywoływany jeżeli folder o podanej ścieżce nie istnieje. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function czyMoznaDodawacPodfoldery(sciezkaDoFolderu As String) As Boolean Const NAZWA_METODY As String = "czyMoznaDodawacPodfoldery" Const SUBFOLDER_NAME As String = "TestFolder" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strTempFolder As String '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| 'Sprawdź czy podany folder w ogóle istnieje. --------------------------------------------------------| If objFSO.FolderExists(sciezkaDoFolderu) Then '| '| 'Stwórz pełną ścieżkę do folderu tymczasowego. '| strTempFolder = sciezkaDoFolderu '| If Not VBA.right$(sciezkaDoFolderu, 1) = "\" Then strTempFolder = strTempFolder & "\" '| strTempFolder = unikatowaNazwaFolderu(strTempFolder & SUBFOLDER_NAME) '| '| 'Spróbuj stworzyć folder tymczasowy. ----------------------------------------------------| '| On Error Resume Next '| '| Call objFSO.utworzFolder(strTempFolder) '| '| On Error GoTo 0 '| '| '----------------------------------------------------------------------------------------| '| '| 'Sprawdza czy folder pomocniczny został utworzony. Jeżeli tak, oznacza to, że -----------| '| 'możliwe jest dodawanie podfolderów w folderze źródłowym. W takiej sytuacji '| '| 'funkcja zwraca wartość True i usuwa folder tymczasowy. '| '| If objFSO.FolderExists(strTempFolder) Then '| '| czyMoznaDodawacPodfoldery = True '| '| Call objFSO.usunFolder(strTempFolder) '| '| End If '| '| '----------------------------------------------------------------------------------------| '| '| Else '| '| GoTo NieistniejacyFolder '| '| End If '| '-------- [If objFSO.FolderExists(sciezkaDoFolderu) Then] -------------------------------------------| '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NieistniejacyFolder: 'Obsługa błędów dla sytuacji, kiedy podany folder nie istnieje. GoTo ExitPoint End Function '********************************************************************************************************** ' Nazwa: unikatowaNazwaFolderu ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja przekształca podaną nazwę folderu, tak aby była ona unikatowa w ramach ' folderu, do którego należy. ' ' Argumenty: ' nazwaFolderu Nazwa folderu, która ma być przetworzona przez funkcję. ' ' Zwraca: ' String Podana ścieżka folderu, przekształcona do takiej postaci aby jego nazwa była ' unikatowa w ramach folderu nadrzędnego. ' ' * Jeżeli folder o podanej ścieżce nie istnieje, zwracana jest oryginalna ścieżka ' folderu. ' ' * Jeżeli folder o podanej ścieżce istnieje, zwracana jest oryginalna ścieżka po ' uprzednim dodaniu do nazwy folderu liczby porządkowej w nawiasie. ' ' ' Przykład: ' --------------------------------------------------------------------------------- ' Jeżeli funkcja została wywołana dla folderu C:\test\ a w systemie plików nie ma ' jeszcze takiego folderu, zwracana jest ścieżka w oryginalnej postaci (C:\test\). ' Jeżeli jednak istnieje już folder o takiej nazwie, leżący w tym samym folderze ' nadrzędnym, zwrócona zostanie ścieżka C:\test (1). Jeżeli również taki folder ' już istnieje, zwrócona ścieżka będzie miała postać: C:\test (2), itd. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function unikatowaNazwaFolderu(nazwaFolderu As String) As String Const NAZWA_METODY As String = "unikatowaNazwaFolderu" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strNazwaFolderu As String Dim strFolderNadrzedny As String Dim strTempNazwa As String Dim intLicznik As Integer '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| With objFSO 'Sprawdź czy podany folder w ogóle istnieje. ----------------------------------------------------| If .FolderExists(nazwaFolderu) Then '| '| 'Jeżeli folder o podanej nazwie już istnieje, funkcja przekształca sprawdzaną nazwę w ten '| 'sposób, że po oryginalnej nazwie folderu dodaje kolejne liczby w nawiasie. '| strFolderNadrzedny = .GetParentFolderName(nazwaFolderu) '| If Not VBA.right$(strFolderNadrzedny, 1) = "\" Then strFolderNadrzedny = _ strFolderNadrzedny & "\" '| strNazwaFolderu = .GetBaseName(nazwaFolderu) '| '| '------------------------------------------------------------------------------------| '| Do '| '| intLicznik = intLicznik + 1 '| '| strTempNazwa = strFolderNadrzedny & strNazwaFolderu & " (" & intLicznik & ")" '| '| Loop While .FolderExists(strTempNazwa) '| '| '------------------------------------------------------------------------------------| '| '| unikatowaNazwaFolderu = strTempNazwa '| '| Else '| '| 'Jeżeli nie znaleziony został folder o takiej ścieżce, oznacza to, że jest unikatowa '| 'i może być zwrócona w oryginalnej formie. '| unikatowaNazwaFolderu = nazwaFolderu '| '| End If '| '-------- [If .FolderExists(nazwaFolderu) Then] ---------------------------------------------------| End With End Function '********************************************************************************************************** ' Nazwa: utworzFolder ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja sprawdza czy podany folder istnieje. Jeżeli tak, zwracane jest odniesienie ' do tego folderu. ' Jeżeli nie, folder jest tworzony i również zwracane jest odniesienie do niego. ' ' Argumenty: ' sciezkaDoFolderu Ścieżka folderu, do którego odniesienie ma być zwrócone. ' ' Zwraca: ' Object Obiekt typu Scripting.Folder reprezentujący podaną ścieżkę. ' ' Jeżeli folder już istnieje, funkcja zwraca referencję do tego folderu nie ' podejmując żadnych dodatkowych akcji. ' ' Jeżeli folder nie istnieje, funkcja tworzy go i zwraca odniesienie do tego folderu. ' ' Jeżeli folder nie istnieje i nie może być utworzony (np. z powodu braku uprawnień ' lub niepoprawnej ścieżki) zwracane jest Nothing. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function utworzFolder(sciezkaDoFolderu As String) As Object Const NAZWA_METODY As String = "utworzFolder" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strNazwaDysku As String Dim strFolderNadrzedny As String '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| With objFSO 'Jeżeli podany folder już istnieje, jest przypisywany do zmiennej [utworzFolder] i zwracany -----| 'jako wynik funkcji. '| If .FolderExists(sciezkaDoFolderu) Then '| '| Set utworzFolder = .getFolder(sciezkaDoFolderu) '| '| Else '| '| 'Sprawdź czy istnieje nazwa dysku podana w ścieżce źródłowej. ---------------------------| '| strNazwaDysku = .GetDriveName(sciezkaDoFolderu) '| '| If .DriveExists(strNazwaDysku) Then '| '| '| '| 'Uzyskaj nazwę folderu nadrzędnego. ---------------------------------------------| '| '| strFolderNadrzedny = .GetParentFolderName(sciezkaDoFolderu) '| '| '| If Not .FolderExists(strFolderNadrzedny) Then '| '| '| 'Jeżeli folder nadrzędny nie istnieje, funkcji [utworzFolder] jest '| '| '| 'wywoływana rekurencyjnie i tworzy ten folder. '| '| '| Call utworzFolder(strFolderNadrzedny) '| '| '| End If '| '| '| '--------------------------------------------------------------------------------| '| '| '| '| '--------------------------------------------------------------------------------| '| '| On Error Resume Next '| '| '| Call .utworzFolder(sciezkaDoFolderu) '| '| '| Set utworzFolder = .getFolder(sciezkaDoFolderu) '| '| '| On Error GoTo 0 '| '| '| '--------------------------------------------------------------------------------| '| '| '| '| End If '| '| '-------- [If .DriveExists(strNazwaDysku) Then] -----------------------------------------| '| '| End If '| '------------ [If .FolderExists(sciezkaDoFolderu) Then] -----------------------------------------| End With End Function '********************************************************************************************************** ' Nazwa: utworzFolder ' Autor: mielk | 2012-12-02 ' ' Opis: Funkcja sprawdza czy podany folder istnieje. Jeżeli tak, zwracane jest odniesienie ' do tego folderu. ' Jeżeli nie, folder jest tworzony i również zwracane jest odniesienie do niego. ' ' Argumenty: ' sciezkaDoFolderu Ścieżka folderu, do którego odniesienie ma być zwrócone. ' ' Zwraca: ' Object Obiekt typu Scripting.Folder reprezentujący podaną ścieżkę. ' ' Jeżeli folder już istnieje, funkcja zwraca referencję do tego folderu nie ' podejmując żadnych dodatkowych akcji. ' ' Jeżeli folder nie istnieje, funkcja tworzy go i zwraca odniesienie do tego folderu. ' ' Jeżeli folder nie istnieje i nie może być utworzony (np. z powodu braku uprawnień ' lub niepoprawnej ścieżki) zwracane jest Nothing. ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-12-02 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function utworzFolder(sciezkaDoFolderu As String) As Object Const NAZWA_METODY As String = "utworzFolder" '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. Dim strNazwaDysku As String Dim strFolderNadrzedny As String '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| With objFSO 'Jeżeli podany folder już istnieje, jest przypisywany do zmiennej [utworzFolder] i zwracany -----| 'jako wynik funkcji. '| If .FolderExists(sciezkaDoFolderu) Then '| '| Set utworzFolder = .getFolder(sciezkaDoFolderu) '| '| Else '| '| 'Sprawdź czy istnieje nazwa dysku podana w ścieżce źródłowej. ---------------------------| '| strNazwaDysku = .GetDriveName(sciezkaDoFolderu) '| '| If .DriveExists(strNazwaDysku) Then '| '| '| '| 'Uzyskaj nazwę folderu nadrzędnego. ---------------------------------------------| '| '| strFolderNadrzedny = .GetParentFolderName(sciezkaDoFolderu) '| '| '| If Not .FolderExists(strFolderNadrzedny) Then '| '| '| 'Jeżeli folder nadrzędny nie istnieje, funkcji [utworzFolder] jest '| '| '| 'wywoływana rekurencyjnie i tworzy ten folder. '| '| '| Call utworzFolder(strFolderNadrzedny) '| '| '| End If '| '| '| '--------------------------------------------------------------------------------| '| '| '| '| '--------------------------------------------------------------------------------| '| '| On Error Resume Next '| '| '| Call .utworzFolder(sciezkaDoFolderu) '| '| '| Set utworzFolder = .getFolder(sciezkaDoFolderu) '| '| '| On Error GoTo 0 '| '| '| '--------------------------------------------------------------------------------| '| '| '| '| End If '| '| '-------- [If .DriveExists(strNazwaDysku) Then] -----------------------------------------| '| '| End If '| '------------ [If .FolderExists(sciezkaDoFolderu) Then] -----------------------------------------| End With End Function '********************************************************************************************************** ' Nazwa: usunPlik ' Autor: mielk | 2012-10-14 ' ' Opis: Funkcja usuwająca z systemu plików plik o podanej ścieżce ' ' Argumenty: ' sciezka Ścieżka dostępu do pliku, który ma zostać usunięty. ' ' Zwraca: ' Boolean True - jeżeli plik został usunięty lub plik o podanej ścieżce nie istnieje. ' False - jeżeli usunięcie pliku o podanej ścieżce jest niemożliwe (np. jest on ' aktualnie używany). ' ' ' --- Zmiany ---------------------------------------------------------------------------------------------- ' 2012-10-14 mielk Utworzenie funkcji. '********************************************************************************************************** Public Function usunPlik(sciezka As String) As Boolean Const NAZWA_METODY As String = "usunPlik" Const ERR_NUM_PLIK_NIE_ISTNIEJE As Long = 53 '------------------------------------------------------------------------------------------------------ Static objFSO As Object 'Późne wiązanie pozwala korzystać z funkcji nawet jeżeli 'nie jest załadowana biblioteka Microsoft Scripting Runtime. '------------------------------------------------------------------------------------------------------ 'Tworzy instancję klasy FileSystemObject, jeżeli nie została jeszcze stworzona. ---------------------| If objFSO Is Nothing Then '| Set objFSO = VBA.CreateObject("Scripting.FileSystemObject") '| End If '| '----------------------------------------------------------------------------------------------------| 'Spróbuj usunąć podany plik. Jeżeli nie jest to możliwe, kod przeskakuje do labelu . ----------------| 'NiemozliweUsunieciePliku '| On Error GoTo NiemozliweUsunieciePliku '| Call objFSO.usunPlik(sciezka) '| usunPlik = True '| '----------------------------------------------------------------------------------------------------| '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NiemozliweUsunieciePliku: If VBA.Err.number = ERR_NUM_PLIK_NIE_ISTNIEJE Then 'Plik nie mógł zostać usunięty, ponieważ nie istnieje. W takiej sytuacji funkcja ma zwracać True. usunPlik = True Else 'Plik nie może być usunięty z innych powodów (np. jest aktualnie używany). usunPlik = False End If GoTo ExitPoint End Function