Not a Member Yet,
Click here to Register
How do you like the new design?
It's cool, great job
[tally: 70%] 70%
It's okay
[tally: 20%] 20%
Its OK but I liked the old layout better
[tally: 0%] 0%
Please bring the old one back
[tally: 10%] 10%

votes: 10

ID: 316
Viewed: 2643
Added: Aug 19, 2002
Version:
Snippet uploaded by: snippet
Written By: Unknown
Demo: Sorry, no demo



User Rated at: 3 Stars3 Stars3 Stars
Rate This:

Thank you for your vote. Please wait...

It appears you already voted for this snippet

It appears your vote value was empty

uses common dialog for file browsing

Highlight all by clicking in box
<!---Declaration--->
Option Explicit

' private internal buffer
Dim iAction As Integer
Dim lAPIReturn As Long
Dim bCancelError As Boolean
Dim sDefaultExt As String
Dim sDialogTitle As String
Dim lExtendedError As Long
Dim sFileName As String
Dim sFileTitle As String
Dim sFilter As String
Dim iFilterIndex As Long
Dim lFlags As Long
Dim lHelpCommand As Long
Dim sHelpContext As String
Dim sHelpFile As String
Dim sHelpKey As String
Dim sInitDir As String
Dim lMax As Long
Dim lMaxFileSize As Long
Dim lMin As Long
Dim objObject As Object

Dim lhWndOwner As Long

Public Enum DlgFileFlags
OFN_ALLOWMULTISELECT = &H200
OFN_CREATEPROMPT = &H2000 = &H80
OFN_EXPLORER = &H80000
OFN_EXTENSIONDIFFERENT = &H400
OFN_FILEMUSTEXIST = &H1000
OFN_HIDEREADONLY = &H4
OFN_LONGNAMES = &H200000
OFN_NOCHANGEDIR = &H8
OFN_NODEREFERENCELINKS = &H100000
OFN_NOLONGNAMES = &H40000
OFN_NONETWORKBUTTON = &H20000
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000
OFN_NOVALIDATE = &H100
OFN_OVERWRITEPROMPT = &H2
OFN_PATHMUSTEXIST = &H800
OFN_READONLY = &H1
OFN_SHOWHELP = &H10
End Enum

'API
Private Const CLSCD_NOACTION = 0
Private Const CLSCD_SHOWOPEN = 1
Private Const CLSCD_SHOWSAVE = 2
Private Const CLSCD_USERCANCELED = 0
Private Const CLSCD_USERSELECTED = 1

Private Const CLSCD_MAXFILESIZE = 128
Private Const CLSCD_ERRNUMUSRCANCEL = 32755
Private Const CLSCD_ERRDESUSRCANCEL = "Cancel was selected."
Private Const CLSCD_ERRNUMUSRBUFFER = 32756
Private Const CLSCD_ERRDESUSRBUFFER = "Buffer to small"

Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001

Private Type tOPENFILENAME
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 DlgFileFlags
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Declare Function GetOpenFileNameA Lib "comdlg32.dll" (pOpenfilename As tOPENFILENAME) As Long
Private Declare Function GetSaveFileNameA Lib "comdlg32.dll" (pOpenfilename As tOPENFILENAME) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

' Read Only
Public Property Get Action() As Integer
Action = iAction
End Property

' Read Only
Public Property Get APIReturn() As Long
APIReturn = lAPIReturn
End Property

' Read/Write
Public Property Get CancelError() As Boolean
CancelError = bCancelError
End Property
Public Property Let CancelError(vNewValue As Boolean)
bCancelError = vNewValue
End Property


' Read/Write
Public Property Get DefaultExt() As String
DefaultExt = sDefaultExt
End Property
Public Property Let DefaultExt(vNewValue As String)
sDefaultExt = vNewValue
End Property

' Read/Write
Public Property Get DialogTitle() As String
DialogTitle = sDialogTitle
End Property
Public Property Let DialogTitle(vNewValue As String)
sDialogTitle = vNewValue
End Property

' Read Only
Public Property Get ExtendedError() As Long
ExtendedError = lExtendedError
End Property

' Read/Write
Public Property Get FileName() As String
FileName = sFileName
End Property
Public Property Let FileName(vNewValue As String)
sFileName = vNewValue
End Property

' Read/Write
Public Property Get FileTitle() As String
FileTitle = sFileTitle
End Property
Public Property Let FileTitle(vNewValue As String)
sFileTitle = vNewValue
End Property

' Read/Write
Public Property Get Filter() As String
Filter = sFilter
End Property
Public Property Let Filter(vNewValue As String)
sFilter = vNewValue
End Property

' Read/Write
Public Property Get FilterIndex() As Long
FilterIndex = iFilterIndex
End Property
Public Property Let FilterIndex(vNewValue As Long)
iFilterIndex = vNewValue
End Property

' Read/Write
Public Property Get Flags() As Long
Flags = lFlags
End Property
Public Property Let Flags(vNewValue As Long)
lFlags = vNewValue
End Property


' Read/Write
Public Property Get hWndOwner() As Long
hWndOwner = lhWndOwner
End Property
Public Property Let hWndOwner(vNewValue As Long)
lhWndOwner = vNewValue
End Property

' Read/Write
Public Property Get HelpCommand() As Long
HelpCommand = lHelpCommand
End Property
Public Property Let HelpCommand(vNewValue As Long)
lHelpCommand = vNewValue
End Property

