'PriMore V0.85 (2008/08/22) 'Copyright (C) 2008-2010 komikoni All Rights Reserved. '**Start Encode** '**************************************************************** Const ForReading = 1, ForWriting = 2, ForAppending = 8 Set objFSO = CreateObject("Scripting.FileSystemObject") Set objShell = WScript.CreateObject("WScript.Shell") if WScript.Arguments.Unnamed.Count=1 Then call Parent_Process ElseIf WScript.Arguments.Named.Count=1 And _ WScript.Arguments.Named.Exists("PSFilePath") Then call Child_Process Else a=msgbox("Arguments Error",64) msgbox("named="&WScript.Arguments.Named.Count) & vbcrlf & _ "unnamed="&WScript.Arguments.Unnamed.Count WScript.Quit End If '**************************************************************** Sub Parent_Process() '引数のファイルをリネイム Set objFilePSFile = objFSO.GetFile(WScript.Arguments.Unnamed.Item(0)) objFilePSFile.name = objFSO.GetTempName() '子プロセス(自分自身)をリネイム後のファイル名を名前つきパラメータで渡して起動(戻りなし) execstmt= """" & ModulePath() & """ /PSFilePath:""" & objFilePSFile.path & """" objShell.Run execstmt ,, False End Sub '**************************************************************** Sub Child_Process() '実体PSファイルのパス PSFilePath=WScript.Arguments.Named("PSFilePath") '実体PSファイルのフォルダ tempFolder=objFSO.GetParentFolderName(PSFilePath) & "\" 'PriMoreMainパス MainPath=tempFolder & "PriMoreMain.ps" 'PriMoreListパス ListPath=tempFolder & "PriMoreList.ps" 'PrimoPDFのフォルダ PrimoFolder=objFSO.GetParentFolderName(ModulePath())& "\" 'PrimoPDFのパス PrimoPath =PrimoFolder & "PrimoPDF.exe" 'PSFile情報読み取り Set objTextPSFile = objFSO.OpenTextFile(PSFilePath,ForReading) Y_Top="" ' Do Until strInput="%%EndComments" Or objFile2.AtEndOfStream Do Until objTextPSFile.AtEndOfStream strInput = objTextPSFile.ReadLine() If left(strInput,8)= "%%Title:" Then title = Mid(strInput, 10) If Left(title,1)="<" And right(title,1)=">" Then title = HexDecode(mid(title,2,Len(title)-2)) '< > both trim Elseif Left(title,1)="(" And Right(title,1) = ")" Then title = OctDecode(mid(title,2,Len(title)-2)) '( ) both trim End If 'CommentTitle = "%%Title: " & title CommentTitle = "%%Title: " & objFSO.GetBaseName(title)&" " PffDocTitle =PDFDocEncoding(title) PdfMarkTitle = "[/Title (" & PffDocTitle & ") /DOCINFO pdfmark" ElseIf left(strInput,6)= "%%For:" Then CommentFor = strInput ElseIf left(strInput,8)= "%%Pages:" And Mid(strInput,10,1)<>"(" Then '(atend) Pages = Mid(strInput, 10) ElseIf left(strInput,18)= "%%PageBoundingBox:" And Y_Top="" Then Y_Top = Split(Mid(strInput, 20))(3) End If Loop objTextPSFile.close 'ロックされていないメインファイルの残骸は削除 on error resume next objFSO.DeleteFile MainPath Err.Clear on error goto 0 If objFSO.FileExists(MainPath) Then 'メインファイルが存在する場合 Set objTextList = objFSO.OpenTextFile(ListPath,ForAppending,True) 'リストファイルにファイル名をエスケイプ(\⇒\\)して出力 objTextList.WriteLine "[ /Count 0 /Page Pages /View [/XYZ 0 " & Y_Top & " null] /Title (" & PffDocTitle & ") /OUT pdfmark" Call Bookmark(objTextList) objTextList.WriteLine "_begin_job_" 'リストファイルにPSファイルのタイトルをしおりで出力 objTextList.WriteLine "(" & Replace(PSFilePath,"\","\\") & ")run" objTextList.WriteLine "__end__job_" objTextList.WriteLine "/Pages Pages "& Pages &" add def" Else 'メインファイルが存在しない場合 'メインファイルを作成 Set objTextMain = objFSO.OpenTextFile(MainPath,ForWriting,True) objTextMain.WriteLine "%!PS-Adobe-3.0" 'メインファイルにPSファイルのタイトルをコメント形式とPDFMARK形式で出力 objTextMain.WriteLine CommentFor objTextMain.WriteLine CommentTitle '(メインファイルにしおりを出力) 'メインファイルにリストファイル名をエスケイプ(\⇒\\)して出力 objTextMain.WriteLine "(" & Replace(ListPath,"\","\\") & ")run" objTextMain.WriteLine PdfMarkTitle objTextMain.WriteLine "userdict /pdfmark systemdict /cleartomark get put" objTextMain.Close 'リストファイルを作成 Set objTextList = objFSO.OpenTextFile(ListPath,ForWriting,True) objTextList.WriteLine "%!PS-Adobe-3.0" objTextList.WriteLine "% Written by Helge Blischke, see" objTextList.WriteLine "% http://groups.google.com/groups?ic=1&selm=3964A684.49D%40srz-berlin.de" objTextList.WriteLine "/_begin_job_" objTextList.WriteLine "{" objTextList.WriteLine " /tweak_save save def" objTextList.WriteLine " /tweak_dc countdictstack def" objTextList.WriteLine " /tweak_oc count 1 sub def" objTextList.WriteLine " userdict begin" objTextList.WriteLine "}bind def" objTextList.WriteLine "/__end__job_" objTextList.WriteLine "{" objTextList.WriteLine " count tweak_oc sub{pop}repeat" objTextList.WriteLine " countdictstack tweak_dc sub{end}repeat" objTextList.WriteLine " tweak_save restore" objTextList.WriteLine "}bind def" objTextList.WriteLine "/Pages 0 def" 'リストファイルにファイル名をエスケイプ(\⇒\\)して出力 objTextList.WriteLine "[ /Count 0 /Page Pages 1 add /View [/XYZ 0 " & Y_Top & " null] /Title (" & PffDocTitle & ") /OUT pdfmark" Call Bookmark(objTextList) objTextList.WriteLine "_begin_job_" 'リストファイルにPSファイルのタイトルをしおりで出力 objTextList.WriteLine "(" & Replace(PSFilePath,"\","\\") & ")run" objTextList.WriteLine "__end__job_" objTextList.WriteLine "/Pages Pages "& Pages &" add def" objTextList.Close 'メインファイルを引数にPrimoPDFを起動(戻り確認あり) execstmt= """" & PrimoPath & """ """ & MainPath & """" objShell.Run execstmt ,, True 'リストファイル内で指定されているファイルを削除 Set objTextList = objFSO.OpenTextFile(ListPath,ForReading) For i = 1 to 17 objTextList.SkipLine next Do Until objTextList.AtEndOfStream objTextList.SkipLine objTextList.SkipLine strInput = objTextList.ReadLine() strInput = Replace(Mid(strInput,2,len(strInput)-5),"\\","\") objFSO.DeleteFile strInput objTextList.SkipLine objTextList.SkipLine Loop objTextList.Close 'メインファイル、リストファイルを削除 objFSO.DeleteFile MainPath objFSO.DeleteFile ListPath End If End Sub '**************************************************************** Sub Bookmark(objTextList) Dim objXML, fileXML Dim node, item, mesg fileXML = objFSO.GetParentFolderName(ModulePath()) & "\" & "PDFMark.xml" Set objXML = WScript.CreateObject("MSXML.DOMDocument") msgbox fileXML rtResult = objXML.load(fileXML) if rtResult = True then ' call bookmarkget(objXML.childNodes) call bookmarkget(objXML.selectNodes("/PDFMark/Bookmarks/Bookmark"),objTextList) End If End Sub '**************************************************************** Sub Bookmarkget( nodes ,objTextList) For Each node In nodes ' WScript.Echo "ループ開始" &node.nodename If node.nodeName ="Bookmark" Then title = node.getAttribute("Title") page = node.getAttribute("Page") H_top = node.getAttribute("Top") W_left = node.getAttribute("Left") mode = node.getAttribute("Mode") ' count = node.childNodes.length count = node.selectNodes("./Bookmark").length 'しおりを閉じる場合、負数にする If Ucase(mode)="CLOSE" Then count = count * -1 End If objTextList.writeline("[ /Count " & count & _ " /Page Pages "& page & " add" &_ " /View [/XYZ "&H_top&" "&W_left&" null] "& _ " /Title ("&PDFDocEncoding(title)&")"& _ " /OUT pdfmark") End If If node.hasChildNodes Then call bookmarkget(node.childNodes,objTextList) End If Next End Sub '**************************************************************** Function OctDecode(Source) On Error Resume Next sTmp="" iCount = 1 lSrcLen=Len(Source) Do Until iCount > lSrcLen If Mid(Source,iCount,1)="\" Then If Mid(Source,iCount +1,1)="\" Or _ Mid(Source,iCount +1,1)="(" Or _ Mid(Source,iCount +1,1)=")" Then sHex=Hex(asc(Mid(Source,iCount +1,1))) iCount = iCount + 2 Else sHex=Hex("&O"&Mid(Source,iCount +1,3)) If Len(sHex) <2 Then sHex ="0" & sHex End If iCount = iCount + 4 End If Else sHex=Hex(Asc(Mid(Source,iCount,1))) If len(sHex) <2 Then sHex ="0" & sHex End If iCount = iCount + 1 End If sTmp=sTmp & sHex Loop OctDecode = HexDecode(sTmp) End Function '**************************************************************** Function HexDecode(Source) On Error Resume Next sTmp="" iCount = 1 lSrcLen=Len(Source) Do Until iCount > lSrcLen sHex = Mid(Source,iCount,2) iCount = iCount + 2 iAsc = CByte("&H" & sHex) If (&H00 <= iAsc And iAsc <= &H80) Or _ (&HA0 <= iAsc And iAsc <= &HDF) Then '1Byte char sChr=Chr(iAsc) ElseIf (&H81 <= iAsc And iAsc <= &H9F) Or _ (&HE0 <= iAsc And iAsc <= &HFF) Then '2byte char sHex2 = Mid(Source,iCount,2) iCount = iCount + 2 sChr=Chr(CInt("&H" & sHex & sHex2)) End If sTmp=sTmp & sChr Loop HexDecode = sTmp End Function '**************************************************************** Function PDFDocEncoding(Source) Result="" For i=1 to len(Source) Wbyte= hex(AscW(Mid(Source,i,1))) If len(Wbyte) <4 Then Wbyte =String(4-len(Wbyte),"0") & Wbyte End If HiByte= "&h" & Mid(Wbyte,1,2) LoByte= "&h" & Mid(Wbyte,3,2) Res = Res & PDFDocEncodingByte(HiByte) & _ PDFDocEncodingByte(LoByte) Next If Res<>"" Then PDFDocEncoding ="\376\377" & Res Else PDFDocEncoding =Res End If End Function '**************************************************************** Function PDFDocEncodingByte(Source) select case Source case &h5c , &h28 , &h29 PDFDocEncodingByte="\" & ChrW(Source) case else if Source >= &h20 And _ Source <= &h7f Then PDFDocEncodingByte=ChrW(Source) else Octstr=Oct(Source) PDFDocEncodingByte= "\" & String(3-len(Octstr),"0") & Octstr end if End Select End Function '**************************************************************** Private Function GetProfile(strSection, strKey, varDefault, strPathIni) GetProfile = varDefault ' Initialize by default Dim f : Set f = objFSO.OpenTextFile(strPathIni) Dim strLine Dim fSectionFound Dim strKeyFound fSectionFound = False Do Until f.AtEndOfStream strLine = Trim(f.ReadLine) If (strLine <> "") And (Left(strLine, 1) <> ";") Then ' Skip Blank/Comment Line ' When Key was found If fSectionFound = True Then If strKey = Left(strLine, InStr(strLine, "=") - 1) Then GetProfile = Mid(strLine, InStr(strLine, "=") + 1) f.Close() Set objFSO = Nothing Exit Function ' Success End If End If ' Control inside target section or not. If (Left(strLine, 1) = "[") And (Right(strLine, 1) = "]") Then If strLine = ("[" + strSection + "]") Then fSectionFound = True Else fSectionFound = False End If End If End If Loop f.Close() Set f = Nothing End Function '**************************************************************** Function ModulePath() dim T,fHandle ModulePath=WScript.ScriptFullName T=lcase(ModulePath) T=left(T,len(T)-4) if right(T,4)<>".tmp" Then exit function on error resume next set fHandle=objFSO.OpenTextFile(T) T=fHandle.ReadLine fHandle.close if err.number=0 Then ModulePath=T End Function