Office関連

手軽に参照設定するためのVBAアドイン

thom氏のブログで面白い記事がありました。

・VBA 参照設定でライブラリを探すのが面倒なので、ライブラリを検索できる参照設定ダイアログを自作してみた – t-hom’s diary
http://thom.hateblo.jp/entry/2016/02/10/235414

VBEの参照設定ダイアログが使いづらいので自分で作ってしまおう、というお話しです。
そう、thom氏の言う通り、参照設定ダイアログは“使いづらい”です。イケてないです。
私も常々そう思っていました。
(ならもっと前から何か工夫しておこうよ・・・って話なのですが、それをやらないのが私です。)

thom氏の記事にはコードも載っていて、それを見るとUserFormに配置したListBox等のコントロールを使って、ライブラリの検索や参照を行うようです。

素晴らしい。
これは便利そう!

・・・ならばパクるしかない!!

UserFormを用意することすら面倒くさい

というわけで、私も似たような「自作参照ダイアログ」をやってみることにしたのですが、そこは不精な私、UserFormを用意してコントロールを配置することすら面倒くさい、そう感じてしまいます。

なので、下記のようにCommandBarComboBoxを使って必要最低限のUIのみで処理を実現することにしました。

・処理概要

  1. レジストリからTypeLib情報を取得し、XMLファイルに格納する。
  2. CommandBarを作成し、ComboBoxを追加する。
  3. XMLから読み込んだTypeLib情報をComboBoxに放り込む。
  4. ComboBoxで選択したライブラリを参照設定する。

アドインのコード

実際に書いたコードが下記になります。
ソートのためにRecordsetオブジェクトを使ったりしていますが、そう複雑なことはやっていません。

'ThisWorkbook
Option Explicit

Private Const XmlFileName As String = "TypeLibInfo.xml"
Private Const CbarName As String = "TypeLib"
Private Const CboCaption As String = "TypeLibBox"
Private WithEvents Btn As Office.CommandBarButton

Private Sub Workbook_Open()
  Init
End Sub

Private Sub Workbook_AddinInstall()
  Init
End Sub

Private Sub Workbook_AddinUninstall()
  On Error Resume Next
  Application.VBE.CommandBars(CbarName).Delete
  On Error GoTo 0
End Sub

Private Sub Init()
  Dim Cbar As Office.CommandBar
  Dim Cbo As Office.CommandBarComboBox
  Dim d As Object
  Dim nodes As Object
  Dim XmlFilePath As String
  Dim i As Long
  
  On Error Resume Next
  Set Cbar = Application.VBE.CommandBars(CbarName)
  If Err.Number <> 0 Then
    Select Case Err.Number
      Case 1004
        MsgBox "[セキュリティ センターの設定]から" & vbNewLine & vbNewLine & _
               "【VBA プロジェクト オブジェクト モデルへのアクセスを信頼する】" & vbNewLine & vbNewLine & _
               "にチェックを入れた後、アドインを再度読み込んでください。", vbExclamation + vbSystemModal
        Exit Sub
    End Select
    Err.Clear
  End If
  On Error GoTo 0
  If Cbar Is Nothing Then
    'コマンドバー設定
    Set Cbar = Application.VBE.CommandBars.Add(Name:=CbarName, Position:=msoBarFloating)
    Set Cbo = Cbar.Controls.Add(Type:=msoControlComboBox)
    Cbo.Caption = CboCaption
    Cbo.Width = 150
    Set Btn = Cbar.Controls.Add(Type:=msoControlButton)
    Btn.Caption = "参照"
    Btn.Style = msoButtonCaption
    
    'XMLファイル読込
    XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName
    With CreateObject("Scripting.FileSystemObject")
      If .FileExists(XmlFilePath) = False Then
        CreateTypeLibXml XmlFilePath
      End If
    End With
    Set d = CreateObject("Msxml2.DOMDocument")
    If d.Load(XmlFilePath) = True Then
      Set nodes = d.SelectNodes("/items/item")
      For i = 0 To nodes.Length - 1
        Cbo.AddItem nodes.item(i).Attributes(1).Text, i + 1
      Next
    End If
  End If
  Cbar.Visible = True
End Sub

Private Sub Btn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  Dim d As Object
  Dim XmlFilePath As String
  
  With Application.VBE.CommandBars(CbarName).Controls(CboCaption)
    If .ListIndex > 0 Then
      Set d = CreateObject("Msxml2.DOMDocument")
      XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName
      If d.Load(XmlFilePath) = True Then
        'MsgBox d.SelectNodes("/items/item").item(.ListIndex - 1).Attributes(2).Text '確認用
        On Error Resume Next
        Application.VBE.ActiveVBProject.References.AddFromFile _
          d.SelectNodes("/items/item").item(.ListIndex - 1).Attributes(2).Text
        If Err.Number <> 0 Then
          MsgBox "参照設定に失敗しました。", _
                 vbCritical + vbSystemModal, _
                 "Error No:" & Err.Number
          Err.Clear
        End If
        On Error GoTo 0
      End If
    End If
  End With