' Read/Write
Public Property Get HelpContext() As String
HelpContext = sHelpContext
End Property
Public Property Let HelpContext(vNewValue As String)
sHelpContext = vNewValue
End Property

' Read/Write
Public Property Get HelpFile() As String
HelpFile = sHelpFile
End Property
Public Property Let HelpFile(vNewValue As String)
sHelpFile = vNewValue
End Property

' Read/Write
Public Property Get HelpKey() As String
HelpKey = sHelpKey
End Property
Public Property Let HelpKey(vNewValue As String)
sHelpKey = vNewValue
End Property

' Read/Write
Public Property Get InitDir() As String
InitDir = sInitDir
End Property
Public Property Let InitDir(vNewValue As String)
sInitDir = vNewValue
End Property


' Read/Write
Public Property Get MaxFileSize() As Long
MaxFileSize = lMaxFileSize
End Property
Public Property Let MaxFileSize(vNewValue As Long)
lMaxFileSize = vNewValue
End Property


' Read Only
Public Property Get Object() As Object
Object = objObject
End Property
'Provide the ShowOpen method.

Highlight All
<!---Code--->
Public Sub ShowOpen()
ShowFileDialog (CLSCD_SHOWOPEN)
End Sub

'Provide the ShowSave method.
Public Sub ShowSave()
ShowFileDialog (CLSCD_SHOWSAVE)
End Sub


Private Sub ShowFileDialog(ByVal iAction As Integer)
Dim vOpenFile As tOPENFILENAME
Dim lMaxSize As Long
Dim sFileNameBuff As String
Dim sFileTitleBuff As String

On Error GoTo ShowFileDialogError
iAction = iAction 'Action property
lAPIReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property
If lMaxFileSize > 0 Then
lMaxSize = lMaxFileSize
Else
lMaxSize = CLSCD_MAXFILESIZE
End If

vOpenFile.hWndOwner = lhWndOwner
vOpenFile.lpstrFile = sFileName & Space(lMaxSize - Len(sFileName) - 1) & vbNullChar
vOpenFile.nMaxFile = lMaxSize
vOpenFile.lpstrDefExt = sDefaultExt
vOpenFile.lpstrFileTitle = Space(lMaxSize - 1) & vbNullChar
vOpenFile.nMaxFileTitle = lMaxSize
vOpenFile.lpstrFilter = sAPIFilter(sFilter)
vOpenFile.nFilterIndex = iFilterIndex
vOpenFile.Flags = lFlags 'And Not (OFN_ALLOWMULTISELECT)
vOpenFile.lpstrInitialDir = sInitDir
vOpenFile.lpstrTitle = sDialogTitle
vOpenFile.lStructSize = Len(vOpenFile)

Select Case iAction
Case CLSCD_SHOWOPEN
lAPIReturn = GetOpenFileNameA(vOpenFile)
Case CLSCD_SHOWSAVE
lAPIReturn = GetSaveFileNameA(vOpenFile)
Case Else 'unknown action
Exit Sub
End Select

If lAPIReturn = CLSCD_USERSELECTED Then
sFileName = sLeftOfNull(vOpenFile.lpstrFile)
sFileTitle = sLeftOfNull(vOpenFile.lpstrFileTitle)
iFilterIndex = vOpenFile.nFilterIndex
Else
lExtendedError = CommDlgExtendedError
If lExtendedError = FNERR_BUFFERTOOSMALL Then
On Error GoTo 0
Err.Raise Number:=CLSCD_ERRNUMUSRBUFFER, Description:=CLSCD_ERRDESUSRBUFFER
Exit Sub
Else
If bCancelError = True Then
On Error GoTo 0
Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL
Exit Sub
End If
End If
End If
Exit Sub

ShowFileDialogError:
Exit Sub

End Sub

' commondialog control scheidt de filter onderdelen met |
' api's doen het met chr(0)
' deze routine zet de control schrijfwijze om in api schrijfwijze
Private Function sAPIFilter(ByVal Filter As String) As String
Dim I As Long
Dim C As String * 1
Dim NullFilter As String

For I = 1 To Len(Filter)
C = Mid(Filter, I, 1)
If C = "|" Then
NullFilter = NullFilter & Chr(0)
Else
NullFilter = NullFilter & C
End If
Next I
While Right(NullFilter, 2) <> Chr(0) & Chr(0)
NullFilter = NullFilter & Chr(0)
Wend
sAPIFilter = NullFilter
End Function

Private Function sLeftOfNull(ByVal txt As String)
Dim I As Long, P As Long
Dim ntxt As String, k As String * 1

P = InStr(txt, Chr(0) & Chr(0))
If P > 0 Then
For I = 1 To P - 1
k = Mid(txt, I, 1)
If k = Chr(0) Then ntxt = ntxt & " " Else ntxt = ntxt & k
Next I
Else
ntxt = Left(txt, InStr(txt, Chr(0)) - 1)
End If
sLeftOfNull = ntxt
End Function;


No Comments to show

Please completely fill out the form below if you want to review this snippet. All reviews are subject to validation.


Replying to a Comment...


Adding your comment. Please wait...

Thanks for adding your comment!. After further review it will be added.

There was a problem adding your comment. Please try again.

Please complete all the fields in the form before sending.

© 2002 - 2017 snippetlibrary.com All Rights Reserved. Conditions