Flasher
|
 Posted: Sun Jan 20, 2019 21:40 Post subject: |
 |
|
| Code: | '================================ VBS ================================
' Создать PDFs из картинок активного каталога согласно именным группам
' Условие: Путь запуска — пустой
' Параметры: "<путь назначения>" <маска расширений> <формат сжатия>
' Форматы сжатия: 1 (Fax), 2 (Rle), 3 (LZW), 4 (ZIP), 5 (JPEG)
' /min — ключ cмены скрытой консоли на свёрнутую в панель задач
' Примеры: "%T" *.tif 3 /min
' "%T" *.jpg;*jpeg;*.png;*.tif;*.tiff 5
Option Explicit
'========================== Путь к NConvert ==========================
Const NConv = "%COMMANDER_PATH%\Utils\NConvert\nconvert.exe"
'================================================ Автор: Flasher © ===
Dim A, WSS, ShA, Dic, Kit, FSO, Coll, Sort, Rgx, CDir, _
Itms, Items, ODir, M, List, F, Name, BN0, BN, Item, i, S
Const Title = " Объединение картинок в PDF "
Set A = WSH.Arguments: If A.UnNamed.Count <> 3 Then _
MsgBox "Укажите 3 параметра!", 4144, Title : WSH.Quit
Set WSS = CreateObject("WScript.Shell")
Set ShA = CreateObject("Shell.Application")
Set Dic = CreateObject("Scripting.Dictionary")
Set Kit = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Coll = CreateObject("System.Collections.ArrayList")
Set Sort = CreateObject("System.Collections.SortedList")
Set Rgx = New RegExp : CDir = WSS.CurrentDirectory
Set Itms = ShA.NameSpace(CDir).Items
Set Items = ShA.NameSpace(CDir).Items
Items.Filter 8416, A(1)
ODir = FSO.BuildPath(A(0), "\")
If A.Named.Exists("min") Then M = 2 Else M = 0
Rgx.Pattern = "((.+)[ \-—_])(\d+)\w?\.[A-z]{3,4}$"
List = FSO.GetSpecialFolder(2) & "\" & FSO.GetTempName
For Each F In Items
Name = FSO.GetFileName(F.Path) : BN = FSO.GetBaseName(Name)
If Rgx.Test(Name) Then
Set Name = Rgx.Execute(Name)(0) : BN0 = Name.Submatches(0)
If Not Dic.Exists(BN0) Then
Dic.Add BN0, Empty : Item = " -l """ & List
Itms.Filter 8416, Replace(A(1), "*", BN0 & "*")
If Itms.Count > 1 Then
For Each i in Itms
Sort.Add CLng(Rgx.Execute(i.Path)(0).Submatches(2)), i.Path
Next : Coll.Addrange Sort.Values
BN = Name.Submatches(1) : S = ""
Itms.Filter 8416, Replace(A(1), "*", BN)
If Itms.Count = 1 Then i = Itms.Item(0).Path : KitAdd i : S = i & vbCrLf
FSO.CreateTextFile(List, 1).Write S & Join(Coll.ToArray, vbCrLf)
Sort.Clear : Coll.Clear
Else Item = " """ & F.Path End If
Call Run
End If
Else KitAdd F.Path
End if
Next
For Each F in Kit.Keys
Item = " """ & F : Call Run
Next
If Len(BN) Then
If FSO.FileExists(List) Then FSO.DeleteFile List, 1
WSS.Popup " Выполнено!", 1.5, Title, 4160
Else
WSS.Popup "Нет подходящих файлов!", 1.5, Title, 4144
End If
For Each i in Array(Name, Itms, Items, Coll, Sort, Dic, Kit, FSO, Rgx, WSS)
Set i = Nothing
Next
Sub Run
WSS.Run """" & NConv & """ -quiet -multi -o """ & ODir & BN &_
".pdf" & """ -out pdf -q 100 -c " & A(2) & Item & """", M, 1
End Sub
Sub KitAdd(FPath)
If Kit.Exists(FPath) Then Kit.Remove(FPath) Else Kit.Add FPath, Empty
End Sub |
_________________
Автору сборки TC Image (Andrey_A) настоятельно рекомендуется не распространять на иных ресурсах любую предоставленную мной где-либо техническую информацию по автоматизации и оптимизации в работе с ТС и системой.
Last edited by Flasher on Wed Jan 23, 2019 09:54; edited 7 times in total |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
