_Johm
|
 Posted: Tue Sep 21, 2010 16:39 Post subject: |
 |
|
Этот пост меня вдохновил, наконец то. Искал реализацию автосоздания txt'шника по имени, но как обычно свои мысли, свои задумки по функционалу. Может кому-нибудь пригодится.
| Code: |
Option Explicit
Dim Dict : Set Dict = CreateObject("Scripting.Dictionary") : Dict.CompareMode = vbTextCompare
Dim Editor, Ext, ShowMemo, DefaultNoname, WinAssociation, OpenNewFile, Divider, DontOpen
'============================================================================================
' Имя: Новый файл по SHIFT+F4
' Параметры: ""%P%N""
'
'Использование (ввод в InputBox):
'[имя файла][пробел][?сокращение редактора]
'
'РЕДАКТОРЫ:
'первый параметр - сокращение редактора
'второй параметр - путь к редактору[[пробел]/расширение]
' здесь расширение создаваемого файла
' т.е, если в InputBox ввести "filename ?сокращение редактора", то получим
' файл "filename.расширение
'
'Так же работет явное указание расширения (условие - неравенство имени
'файла/папки под курсором и введенного имени до ?, не зависит от регистра)
'
'Знак вопроса можно заменить на другой разделитель в конфигурации (параметр Divider)
'============================================================================================
'=========Конфигурация========
'РЕДАКТОРЫ
Dict.Add "default", ""
'--------
Dict.Add "np", "%SystemRoot%\Notepad.exe"
Dict.Add "em", "%COMMANDER_PATH%\PROGS\OFFICE\emed32 10.0.0\EmEditor.exe"
Dict.Add "++", "%COMMANDER_PATH%\PROGS\OFFICE\notepadpp\notepad+1+.exe"
Dict.Add "ps", "%ProgramFiles%\Adobe\Photoshop CS\Photoshop.exe /psd"
Dict.Add "aud", "%ProgramFiles%\Adobe\Adobe Audition 3.0\Audition.exe /wav"
'Dict.Add
'Dict.Add
'Редактор по умолчанию
Editor = "em"
'Расширение по умочланию
Ext = "txt"
'Показывать памятку
ShowMemo = False
'Имя файла при пустом вводе
DefaultNoname = "Untitled"
'использовать системные ассоциации (не учитывать расширения в Dict)
WinAssociation = False
'Открывать созданный файл
OpenNewFile = True
'Управляющий символ
Divider = "/"
DontOpen = "-" 'если ввести последним, то файл только создается
'================================
Dim FSO, WS, Memo, arg1, FilePath, FileName, Resp, STR
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WS = WScript.CreateObject("WScript.Shell")
Dim i, DictKeys : DictKeys = Dict.Keys
If Dict.Count < 2 Then
WinAssociation = True
Else
If Dict.Count = 2 Then
Dict.Item("default") = Trim(Split(Dict.Item(DictKeys(1)),"/")(0))
ElseIf Dict.Exists(Editor) Then
Dict.Item("default") = Trim(Split(Dict.Item(Editor),"/")(0))
End If
Editor = Dict.Item("default")
End If
If ShowMemo Then
AssembleMemo()
Else
If Dict.Count > 1 Then Memo = vbCrLf & "для справки введите " & Divider & "memo" & vbCrLf
End If
'определяем путь и имя без расширения от файла/папки под курсором
If WScript.Arguments.Count = 1 Then
arg1 = WScript.Arguments(0)
Else
MsgBox "Неверно количество аргументов", vbExclamation, "Создание файла"
Quit
End If
If Right(arg1,1) = "\" Then
FileName = ""
FilePath = arg1
Else
FileName = FSO.GetBaseName(arg1)
FilePath = FSO.GetParentFolderName(arg1)
If Not Right(FilePath, 1) = "\" Then FilePath = FilePath & "\"
End If
'ввод пользователя (если используется разделитель(напрмер ?) и указано несуществующее
'сокращение редактора то цикл
STR = FileName
Dim str1, str2, editor1, str3, str4
str3 = "системная ассоциация"
arg1 = True 'как флаг
Do Until UserInput(STR) : : Loop
If OpenNewFile Then
On Error Resume Next
If WinAssociation Then
WS.Run Chr(34) & Resp & Chr(34)
If err Then MsgBox "Нет программы" & vbCrLf & _
"ассоциированной с расширением:" & vbCrLf & _
str2, vbExclamation, "Cоздание файла"
ElseIf FSO.FileExists(WS.ExpandEnvironmentStrings(Editor)) Then
WS.Run Chr(34) & Editor & Chr(34) & " " & Chr(34) & Resp & Chr(34)
If err Then MsgBox "Неизвестная ошибка" , vbExclamation, "Cоздание файла"
Else
MsgBox "Не найден редактор:" & vbCrLf & _
Editor, _
vbExclamation, _
"Создание файла"
End If
On Error Goto 0
End If
Quit
Sub AssembleMemo
''собираем памятку-таблицу для InputBox (сокращение exe'шник редактора)
If Dict.Count > 1 Then
For i = 1 To Dict.Count -1
Memo = Memo & DictKeys(i) & Chr(9) & FSO.GetBaseName(Dict.Item(DictKeys(i))) & vbCrLf
Next
Memo = vbCrLf & "(filename.ext " & Divider & "alias)" & vbCrLf & Memo
End If
End Sub
Function UserInput(Byref def_)
UserInput = False
If Not WinAssociation AND Dict.Count > 1 Then str3 = FSO.GetBaseName(Dict.Item("default"))
Resp = InputBox( "Введите имя создаваемого файла ." & Ext & ":" & vbCrlf & _
"редактор: " & str3 & vbCrlf & _
Memo, _
"Создание файла", _
def_)
If IsEmpty(Resp) Then Quit
If LCase(Resp) = Divider & "memo" Then
Memo = ""
AssembleMemo()
WinAssociation = False
Exit Function
End If
If Right(Resp, 1) = DontOpen Then
OpenNewFile = False
Resp = Left(Resp,Len(Resp)-1)
End If
If InStr(Resp, Divider) Then
Dim resp1
str1 = Split(Resp, Divider, 2)
resp1 = Trim(str1(0))
If (Dict.Count > 1) Then
WinAssociation = False
editor1 = Trim(str1(1))
If Dict.Exists(editor1) Then
str2 = Dict.Item(editor1)
If InStr(str2, Divider) Then
str1 = Split(str2, "/", 2)
Editor = Trim(str1(0))
Ext = LCase(str1(1))
Else
Editor = str2
End If
arg1 = False
Else
STR = Resp
Exit Function
End If
Else
Exit Function
End If
Resp = resp1
End If
If Len(Resp) = 0 Then
'FilePath = WS.SpecialFolders("MyDocuments") & "\"
FileName = DefaultNoname
ElseIf Resp = FileName Then
'do nothing
Else
If Not LCase(Resp) = LCase(FileName) Then
str2 = FSO.GetExtensionName(Resp)
If Not Len(str2) = 0 Then
Ext = ""
If (Not WinAssociation) AND arg1 AND (Dict.Count > 1) Then
Dim i, DictKeys
DictKeys = Dict.Keys
For i = 1 To Dict.Count -1
editor1 = Dict.Item(DictKeys(i))
If InStr(editor1, Divider) Then
str1 = Split(editor1, "/", 2)
If LCase(str2) = Trim(LCase(str1(1))) Then
Editor = Trim(str1(0))
Exit For
End If
End If
Next
End If
End If
End If
FileName = Resp
End If
If Not Len(Ext) = 0 Then Ext = "." & Ext
str4 = Resp
Resp = FilePath & FileName & Ext
If Not FSO.FileExists(Resp) Then
On Error Resume Next
FSO.CreateTextFile(Resp)
If err Then
MsgBox "Ошибка создания файла", _
vbExclamation, _
"Cоздание файла"
UserInput = False
STR = str4
Exit Function
End If
On Error Goto 0
End If
UserInput = True
End Function
Sub Quit
Set FSO = Nothing
Set WS = Nothing
Set Dict = Nothing
WScript.Quit
End Sub
|
Только не пойму, диалог нового файла в Photoshop CS всплывает, но при нажатии на Ok выдает Could not complete your request because of a program error.
Audition новый файл создает нормально.
Last edited by _Johm on Wed Sep 22, 2010 21:01; edited 14 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
