Excel、PowerPoint、Wordのアドインを自動で登録するマクロ

アドインの登録を自動化したい！
執筆させていただいた書籍「生成AIをWord＆Excel＆PowerPoint＆Outlookで自在に操る超実用VBAプログラミング術」では、今すぐ使用できる生成AIアドインを、出版社インプレスの読者特典サイトから無料でダウンロードできるのですが、このアドインを自動で登録するマクロを作ってみました。マクロを記述したワークブックは、登録するアドインと同じフォルダーに入れて実行ください。各Officeアプリのリボン上に、ChatGPTや画像生成を自在に扱う各種メニューが表示され、使えるようになります。

**自動でアドイン登録するだけで、あなたのOfficeが生成AI対応に機能アップ！**

もちろん、コード中のアドイン名を書き換えれば、どんなアドインでも対応できるので、Excelだけでなく、他のWordやPowerPointのアドインを自動登録したい局面でも、本マクロコードを使っていただけるかと思います。

コードのポイントとしては、Excelで動作しているので、対象のExcelアドインが有効となっている場合は一度無効にしている点と、PowerPointはExcelやWordとプロパティが異なり、独自のAutoLoadプロパティをTrueにすることで恒常的に有効となる点です。またWordの場合、デフォルトとなっているTemplateフォルダではなくSTARTUPフォルダに入れることで、恒常的に有効となります。デフォルトのTemplateフォルダにアドインを入れて登録しても、再起動する度に有効のチェックボックスが外れ、毎回、Wordを起動する度に手動でチェックボックスをオンにする必要があるので、本コードのようにSTARTUPフォルダーに入れての登録がお勧めです。

アドイン自動登録のマクロコードは次の通りです。

