フォルダごとドラッグアンドドロップして印刷するVBS

## 概要・使い方
- フォルダごとvbsファイルにドラッグアンドドロップするだけ
- あとはフォルダ内ファイルを印刷
- 印刷コマンドはSendKeysで力技（APIなど不明なツールを力技で印刷する）
- 拡張子指定可能


素晴らしすぎるプログレスバーはこちらから拝借
https://qiita.com/fusafusa/items/14be276291233116f5b5#%E3%83%97%E3%83%AD%E3%82%B0%E3%83%AC%E3%82%B9%E3%83%90%E3%83%BC%E3%83%A1%E3%82%A4%E3%83%B3%E3%82%AF%E3%83%A9%E3%82%B9

## コード
``` vb
Option Explicit
'-------------------------------------------------------------------------------
' 変数定義
'------------------------------------------------------------------------------
'Main用
  Const fExtension = "mx2"
  Const Interval = 10  '1件ダイアログを実行した後の処理待ち時間。単位は秒

  Const Reg_Start = "Start"
  Const Reg_Stop = "Stop"
  Dim objPB, objFSO
  Dim i
  Dim DirPath()
  Dim fName()

'Class用
  Const WIDTH = 400
  Const HEIGHT = 150
  Const BAR_WIDTH = 350
  Const BAR_HEIGHT = 16
  Const BAR_BG = "#C0C0C0"
  Const BAR_FG = "#0066FF"

'------------------------------------------------------------------------------
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'レジストリを開始モードにする
    Call SetReg(Reg_Start)

    Dim GetPathArray
    Set GetPathArray = WScript.Arguments
    Dim pt

  Dim WSS
  Set WSS = CreateObject("WScript.Shell")

'-------------------------------------------------------------------------------
' メイン処理
'-------------------------------------------------------------------------------
    Set objPB = New ProgressBar
    objPB.SetTitle "mx2pdf 進捗状況"

    objPB.SetProgress 0 '進捗0%の表示--------------------------------

    Dim mx2s, m, n
    m = 0
    For Each pt In GetPathArray
      Call StopVBS
      Call GetFiles(pt)
    Next

    Call jikkousuruka(m)

    For n = 1 To m
      Call main(DirPath(n), fName(n))
      objPB.SetProgress n / m        ' 実行数／全体数　（1.00で全部終了）
    Next

    Set objPB = Nothing
    Set objFSO = Nothing

    MsgBox "PDF化完了！"

'-------------------------------------------------------------------------------
' 各処理
'-------------------------------------------------------------------------------

Sub GetFiles(Target) '-------------------------------------------------------
  'Dim mx2s()
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")

  Dim folder
  Set folder = fso.getFolder(Target) '& "\")

  ' ファイル一覧を取得
  Dim file, fExt ', DirPath, fName
  For Each file In folder.Files
    fExt = Split(file.Name, ".")(1)
    If fExt = fExtension Then
    m = m + 1
    ReDim Preserve DirPath(m)
    ReDim Preserve fName(m)
    DirPath(m) = file.Path
    fName(m) = Split(file.Name, ".")(0)
    'Redim Preserve mx2s(m)
    'mx2s(m) = file '.Path
    'msgbox mx2s(m)
    End If
  Next

  'サブフォルダがなくなるまでこのSubを無限ループさせる
  Dim subfolder
  For Each subfolder In folder.subfolders
      Call GetFiles(subfolder.Path) ',m)
  Next

    'GetFiles=mx2s
End Sub

'-------------------------------------------------------------------------------
Sub jikkousuruka(m)
    Dim msg1(6)
    msg1(0) = m & "件のmx2ファイルをPDF化します。"
    msg1(1) = "実行しますか？"
    msg1(2) = ""
    msg1(3) = "※暴走した際は【強制終了.vbs】を実行してください。"
    msg1(4) = ""
    msg1(5) = "No:フォルダ>図面名"
    msg1(6) = FolderStructure

    Dim msg2: msg2 = Join(msg1, vbCrLf)
    Dim r
    r = MsgBox(msg2, vbYesNo)
    If r = vbNo Then: WScript.Quit
End Sub

'-------------------------------------------------------------------------------
Sub main(DirPath, fName) '-------------------------------------------------------
'      DirPath = file.Path
'      fName = Split(file.Name, ".")(0)
      Call filePrint(DirPath)
      Call SetDirPath(DirPath)
      Call SetPDFName(fName)
  '   Call CloseFile
End Sub

'-------------------------------------------------------------------------------
Sub filePrint(Target) '-------------------------------------------------------
  Call StopVBS
  'ファイルを開く
    With WSS
      .Run Target
      WScript.Sleep (1000)
    .SendKeys ("^{ESC}{RIGHT}")
    '力技で印刷する
      .SendKeys ("%")
      .SendKeys ("F")
      .SendKeys ("P")
      WScript.Sleep (1000)
      .SendKeys ("{ENTER}")
    End With
End Sub

'-------------------------------------------------------------------------------
Sub SetDirPath(DirPath)
  WScript.Sleep (500)
  Call StopVBS
  With WSS
    Dim i
'アドレスバーに保存先パスを入力----------------------------------------------
    For i = 1 To 6
      .SendKeys ("{TAB}")
      WScript.Sleep (100)
    Next
  Call StopVBS
    .SendKeys ("{ENTER}")
ClipPaste (DirPath)
    WScript.Sleep (100)
  Call StopVBS
    .SendKeys ("{ENTER}")
    WScript.Sleep (100)
  End With
End Sub

'-------------------------------------------------------------------------------
Sub SetPDFName(fName)
  Call StopVBS
  WScript.Sleep (500)
  With WSS
    Dim i
'ファイル名を入力------------------------------------------------------------
      .SendKeys ("{TAB}")
      WScript.Sleep (500)
    For i = 1 To 5
      .SendKeys ("{TAB}")
      WScript.Sleep (100)
    Next
ClipPaste (fName)
    WScript.Sleep (100)
  Call StopVBS
    .SendKeys ("{ENTER}")
   'すでにpdfがある場合は上書き　これも力業
      WScript.Sleep (1000)
      .SendKeys ("{LEFT}")
    .SendKeys ("{ENTER}")
  End With
    WScript.Sleep (Interval * 1000)
End Sub

'-------------------------------------------------------------------------------
Sub CloseFile()
  WSS.SendKeys ("%{F4}")
End Sub


Sub ClipPaste(Target)
   Dim onjShell
   Dim textClip

   Set textClip = CreateObject("WScript.Shell")
   WScript.Sleep 100
   textClip.Run "cmd.exe /c Echo " & Target & " | Clip", 0, True


      textClip.SendKeys ("^v")
    Set onjShell = Nothing
    Set textClip = Nothing
End Sub

'-------------------------------------------------------------------------------
Sub StopVBS()
  If GetReg = Reg_Stop Then
    WScript.Quit
  End If
End Sub

'-------------------------------------------------------------------------------
Function GetReg()
  Dim Ws
  Dim bKey
  Set Ws = WScript.CreateObject("WScript.Shell")
  bKey = Ws.RegRead("HKCU\Software\ACME\test\MindReader")
  GetReg = bKey
End Function

'-------------------------------------------------------------------------------
Sub SetReg(Str)
  Dim Ws

  Set Ws = WScript.CreateObject("WScript.Shell")
  Ws.RegWrite "HKCU\Software\ACME\test\", 1, "REG_BINARY"
  Ws.RegWrite "HKCU\Software\ACME\test\MindReader", Str, "REG_SZ"
End Sub

'-------------------------------------------------------------------------------
Function FolderStructure()
    Dim buf, DirName, mxName

    Dim msg1()
    ReDim msg1(m)
    For i = 1 To m
        buf = Split(DirPath(i), "\")
        DirName = buf(UBound(buf) - 1)
        mxName = buf(UBound(buf))
        msg1(i) = i & " : " & DirName & " > " & mxName
    Next
    FolderStructure = Join(msg1, vbCrLf)
End Function


'-------------------------------------------------------------------------------
' ProgressBar : 進捗バークラス
'-------------------------------------------------------------------------------
'Const WIDTH = 400
'Const HEIGHT = 150
'Const BAR_WIDTH = 350
'Const BAR_HEIGHT = 16
'Const BAR_BG = "#C0C0C0"
'Const BAR_FG = "#0066FF"

Class ProgressBar

    '----------------------------------------------------
    ' クラス変数定義
    '----------------------------------------------------
    Private strTitle1
    Private nCurrent1
    Private nStartTime, nCurrentTime
    Private objIE
    Private div1, div2, div3

    '----------------------------------------------------
    ' コンストラクタ
    '----------------------------------------------------
    Private Sub Class_Initialize()
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Visible = False
        objIE.Navigate2 "about:blank"
        objIE.Document.Title = "進捗状況"
        objIE.AddressBar = False
        objIE.MenuBar = False
        objIE.Toolbar = False
        objIE.Resizable = False
        objIE.WIDTH = WIDTH
        objIE.HEIGHT = HEIGHT
        objIE.Top = 0
        objIE.Left = 0
        Set div1 = objIE.Document.CreateElement("div")
        div1.ID = "div1"
        div1.Style.Position = "absolute"
        div1.Style.Top = "10px"
        div1.Style.Left = "10px"
        div1.Style.backgroundColor = BAR_BG
        div1.Style.WIDTH = BAR_WIDTH & "px"
        div1.Style.HEIGHT = BAR_HEIGHT & "px"
        div1.Style.Border = "1px solid"
        div1.Style.overflow = "hidden"
        Set div2 = objIE.Document.CreateElement("div")
        div2.ID = "div2"
        div2.Style.Position = "relative"
        div2.Style.Top = "1px"
        div2.Style.Left = "1px"
        div2.Style.backgroundColor = BAR_FG
        div2.Style.WIDTH = "0px"
        div2.Style.HEIGHT = (BAR_HEIGHT - 2) & "px"
        div2.Style.overflow = "hidden"
        Set div3 = objIE.Document.CreateElement("div")
        div3.ID = "div3"
        div3.Style.Position = "absolute"
        div3.Style.Top = "45px"
        div3.Style.Left = "10px"

        objIE.Document.Body.AppendChild (div1)
        div1.AppendChild (div2)
        objIE.Document.Body.AppendChild (div3)

        nStartTime = Timer()
    End Sub

    '----------------------------------------------------
    ' デストラクタ
    '----------------------------------------------------
    Private Sub Class_Terminate()
        On Error Resume Next
        objIE.Quit
        Set objIE = Nothing
        On Error GoTo 0
    End Sub

    '----------------------------------------------------
    ' 表示タイトルの設定
    '----------------------------------------------------
    Public Sub SetTitle(t)
        strTitle1 = t
        objIE.Document.Title = t & String(40, "　")
        objIE.Visible = True
    End Sub

    '----------------------------------------------------
    ' 進捗パーセントの設定
    '----------------------------------------------------
    Public Sub SetProgress(n1)
        nCurrent1 = n1
        Repaint
    End Sub

    '----------------------------------------------------
    ' 進捗バー再描画
    '----------------------------------------------------
    Private Sub Repaint()

    Dim nAverage
    Dim nElapsedTime
    Dim nRemain
    Dim strRemain
    Dim strPercent

    Dim w1
    Dim style1, style2

        nCurrentTime = Timer()
        nElapsedTime = nCurrentTime - nStartTime

        w1 = BAR_WIDTH * (nCurrent1)
        strRemain = "不明"
        If nElapsedTime <> 0 Then
            nAverage = nCurrent1 / nElapsedTime
            If nAverage <> 0 Then
                nRemain = Round((1 - nCurrent1) / nAverage, 1)
            End If
            If nRemain > 60 Then
                strRemain = "約" & CStr(Round(nRemain / 60, 0)) & "分"
            Else
                strRemain = FormatNumber(nRemain, 1) & "秒"
            End If
        End If

        strPercent = FormatNumber(nCurrent1 * 100, 1)

        On Error Resume Next
        div2.Style.WIDTH = (w1 - 1) & "px"
        div3.innerText = strPercent & "%終了　--　残り推定：" & strRemain
        objIE.Visible = True
        objIE.Document.all(0).Click
        On Error GoTo 0
    End Sub
End Class

```

## 中断コード（別ファイル）
別vbsファイルで保存して
ショートカットを設定する。

こっちを実行すると
メインコード側のレジストリ判定でメイン側を止める。

``` vb
const Reg_Stop= "Stop"
Dim Ws

Set Ws = WScript.CreateObject("WScript.Shell")
Ws.RegWrite "HKCU\Software\ACME\test\", 1, "REG_BINARY"
Ws.RegWrite "HKCU\Software\ACME\test\MindReader", Reg_Stop, "REG_SZ"

```