Excel-VBA-Collection

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

7
Const DefaultMask = "Все файлы (*.*),*.*"
8

9
Public Function BrowseForFile(ByRef File As String, Optional Mask As String = vbNullString, _
10
    Optional Capt As String = "файл", Optional Force As Boolean = False) As Boolean
11
    Dim f As Variant, s1 As String, s2 As String, Home As String
12
    s1 = FileNameExt(File)
13
    If Not Force Then
14
        If IsFile(File) Then
15
            BrowseForFile = True
16
            Exit Function
17
        End If
18
    End If
19
    On Error Resume Next
20
    Home = CurDir
21
    If Len(Mask) = 0 Then
22
        Mask = DefaultMask
23
    Else
24
        Mask = Mask & "," & DefaultMask
25
    End If
26
    With Application
27
        'set by default
28
        .DefaultFilePath = Application.Path
29
        ChDrive .DefaultFilePath
30
        ChDir .DefaultFilePath
31
    
32
        .DefaultFilePath = FilePath(File) 'Some problems on some computers
33
        ChDrive .DefaultFilePath
34
        ChDir .DefaultFilePath
35
    End With
36
    Do
37
        f = Application.GetOpenFilename(Mask, 1, "Укажите " & Capt)
38
        If f <> False Then 'don't change this!
39
            File = CStr(f)
40
        Else
41
            BrowseForFile = False
42
            ChDrive Home
43
            ChDir Home
44
            Exit Function
45
        End If
46
        s2 = FileNameExt(File)
47
        
48
        If Not Force Then Exit Do
49
        If UCase(s1) = UCase(s2) Then Exit Do
50
        If YesNoBox("ВНИМАНИЕ! Возможно, Вы указали не тот файл,\n" & _
51
            "который ждет от Вас программа:\n\n%s\n(вместо ожидаемого %s)\n\n" & _
52
            "Все равно использовать этот файл?", File, s1) Then Exit Do
53
    Loop
54
    BrowseForFile = IsFile(File)
55
    ChDrive Home
56
    ChDir Home
57
End Function
58

59
Public Function BrowseForFiles(ByRef Files As Variant, Optional Mask As String = vbNullString, _
60
    Optional Capt As String = "файл(ы)", Optional FilterIndex As Long = 1) As Boolean
61
    Dim f As Variant, Home As String
62
    On Error Resume Next
63
    Home = CurDir
64
    If Len(Mask) = 0 Then
65
        Mask = DefaultMask
66
    Else
67
        Mask = Mask & "," & DefaultMask
68
    End If
69
    With Application
70
        .DefaultFilePath = FilePath(CStr(Files)) 'Some problems on some computers
71
        ChDrive .DefaultFilePath
72
        ChDir .DefaultFilePath
73
        f = .GetOpenFilename(Mask, FilterIndex, "Укажите " & Capt, , True)
74
    End With
75
    If f <> False Then 'don't change this!
76
        BrowseForFiles = True
77
        Files = f
78
    Else
79
        BrowseForFiles = False
80
    End If
81
    ChDrive Home
82
    ChDir Home
83
End Function
84

85
Public Function BrowseForSave(ByRef File As String, Optional Mask As String = vbNullString, _
86
    Optional Capt As String = "файл") As Boolean
87
    Dim f As Variant, Home As String
88
    BrowseForSave = False
89
    On Error Resume Next
90
    Home = CurDir
91
    If Len(Mask) = 0 Then
92
        Mask = DefaultMask
93
    Else
94
        Mask = Mask & "," & DefaultMask
95
    End If
96
    With Application
97
        .DefaultFilePath = FilePath(File) 'Some problems on some computers
98
        ChDrive .DefaultFilePath
99
        ChDir .DefaultFilePath
100
        f = .GetSaveAsFilename(File, Mask, 1, "Укажите " & Capt)
101
    End With
102
    ChDrive Home
103
    ChDir Home
104
    If f = False Then Exit Function
105
    File = CStr(f)
106
    BrowseForSave = True
107
End Function
108

109
Public Function IsFile(File As String) As Boolean
110
    IsFile = False
111
    On Error GoTo ErrDir
112
    IsFile = GetAttr(File)
113
    IsFile = Not IsDir(File)
114
ErrDir:
115
End Function
116

117
Public Function IsFile1(RunCmd As String) As Boolean
118
    Dim File As String, Arr As Variant
119
    IsFile1 = False
120
    On Error GoTo ErrDir
121
    Arr = StrToArr(RunCmd)
122
    File = Arr(1)
123
    IsFile1 = GetAttr(File)
124
    IsFile1 = Not IsDir(File)
125
ErrDir:
126
End Function
127

128
Public Function IsDir(File As String) As Boolean
129
    IsDir = False
130
    On Error GoTo ErrDir
131
    IsDir = GetAttr(File) And vbDirectory
132
ErrDir:
133
End Function
134