Option Explicit
Public ADDIN_NAME As String ' アドイン名
Public ADDIN_FILE_NAME As String ' アドインファイル名
Public MENU_RIGHT_CLICK As String ' 右クリックメニュー名
Public EXCEL_FILE As String ' Excelファイル
Public PDF_FILE As String ' PDFファイル
' 初期処理
Public Sub Init()
' 変数設定
ADDIN_NAME = "サンプルアドインツール"
ADDIN_FILE_NAME = "サンプルアドインツール.xlam"
MENU_RIGHT_CLICK = "サンプルメニュー"
EXCEL_FILE = "C:\temp\サンプルExcelファイル.xlsx"
PDF_FILE = "C:\temp\Adobe Acrobat Pro DC.pdf"
' WSHオブジェクト
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
' 特殊フォルダのパスを格納する変数
Dim path As String
path = wsh.SpecialFolders("MyDocuments")
path = wsh.SpecialFolders(16)
End Sub
' アドイン追加
Public Sub SaveAddin()
Dim savePath As String
' アドイン登録済の場合、無効にする
If IsExistAddin() Then
If AddIns(ADDIN_NAME).Installed = True Then
AddIns(ADDIN_NAME).Installed = False
End If
End If
' アドイン規定のディレクトリに保存（拡張子：xlsm→xlam）
savePath = Application.UserLibraryPath & Replace(ThisWorkbook.Name, ".xlsm", ".xlam")
' アドイン追加
Application.DisplayAlerts = False
ThisWorkbook.SaveAs savePath, XlFileFormat.xlOpenXMLAddIn
Application.DisplayAlerts = False
' 完了メッセージ表示
If ThisWorkbook.Saved = True Then
MsgBox "アドインを追加しました。Excelを再起動してアドインを有効にしてください。", vbInformation
End If
End Sub
' アドイン有効
Public Sub AddinEnabled()
' アドイン有無チェック
If IsExistAddin() Then
AddIns(ADDIN_NAME).Installed = True
End If
End Sub
' アドイン無効
Public Sub AddinUnEnabled()
' アドイン有無チェック
If IsExistAddin() Then
AddIns(ADDIN_NAME).Installed = False
End If
End Sub
' アドイン有無チェック
Public Function IsExistAddin() As Boolean
Dim addin As addin
For Each addin In AddIns
If addin.Name = ADDIN_FILE_NAME Then
IsExistAddin = True
Exit Function
End If
Next
IsExistAddin = False
End Function
' 右クリックメニューを追加
Public Sub AddMenuRight()
' 右クリックメニューを削除
Call DeleteMenuRight
'一番上のメニューから下がグループの始まりと設定する
Application.CommandBars("Cell").Controls(1).BeginGroup = True
' 右クリックメニューを追加
'With Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Before:=1) ' 先頭に追加
With Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup) ' 末尾に追加
.Caption = MENU_RIGHT_CLICK
.BeginGroup = True
With .Controls.Add
.Caption = "Excelファイルを開く"
.OnAction = "'OpenExcel """ & EXCEL_FILE & """'"
.BeginGroup = True
.FaceId = 1
End With
With .Controls.Add
.Caption = "PDFファイルを開く"
.OnAction = "'OpenPDF """ & PDF_FILE & """'"
.BeginGroup = True
.FaceId = 1
End With
End With
End Sub
' 右クリックメニューを削除
Public Sub DeleteMenuRight()
Dim cmd
For Each cmd In Application.CommandBars("Cell").Controls
If TypeName(cmd) = "CommandBarPopup" Then
If cmd.Caption = MENU_RIGHT_CLICK Then
cmd.Delete
End If
End If
Next
End Sub
' Excelファイルを開く
Public Sub OpenExcel(pExcelFile As String)
Workbooks.Open pExcelFile
End Sub
' PDFファイルを開く
Public Sub OpenPDF(pWordFile As String)
CreateObject("Shell.Application").ShellExecute pWordFile
End Sub
