Excel-VBA-Collection

1
Attribute VB_Name = "StrFiles"
2
Option Explicit
3
Option Compare Text
4
Option Base 1
5
DefLng A-Z
6

7
Const ExtChar = "."
8
Const PathChar = "\"
9
Const UNCChar = "\\"
10
Const SepChar = ";"
11

12
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
13
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
14
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
15
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
16
'Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
17

18
'Windows
19
Public Function GetWinDir() As String
20
    Dim s As String, n
21
    n = 255
22
    s = Space(n)
23
    n = GetWindowsDirectory(s, n)
24
    GetWinDir = RightSlash(Left(s, n))
25
End Function
26

27
Public Function GetWinSysDir() As String
28
    Dim s As String, n
29
    n = 255
30
    s = Space(n)
31
    n = GetSystemDirectory(s, n)
32
    GetWinSysDir = RightSlash(Left(s, n))
33
End Function
34

35
Public Function GetWinTempDir() As String
36
    Dim s As String, n
37
    n = 255
38
    s = Space(n)
39
    n = GetTempPath(n, s)
40
    GetWinTempDir = RightSlash(Left(s, n))
41
End Function
42

43
Public Function GetWinTempFile(Optional Prefix As String = "TMP") As String
44
    Dim s As String, n
45
    n = 255: s = Space(n)
46
    n = GetTempPath(n, s)
47
    GetTempFileName Left(s, n), Prefix, 0, s
48
    GetWinTempFile = Left(s, InStr(s, vbNullChar) - 1)
49
End Function
50

51
'Files
52
Public Function FullFile(File As String) As String
53
    Dim Disk As String, Path As String, CurPath As String
54
    If Len(File) = 0 Then
55
        FullFile = vbNullString
56
        Exit Function
57
    End If
58
    CurPath = ActiveWorkbook.FullName
59
    CurPath = Left(CurPath, InStrR(CurPath, PathChar) - 1) 'instead CurDir!
60
    If Mid(File, 2, 1) = ":" Then
61
        Disk = Left(File, 2)
62
        Path = Mid(File, 3)
63
    ElseIf Left(File, 2) = UNCChar Then
64
        Disk = vbNullString
65
        Path = File
66
    Else 'ignore CurDir
67
        'Disk = Left(CurDir, 2)
68
        Disk = Left(CurPath, 2)
69
        Path = File
70
    End If
71
    If Left(Path, 2) = ".\" Then Path = Mid(Path, 3)
72
    Do While Left(Path, 3) = "..\"
73
        Disk = Left(Disk, InStrR(Disk, PathChar) - 1)
74
        Path = Mid(Path, 4)
75
    Loop
76
    If Left(Path, 1) = PathChar Then
77
        FullFile = Disk & Path
78
    Else
79
        'FullFile = RightPathName(CurDir(Disk), Path)
80
        FullFile = RightPathName(CurPath, Path)
81
    End If
82
End Function
83

84
Public Function FilePath(File As String) As String
85
    Dim n As Long
86
    File = FullFile(File)
87
    If IsDir(File) Then
88
        FilePath = RightSlash(File)
89
    Else
90
        n = InStrR(File, PathChar)
91
        If n > 0 Then
92
            FilePath = Left(File, n)
93
        Else
94
            FilePath = RightSlash(CurDir)
95
        End If
96
    End If
97
End Function
98

99
Public Function FileNameExt(File As String) As String
100
    Dim n As Long
101
    n = InStrR(File, PathChar)
102
    If n = Len(File) Then
103
        FileNameExt = vbNullString
104
    ElseIf n > 0 Then
105
        FileNameExt = Mid(File, n + 1)
106
    Else
107
        FileNameExt = File
108
    End If
109
End Function
110

111
Public Function FileNameOnly(File As String) As String
112
    Dim n1 As Long, n2 As Long
113
    If Right(File, 1) = PathChar Then File = Left(File, Len(File) - 1)
114
    n1 = InStrR(File, PathChar)
115
    n2 = InStrR(File, ExtChar)
116
    If n1 > n2 Then
117
        FileNameOnly = Mid(File, n1 + 1)
118
    ElseIf n2 > 0 Then
119
        FileNameOnly = Mid(File, n1 + 1, n2 - n1 - 1)
120
    Else
121
        FileNameOnly = Mid(FileNameOnly, n1 + 1)
122
    End If
123
End Function
124

125
Public Function FileExt(File As String) As String
126
    Dim n1 As Long, n2 As Long
127
    If Right(File, 1) = PathChar Then File = Left(File, Len(File) - 1)
128
    n1 = InStrR(File, PathChar)
129
    n2 = InStrR(File, ExtChar)
130
    If n1 > n2 Then
131
        FileExt = vbNullString
132
    ElseIf n2 > 0 Then
133
        FileExt = Mid(File, n2 + 1)
134
    Else
135
        FileExt = vbNullString
136
    End If
137
End Function
138

139
Public Function ChangeFileExt(File As String, FileExt As String) As String
140
    'No error checking!
141
    If Len(File) = 0 Then
142
        ChangeFileExt = vbNullString
143
    Else
144
        ChangeFileExt = FullFile(Left(File, InStrR(File, ExtChar)) & FileExt)
145
    End If
146
End Function
147

148
Public Function RightSlash(FilePath As String) As String
149
    If Len(FilePath) = 0 Then FilePath = CurDir
150
    If Right(FilePath, 1) = PathChar Then
151
        RightSlash = FilePath
152
    Else
153
        RightSlash = FilePath & PathChar
154
    End If
155
End Function
156

157
Public Function RightPathName(FilePath As String, File As String) As String
158
    RightPathName = RightSlash(FilePath) & File
159
End Function
160

161
'Quote long filenames with spaces in
162
Public Function QFile(File As String) As String
163
    If InStr(File, " ") > 0 And Left(File, 1) <> """" Then
164
        QFile = """" & File & """"
165
    Else
166
        QFile = File
167
    End If
168
End Function
169

170
'Create all dirs in the path
171
Public Sub ForceDirectories(Path As String)
172
    Dim Arr As Variant, i As Long, s As String
173
    If IsDir(Path) Then Exit Sub
174
    On Error Resume Next
175
    Path = FullFile(Path)
176
    Arr = StrToArr(Path, PathChar)
177
    s = Left(Path, InStr(Path, PathChar) - 1)
178
    For i = 2 To UBound(Arr)
179
        s = s & PathChar & CStr(Arr(i))
180
        MkDir s
181
    Next
182
End Sub
183

184
'Search for the file a-la PATH
185
Public Function PathDirectories(Path As String, File As String) As String
186
    Dim Arr As Variant, i As Long, s As String
187
    On Error Resume Next
188
    s = ActiveWorkbook.FullName
189
    s = Left(s, InStrR(s, PathChar) - 1)
190
    Path = Path & SepChar & s '& SepChar & Environ("PATH")
191
    Arr = StrToArr(Path, SepChar)
192
    For i = 1 To UBound(Arr)
193
        s = FullFile(RightPathName(CStr(Arr(i)), File))
194
        If IsFile(s) Then
195
            PathDirectories = FullFile(s)
196
            Exit Function
197
        End If
198
    Next
199
    PathDirectories = vbNullString
200
End Function
201

202
Public Function CountFiles(Mask As String) As Long
203
    Dim File As String
204
    File = Dir(Mask)
205
    CountFiles = 0
206
    Do While File <> vbNullString
207
        CountFiles = CountFiles + 1
208
        File = Dir
209
    Loop
210
End Function
211