Total Commander

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

FileName = Left(Clip, InStr(Clip, " ") - 1) & ".txt" 

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

'=================================================================
' Создание текстового файла с содержимым буфера обмена
'=================================================================
Option Explicit
Dim CharArr
'========== Изменяемые параметры =================================
Const Ext = "txt" 'Расширение создаваемого файла
'Массив недопустимых символов. Заменяем их указанным ниже символом
CharArr = Array(vbCrLf,vbCr,vbLf,"","/","*","?","""")
'Символ для замены
Const ReplaceChar = ""
'Количество первых слов из буфера обмена для имени файла
Const NumWords    = 2
'=================================================================
Dim Mess, FSO, FileName, Clip, Btn, Title, Text
SetMess
On Error Resume Next
Clip = CreateObject("TCScript.Helper").GetTextFromClip
If Err.Number > 0 Then
  MsgBox Mess(3), vbCritical+vbOKOnly, Mess(0)
  Quit Err.Number
End If
On Error GoTo 0
If Len(Clip) = 0 Then
  MsgBox Mess(3), vbCritical+vbOKOnly, Mess(0)
  Quit 0
End If
Set FSO  = CreateObject("Scripting.FileSystemObject")
FileName = GetFileName(Clip) & "." & Ext
If FSO.FileExists(FileName) Then
  Text  = Mess(4) & vbCrLf & Mess(5) & FileName & Mess(7) & vbCrLf
  Title = Mess(1)
Else
  Text  = Mess(4) & vbCrLf & Mess(6) & FileName & Mess(8) & vbCrLf
  Title = Mess(0)
End If
Btn = MsgBox(Text, vbYesNo + vbQuestion, Title)
If Btn = 7 Then Quit 0
FSO.OpenTextFile(FileName, 2, True).Write Clip

Quit 0

Sub SetMess
  Set Mess = CreateObject("Scripting.Dictionary")
  With Mess
    .Add  0, "Создание файла с содержимым буфера обмена"
    .Add  1, "Замена содержимого файла содержимым буфера обмена"
    .Add  2, "Не зарегистрирован объект 'Script Helper ActiveX for Total Commander'!"
    .Add  3, "Буфер обмена не содержит текста!"
    .Add  4, "Буфер обмена содержит текст."
    .Add  5, "Заменить содержимое файла "
    .Add  6, "Создать файл "
    .Add  7, " текстом из буфера обмена?"
    .Add  8, " с содержимым буфера обмена?"
  End With
End Sub

Function GetFileName(pText)
  Dim lText, Char
  lText = pText
  For Each Char In CharArr
    lText = Replace(lText, Char, ReplaceChar)
  Next
  GetFileName = GetSomeWords(lText, NumWords)
End Function

Function GetSomeWords(pText, pNumWords)
  Dim regEx, lM, l, lF, lNum
  Set regEx     = New RegExp
  regEx.Pattern = "\S+"
  regEx.Global  = True
  Set lM        = regEx.Execute(pText)
  If  lM.Count  < pNumWords Then
    lNum = lM.Count
  Else
    lNum = pNumWords
  End If
  For l = 1 To lNum
    lF = lF & " " & lM.Item(l-1).Value
  Next
  GetSomeWords = Mid(lF, 2)
  Set lM    = Nothing
  Set regEx = Nothing
End Function

Sub Quit(pExitCode)
  Set FSO  = Nothing
  Set Mess = Nothing
  WScript.Quit pExitCode
End Sub

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

regEx.Pattern = "\w+"

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

regEx.Pattern = "\S{2,}"

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

Function GetSomeWords(pText, pNumWords)
  Dim regEx, lM, lNum
  Set regEx     = New RegExp
  regEx.Pattern = "\S{2,}"
  regEx.Global  = True
  If regEx.Test(pText) Then
    Set lM = regEx.Execute(pText)
    If  lM.Count < pNumWords Then
      lNum = lM.Count
    Else
      lNum = pNumWords
    End If
    GetSomeWords = Left(pText, lM.Item(lNum-1).FirstIndex + Len(lM.Item(lNum-1).Value))
    Set lM = Nothing
  Else
    GetSomeWords = ""
  End If
  Set regEx = Nothing
End Function