Авторские программы, библиотеки, надстройки и шаблоны

Sub Rename_PlayFiles()
    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim i%, j%, MyPath$, FCnt%, Min!, PoTemp!, sTmp$, sL$, sR$, Usl As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = "C:\"
        If .Show <> -1 Then Exit Sub
        MyPath = .SelectedItems(1)
    End With
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(MyPath)
    MyPath = MyPath & "\"
    FCnt = oFolder.Files.Count
    ReDim OldNames$(FCnt), NewNames$(FCnt), Poryadok!(FCnt), NewPrefix$(FCnt)
    i = 0
    For Each oFile In oFolder.Files
        i = i + 1
        OldNames(i) = oFile.Name
        sL = Left$(OldNames(i), 5)
        sR = Right$(OldNames(i), Len(OldNames(i)) - 5)
        Usl = True
        If sL Like "[0-9][0-9][0-9][0-9]_" Then
           sL = ""
        ElseIf sL Like "[0-9][0-9][0-9][0-9]?" Then
           sL = Right$(sL, 1)
        ElseIf sL Like "[0-9][0-9][0-9]*" Then
           sL = Right$(sL, 2)
        ElseIf sL Like "[0-9][0-9]*" Then
           sL = Right$(sL, 3)
           Usl = False
        ElseIf sL Like "[0-9]*" Then
           sL = Right$(sL, 4)
           Usl = False
        Else
            Usl = False
        End If
        If Usl Then
            sL = Replace(sL, "_", "")
            sL = Replace(sL, " ", "")
        End If
        NewNames(i) = sL & sR
        Poryadok(i) = Rnd
        NewPrefix(i) = Format$(i, "0000") & "_"
    Next
    Randomize Timer
    For i = 1 To FCnt
        Min = Poryadok(i)
        For j = i + 1 To FCnt
            If Min > Poryadok(j) Then
                PoTemp = Poryadok(i)
                Poryadok(i) = Poryadok(j)
                Poryadok(j) = PoTemp
                sTmp = NewPrefix(i)
                NewPrefix(i) = NewPrefix(j)
                NewPrefix(j) = sTmp
            End If
        Next j
    Next i
    For i = 1 To FCnt
        OldNames(i) = MyPath & OldNames(i)
        NewNames(i) = MyPath & NewPrefix(i) & NewNames(i)
        Name OldNames(i) As NewNames(i)
    Next i
    Set oFolder = Nothing
    Set oFSO = Nothing
End Sub

Option Explicit
 
Public Function MsgBoxEx(Prompt, Optional Buttons As VbMsgBoxStyle = 0, Optional Title, Optional SecondsToWait = 0) As VbMsgBoxResult
'---------------------------------------------------------------------------------------
' Procedure : MsgBoxEx
' Author    : Казанский, [email]exceleved@yandex.ru[/email]
' Date      : 07.03.2014
' Purpose   : MsgBox with timeout based on WScript.Shell Popup method. Creates .VBS file
'             in temporary folder, runs it, returns result code, deletes the file.
' Arguments : First three are the same as for MsgBox, 4-th is timeout in seconds.
'           : If 4-th arg. is omitted or <=0 then waits for user action infinitely.
' Ret.Value : The same as of Msgbox, -1 if timeout occured.
' Errors    : Raises error 735 if temporary folder can't be found.
'---------------------------------------------------------------------------------------
 
Dim sTmp$, ff%, WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
sTmp = Environ("temp")
If sTmp = "" Then
  sTmp = Environ("tmp")
  If sTmp = "" Then
    sTmp = WshShell.SpecialFolders("MyDocuments")
    If sTmp = "" Then Err.Raise 735 'Can't save file to TEMP directory
  End If
End If
sTmp = sTmp & Format$(Now, """\~MsgBoxEx""YYMMDDHHMMSS"".vbs""")
ff = FreeFile
Open sTmp For Output As ff
 
If IsMissing(Title) Then Title = ""
 
'Popup(<Text>,<SecondsToWait>,<Title>,<Type>)
 
Print #ff, "WScript.Quit CreateObject(""WScript.Shell"").Popup (""" & Str2Code(Prompt) & _
  """, " & Int(SecondsToWait) & ", """ & Str2Code(Title) & """, " & Int(Buttons) & ")"
Close ff
MsgBoxEx = WshShell.Run(sTmp, 0, True)
On Error Resume Next
Kill sTmp
End Function
 
Private Function Str2Code$(s)
'---------------------------------------------------------------------------------------
' Procedure : Str2Code
' Author    : Казанский, [email]exceleved@yandex.ru[/email]
' Date      : 07.03.2014
' Purpose   : Replaces combinations CR+LF, LF+CR, single chars CR, LF with " & vblf & "
'             to be used in VBS code
'---------------------------------------------------------------------------------------
 
Str2Code = Replace$( _
            Replace$( _
              Replace$( _
                Replace$( _
                  Replace$(s, """", """"""), _
                vbCrLf, vbLf), _
              vbLf & vbCr, vbLf), _
            vbCr, vbLf), _
           vbLf, """ & vblf & """)
End Function