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関連

    指定したAccessファイルで「データベースの最適化/修復」を実行するVBAマクロ

    大分前の記事になりますが、開いているデータベースを最適化するマクロのコ…

  2. Office関連

    UIAutomationClient参照時にDLL読み込みエラーが発生した時の対処法

    マクロでダイアログやボタンの操作を行う時に便利なUI Automati…

  3. アイコン一覧

    Office 365アイコン(imageMso)一覧(X,Y,Z)

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

  4. Office関連

    段落内改行を一括置換するOutlookマクロ

    「段落内改行 置換 Outlook マクロ」といったキーワードでのアク…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP