【ここにExcelをドラッグ&ドロップ】customUI差し替え&エクセルアドイン化&登録.vbs

【ここにExcelをドラッグ&ドロップ】customUI差し替え&エクセルアドイン化&登録.vbs

Call main

'★main処理
Function main()
  Start_Time = fnc_startProc '全体計測開始

  fnc_Start_Time = fnc_startProc '個別計測開始
  DnDfullPath = fnc_DnDfullPath '■ドラッグ＆ドロップしたファイルのフルパスを取得
  Proc_Time_Str = Proc_Time_Str & "fnc_DnDfullPath    :" & fnc_endProc(fnc_Start_Time) & vbCrLf '個別計測時間を格納

  fnc_Start_Time = fnc_startProc '個別計測開始
  Call fnc_zipDecomp(DnDfullPath) '■xlsmをxlsm.zipにリネームして解凍
  Proc_Time_Str = Proc_Time_Str & "fnc_zipDecomp      :" & fnc_endProc(fnc_Start_Time) & vbCrLf '個別計測時間を格納

  fnc_Start_Time = fnc_startProc '個別計測開始
  Call fnc_customUIChange(DnDfullPath) '■customUI差し替え
  Proc_Time_Str = Proc_Time_Str & "fnc_customUIChange :" & fnc_endProc(fnc_Start_Time) & vbCrLf '個別計測時間を格納

  fnc_Start_Time = fnc_startProc '個別計測開始
  Call fnc_makeAddin(DnDfullPath) '■アドインファイル作成
  Proc_Time_Str = Proc_Time_Str & "fnc_makeAddin      :" & fnc_endProc(fnc_Start_Time) & vbCrLf '個別計測時間を格納

  fnc_Start_Time = fnc_startProc '個別計測開始
  Call fnc_registerAddin(DnDfullPath) '■アドインファイル登録
  Proc_Time_Str = Proc_Time_Str & "fnc_registerAddin  :" & fnc_endProc(fnc_Start_Time) & vbCrLf '個別計測時間を格納

  Proc_Time_Str = Proc_Time_Str & vbCrLf & "Total              :" & fnc_endProc(Start_Time) & vbCrLf '全体計測時間を格納
  Call fnc_writeProc(Proc_Time_Str) '処理時間をテキストに書き込み

  MsgBox "インストール完了"

End Function

'■ドラッグ＆ドロップしたファイルのフルパスを取得
Function fnc_DnDfullPath()

  '対象は1個だけ
  If WScript.Arguments.Count < 1 Then
    WScript.Echo ("ファイルをドロップしてください")
    WScript.Quit
  ElseIf WScript.Arguments.Count > 1 Then
    WScript.Echo ("1個にしてください")
    WScript.Quit
  End If

  fnc_DnDfullPath = WScript.Arguments(0)

End Function

