Batya
|
 Posted: Wed Jul 22, 2009 17:42 Post subject: |
 |
|
| universal007 wrote: | Как сделать что бы хотя бы два первых слова появлялись в имени файла?
И если текст в буфере начинается со спецсимволов типа " (ковычек)
то выдаётся ошибка. Как побороть это?
|
"По заявкам радиослушателей ..." (с): | Code: | '=================================================================
' Создание текстового файла с содержимым буфера обмена
'=================================================================
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 |
_________________
Нет, я не сплю. Я просто медленно моргаю.
Last edited by Batya on Thu Jul 23, 2009 10:16; edited 2 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
