TopPicLogo TopPicText

Имя файла по пути с новым номером по фиксированной маске

Public Function GetNewFileNo(sPath$, sFileMask$) As String
'Возвращает имя файла по пути с новым номером по фиксированной маске ???? (4 символа строго)
'ВНИМАНИЕ!!! - Проверка существования папки сохранения не прозводится.
'--------------------------------------------------------------------------
Const iMaskLen% = 4 'Длинна маски номера файла - Тут фиксировано для упрощения кода
Dim iMaskStart%     'Начало маски
Dim iMaxNo%         'Максимальный номер файла
Dim s$, sTemp$, iTempNo% ' Вспомогательные
'--------------------------------------------------------------------------
On Error GoTo GetNewFileNo_Err
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    
    iMaskStart = InStr(1, sFileMask, "?")          ' Получаем начало маски
    
    'Перебор файлов в папке:
    s = Dir(sPath & sFileMask, vbNormal)
    Do While s <> ""
        sTemp = Mid(s, iMaskStart, iMaskLen)       ' Номер файла из пути
        iTempNo = CInt(sTemp)                      ' Преобразуем в число для сравнения
        If iTempNo > iMaxNo Then iMaxNo = iTempNo  ' Оперируем номером .... получаем максимальный
        s = Dir
    Loop

    sTemp = String(iMaskLen, "0") 'формат маcки
    s = Format(iMaxNo + 1, sTemp)
' Формируем новое название файла
    GetNewFileNo = sPath & Mid(sFileMask, 1, iMaskStart - 1) & s & Mid(sFileMask, iMaskStart + iMaskLen)

GetNewFileNo_Bye:
    Exit Function

GetNewFileNo_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & "в процедуре: GetNewFileNo", vbCritical, "Error in module Module1"
    Resume GetNewFileNo_Bye
End Function


Проверочка:

Public Sub Test01()
Dim s$
    s = "Имя_файла_????.xls"
    Debug.Print GetNewFileNo("D:\Temp2\", s) & " = а вот и результ!"
   
End Sub
Назад ToTop
L.E. 14.03.2017
Рейтинг@Mail.ru