ドラッグ&ドロップでExcelのアドインを登録するVBScript

ホーム
Office関連, Excel, VBScript
ドラッグ&ドロップでExcelのアドインを登録するVBScript

Office関連

2012.10.22

ドラッグ&ドロップでExcelのアドインを登録するVBScript

「ドラッグ&ドロップでWordのテンプレートを登録・解除する(VBS)」でWordテンプレートの登録・解除を補佐するスクリプトを紹介しましたが、今回はドラッグ&ドロップでExcelのアドインを登録するスクリプトを紹介します。

下記コードは、

Excelのアドインフォルダのパスを取得
ドラッグ&ドロップされたアドインファイルをExcelのアドインフォルダにコピー
コピーしたアドインファイルを登録

といった作業を自動的に行います。
アドインファイルのコピー先を変更したい、複数のアドインファイルを同時に登録したい、といった場合には、適当にコードを変更してご使用ください。

Option Explicit

InstallAddIn()
If MsgBox("処理が終了しました。" & vbCrLf & "Excelを今すぐ起動しますか？", vbYesNo) = vbYes Then _
CreateObject("WScript.Shell").Run "EXCEL.EXE", 1, False

Public Sub InstallAddIn()
  Dim Args
  Dim SourceFilePath
  Dim AddInFileName
  Dim AddInFilePath
  Dim AddInFolderPath
  Dim Wb
  Const MsgTitle = "Excelアドインファイル登録スクリプト"
  
  Set Args = WScript.Arguments
  If Args.Count < 1 Then
    MsgBox "Excelに登録したいアドインファイルを" & vbCrLf & _
           "当スクリプトファイルにドラッグ&ドロップして" & vbCrLf & _
           "処理を実行してください。", 16, MsgTitle
    Exit Sub
  ElseIf Args.Count > 1 Then
    MsgBox "当スクリプトが一度に処理できるのは1ファイルだけです。" & vbCrLf & _
           "処理を中止します。", 16, MsgTitle
    Exit Sub
  End If
  With CreateObject("Scripting.FileSystemObject")
    Select Case LCase(.GetExtensionName(Args(0)))
      Case "xla", "xlam"
        AddInFileName = .GetFileName(Args(0))
        SourceFilePath = Args(0)
      Case Else
        MsgBox "Excelアドインファイルではありません。" & vbCrLf & "処理を中止します。", 16, MsgTitle
        Exit Sub
    End Select
  End With
  Set Args = Nothing
  
  'アプリケーション起動チェック
  If ChkApp Then
    MsgBox "Excelが起動しています。" & vbCrLf & "Excelを終了してから再度実行してください。", 16, MsgTitle
    Exit Sub
  End If
  
  'アドインフォルダのパス取得
  AddInFolderPath = GetUserLibraryPath()
  If Len(AddInFolderPath) < 1 Then
    MsgBox "アドインフォルダのパスの取得に失敗しました。", 16, MsgTitle
    Exit Sub
  End If
  If Right(AddInFolderPath, 1) <> "\" Then AddInFolderPath = AddInFolderPath & "\"
  AddInFilePath =  AddInFolderPath & AddInFileName
  
  'アドインファイルのコピー
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    If .FolderExists(AddInFolderPath) <> True Then
      MsgBox "アドインフォルダが見つかりませんでした。", 16, MsgTitle
      Exit Sub
    End If
    If .FileExists(AddInFilePath) Then
      MsgBox "すでに[" & AddInFilePath & "]が存在しています。" & vbCrLf & _
             "処理を中止します。", 16, MsgTitle
      Exit Sub
    End If
    .CopyFile SourceFilePath, AddInFolderPath, True 'ファイルコピー(上書き)
  End With
  
  'アドインの登録
  With CreateObject("Excel.Application")
    .Visible = True
    Set Wb = .Workbooks.Add()
    .AddIns.Add(AddInFilePath).Installed = True
    Wb.Close False
    .Quit
  End With
  If Err.Number <> 0 Then
    MsgBox "エラーが発生しました。" & vbCrLf & "エラー内容 : " & Err.Description, 16, MsgTitle
    Err.Clear
    Exit Sub
  End If
  On Error GoTo 0
End Sub

'アドインフォルダのパス取得
Private Function GetUserLibraryPath()
  Dim ret
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("Excel.Application")
    .Visible = False
    ret = .UserLibraryPath
    .Quit
  End With
  Err.Clear
  On Error GoTo 0
  GetUserLibraryPath = ret
End Function

'Excelの起動チェック
Private Function ChkApp()
  Dim app, ret
  
  ret = False '初期化
  On Error Resume Next
  Set app = GetObject(, "Excel.Application")
  Err.Clear
  On Error GoTo 0
  If Not IsEmpty(app) Then ret = True
  ChkApp = ret
End Function