'■xlsmをxlsm.zipにリネームして解凍
Function fnc_zipDecomp(file)

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set shellObj = CreateObject("Shell.Application")
  Dim wsh
  Set wsh = CreateObject("WScript.Shell")

  '名前を.xlsmから.xlsm.zipに変更
  Set objFile = fso.GetFile(fso.GetAbsolutePathName(file))
  objFile.Name = fso.GetFileName(file) & ".zip"
  
  filezip = file & ".zip"

  '解凍
  '7-Zipがインストールされているか確認
  ret = fso.FileExists("C:\Program Files\7-Zip\7z.exe")
  If ret Then
  
    Dim a_sZipPath
    Dim a_sMakeDirectory
    Dim a_sPassword
    Dim s7zPath   '// 7z.exeのフルパス
    Dim sCmd  '// コマンド文字列
  
    '// 解凍先フォルダとパスワードを指定しない場合（zipファイルと同じ階層に中身が展開される）
    '★対象zipファイル
    a_sZipPath = filezip
  
    '★解凍先フォルダ(指定しない場合は同一階層に展開)
    a_sMakeDirectory = fso.GetParentFolderName(file) & "\" & fso.GetFileName(file)
  
    '★パスワード(かかっていれば)
    a_sPassword = ""
      
    s7zPath = """C:\Program Files\7-Zip\7z.exe"""
    sCmd = s7zPath & " x "
      
    '// 引数で解凍先ディレクトリが設定されている場合
    If a_sMakeDirectory <> "" Then
      sCmd = sCmd & "-o" & Chr(34) & a_sMakeDirectory & Chr(34) & " "
      
    '// 解凍先ディレクトリが設定されていない場合は圧縮ファイルがあるフォルダを解凍先とする
    Else
      sCmd = sCmd & "-o" & Chr(34) & Left(a_sZipPath, InStrRev(a_sZipPath, "\")) & Chr(34) & " "
    End If
    
    '// 引数でパスワードが設定されている場合（-p + パスワード　を付与）
    If a_sPassword <> "" Then
      sCmd = sCmd & "-p" & a_sPassword & " "
    End If
          
    '// 「7z.exe x [-o解凍先フォルダ] [-pパスワード] -y 圧縮ファイルパス」のコマンド文字列を作成
    '// -yは解凍時の問い合わせを全て「Yes」として扱う
    sCmd = sCmd & "-y " & Chr(34) & a_sZipPath & Chr(34)
      
    '// 7-Zipの解凍コマンドを実行
    Call wsh.Run(sCmd,0,True) '0は画面非表示、Trueは同期実行(圧縮完了するまで次の処理にいかない)
  
  Else
    'Windows標準解凍
    'フォルダの名前を決める
    ExtractFolder = fso.GetParentFolderName(filezip) & "\" & fso.GetBaseName(filezip)

    'なかったら作る
    If Not fso.FolderExists(ExtractFolder) Then
      fso.CreateFolder (ExtractFolder)
    End If

    shellObj.Namespace(ExtractFolder).CopyHere shellObj.Namespace(filezip).Items
  End If
  
  '終了時の解放
  Set fso = Nothing
  Set wsh = Nothing
  Set shellObj = Nothing

End Function

'■customUI差し替え
Function fnc_customUIChange(file)

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set shellObj = CreateObject("Shell.Application")

  ExtractFolder = file '解凍後のフォルダ

  customUIFolder = ExtractFolder & "\customUI"

  'customUIフォルダがなければ作成する
  strFolder = WScript.Arguments.Item(0)
  If Err.Number = 0 Then
    If fso.FolderExists(customUIFolder) = True Then
      '何もしない
    Else
      fso.CreateFolder(customUIFolder)
      If Err.Number = 0 Then
        'エラーなし
      Else
        strMessage = "エラー: " & Err.Description
      End If
    End If
  Else
    WScript.Echo "エラー: " & Err.Description
  End If

  'コピー元のファイルのパスを指定
  strFilePathFrom = fso.GetParentFolderName(file) & "\customUI.xml"
  strFilePathTo = ExtractFolder & "\customUI\customUI.xml"

  zipFile = ExtractFolder & ".zip"
  
  '待ち
  WScript.Sleep 5000
  
  'ファイルを上書きコピー
  Call fso.CopyFile(strFilePathFrom, strFilePathTo)
  
  'zipファイルを削除
  fso.DeleteFile zipFile

  '7-Zipがインストールされているか確認
  ret = fso.FileExists("C:\Program Files\7-Zip\7z.exe")
  If ret Then

    Set objFolder = fso.GetFolder(ExtractFolder)

    'フォルダ内のフォルダの数だけループ
    For Each objSubFolder In objFolder.SubFolders
      '■7-Zipで圧縮
      Call fnc_MakeZip7(objSubFolder, zipFile)
    Next

    'フォルダ内のファイルの数だけループ
    For Each objFile In objFolder.Files
      '■7-Zipで圧縮
      Call fnc_MakeZip7(objFile, zipFile)
    Next
   
  Else

    'Windows通常圧縮処理
    'ZIPファイル作成
    Set fileObj = fso.CreateTextFile(zipFile, True)
    'ヘッダの書き込み
    fileObj.Write (Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0))
    fileObj.Close
  
    '圧縮対象ファイルを作成したZIPファイル内に格納
    ' 対象ファイル群を取得
    Set sourceFiles = shellObj.Namespace(ExtractFolder).Items
    ' ZIPファイルに追加
    shellObj.Namespace(zipFile).CopyHere (sourceFiles)
  
    '待ち
    WScript.Sleep 3000

  End If
  
  'フォルダを削除
  fso.DeleteFolder ExtractFolder
  
  '名前を.xlsm.zipから.xlsmに戻す
  Set objFile = fso.GetFile(fso.GetAbsolutePathName(zipFile))
  objFile.Name = fso.GetFileName(file)
  
  '終了時の解放
  Set fso = Nothing
  Set shellObj = Nothing

End Function

'■7-Zipで圧縮
Function fnc_MakeZip7(a_sPath, a_sZipPath)
    Dim wsh       '// WshShellクラス
    Dim s7zPath   '// 7z.exeのフルパス
    Dim sCmd      '// コマンド文字列
    
    a_sPassword = ""

    s7zPath = """C:\Program Files\7-Zip\7z.exe"""
    
    '// 引数でパスワードが設定されていない場合
    If a_sPassword = "" Then
        sCmd = s7zPath & " a " & a_sZipPath & " " & a_sPath
    '// 引数でパスワードが設定されている場合（-p + パスワード　を付与）
    Else
        sCmd = s7zPath & " a -p" & a_sPassword & " " & a_sZipPath & " " & a_sPath
    End If
    
    '// WshShellオブジェクトを作成
    Set wsh = CreateObject("WScript.Shell")
    
    '// 7-Zipの圧縮コマンドを実行
    Call wsh.Run(sCmd,0,True) '0は画面非表示、Trueは同期実行(圧縮完了するまで次の処理にいかない)

End Function


'■アドインファイル作成
Function fnc_makeAddin(file)
  '★動作内容
  'ドラッグ&ドロップしたエクセルファイル(.xlsm)をアドインファイル(.xlam)に変換して同じディレクトリに一時保存
  'アドインファイルを登録して一時保存したアドインファイルを削除

  Dim Args
  Dim OutputFilePath
  Dim i
  Set fso = CreateObject("Scripting.FileSystemObject")
  Const xlOpenXMLAddIn = 55
  
  Select Case LCase(fso.GetExtensionName(file))
    Case "xls", "xlsx", "xlsm"
      OutputFilePath = fso.GetParentFolderName(file) & ChrW(92) & fso.GetBaseName(file) & ".xlam"
      With CreateObject("Excel.Application")
        .Visible = True
        .DisplayAlerts = False
        With .Workbooks.Open(file)
          .SaveAs OutputFilePath, xlOpenXMLAddIn
          .Close False
        End With
        .DisplayAlerts = True
        .Quit
      End With
  End Select
    
  '終了時の解放
  Set fso = Nothing

End Function

'■アドインファイル登録
Function fnc_registerAddin(file)

  Dim InstallPath
  Dim AddinFile
  Dim AddinName
  Dim xlApp
  Dim wsh
  Dim f
  Dim f1
  Dim fc
  Dim RE
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  Dim objWshShell
  Set objWshShell = WScript.CreateObject("WScript.Shell")
  Set RE = CreateObject("VBScript.RegExp")
  RE.Pattern = "\.xlam"
  Set f = fso.GetFolder(objWshShell.CurrentDirectory)
  Set fc = f.Files
  
  AddinName = fso.GetBaseName(file)
  AddinFile = fso.GetBaseName(file) & ".xlam"
  
  OutputFilePath = fso.GetParentFolderName(file) & "\" & AddinFile
  
  On Error Resume Next
    
  'Excelのインスタンス
  Set xlApp = CreateObject("Excel.Application") 'VbScript
  xlApp.DisplayAlerts = False
  
  '登録済対策
  xlApp.AddIns(AddinFile).Installed = False
  
  'Addinsフォルダ、任意のフォルダを指定可能
  InstallPath = objWshShell.SpecialFolders("Appdata") & "\Microsoft\Addins\"
  'アドインファイルをコピー
  fso.CopyFile OutputFilePath, InstallPath & AddinFile, True

  'アドイン登録
  xlApp.Workbooks.Add 'VbScript
  xlApp.AddIns.Add InstallPath & AddinFile
  xlApp.AddIns(AddinName).Installed = True
  xlApp.Quit 'VbScript
  
  'アドイン削除
  fso.DeleteFile OutputFilePath
  
  On Error GoTo 0
    
  '終了時の解放
  Set wsh = Nothing
  Set fso = Nothing
  Set xlApp = Nothing
  Set RE = Nothing

End Function

'■■■デバッグ用タイマー処理■■■
'開始処理
Function fnc_startProc()
  '開始時間取得
  fnc_startProc = Timer
End Function

'終了処理
Function fnc_endProc(Start_Time)
  '終了時間取得
  End_Time = Timer
  '処理時間計算
  Proc_Time = End_Time - Start_Time
  '処理時間表示
  'MsgBox( "終了(処理時間：" & Proc_Time & ")" )
  fnc_endProc = Proc_Time
End Function

Function fnc_writeProc(Proc_Time_Str)
  Set fso = CreateObject("Scripting.FileSystemObject")
  'テキストファイルのオープン(追記モード)
  outtxt = fso.getParentFolderName(WScript.ScriptFullName) & "\処理時間ログ.txt"

  '書き込む前に古いファイルを削除
  If(fso.FileExists(outtxt))Then
    fso.DeleteFile outtxt
  End If

  Set file = fso.OpenTextFile(outtxt, 8, True)
  file.WriteLine (Proc_Time_Str)
  file.Close

  '終了時の解放
  Set fso = Nothing
End Function