Форум программистов [Powered by Invision Power Board]

Код

'     код модуля для открытия диалога выбора файлов
'--------------------------------------------------------------------------
Option Explicit

'Окна открытия и сохранения файлов Common Dialog

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
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OpenFileName) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OpenFileName) As Long

'--------------------------------------------------------------------------
Function OpenDialog$(Optional ByVal DefaultFile$, Optional ByVal MasksList$)
'            Функция получения имени файла для открытия.
'
' Вход: два необязательных аргумента.
' Первый аргумент - строка: предлагаемое имя файла (можно с путем).
' Второй аргумент - строка, список расширений,
'   разделенных запятыми, напр.: "Текстовые,*.txt,Все файлы,*.*"
'   (пробелы являются значащими).
'
' Возвращает: строка- полное имя выбранного файла (либо пустую строку при отмене).
' Длина имени файла - не более 218 символов. При превышении выдает пустую строку.
' Использует подпрограмму SplitFName.
' -----------------------------------------------------------------------------------

Dim OpenFile As OpenFileName, EndName As Integer, sFilter As String, strIniFolder As String

DefaultFile$ = Trim(DefaultFile$)    ' (иначе не откроется окно)

' Определение маски отображаемых файлов
If MasksList$ = "" Then
  sFilter = " " & Chr$(0) & "*.*" & Chr$(0)
Else
  sFilter = Replace(MasksList$, ",", Chr$(0)) + Chr$(0) 'замена запятых нулями.
End If

Call SplitFName(DefaultFile$, strIniFolder, DefaultFile$) ' разделение пути и имени

' Заполнение структуры для вызова функции GetOpenFileName
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = 0
OpenFile.hInstance = 0
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = Left$(DefaultFile$ + String$(255, 0), 255) + Chr$(0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = strIniFolder
OpenFile.lpstrTitle = "Выбор файла"               ' заголовок окна
OpenFile.flags = 0

GetOpenFileName OpenFile                          ' вызов API

' Получаем полное имя файла
If InStr(OpenFile.lpstrFile, "\") = 0 Then
  OpenDialog$ = ""      'если имя файла было предложено, но отмена.
Else
  EndName = InStr(OpenFile.lpstrFile, Chr$(0))
  Select Case EndName
    Case 1:    OpenDialog$ = ""      '0 в первой позиции - имя не введено
    Case 0:    OpenDialog$ = ""      'слишком длинное имя
    Case Else: OpenDialog$ = Left$(OpenFile.lpstrFile, EndName - 1)
  End Select
End If

End Function

'--------------------------------------------------------------------------
Function SaveDialog$(Optional ByVal DefaultFile$, Optional ByVal MasksList$)
'            Функция получения имени файла для сохранения.
'
' Вход: два необязательных аргумента.
' Первый аргумент - строка: предлагаемое имя файла (можно с путем).
' Второй аргумент - строка, список расширений,
'   разделенных запятыми, напр.: "Текстовые,*.txt,Все файлы,*.*"
'   (пробелы являются значащими).
'
' Возвращает: строка- полное имя выбранного файла (либо пустую строку при отмене).
' Длина имени файла - не более 218 символов. При превышении выдает пустую строку.
' Использует подпрограмму SplitFName.
' -----------------------------------------------------------------------------------

Dim OpenFile As OpenFileName, EndName As Integer, sFilter As String, strIniFolder As String

DefaultFile$ = Trim(DefaultFile$)
If MasksList$ = "" Then
  sFilter = " " & Chr$(0) & "*.*" & Chr$(0)
Else
  sFilter = Replace(MasksList$, ",", Chr$(0)) + Chr$(0)
End If
Call SplitFName(DefaultFile$, strIniFolder, DefaultFile$)
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = 0
OpenFile.hInstance = 0
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = Left$(DefaultFile$ + String$(255, 0), 255) + Chr$(0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = strIniFolder
OpenFile.lpstrTitle = "Сохранение файла"               ' заголовок окна
OpenFile.flags = 0

GetSaveFileName OpenFile                          ' вызов API

' Получаем полное имя файла
If InStr(OpenFile.lpstrFile, "\") = 0 Then
  SaveDialog$ = ""      'если имя файла было предложено, но отмена.
Else
  EndName = InStr(OpenFile.lpstrFile, Chr$(0))
  Select Case EndName
    Case 1:    SaveDialog$ = ""      '0 в первой позиции - имя не введено
    Case 0:    SaveDialog$ = ""      'слишком длинное имя
    Case Else: SaveDialog$ = Left$(OpenFile.lpstrFile, EndName - 1)
  End Select
End If

End Function


'--------------------------------------------------------------------------
Public Sub SplitFName(ByVal FileSpec$, ByRef varFilePath$, ByRef varFileName$)
'    Подпрограмма расщепления полного имени файла:
' Делит путь+имя на отдельные путь и имя файла.
' FileSpec$ - исходная строка: путь или имя или путь+имя файла
' varFilePath$ -приемная переменная: путь (строка)
' varFileName$ -приемная переменная: имя (строка)
' Все параметры обязательные, но могут быть пустыми строками.
' Исходная переменная может, в то же время, принимать результат.
' --------------------------------------------------------------------------
Dim tmp1 As Integer

varFilePath$ = ""
tmp1 = InStrRev(FileSpec$, "\")
' если есть слэш, значит задан путь
If tmp1 > 0 Then
 varFilePath$ = Left$(FileSpec$, tmp1)
  If tmp1 = Len(FileSpec$) Then
    FileSpec$ = ""  'обнуляем имя файла, если слэш на конце (путь без имени)
  Else
    FileSpec$ = Right$(FileSpec$, Len(FileSpec$) - tmp1)  ' удаляем путь из имени
  End If
End If
' исключения:
If Trim(FileSpec$) = "." Then FileSpec$ = ""
If Trim(FileSpec$) = ".." Then
  FileSpec$ = ""
  varFilePath$ = ".."
End If
varFileName$ = FileSpec$

End Sub
'-----------------------------------------------------------------------------