End Sub

Private Sub CreateTypeLibXml(ByVal XmlFilePath As String)
'TypeLib情報をXMLに格納
  Dim reg As Object
  Dim rs As Object
  Dim d As Object
  Dim item As Object
  Dim items As Object
  Dim names As Variant
  Dim child_names As Variant
  Dim lib As Variant
  Dim tlb As Variant
  Dim ret1 As Long, ret2 As Long
  Dim i As Long, j As Long
  Const adVarChar = 200
  Const HKEY_CLASSES_ROOT = &H80000000
  Const SubKeyName As String = "TypeLib"
  
  'レジストリから取得したTypeLib情報をRecordsetに格納
  Set reg = CreateObject("WbemScripting.SWbemLocator") _
              .ConnectServer(, "root\default") _
              .Get("StdRegProv")
  reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName, names
  If Not IsNull(names) Then
    Set rs = CreateObject("ADODB.Recordset")
    rs.Fields.Append "GUID", adVarChar, 255
    rs.Fields.Append "Name", adVarChar, 255
    rs.Fields.Append "Library", adVarChar, 255
    rs.Open
    For i = LBound(names) To UBound(names)
      reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName & ChrW(92) & names(i), child_names
      If Not IsNull(child_names) Then
        For j = LBound(child_names) To UBound(child_names)
          ret1 = reg.GetStringValue(HKEY_CLASSES_ROOT, _
                                    SubKeyName & ChrW(92) & _
                                      names(i) & ChrW(92) & _
                                      child_names(j), _
                                    "", _
                                    lib)
          ret2 = reg.GetStringValue(HKEY_CLASSES_ROOT, _
                                    SubKeyName & ChrW(92) & _
                                      names(i) & ChrW(92) & _
                                      child_names(j) & ChrW(92) & _
                                      "0" & ChrW(92) & _
                                      "win32", _
                                    "", _
                                    tlb)
          If (ret1 = 0) And (ret2 = 0) Then
            rs.AddNew
            rs.Fields("GUID").Value = names(i)
            rs.Fields("Name").Value = lib
            rs.Fields("Library").Value = tlb
            rs.Update
          End If
        Next
      End If
    Next
    rs.Sort = "Name ASC" '名前順でソート
    
    'TypeLib情報をXMLファイルとして保存
    rs.MoveFirst
    Set d = CreateObject("Msxml2.DOMDocument")
    Set items = d.createElement("items")
    Do Until rs.EOF
      Set item = d.createElement("item")
      item.setAttribute "guid", rs.Fields("GUID").Value
      item.setAttribute "name", rs.Fields("Name").Value
      item.setAttribute "library", rs.Fields("Library").Value
      items.appendChild item
      Set item = Nothing
      rs.MoveNext
    Loop
    rs.Close
    d.appendChild items
    On Error Resume Next
    d.Save XmlFilePath
    If Err.Number <> 0 Then
      MsgBox "XMLファイルの保存に失敗しました。" & vbNewLine & _
             XmlFilePath, vbCritical + vbSystemModal
      Err.Clear
    End If
    On Error GoTo 0
  End If
End Sub

Private Function AddPathSeparator(ByVal str As String) As String
  If Right(str, 1) <> ChrW(92) Then str = str & ChrW(92)
  AddPathSeparator = str
End Function

動作画面

実際にアドインを読み込んで、動作させたときの様子が下図になります。

AddTypeLib_01

ComboBoxとCommandButtonしかシンプルなインターフェースで、自分で使った感じでは、なかなか使いやすいです。

ダウンロード

コードは上に書いていますが、一応アドインファイルもアップしておきますので、興味がある方は試してみてください。
(「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックが入っていないと使用できませんので、その点はご注意ください。)

► ダウンロード

Outlook.comが正式版になりました。前のページ

オトカドール 3rdドリームをプレイしてきたよ(6)次のページ

関連記事

  1. Office関連

    Office製品の開発チームにユーザーの声を届けよう!

    Office 用アプリやSharePoint 用アプリを開発する際「こ…

  2. Windows 10

    続・Microsoft Edgeを操作するVBAマクロ(DOM編)

    以前VBAからMicrosoft Edgeを操作するマクロについて記事…

  3. アイコン一覧

    Office 365アイコン(imageMso)一覧(U)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

  4. Office関連

    プログラムのソースコードを別の言語に変換するVBAマクロ

    SharpDevelopが公開している、ソースコードを変換するAPI「…

  5. Office アドイン

    [Officeアドイン]地図記号挿入アドイン

    ちょっとずつ作成していたWord用のOffice アドインがようやくO…

  6. Office関連

    VBE用のCOMアドインをメモ帳で作ってみる。

    “Officeアプリケーション用のCOMアドインをVisual Stu…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP