-
Notifications
You must be signed in to change notification settings - Fork 59
/
Copy pathclsCmnDlg.cls
227 lines (189 loc) · 7.11 KB
/
clsCmnDlg.cls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsCmnDlg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Author: [email protected]
'Site: http://sandsprite.com
Option Explicit
Const LANG_US = &H409
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type oColorDlg
lStructSize As Long
hWndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Enum FilterTypes
textFiles = 0
htmlFiles = 1
exeFiles = 2
zipFiles = 3
AllFiles = 4
CustomFilter = 5
End Enum
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As oColorDlg) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private o As OPENFILENAME
Private filters(6) As String
Private extensions(6) As String
Private errOnCancel As Boolean
Property Let ErrorOnCancel(bln As Boolean)
errOnCancel = bln
End Property
Property Get ErrorOnCancel() As Boolean
ErrorOnCancel = errOnCancel
End Property
Sub SetCustomFilter(displayText As String, Optional wildCardExtMatch = "*.*")
filters(5) = "____" + Chr$(0) + "___" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
filters(5) = Replace(filters(5), "____", displayText)
filters(5) = Replace(filters(5), "___", wildCardExtMatch)
extensions(5) = Replace(wildCardExtMatch, "*", "")
End Sub
Private Sub Class_Initialize()
'If Not isRegistered And Not isInitalized Then TellThemAllAboutIt
filters(0) = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
filters(1) = "Html Files (*.htm*)" + Chr$(0) + "*.htm*" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
filters(2) = "Exe Files (*.exe)" + Chr$(0) + "*.exe" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
filters(3) = "Zip Files (*.zip)" + Chr$(0) + "*.zip" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
filters(4) = "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
extensions(0) = "txt"
extensions(1) = "html"
extensions(2) = "exe"
extensions(3) = "zip"
extensions(4) = "bin"
End Sub
Function OpenDialog(filt As FilterTypes, Optional initDir As String, Optional title As String, Optional pHwnd As Long = 0) As String
o.lStructSize = Len(o)
o.hWndOwner = pHwnd
o.hInstance = 0
o.lpstrFilter = filters(filt)
o.lpstrFile = Space$(254)
o.nMaxFile = 255
o.lpstrFileTitle = Space$(254)
o.nMaxFileTitle = 255
o.lpstrInitialDir = initDir
o.lpstrTitle = title
o.flags = 0
OpenDialog = IIf(GetOpenFileName(o), Trim$(o.lpstrFile), "")
OpenDialog = Replace(OpenDialog, Chr(0), Empty)
If Len(OpenDialog) = 0 And errOnCancel Then Err.Raise 1, "OpenDialog", "Cancel"
End Function
Function SaveDialog(filt As FilterTypes, Optional initDir As String, Optional title As String = "", Optional ConfirmOvewrite As Boolean = True, Optional pHwnd As Long = 0, Optional defaultFileName As String) As String
o.lStructSize = Len(o)
o.hWndOwner = pHwnd
o.hInstance = pHwnd
o.lpstrFilter = filters(filt)
o.lpstrFile = Space$(254)
o.nMaxFile = 255
o.lpstrFileTitle = Space$(254)
o.nMaxFileTitle = 255
o.lpstrInitialDir = initDir
o.lpstrTitle = title
o.lpstrDefExt = extensions(filt)
o.flags = 0
If Len(defaultFileName) > 0 Then
o.lpstrFile = defaultFileName & Space$(254)
o.nMaxFile = Len(o.lpstrFile) + 1
End If
Dim tmp As String
tmp = IIf(GetSaveFileName(o), Trim$(o.lpstrFile), "")
If ConfirmOvewrite And tmp <> "" Then
If FileExists(tmp) Then
If MsgBox("File Already Exists" & vbCrLf & vbCrLf & "Are you sure you wish to overwrite existing file?", vbYesNo + vbExclamation, "Confirm Overwrite") = vbYes Then SaveDialog = tmp
Else
SaveDialog = tmp
End If
Else
SaveDialog = tmp
End If
SaveDialog = Replace(SaveDialog, Chr(0), Empty)
If Len(SaveDialog) = 0 And errOnCancel Then Err.Raise 1, "SaveDialog", "Cancel"
End Function
Function ColorDialog(Optional pHwnd As Long) As Long
Dim c As oColorDlg
Dim cColors() As Byte
c.lStructSize = Len(c)
c.hWndOwner = pHwnd
c.hInstance = App.hInstance
c.lpCustColors = StrConv(cColors, vbUnicode, LANG_US)
c.flags = 0
If ChooseColor(c) <> 0 Then
ColorDialog = c.rgbResult
cColors = StrConv(c.lpCustColors, vbFromUnicode, LANG_US)
Else
ColorDialog = -1
If errOnCancel Then Err.Raise 1, "ShowColor", "Cancel"
End If
End Function
Function FolderDialog(Optional initDir As String, Optional pHwnd As Long = 0) As String
Dim bInfo As BrowseInfo, ret As String, ptrList As Long, nullChar As Long
With bInfo
.hWndOwner = pHwnd
.lpszTitle = lstrcat(initDir, "") 'returns memaddress
.ulFlags = 1 'only directories
End With
ptrList = SHBrowseForFolder(bInfo)
If ptrList Then
ret = String$(260, 0)
SHGetPathFromIDList ptrList, ret 'Get the path from the IDList
CoTaskMemFree ptrList 'free the block of memory
nullChar = InStr(ret, vbNullChar)
If nullChar > 0 Then ret = Left$(ret, nullChar - 1)
End If
FolderDialog = Replace(ret, Chr(0), Empty)
If Len(ret) = 0 And errOnCancel Then Err.Raise 1, "ChooseFolder", "Cancel"
End Function
Private Function FileExists(path) As Boolean
If Len(path) = 0 Then Exit Function
If Dir(path, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then FileExists = True
End Function