Sub SetAddin()
    
    Dim i As Long
    Dim addinName(1 To 3) As String
    'アドインファイルの存在チェック
    addinName(1) = "OpenAI.xlam"
    addinName(2) = "OpenAI.ppam"
    addinName(3) = "OpenAI.dotm"
    For i = 1 To 3
        If Dir(ThisWorkbook.Path & "\" & addinName(i)) = "" Then
            MsgBox addinName(i) & "を同じフォルダーに入れて実行してください。"
            Exit Sub
        End If
    Next i
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim objAddin As Object
    Dim objApp As Object
    
    'PowerPoint、Wordの起動チェック
    Dim appName(1 To 2) As String
    appName(1) = "PowerPoint"
    appName(2) = "Word"
    For i = 1 To 2
        On Error Resume Next
        Set objApp = GetObject(, appName(i) & ".Application")
        On Error GoTo 0
        If Not objApp Is Nothing Then
            MsgBox appName(i) & "を終了してから実行してください"
            Exit Sub
        End If
    Next i
    
    Dim AdName As String
    Dim AddinPath As String
    Dim installPath As String
    
    'Excel－－－－－－－－－－－－－－－－－－－－－－－－－－－－
    AdName = addinName(1)
    AddinPath = ThisWorkbook.Path & "\" & AdName
    installPath = Application.UserLibraryPath & AdName

    '既登録のアドインを無効化
    With Application.AddIns
        On Error Resume Next
        Set objAddin = .Item(Replace(AdName, ".xlam", ""))
        On Error GoTo 0
        If Not objAddin Is Nothing Then
            If Dir(objAddin.FullName) <> "" Then objAddin.Installed = False
        End If
    End With

    '所定の場所にアドインをコピーし登録
    fso.CopyFile AddinPath, installPath, True
    Set objAddin = Application.AddIns.Add(installPath, True)
    objAddin.Installed = True
    AppActivate (ThisWorkbook.Name & " - Excel")
    
    'PowerPoint－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
    AdName = addinName(2)
    AddinPath = ThisWorkbook.Path & "\" & AdName
    installPath = Application.UserLibraryPath & AdName
    fso.CopyFile AddinPath, installPath, True
    
    Set objApp = CreateObject("PowerPoint.Application")
    objApp.Visible = True
    objApp.presentations.Add
    Set objAddin = Nothing
    With objApp.AddIns
        ' 既登録のアドインを削除
        On Error Resume Next
        Set objAddin = .Item(AdName)
        On Error GoTo 0
        If Not objAddin Is Nothing Then
            objApp.AddIns.Remove AdName
        End If
        ' アドインを追加
        Set objAddin = .Add(installPath)
        objAddin.Loaded = True          ' アドインをロード
        objAddin.registered = True
        objAddin.AutoLoad = True        '恒常化
    End With
        
    'Word－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
    AdName = addinName(3)
    AddinPath = ThisWorkbook.Path & "\" & AdName
    Dim folderPath As String
    '恒常起動できるSTARTUPフォルダーにアドインを格納
    folderPath = Replace(Application.UserLibraryPath, "AddIns", "Word\STARTUP")
    installPath = folderPath & AdName
    'STARTUPフォルダーがない場合は作成
    If Dir(folderPath, vbDirectory) = "" Then MkDir (folderPath)
    fso.CopyFile AddinPath, installPath, True
        
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = True
    objApp.documents.Add
    Set objAddin = objApp.AddIns.Add(installPath, True)
    objAddin.Installed = True
    
    '終了処理－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
    Set fso = Nothing
    Set objApp = Nothing
    Set objAddin = Nothing
    
    AppActivate (ThisWorkbook.Name & " - Excel")
    MsgBox "アドイン登録が完了しました。", vbInformation
    
End Sub

100

101

102

103

104

105

106

107

108

109

110

Sub SetAddin()

Dim i As Long

Dim addinName(1 To 3) As String

'アドインファイルの存在チェック

addinName(1) = "OpenAI.xlam"

addinName(2) = "OpenAI.ppam"

addinName(3) = "OpenAI.dotm"

For i = 1 To 3

If Dir(ThisWorkbook.Path & "\" & addinName(i)) = "" Then

MsgBox addinName(i) & "を同じフォルダーに入れて実行してください。"

Exit Sub

End If

Next i

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

Dim objAddin As Object

Dim objApp As Object

'PowerPoint、Wordの起動チェック

Dim appName(1 To 2) As String

appName(1) = "PowerPoint"

appName(2) = "Word"

For i = 1 To 2

On Error Resume Next

Set objApp = GetObject(, appName(i) & ".Application")

On Error GoTo 0

If Not objApp Is Nothing Then

MsgBox appName(i) & "を終了してから実行してください"

Exit Sub

End If

Next i

Dim AdName As String

Dim AddinPath As String

Dim installPath As String

'Excel－－－－－－－－－－－－－－－－－－－－－－－－－－－－

AdName = addinName(1)

AddinPath = ThisWorkbook.Path & "\" & AdName

installPath = Application.UserLibraryPath & AdName

'既登録のアドインを無効化

With Application.AddIns

On Error Resume Next

Set objAddin = .Item(Replace(AdName, ".xlam", ""))

On Error GoTo 0

If Not objAddin Is Nothing Then

If Dir(objAddin.FullName) <> "" Then objAddin.Installed = False

End If

End With

'所定の場所にアドインをコピーし登録

fso.CopyFile AddinPath, installPath, True

Set objAddin = Application.AddIns.Add(installPath, True)

objAddin.Installed = True

AppActivate (ThisWorkbook.Name & " - Excel")

'PowerPoint－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

AdName = addinName(2)

AddinPath = ThisWorkbook.Path & "\" & AdName

installPath = Application.UserLibraryPath & AdName

fso.CopyFile AddinPath, installPath, True

Set objApp = CreateObject("PowerPoint.Application")

objApp.Visible = True

objApp.presentations.Add

Set objAddin = Nothing

With objApp.AddIns

' 既登録のアドインを削除

On Error Resume Next

Set objAddin = .Item(AdName)

On Error GoTo 0

If Not objAddin Is Nothing Then

objApp.AddIns.Remove AdName

End If

' アドインを追加

Set objAddin = .Add(installPath)

objAddin.Loaded = True ' アドインをロード

objAddin.registered = True

objAddin.AutoLoad = True '恒常化

End With

'Word－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

AdName = addinName(3)

AddinPath = ThisWorkbook.Path & "\" & AdName

Dim folderPath As String

'恒常起動できるSTARTUPフォルダーにアドインを格納

folderPath = Replace(Application.UserLibraryPath, "AddIns", "Word\STARTUP")

installPath = folderPath & AdName

'STARTUPフォルダーがない場合は作成

If Dir(folderPath, vbDirectory) = "" Then MkDir (folderPath)

fso.CopyFile AddinPath, installPath, True

Set objApp = CreateObject("Word.Application")

objApp.Visible = True

objApp.documents.Add

Set objAddin = objApp.AddIns.Add(installPath, True)

objAddin.Installed = True

'終了処理－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Set fso = Nothing

Set objApp = Nothing

Set objAddin = Nothing

AppActivate (ThisWorkbook.Name & " - Excel")

MsgBox "アドイン登録が完了しました。", vbInformation

End Sub

それでは、よいVBAライフを！