Total Commander

Код: Выделить всё

'=====================================================================
' Запуск поиска в текущей папке файла, имя которого находится в буфере
'=====================================================================

Dim TCS
Set TCS = CreateObject("TCScript.Helper")
TCS.Pause=100
TCS.LockTC True
TCS.SendCommand(501)
TCS.SendKeystroke (TCS.GetTextFromClip)
TCS.SendKeystroke ("{Enter}")
TCS.LockTC False
Set TCS=Nothing
Wscript.Quit

Код: Выделить всё

'=====================================================================
' Создание папки с частью имени файла, перемещение в нее файла
' Может быть выделено несколько файлов

' В параметрах вызова из TC должно быть прописано:
' %L
'=====================================================================

Dim TempFile, FSO, SelFile
Set TempFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.Arguments(0), 1)
Set FSO = CreateObject("Scripting.FileSystemObject")

Dim MoveFiles, FileName, FilePath, DashInName, NewFilePath, M1, M2, M3, M4
MoveFiles = ""
Do While Not TempFile.AtEndOfStream
  Set SelFile = FSO.GetFile(TempFile.ReadLine)
  FileName = SelFile.Name
  FilePath = SelFile.ParentFolder
  DashInName = InstrRev(FileName, "-")
  If DashInName <> 0 Then
      NewFilePath = FilePath & "\" & Trim(Left(FileName, DashInName - 1))
      If Not FSO.FolderExists(NewFilePath) Then
        FSO.CreateFolder(NewFilePath)
      End If
      If Not FSO.FileExists(NewFilePath & "\" & FileName) Then
        FSO.MoveFile SelFile, NewFilePath & "\"
        MoveFiles = MoveFiles + FileName & chr(13)
      Else
        M1 = MsgBox("Уже существует файл " & FileName & " в папке " & NewFilePath, vbOKOnly + vbExclamation, "Внимание!")
      End If
  Else
    M2 = MsgBox("Имя исполнителя не выявлено", vbOKOnly + vbExclamation, "Внимание!")
  End If
Loop
If MoveFiles <> "" Then
  MoveFiles = Left(MoveFiles, Len(MoveFiles) - 1)
  M3 = MsgBox("Перемещены файлы:" & chr(13) & MoveFiles, vbOKOnly + vbInformation, "Результат")
Else
  M4 = MsgBox("Ни одного файла не перемещено" & chr(13) & MoveFiles, vbOKOnly + vbExclamation, "Внимание!")
End If
Set TempFile = Nothing
Set FSO = Nothing
Set SelFile = Nothing
Wscript.Quit

Код: Выделить всё

'=====================================================================
' Запуск поиска в текущей папке по содержимому тексту из буфера
'=====================================================================

Dim TCS, Str
Set TCS = CreateObject("TCScript.Helper")
Str = TCS.GetTextFromClip         ' Текст из буфера
TCS.Pause=100
TCS.LockTC True
TCS.SendCommand(501)
TCS.SendKeystroke ("{DEL}")       ' Очистить файловую маску
TCS.SendKeystroke ("{TAB 5} ")    ' Перейти к чекбоксу и нажать пробел
If Len(Str) > 0 Then
  TCS.SendKeystroke (Str)         ' Вставить текст
  'TCS.SendKeystroke ("+{TAB 6}")  ' Вернуться в поле ввода файловой маски
  TCS.SendKeystroke ("{Enter}")   ' Запустить поиск
End If
TCS.LockTC False
Set TCS = Nothing
Wscript.Quit

Код: Выделить всё

'==========================================================================
' Создание в текущей папке для всех файлов с указанным расширением
'   аналогичного файла с другим указанным расширением

' В параметрах вызова из TC должно быть прописано:
' "%P" {расширение исходных файлов} {расширение создаваемых файлов}
' Пример:
' "%P" mp3 txt
'==========================================================================
Dim MB
If WScript.Arguments.Count < 3 Then
  MB = MsgBox("Заданы не все параметры!", vbOKOnly + vbExclamation, "Создание новых файлов")
  WScript.Quit
End If

Dim FSO, CurrentFolder, Ext1, Ext2, oFolder, oFile, NewFilePath, oNewFile
Set FSO = CreateObject("Scripting.FileSystemObject")

CurrentFolder = WScript.Arguments(0)
Ext1          = WScript.Arguments(1)
Ext2          = WScript.Arguments(2)

If not FSO.FolderExists(CurrentFolder) Then
  MB = MsgBox("Папка " & CurrentFolder & " не существует!", vbOKOnly + vbExclamation, "Создание новых файлов")
  WScript.Quit
End If

Set oFolder = FSO.GetFolder(CurrentFolder)

For Each oFile in oFolder.Files
  If FSO.GetExtensionName(oFile.Path) = Ext1 Then
    NewFilePath = CurrentFolder & FSO.GetBaseName(oFile.Path) & "." & Ext2
    If not FSO.FileExists(NewFilePath) Then
      Set oNewFile = FSO.CreateTextFile(NewFilePath)
      oNewFile.Close
    End If
  End If
Next

Set oFolder  = Nothing
Set oFile    = Nothing
Set oNewFile = Nothing
Set FSO      = Nothing
Wscript.Quit

Код: Выделить всё

'==============================================================================
' Установка в качестве обоев случайного файла из текущего каталога
' Для установки обоев используется программа IrfanView
'
' В качестве первого параметра указать полный путь до папки или:
' "%P"
' Вторым параметром можно указать имя файла-картинки
'==============================================================================
Option Explicit 
Dim MyPictures, Irfan
'============= Задайте каталог картинок  по умолчанию =========================
MyPictures = "e:\Photo\2005_12_24\"'"D:\Pictures"
'============== Задайте путь IrfanView ========================================
Irfan = "D:\Program Files\IrfanView\i_view32.exe"
'==============================================================================

If WScript.Arguments.Count = 0  Then 
  MsgBox "Не указан параметр - папка с обоями", _
         vbOKOnly + vbExclamation, _
         "Установка обоев"
  WScript.Quit
End If
Dim FSO, WSH, oFolder, n, x, FilesSet, aFileSet, Wall
Set FSO     = CreateObject("Scripting.FileSystemObject")
Set WSH     = WScript.CreateObject("WScript.Shell")
Set oFolder = FSO.GetFolder(WScript.Arguments(0))

FilesSet = Pictures(oFolder)
aFileSet = Split(FilesSet, vbCr)
n        = UBound(aFileSet)
Wall     = ""
Randomize

If n > 0 Then
  x = Int(n * Rnd) + 1
  Wall = aFileSet(x - 1)
Else
  If WScript.Arguments.Count > 1 Then
    Wall = WScript.Arguments(1)
  Else
    If FSO.FolderExists(MyPictures) Then
      FilesSet = Pictures(FSO.GetFolder(MyPictures))
      aFileSet = Split(FilesSet, vbCr)
      n        = UBound(aFileSet)
      If n > 0 Then
        x    = Int(n * Rnd) + 1
        Wall = aFileSet(x - 1)
      End If
    End If
  End IF
End If

If Len(Wall) > 0 Then
  WSH.Run("""" & Irfan + """ " + Wall + " /wall=2 /killmesoftly")
Else
  MsgBox "Не найден файл с картинкой", _
         vbOKOnly + vbExclamation, _
         "Установка обоев"
End If

Set oFolder = Nothing
Set WSH     = Nothing
Set FSO     = Nothing
WScript.Quit

Function Pictures(oFold)
  Dim ScanFile, Ext
  Pictures = ""
  For Each ScanFile in oFold.Files
    Ext = LCase(FSO.GetExtensionName(ScanFile))
    If Ext = "jpg" or Ext = "bmp" or Ext = "gif" or Ext = "jpeg" Then
      Pictures = Pictures + ScanFile.Path + vbCr
    End If
  Next
  Set ScanFile = Nothing
  Set oFold    = Nothing
End Function

Код: Выделить всё

\\10.0.255.26\рисунки\Рисунки\WAR\01.jpg

Код: Выделить всё

\\10.0.255.26\@8AC=:8\Рисунки\WAR\01.jpg