hackoo

[VBS] Doc2Pdf.vbs

Jun 25th, 2020
1,111
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '------------------------------------------------------------------------------------------------------------------
  2. ' This vbscript is inspired from https://www.winhelponline.com/blog/how-to-batch-convert-word-documents-into-pdf-files/
  3. ' And asked for tweaking here :
  4. ' https://stackoverflow.com/questions/62564156/converting-multiple-word-documents-to-multiple-pdfs-at-the-same-time-using-vbscr
  5. '------------------------------------------------------------------------------------------------------------------
  6. Option Explicit
  7. Dim Title
  8. Title = "Doc2PDF to Convert Multiple .doc or .docx files to PDF files"
  9.  
  10. 'We create a shortcut of this vbscript into SendTo Folder
  11. Call Create_Shortcut(_
  12. "Convert Word Docs to PDF",_
  13. chr(34) & WScript.ScriptFullName & chr(34),_
  14. "%SystemRoot%\system32\msdt.exe,0",_
  15. "Convert Multiple .doc or .docx files to PDF files")
  16.  
  17. On Error Resume Next
  18. Call Doc2PDF()
  19. If Err Then
  20.     Call ShowError()
  21.     Wscript.Quit(1)
  22. Else
  23.     MsgBox "The Conversion of Doc(s) to PDF(s) files is Successfully Done !",VbInformation+vbSystemModal,Title
  24. End If
  25. '------------------------------------------------------------------------------------------------------------------
  26. Sub Create_Shortcut(ShortcutName,TargetPath,IconLocation,Description)
  27.     Dim objShell,SendTo_Folder,objShortCut
  28.     Set objShell = CreateObject("WScript.Shell")
  29.     SendTo_Folder = objShell.ExpandEnvironmentStrings("%AppData%\Microsoft\Windows\SendTo")
  30.     Set objShortCut = objShell.CreateShortcut(SendTo_Folder & "\" & ShortcutName & ".lnk")
  31.     objShortCut.TargetPath = TargetPath
  32.     ObjShortCut.IconLocation = IconLocation
  33.     ObjShortCut.Description = Description
  34.     objShortCut.Save
  35. End Sub
  36. '-------------------------------------------------------------------------------------------------------------------
  37. Sub Doc2PDF()
  38. Dim fso,i,docPath,objWord,pdfPath,objDoc
  39.     Set fso = CreateObject("Scripting.FileSystemObject")
  40.     If WScript.Arguments.Count = 0 Then Wscript.Quit
  41.     For i= 0 To WScript.Arguments.Count -1
  42.         docPath = WScript.Arguments(i)
  43.         docPath = fso.GetAbsolutePathName(docPath)
  44.         If LCase(fso.GetExtensionName(docPath)) = LCase("doc") _
  45.         Or LCase(fso.GetExtensionName(docPath)) = LCase("docx") Then
  46.             Set objWord = CreateObject("Word.Application")
  47.             pdfPath = fso.GetParentFolderName(docPath) & "\" & _
  48.             fso.GetBaseName(docpath) & ".pdf"
  49.             objWord.Visible = False
  50.             Set objDoc = objWord.documents.open(docPath)
  51.             objDoc.saveas pdfPath,17
  52.             objDoc.Close
  53.             objWord.Quit
  54.         Else
  55.             MsgBox "You must send only files with those extensions "".doc"" or "".docx""",vbExclamation,Title
  56.             Wscript.Quit(1)
  57.         End If
  58.     Next
  59. End Sub
  60. '--------------------------------------------------------------------------------------------------------------------
  61. Sub ShowError()
  62.     Dim ErrLine
  63.     ErrLine  = Get_Date_Time
  64.     ErrLine  = ErrLine &  vbcrlf &_
  65.     "Error " & err.number & " (0x" & hex(err.number) & ") " & vbcrlf &_
  66.     err.Description & vbCrlf &_
  67.     "Source : " & err.Source
  68.     MsgBox ErrLine,vbCritical,Title
  69. End Sub
  70. '--------------------------------------------------------------------------------------------------------------------
  71. Function Get_Date_Time()
  72.     Get_Date_Time = LPad(Day(Now),2,"0") & "/" & LPad(Month(Now),2,"0") & "/" & Year(Now) &_
  73.     vbTab & LPad(Hour(Now),2,"0") & ":" & LPad(Minute(Now),2,"0")  & ":" & LPad(Second(Now),2,"0")
  74. End Function
  75. '--------------------------------------------------------------------------------------------------------------------
  76. Function LPad(s, l, c)
  77.   Dim n : n = 0
  78.   If l > Len(s) Then n = l - Len(s)
  79.   LPad = String(n, c) & s
  80. End Function
  81. '--------------------------------------------------------------------------------------------------------------------
RAW Paste Data