不具合ご報告（2023/12/19）
複数のブックを同時に開き、ある一つのブックに対してこのアドインを使用すると、使用したブックを閉じてもVBEのプロジェクトエクスプローラに閉じた筈のプロジェクトが残ってしまう不具合を発見しました。プロジェクトが残ったままの状態でもう一度該当ブックを開くと、同じプロジェクトが二つ表示されてしまいます。
これは全てのブックを閉じてExcelを終了させれば解消します。
不具合を解決しようとコードを見返していますが、行き詰っています。どなたか解決策をご存じでしたらご教授ください。
あー何と皮肉にも絶望的なことになってもうた、、、
そんなに絶望的か？
あるとき、VBAの開発環境に絶望したという記事を見て、そこで紹介されているVSCodeを使ったVBA開発環境の構築を試してみました。
自分の感想としては即座にデバックできないところなど、どうにも勝手が悪く返って使いづらい印象を持ちました。やはり長年慣れ親しんだVBEを捨ててVSCodeに移行するなどという気には到底なれません。
しかし、確かにコード管理がGitHubでできるのは便利だと思い、そこだけ取り入れてアドインにしてみました。以下のようなメニュー項目をVBEに追加して使用します。
とにかく「単純に」を目指して作りましたが、単純を積み重ねていくと自然と複雑になってしまうものですね。
必要な準備
パソコンにGitをインストール
これが無いとGitコマンドが使えません。以下のサイトでWindows用のインストーラをダウンロードしてインストールします。
Windows Script Hostでこれを操作します。
GitHubアカウントの用意
当然ですが、GitHub上に自分の場所を作らなければなりません。VBAプロジェクトをプッシュする先であるリモートリポジトリを作るためにアカウントが必要です。アカウントをお持ちでない方は以下でSign upします。
個人用アクセストークンの入手
これはVBAを使用してGitHub APIにアクセスし、新しいリポジトリを作成する際に必要です。GitHubアカウント作成後に以下で取得します。
トークン入手の手順
上のページに行ったら、Generate new tokenボタンをクリックしてClassicの方を選びます。
Noteに適当な文字列を入力、Expirationはデフォルトのままにしました。Select scopsはrepoのみチェックします。
ページ下にスクロールしてGenerate tokenをクリックします。
ページが変わりトークンが表示されますので、コピーボタンでコピーしておきます。作成されたトークンは一度きりしか表示されませんので注意が必要です。
トークンをレジストリに登録
上で取得したトークンをレジストリに登録しておきます。トークンは、出現するメッセージボックスにプレーンテキストで貼り付けます（Ctrl+Vで）。トークンは固定せずに一定期間で更新するようにすればセキュリティが高まるでしょう。（レジストリを使う時点でセキュリティに問題があると指摘される方もいらっしゃいますが）
ModuleGit.bas
' レジストリにトークンを登録
Public Sub RegisterToken()
On Error GoTo Catch
Dim keyStr As String
keyStr = InputBox("GitHubの個人アクセストークンを入力してください。")
If keyStr = "" Then Exit Sub
Call SaveSetting("GitHub", "Token", "Classic", keyStr)
MsgBox "GitHubの個人アクセストークンを登録しました。", vbInformation
Exit Sub
Catch:
MsgBox Err.Description, vbExclamation
End Sub
' レジストリからトークン用のキーを削除
Public Sub DeleteToken()
Call DeleteSetting("GitHub", "Token", "Classic")
End Sub
' レジストリからトークンを得る
Public Function GetTokenFromRegistry() As String
GetTokenFromRegistry = GetSetting("GitHub", "Token", "Classic")
End Function
VBAの標準機能であるSaveSettingステートメントとDeleteSettingステートメントでトークンの登録と削除を行います。登録したトークンを取得するには、これも標準機能であるGetSetting関数を使用しています。
これらは、VBA専用に用意されたHKEY_CURRENT_USER\Software\VB and VBA Program Settingを操作するための便利な機能です。
リポジトリの作成
リポジトリの作成は以下の流れで行います。
1. リポジトリ名の設定
インプットボックスを表示してユーザーにリポジトリ名の入力を促します。その際に入力された値がリポジトリ名として有効かどうかを検証します。有効であればレジストリに登録すると共に戻り値としてそれを返します。
ModuleGit.bas
' リポジトリ名をレジストリに記録
Public Function SetAndThenGetReposName() As String
Dim bookName As String: bookName = GetShortBookName(ActiveWorkbook.Name)
Dim repoName As String: repoName = GetSetting("Excel", bookName, "RepositoryName")
If repoName = "" Then
repoName = InputBox("リポジトリ名を英字で入力してください。")
If repoName = "" Then
SetAndThenGetReposName = ""
Exit Function
End If
If Not IsValidRepoName(repoName) Then
MsgBox "リポジトリ名は無効です。" & vbCr & vbCr & _
"リポジトリ名は英字で始まり、小文字、数字、ハイフン、アンダースコア、" & vbCr & _
"ピリオドを含めることができ、最大256文字までです。" & vbCr & _
"連続するハイフン、アンダースコアは使用できません。", vbInformation
SetAndThenGetReposName = ""
Exit Function
End If
Call SaveSetting("Excel", bookName, "RepositoryName", repoName)
End If
SetAndThenGetReposName = repoName
End Function
' GitHubのリポジトリ名の有効性をチェックする
Function IsValidRepoName(repoName As String) As Boolean
Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp")
' リポジトリ名は英字で始まり、指定された文字のみ含む、最大256文字
With regEx
.Pattern = "^[a-zA-Z][-a-zA-Z0-9_.]*$"
.IgnoreCase = False
.Global = False
End With
' リポジトリ名が空、長すぎる、または正規表現に一致しない場合は無効
If Len(repoName) = 0 Or Len(repoName) > 256 Or Not regEx.Test(repoName) Then
IsValidRepoName = False
Else
' 連続するハイフン、アンダースコアをチェック
If InStr(repoName, "--") > 0 Or InStr(repoName, "__") > 0 Then
IsValidRepoName = False
Else
IsValidRepoName = True
End If
End If
Set regEx = Nothing
End Function
また、ブック名の後ろにアンダースコアと8桁の日付を付けるという自分勝手な運用をしていて、レジストリにはこの部分を消去した状態で登録、日付部分を書き換えても対応できるようにしています。以下は日付部分を消去する関数です。
' 最初のアンダースコアから最後のドットまでの間の文字列を消去する
Private Function GetShortBookName(bookName As String) As String
' アンスコの位置
Dim unsPos As Integer: unsPos = InStr(bookName, "_")
' ドットの位置
Dim dotPos As Integer: dotPos = InStrRev(bookName, ".")
If unsPos = 0 Or dotPos = 0 Then
' アンスコまたはドットが見つからない場合、元のファイル名を返す
GetShortBookName = bookName
Else
' アンスコの前の部分と、最後のドットの後の部分を結合
GetShortBookName = Left(bookName, unsPos - 1) & Mid(bookName, dotPos)
End If
End Function
2. ローカルリポジトリフォルダの作成
ローカルリポジトリの場所は、自分のお気に入りの開発環境であるVisual Studio 2022のプロジェクトがデフォルトで格納される、
C:\Users\{ユーザー名}\Source\Repos
にしています。その直下にVBAフォルダを作り、更にその下にリポジトリ名でフォルダを作ります。
ModuleGit.bas
' ルートの親フォルダ
Public Const parentDir As String = "Source\Repos\VBA"
' ルートディレクトリを返す
Private Function GetRootDir() As String
Dim bookName As String: bookName = GetShortBookName(ActiveWorkbook.Name)
Dim repoName As String: repoName = GetSetting("Excel", bookName, "RepositoryName")
If repoName = "" Then
GetRootDir = ""
Exit Function
End If
GetRootDir = Environ$("USERPROFILE") & "\" & parentDir & "\" & repoName
End Function
' 引数のフォルダパスが存在しない場合に作る
Public Sub CreateDirIfThereNo(dirPath As String)
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim dirs As Variant: dirs = Split(dirPath, "\")
Dim i As Integer, dr As String
For i = 0 To UBound(dirs)
dr = dr & dirs(i) & "\"
' 共有ネットワークパスを考慮
If dr = "\\" Then
i = i + 1
dr = dr & dirs(i) & "\"
ElseIf Not fso.FolderExists(dr) Then
fso.CreateFolder dr
End If
Next
Set fso = Nothing
End Sub
3. Git設定ファイルの作成
ModuleGitFilesContentsモジュールの記載内容を元に必要なGit設定ファイルを作成します。
' Git設定ファイルの内容が埋め込まれているモジュール名
Private Const ContentsModuleName As String = "ModuleGitFilesContents"
' Git設定ファイルの作成
Public Sub GenerateGitFiles(rootDir As String, srcDir As String)
If Application.VBE.ActiveVBProject Is Nothing Then Exit Sub
Dim txt As String, fileName As String
With ThisWorkbook.VBProject.VBComponents(ContentsModuleName).CodeModule
Dim i As Long, iLine As String
For i = 1 To .CountOfLines
iLine = .Lines(i, 1)
' 対象はコメント行のみ
If UCase(Left(Trim(iLine), 3)) = "REM" Then
fileName = Trim(Mid(Trim(iLine), 4))
txt = ""
ElseIf Left(Trim(iLine), 1) = "'" Then
' 先頭シングルクォーテーションの除去
iLine = Mid(RTrim(iLine), 2)
txt = txt & iLine & vbCrLf
End If
' 空白行または最終行ならテキスト作成
If (Trim(iLine) = "" Or i = .CountOfLines) And Trim(txt) <> "" Then
If fileName = "settings.json" Then
Call GenerateUTF8(txt, rootDir & "\.vscode\" & fileName)
Else
Call GenerateUTF8(txt, srcDir & "\" & fileName)
End If
End If
Next
End With
End Sub
には.gitattributes、.gitignore、settings.jsonの内容がコメントとして埋め込まれています。REM行をファイル名、'行を本文、コメントなし行をファイルの区切り位置としてファイル化します。
Rem .gitattributes
'# Auto detect text files and perform LF normalization
'* text=auto
'
'*.bas text eol=crlf
'*.cls text eol=crlf
'*.frm text eol=crlf
'*.frx binary eol=crlf
'*.dcm text eol=crlf
'*.vbaproj text eol=crlf
'
'*.wsf text eol=crlf
'*.bat text eol=crlf
'
'*.cls linguist-language=VBA
'*.dcm linguist-language=VBA
'*.vbaproj linguist-language=INI
'
'# file encording
'*.bas working-tree-encoding=sjis
'*.cls working-tree-encoding=sjis
'*.dcm working-tree-encoding=sjis
'*.frm working-tree-encoding=sjis
'
'*.bas encoding=sjis
'*.cls encoding=sjis
'*.dcm encoding=sjis
'*.frm encoding=sjis
'
'*.bas diff=sjis
'*.cls diff=sjis
'*.dcm diff=sjis
'*.frm diff=sjis
Rem .gitignore
'*.tmp
'*.xl*
'~$*.xl*
'bin/old
'!bin/*.xl*
'!src/*
Rem settings.json
'{
' "[markdown]": {
' "editor.wordWrap": "on",
' "editor.quickSuggestions": {
' "comments": "off",
' "strings": "off",
' "other": "off"
' },
' "files.encoding": "utf8",
' },
' "files.encoding": "shiftjis",
' "files.associations": {
' "*.bas": "vb",
' "*.cls": "vb",
' "*.dcm": "vb",
' "*.frm": "vb"
' }
'}
4. binフォルダに対象ブックをコピー
binフォルダにブック名を変えることなくブックをコピーします。コピー前にブックの編集内容を反映させるためにブックを保存しますので注意が必要です。
5. srcフォルダにコードをエキスポート
srcフォルダにプロジェクト内のすべてのコードをエキスポートします。
' srcフォルダを指定してActiveWorkbookをExport
Public Sub Decombine(Optional includeBookName As Boolean = False)
Dim srcPath As String
Dim rootDir As String: rootDir = GetRootDir
If rootDir = "" Then Exit Sub
If includeBookName Then
srcPath = rootDir & "\src\" & GetShortBookName(ActiveWorkbook.Name)
Else
srcPath = rootDir & "\src"
End If
Call CreateDirIfThereNo(srcPath)
Call ExportCodeModules(ActiveWorkbook, srcPath)
End Sub
' プロジェクト内の全てのモジュールをsrcフォルダにExport
Private Sub ExportCodeModules(ByVal xBook As Workbook, ByVal srcDir As String)
On Error GoTo Catch
Dim vbPjt As VBIDE.VBProject: Set vbPjt = xBook.VBProject
Dim vbCmp As VBIDE.VBComponent
For Each vbCmp In vbPjt.VBComponents
Select Case vbCmp.Type
Case vbext_ct_StdModule
vbCmp.Export srcDir & "\" & vbCmp.Name & ".bas"
Case vbext_ct_MSForm
vbCmp.Export srcDir & "\" & vbCmp.Name & ".frm"
Case vbext_ct_ClassModule
vbCmp.Export srcDir & "\" & vbCmp.Name & ".cls"
Case vbext_ct_Document
vbCmp.Export srcDir & "\" & vbCmp.Name & ".dcm"
End Select
Next
GoTo Finally
Catch:
OutputError "ExportCodeModules"
Finally:
' 何もしない
End Sub
6. リモートリポジトリの作成
リモートリポジトリはGitHub APIで作成します。前述した個人用アクセストークンをHTTPオブジェクトのリクエストヘッダーに添えます。アクセス修飾子はprivateに固定しています。
リモートリポジトリが無事に作成されればリモートリポジトリのURLを取得することができます。
取得したURLはレジストリに登録します。
ModuleGit.bas
Public Function CreateRemoteRepos(bookName As String, repoName As String) As Boolean
On Error GoTo Catch
Dim rt As Boolean: rt = False
' トークンを取得
Dim token As String: token = GetTokenFromRegistry()
If Trim(token) = "" Then
MsgBox "個人用アクセストークンを登録してください。", vbInformation
CreateRemoteRepos = rt
Exit Function
End If
' HTTPオブジェクトを生成
Dim http As Object: Set http = CreateObject("MSXML2.XMLHTTP")
' GitHub APIのURL
Dim url As String: url = "https://api.github.com/user/repos"
http.Open "POST", url, False
http.setRequestHeader "Content-Type", "application/json"
http.setRequestHeader "Authorization", "token " & token
' JSONリクエストボディを作成（アクセス修飾子はprivate）
Dim jsonBody As String: jsonBody = "{""name"":""" & repoName & """, ""private"": true}"
' リクエストを送信
Call http.send(jsonBody)
' 結果を表示
If http.Status = 201 Then
Dim json As Object: Set json = JsonConverter.ParseJson(http.responseText)
Dim repoUrl As String: repoUrl = json("html_url")
Call SaveSetting("Excel", bookName, "RepositoryURL", repoUrl)
Call GitCmd(Init)
MsgBox "リモートリポジトリが作成されました。" & vbCr & vbCr & repoUrl, vbInformation
rt = True
Else
MsgBox "リモートリポジトリの作成に失敗しました。" & vbCr & vbCr & _
"Status: " & http.Status & vbCr & http.responseText, vbExclamation
rt = False
End If
GoTo Finally
Catch:
MsgBox Err.Description, vbExclamation
rt = False
Finally:
Set http = Nothing
Set json = Nothing
CreateRemoteRepos = rt
End Function
レスポンスからURLを取得するためのJSONパーサーは、有名な以下のライブラリを使用しています。
https://github.com/VBA-tools/VBA-JSON
ここにあるJsonConverter.basをアドインプロジェクトに追加しただけです。
7. リポジトリの初期化と最初のコミット＆プッシュ
前述のCreateRemoteRepos関数の中で後述するGitCmd関数を呼び出して行っています。最初のコミットのコメントは「リポジトリ開始」に固定されています。リモートリポジトリ作成後にそのリポジトリのページで案内される初期設定のためのGitコマンド群をそのまま実行しています。
ModuleGit.bas
Public Sub CreateNewRepository()
' リポジトリ名を設定する
Dim repoName As String: repoName = SetAndThenGetReposName
If repoName = "" Then Exit Sub
' ローカルリポジトリフォルダ作成
Dim repoDir As String: repoDir = GetRootDir
If repoDir = "" Then Exit Sub
Call CreateDirIfThereNo(repoDir)
' ローカルリポジトリフォルダ内のサブフォルダ作成
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(repoDir & "\.vscode") Then fso.CreateFolder repoDir & "\.vscode"
If Not fso.FolderExists(repoDir & "\bin") Then fso.CreateFolder repoDir & "\bin"
If Not fso.FolderExists(repoDir & "\bin\old") Then fso.CreateFolder repoDir & "\bin\old"
If Not fso.FolderExists(repoDir & "\src") Then fso.CreateFolder repoDir & "\src"
Dim bookName As String: bookName = GetShortBookName(ActiveWorkbook.Name)
Dim srcDir As String: srcDir = repoDir & "\src"
If Not fso.FolderExists(srcDir) Then fso.CreateFolder srcDir
' Git設定ファイル作成
Call GenerateGitFiles(repoDir, srcDir)
' ブックを保存してbinフォルダにコピー
ActiveWorkbook.Save
Call fso.CopyFile(ActiveWorkbook.FullName, repoDir & "\bin\" & ActiveWorkbook.Name, True)
Set fso = Nothing
' srcフォルダにCodeModuleをExport
Call Decombine
' リモートリポジトリの作成
If CreateRemoteRepos(bookName, repoName) Then
MsgBox bookName & " 用のリポジトリの準備ができました。", vbInformation
End If
End Sub
ステージ、コミット、プッシュ
ステージ、コミット、プッシュはいずれもWindows Script Hostを使ってGitコマンドを実行する流れになります。以下のGitCmd関数は各工程で必要な処理があればそれをして、RunCmd関数にテキストのGitコマンドを投げます。RunCmdではコマンド実行と共に何か出力が返って来たらそれをテキストファイルにリダイレクトし、その内容を戻り値として返すというワンパターンの処理を行っています。
ModuleGit.bas
' GitCmd引数用
Public Enum GitCommand
Init
Status
Stage
Commit
Push
End Enum
' Gitコマンドを実行
Public Function GitCmd(cmd As GitCommand, Optional arg As String = Empty, Optional isPowerShell As Boolean = False) As Integer
On Error GoTo Catch
Dim rootDir As String: rootDir = GetRootDir
If rootDir = "" Then
MsgBox """" & ActiveWorkbook.Name & """" & vbLf & vbLf & "リポジトリ名が登録されていません。", vbInformation
Exit Function
End If
Call ChDir(rootDir)
Dim rt As String
Select Case cmd
Case Init
Dim bookName As String: bookName = GetShortBookName(ActiveWorkbook.Name)
Dim repoUrl As String: repoUrl = GetSetting("Excel", bookName, "RepositoryURL")
If repoUrl = "" Then
MsgBox "リモートリポジトリを作成してください。", vbInformation
GoTo Finally
End If
rt = RunCmd("git init")
rt = rt & vbCr & RunCmd("git add .")
rt = rt & vbCr & RunCmd("git commit -m ""リポジトリ開始""")
rt = rt & vbCr & RunCmd("git branch -M main")
rt = rt & vbCr & RunCmd("git remote add origin " & repoUrl)
rt = rt & vbCr & RunCmd("git push -u origin main")
Case Status
rt = RunCmd("git status")
Case Stage
If MsgBox(ActiveWorkbook.Name & " の変更をステージします。" & vbLf & vbLf & _
ActiveWorkbook.Name & " の保存とエクスポートを伴います。", vbInformation + vbOKCancel) = vbOK Then
Application.DisplayAlerts = False
If ActiveWorkbook.path = rootDir & "\bin" Then
MsgBox "binフォルダ内の" & ActiveWorkbook.Name & "を開いたままステージ出来ません。" & vbLf & _
"ステージはキャンセルされました。, vbInformation"
GoTo Finally
Else
ActiveWorkbook.Save
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Call fso.CopyFile(ActiveWorkbook.FullName, rootDir & "\bin\" & ActiveWorkbook.Name, True)
Call Decombine
rt = RunCmd("git add .")
End If
Else
GoTo Finally
End If
Case Commit
If arg = Empty Then
arg = InputBox("コミットのメッセージを入力してください。")
If arg = "" Then GoTo Finally
If MsgBox("""" & arg & """" & vbLf & vbLf & "このメッセージでコミットします。", vbInformation + vbOKCancel) = vbCancel Then
GoTo Finally
End If
End If
rt = RunCmd("git commit -m """ & arg & """")
Case Push
Dim mBranch As String
If arg = Empty Then mBranch = "main"
rt = RunCmd("git push origin " & mBranch)
End Select
Debug.Print rt
GoTo Finally
Catch:
OutputError "GitCmd"
Finally:
Application.DisplayAlerts = True
End Function
' コマンドプロンプトでcmd引数の内容を実行、リダイレクトして文字化けに対応
Private Function RunCmd(cmd As String, Optional showInt As Integer = 0, Optional toWait As Boolean = True) As String
On Error GoTo Catch
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim msgPath As String: msgPath = Environ$("temp") & "\gitTmp.log"
Dim errPath As String: errPath = Environ$("temp") & "\gitErr.log"
Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
Dim rt As Long: rt = wsh.Run("cmd /c " & cmd & " > " & msgPath & " 2> " & errPath, showInt, toWait)
Dim msg As String
If rt = 0 Then
msg = CurDir & " (正常終了 - " & cmd & ")"
Else
msg = CurDir & " (異常終了 - " & cmd & ")"
End If
Dim msgStream As Object: Set msgStream = CreateObject("ADODB.Stream")
msgStream.Type = 2
msgStream.Charset = "utf-8"
msgStream.Open
msgStream.LoadFromFile msgPath
Dim msgText As String
msgText = msgStream.ReadText
msgStream.Close: Set msgStream = Nothing
Dim errStream As Object: Set errStream = CreateObject("ADODB.Stream")
errStream.Type = 2
errStream.Charset = "utf-8"
errStream.Open
errStream.LoadFromFile errPath
Dim errText As String
errText = errStream.ReadText
errStream.Close: Set errStream = Nothing
Select Case True
Case Trim(msgText) = "" And Trim(errText) = ""
' 何もしない
Case Trim(msgText) <> "" And Trim(errText) = ""
msg = msg & vbCr & msgText
Case Trim(msgText) = "" And Trim(errText) <> ""
msg = msg & vbCr & errText
Case Trim(msgText) <> "" And Trim(errText) <> ""
msg = msg & vbCr & msgText & vbCr & errText
End Select
GoTo Finally
Catch:
OutputError "RunCmd"
Finally:
If fso.FileExists(msgPath) Then fso.DeleteFile msgPath
If fso.FileExists(errPath) Then fso.DeleteFile errPath
Set fso = Nothing
Set wsh = Nothing
RunCmd = Trim(msg)
End Function
VBEにメニュー登録
最後に、今まで見てきたプロシージャがワンクリックで使えるようにVBEのメニューに登録します。
ThisWorkbook.dcm
Private newEventsItems() As EventsItem
Private Type ItemProperties
FullName As String
Caption As String
OnAction As String
FaceId As Long
BeginGroup As Boolean
End Type
Private Sub Workbook_Open()
' VBEのメニューバーを取得（メニューバーのIndexは、固定値で「1」）
Dim VBEMenuBar As CommandBar
Set VBEMenuBar = Application.VBE.CommandBars(1)
' 新しいメニューを作成
Dim newMenu As CommandBarControl
Set newMenu = VBEMenuBar.Controls.Add(Type:=msoControlPopup)
' メニューのキャプションを設定
newMenu.Caption = "Git管理(&G)"
' メニューアイテムの設定値を構造体の配列に格納
Dim prop() As ItemProperties: prop = MenuItemSetting
' イベントアイテムクラスを構造体を使って作成
ReDim newEventsItems(LBound(prop) To UBound(prop))
Dim i As Long, newMenuItem As CommandBarControl
For i = LBound(prop) To UBound(prop)
' メニューにアイテムを追加
Set newMenuItem = newMenu.Controls.Add(Type:=msoControlButton)
With prop(i)
newMenuItem.Caption = .Caption
newMenuItem.OnAction = "'" & .FullName & "'!" & .OnAction
newMenuItem.FaceId = .FaceId
newMenuItem.BeginGroup = .BeginGroup
End With
' イベントアイテムクラスの登録
Set newEventsItems(i) = New EventsItem: Call newEventsItems(i).Initialize(newMenuItem)
Next i
End Sub
メニューの内容はItemProperties構造体に設定値を代入していき、配列にします。配列をループで回してEventsItemクラスを登録していきます。これらは上から順番にメニューに登録されます。メニューアイテムを増減させる場合、MaxIndex定数をメニューアイテム数に合わせる必要があります。
ThisWorkbook.dcm
Private Const MaxIndex As Long = 6
Private Function MenuItemSetting() As ItemProperties()
' 【要注意】MaxIndexをメニュー数にする
Dim prop(1 To MaxIndex) As ItemProperties
Dim i As Long
' ---- メニュー開始 ------------------------------------------------------------
' OnActionの設定値にはモジュール名も必要
i = i + 1
prop(i).Caption = "リポジトリの作成"
prop(i).OnAction = "ModuleGit.CreateNewRepository"
prop(i).FaceId = 610
prop(i).BeginGroup = False
i = i + 1
prop(i).Caption = "変更をステージ(&S)"
prop(i).OnAction = "ModuleGit.GitStage"
prop(i).FaceId = 535
prop(i).BeginGroup = True
i = i + 1
prop(i).Caption = "変更をコミット(&C)"
prop(i).OnAction = "ModuleGit.GitCommit"
prop(i).FaceId = 534
prop(i).BeginGroup = False
i = i + 1
prop(i).Caption = "変更をプッシュ(&P)"
prop(i).OnAction = "ModuleGit.GitPush"
prop(i).FaceId = 533
prop(i).BeginGroup = False
i = i + 1
prop(i).Caption = "トークンを登録"
prop(i).OnAction = "ModuleGit.RegisterToken"
prop(i).FaceId = 277
prop(i).BeginGroup = True
i = i + 1
prop(i).Caption = "トークンを削除"
prop(i).OnAction = "ModuleGit.DeleteToken"
prop(i).FaceId = 1786
prop(i).BeginGroup = False
' ---- メニュー終了 ------------------------------------------------------------
Dim FullName As String: FullName = ThisWorkbook.FullName
For i = LBound(prop) To UBound(prop)
prop(i).FullName = FullName
Next
MenuItemSetting = prop
End Function
EventsItem.cls
Private WithEvents MenuItem As VBIDE.CommandBarEvents
Private Sub Class_Terminate()
Set MenuItem = Nothing
End Sub
Public Sub Initialize(ByVal ctl As Office.CommandBarControl)
Set MenuItem = Application.VBE.Events.CommandBarEvents(ctl)
End Sub
Private Sub MenuItem_Click(ByVal sender As Object, handled As Boolean, CancelDefault As Boolean)
Application.Run sender.OnAction
End Sub
ModuleGit.bas
Public Sub GitStage()
Call GitCmd(Stage)
End Sub
Public Sub GitCommit()
Call GitCmd(Commit)
End Sub
Public Sub GitPush()
Call GitCmd(Push)
End Sub
注意点
コード内にCP932に在ってShift-JISに無い文字があるとエラーとなります。
①、②、③、№、㎡などです。これらを他の文字に置き換えれば解決します。
複数のGitHubアカウントには対応していません。
おわりに
このアドインのリポジトリへのリンクは、不具合発見のため消去しました
これのリポジトリは下記になります
binフォルダにあるGitAdmin.xlamが実体です。これをダウンロードしてお使いのパソコンのアドインフォルダに保存し、Excelのオプション設定で有効なアドインとしてチェックすれば使えるようになります。ご利用は自己責任でよろしくお願いいたします