{"id":6721,"date":"2016-02-19T17:34:15","date_gmt":"2016-02-19T08:34:15","guid":{"rendered":"http:\/\/www.ka-net.org\/blog\/?p=6721"},"modified":"2016-02-19T17:34:15","modified_gmt":"2016-02-19T08:34:15","slug":"%e6%89%8b%e8%bb%bd%e3%81%ab%e5%8f%82%e7%85%a7%e8%a8%ad%e5%ae%9a%e3%81%99%e3%82%8b%e3%81%9f%e3%82%81%e3%81%aevba%e3%82%a2%e3%83%89%e3%82%a4%e3%83%b3","status":"publish","type":"post","link":"https:\/\/www.ka-net.org\/blog\/?p=6721","title":{"rendered":"\u624b\u8efd\u306b\u53c2\u7167\u8a2d\u5b9a\u3059\u308b\u305f\u3081\u306eVBA\u30a2\u30c9\u30a4\u30f3"},"content":{"rendered":"

thom<\/a>\u6c0f\u306e\u30d6\u30ed\u30b0\u3067\u9762\u767d\u3044\u8a18\u4e8b\u304c\u3042\u308a\u307e\u3057\u305f\u3002<\/p>\n

\u30fbVBA \u53c2\u7167\u8a2d\u5b9a\u3067\u30e9\u30a4\u30d6\u30e9\u30ea\u3092\u63a2\u3059\u306e\u304c\u9762\u5012\u306a\u306e\u3067\u3001\u30e9\u30a4\u30d6\u30e9\u30ea\u3092\u691c\u7d22\u3067\u304d\u308b\u53c2\u7167\u8a2d\u5b9a\u30c0\u30a4\u30a2\u30ed\u30b0\u3092\u81ea\u4f5c\u3057\u3066\u307f\u305f – t-hom\u2019s diary<\/strong>
\nhttp:\/\/thom.hateblo.jp\/entry\/2016\/02\/10\/235414<\/a><\/p>\n

VBE\u306e\u53c2\u7167\u8a2d\u5b9a\u30c0\u30a4\u30a2\u30ed\u30b0\u304c\u4f7f\u3044\u3065\u3089\u3044\u306e\u3067\u81ea\u5206\u3067\u4f5c\u3063\u3066\u3057\u307e\u304a\u3046\u3001\u3068\u3044\u3046\u304a\u8a71\u3057\u3067\u3059\u3002
\n\u305d\u3046\u3001thom\u6c0f\u306e\u8a00\u3046\u901a\u308a\u3001\u53c2\u7167\u8a2d\u5b9a\u30c0\u30a4\u30a2\u30ed\u30b0\u306f\u201c\u4f7f\u3044\u3065\u3089\u3044\u201d<\/span>\u3067\u3059\u3002\u30a4\u30b1\u3066\u306a\u3044\u3067\u3059\u3002
\n\u79c1\u3082\u5e38\u3005\u305d\u3046\u601d\u3063\u3066\u3044\u307e\u3057\u305f\u3002
\n(\u306a\u3089\u3082\u3063\u3068\u524d\u304b\u3089\u4f55\u304b\u5de5\u592b\u3057\u3066\u304a\u3053\u3046\u3088\u30fb\u30fb\u30fb\u3063\u3066\u8a71\u306a\u306e\u3067\u3059\u304c\u3001\u305d\u308c\u3092\u3084\u3089\u306a\u3044\u306e\u304c\u79c1\u3067\u3059\u3002)<\/p>\n

thom\u6c0f\u306e\u8a18\u4e8b\u306b\u306f\u30b3\u30fc\u30c9\u3082\u8f09\u3063\u3066\u3044\u3066\u3001\u305d\u308c\u3092\u898b\u308b\u3068UserForm\u306b\u914d\u7f6e\u3057\u305fListBox\u7b49\u306e\u30b3\u30f3\u30c8\u30ed\u30fc\u30eb\u3092\u4f7f\u3063\u3066\u3001\u30e9\u30a4\u30d6\u30e9\u30ea\u306e\u691c\u7d22\u3084\u53c2\u7167\u3092\u884c\u3046\u3088\u3046\u3067\u3059\u3002<\/p>\n

\u7d20\u6674\u3089\u3057\u3044\u3002
\n\u3053\u308c\u306f\u4fbf\u5229\u305d\u3046\uff01<\/p>\n

\u30fb\u30fb\u30fb\u306a\u3089\u3070\u30d1\u30af\u308b\u3057\u304b\u306a\u3044\uff01\uff01<\/p>\n

UserForm\u3092\u7528\u610f\u3059\u308b\u3053\u3068\u3059\u3089\u9762\u5012\u304f\u3055\u3044<\/h4>\n

\u3068\u3044\u3046\u308f\u3051\u3067\u3001\u79c1\u3082\u4f3c\u305f\u3088\u3046\u306a\u300c\u81ea\u4f5c\u53c2\u7167\u30c0\u30a4\u30a2\u30ed\u30b0\u300d\u3092\u3084\u3063\u3066\u307f\u308b\u3053\u3068\u306b\u3057\u305f\u306e\u3067\u3059\u304c\u3001\u305d\u3053\u306f\u4e0d\u7cbe\u306a\u79c1\u3001UserForm\u3092\u7528\u610f\u3057\u3066\u30b3\u30f3\u30c8\u30ed\u30fc\u30eb\u3092\u914d\u7f6e\u3059\u308b\u3053\u3068\u3059\u3089\u9762\u5012\u304f\u3055\u3044<\/span>\u3001\u305d\u3046\u611f\u3058\u3066\u3057\u307e\u3044\u307e\u3059\u3002<\/p>\n

\u306a\u306e\u3067\u3001\u4e0b\u8a18\u306e\u3088\u3046\u306bCommandBarComboBox\u3092\u4f7f\u3063\u3066\u5fc5\u8981\u6700\u4f4e\u9650\u306eUI\u306e\u307f\u3067\u51e6\u7406\u3092\u5b9f\u73fe\u3059\u308b\u3053\u3068\u306b\u3057\u307e\u3057\u305f\u3002<\/p>\n

\u30fb\u51e6\u7406\u6982\u8981<\/strong><\/p>\n

    \n
  1. \u30ec\u30b8\u30b9\u30c8\u30ea\u304b\u3089TypeLib\u60c5\u5831\u3092\u53d6\u5f97\u3057\u3001XML\u30d5\u30a1\u30a4\u30eb\u306b\u683c\u7d0d\u3059\u308b\u3002<\/li>\n
  2. CommandBar\u3092\u4f5c\u6210\u3057\u3001ComboBox\u3092\u8ffd\u52a0\u3059\u308b\u3002<\/li>\n
  3. XML\u304b\u3089\u8aad\u307f\u8fbc\u3093\u3060TypeLib\u60c5\u5831\u3092ComboBox\u306b\u653e\u308a\u8fbc\u3080\u3002<\/li>\n
  4. ComboBox\u3067\u9078\u629e\u3057\u305f\u30e9\u30a4\u30d6\u30e9\u30ea\u3092\u53c2\u7167\u8a2d\u5b9a\u3059\u308b\u3002<\/li>\n<\/ol>\n

    \u30a2\u30c9\u30a4\u30f3\u306e\u30b3\u30fc\u30c9<\/h4>\n

    \u5b9f\u969b\u306b\u66f8\u3044\u305f\u30b3\u30fc\u30c9\u304c\u4e0b\u8a18\u306b\u306a\u308a\u307e\u3059\u3002
    \n\u30bd\u30fc\u30c8\u306e\u305f\u3081\u306bRecordset\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u3092\u4f7f\u3063\u305f\u308a\u3057\u3066\u3044\u307e\u3059\u304c\u3001\u305d\u3046\u8907\u96d1\u306a\u3053\u3068\u306f\u3084\u3063\u3066\u3044\u307e\u305b\u3093\u3002<\/p>\n

    'ThisWorkbook\r\nOption Explicit\r\n\r\nPrivate Const XmlFileName As String = "TypeLibInfo.xml"\r\nPrivate Const CbarName As String = "TypeLib"\r\nPrivate Const CboCaption As String = "TypeLibBox"\r\nPrivate WithEvents Btn As Office.CommandBarButton\r\n\r\nPrivate Sub Workbook_Open()\r\n  Init\r\nEnd Sub\r\n\r\nPrivate Sub Workbook_AddinInstall()\r\n  Init\r\nEnd Sub\r\n\r\nPrivate Sub Workbook_AddinUninstall()\r\n  On Error Resume Next\r\n  Application.VBE.CommandBars(CbarName).Delete\r\n  On Error GoTo 0\r\nEnd Sub\r\n\r\nPrivate Sub Init()\r\n  Dim Cbar As Office.CommandBar\r\n  Dim Cbo As Office.CommandBarComboBox\r\n  Dim d As Object\r\n  Dim nodes As Object\r\n  Dim XmlFilePath As String\r\n  Dim i As Long\r\n  \r\n  On Error Resume Next\r\n  Set Cbar = Application.VBE.CommandBars(CbarName)\r\n  If Err.Number <> 0 Then\r\n    Select Case Err.Number\r\n      Case 1004\r\n        MsgBox "[\u30bb\u30ad\u30e5\u30ea\u30c6\u30a3 \u30bb\u30f3\u30bf\u30fc\u306e\u8a2d\u5b9a]\u304b\u3089" & vbNewLine & vbNewLine & _\r\n               "\u3010VBA \u30d7\u30ed\u30b8\u30a7\u30af\u30c8 \u30aa\u30d6\u30b8\u30a7\u30af\u30c8 \u30e2\u30c7\u30eb\u3078\u306e\u30a2\u30af\u30bb\u30b9\u3092\u4fe1\u983c\u3059\u308b\u3011" & vbNewLine & vbNewLine & _\r\n               "\u306b\u30c1\u30a7\u30c3\u30af\u3092\u5165\u308c\u305f\u5f8c\u3001\u30a2\u30c9\u30a4\u30f3\u3092\u518d\u5ea6\u8aad\u307f\u8fbc\u3093\u3067\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n        Exit Sub\r\n    End Select\r\n    Err.Clear\r\n  End If\r\n  On Error GoTo 0\r\n  If Cbar Is Nothing Then\r\n    '\u30b3\u30de\u30f3\u30c9\u30d0\u30fc\u8a2d\u5b9a\r\n    Set Cbar = Application.VBE.CommandBars.Add(Name:=CbarName, Position:=msoBarFloating)\r\n    Set Cbo = Cbar.Controls.Add(Type:=msoControlComboBox)\r\n    Cbo.Caption = CboCaption\r\n    Cbo.Width = 150\r\n    Set Btn = Cbar.Controls.Add(Type:=msoControlButton)\r\n    Btn.Caption = "\u53c2\u7167"\r\n    Btn.Style = msoButtonCaption\r\n    \r\n    'XML\u30d5\u30a1\u30a4\u30eb\u8aad\u8fbc\r\n    XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName\r\n    With CreateObject("Scripting.FileSystemObject")\r\n      If .FileExists(XmlFilePath) = False Then\r\n        CreateTypeLibXml XmlFilePath\r\n      End If\r\n    End With\r\n    Set d = CreateObject("Msxml2.DOMDocument")\r\n    If d.Load(XmlFilePath) = True Then\r\n      Set nodes = d.SelectNodes("\/items\/item")\r\n      For i = 0 To nodes.Length - 1\r\n        Cbo.AddItem nodes.item(i).Attributes(1).Text, i + 1\r\n      Next\r\n    End If\r\n  End If\r\n  Cbar.Visible = True\r\nEnd Sub\r\n\r\nPrivate Sub Btn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)\r\n  Dim d As Object\r\n  Dim XmlFilePath As String\r\n  \r\n  With Application.VBE.CommandBars(CbarName).Controls(CboCaption)\r\n    If .ListIndex > 0 Then\r\n      Set d = CreateObject("Msxml2.DOMDocument")\r\n      XmlFilePath = AddPathSeparator(ThisWorkbook.Path) & XmlFileName\r\n      If d.Load(XmlFilePath) = True Then\r\n        'MsgBox d.SelectNodes("\/items\/item").item(.ListIndex - 1).Attributes(2).Text '\u78ba\u8a8d\u7528\r\n        On Error Resume Next\r\n        Application.VBE.ActiveVBProject.References.AddFromFile _\r\n          d.SelectNodes("\/items\/item").item(.ListIndex - 1).Attributes(2).Text\r\n        If Err.Number <> 0 Then\r\n          MsgBox "\u53c2\u7167\u8a2d\u5b9a\u306b\u5931\u6557\u3057\u307e\u3057\u305f\u3002", _\r\n                 vbCritical + vbSystemModal, _\r\n                 "Error No:" & Err.Number\r\n          Err.Clear\r\n        End If\r\n        On Error GoTo 0\r\n      End If\r\n    End If\r\n  End With\r\nEnd Sub\r\n\r\nPrivate Sub CreateTypeLibXml(ByVal XmlFilePath As String)\r\n'TypeLib\u60c5\u5831\u3092XML\u306b\u683c\u7d0d\r\n  Dim reg As Object\r\n  Dim rs As Object\r\n  Dim d As Object\r\n  Dim item As Object\r\n  Dim items As Object\r\n  Dim names As Variant\r\n  Dim child_names As Variant\r\n  Dim lib As Variant\r\n  Dim tlb As Variant\r\n  Dim ret1 As Long, ret2 As Long\r\n  Dim i As Long, j As Long\r\n  Const adVarChar = 200\r\n  Const HKEY_CLASSES_ROOT = &H80000000\r\n  Const SubKeyName As String = "TypeLib"\r\n  \r\n  '\u30ec\u30b8\u30b9\u30c8\u30ea\u304b\u3089\u53d6\u5f97\u3057\u305fTypeLib\u60c5\u5831\u3092Recordset\u306b\u683c\u7d0d\r\n  Set reg = CreateObject("WbemScripting.SWbemLocator") _\r\n              .ConnectServer(, "root\\default") _\r\n              .Get("StdRegProv")\r\n  reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName, names\r\n  If Not IsNull(names) Then\r\n    Set rs = CreateObject("ADODB.Recordset")\r\n    rs.Fields.Append "GUID", adVarChar, 255\r\n    rs.Fields.Append "Name", adVarChar, 255\r\n    rs.Fields.Append "Library", adVarChar, 255\r\n    rs.Open\r\n    For i = LBound(names) To UBound(names)\r\n      reg.EnumKey HKEY_CLASSES_ROOT, SubKeyName & ChrW(92) & names(i), child_names\r\n      If Not IsNull(child_names) Then\r\n        For j = LBound(child_names) To UBound(child_names)\r\n          ret1 = reg.GetStringValue(HKEY_CLASSES_ROOT, _\r\n                                    SubKeyName & ChrW(92) & _\r\n                                      names(i) & ChrW(92) & _\r\n                                      child_names(j), _\r\n                                    "", _\r\n                                    lib)\r\n          ret2 = reg.GetStringValue(HKEY_CLASSES_ROOT, _\r\n                                    SubKeyName & ChrW(92) & _\r\n                                      names(i) & ChrW(92) & _\r\n                                      child_names(j) & ChrW(92) & _\r\n                                      "0" & ChrW(92) & _\r\n                                      "win32", _\r\n                                    "", _\r\n                                    tlb)\r\n          If (ret1 = 0) And (ret2 = 0) Then\r\n            rs.AddNew\r\n            rs.Fields("GUID").Value = names(i)\r\n            rs.Fields("Name").Value = lib\r\n            rs.Fields("Library").Value = tlb\r\n            rs.Update\r\n          End If\r\n        Next\r\n      End If\r\n    Next\r\n    rs.Sort = "Name ASC" '\u540d\u524d\u9806\u3067\u30bd\u30fc\u30c8\r\n    \r\n    'TypeLib\u60c5\u5831\u3092XML\u30d5\u30a1\u30a4\u30eb\u3068\u3057\u3066\u4fdd\u5b58\r\n    rs.MoveFirst\r\n    Set d = CreateObject("Msxml2.DOMDocument")\r\n    Set items = d.createElement("items")\r\n    Do Until rs.EOF\r\n      Set item = d.createElement("item")\r\n      item.setAttribute "guid", rs.Fields("GUID").Value\r\n      item.setAttribute "name", rs.Fields("Name").Value\r\n      item.setAttribute "library", rs.Fields("Library").Value\r\n      items.appendChild item\r\n      Set item = Nothing\r\n      rs.MoveNext\r\n    Loop\r\n    rs.Close\r\n    d.appendChild items\r\n    On Error Resume Next\r\n    d.Save XmlFilePath\r\n    If Err.Number <> 0 Then\r\n      MsgBox "XML\u30d5\u30a1\u30a4\u30eb\u306e\u4fdd\u5b58\u306b\u5931\u6557\u3057\u307e\u3057\u305f\u3002" & vbNewLine & _\r\n             XmlFilePath, vbCritical + vbSystemModal\r\n      Err.Clear\r\n    End If\r\n    On Error GoTo 0\r\n  End If\r\nEnd Sub\r\n\r\nPrivate Function AddPathSeparator(ByVal str As String) As String\r\n  If Right(str, 1) <> ChrW(92) Then str = str & ChrW(92)\r\n  AddPathSeparator = str\r\nEnd Function<\/pre>\n
    \u52d5\u4f5c\u753b\u9762<\/h4>\n
    \u5b9f\u969b\u306b\u30a2\u30c9\u30a4\u30f3\u3092\u8aad\u307f\u8fbc\u3093\u3067\u3001\u52d5\u4f5c\u3055\u305b\u305f\u3068\u304d\u306e\u69d8\u5b50\u304c\u4e0b\u56f3\u306b\u306a\u308a\u307e\u3059\u3002<\/p>\n
    \"AddTypeLib_01\"<\/p>\n
    ComboBox\u3068CommandButton\u3057\u304b\u30b7\u30f3\u30d7\u30eb\u306a\u30a4\u30f3\u30bf\u30fc\u30d5\u30a7\u30fc\u30b9\u3067\u3001\u81ea\u5206\u3067\u4f7f\u3063\u305f\u611f\u3058\u3067\u306f\u3001\u306a\u304b\u306a\u304b\u4f7f\u3044\u3084\u3059\u3044\u3067\u3059\u3002<\/p>\n
    \u30c0\u30a6\u30f3\u30ed\u30fc\u30c9<\/h4>\n
    \u30b3\u30fc\u30c9\u306f\u4e0a\u306b\u66f8\u3044\u3066\u3044\u307e\u3059\u304c\u3001\u4e00\u5fdc\u30a2\u30c9\u30a4\u30f3\u30d5\u30a1\u30a4\u30eb\u3082\u30a2\u30c3\u30d7\u3057\u3066\u304a\u304d\u307e\u3059\u306e\u3067\u3001\u8208\u5473\u304c\u3042\u308b\u65b9\u306f\u8a66\u3057\u3066\u307f\u3066\u304f\u3060\u3055\u3044\u3002
    \n(\u300c    VBA \u30d7\u30ed\u30b8\u30a7\u30af\u30c8 \u30aa\u30d6\u30b8\u30a7\u30af\u30c8 \u30e2\u30c7\u30eb\u3078\u306e\u30a2\u30af\u30bb\u30b9\u3092\u4fe1\u983c\u3059\u308b<\/a>\u300d\u306b\u30c1\u30a7\u30c3\u30af\u304c\u5165\u3063\u3066\u3044\u306a\u3044\u3068\u4f7f\u7528\u3067\u304d\u307e\u305b\u3093\u306e\u3067\u3001\u305d\u306e\u70b9\u306f\u3054\u6ce8\u610f\u304f\u3060\u3055\u3044\u3002)<\/p>\n
    ► \u30c0\u30a6\u30f3\u30ed\u30fc\u30c9<\/a><\/p>\n","protected":false},"excerpt":{"rendered":"thom\u6c0f\u306e\u30d6\u30ed\u30b0\u3067\u9762\u767d\u3044\u8a18\u4e8b\u304c\u3042\u308a\u307e\u3057\u305f\u3002 \u30fbVBA \u53c2\u7167\u8a2d\u5b9a\u3067\u30e9\u30a4\u30d6\u30e9\u30ea\u3092\u63a2\u3059\u306e\u304c\u9762\u5012\u306a\u306e\u3067\u3001\u30e9\u30a4\u30d6\u30e9\u30ea\u3092\u691c\u7d22\u3067\u304d\u308b\u53c2\u7167\u8a2d\u5b9a\u30c0\u30a4\u30a2\u30ed\u30b0\u3092\u81ea\u4f5c\u3057\u3066\u307f\u305f – t-hom\u2019s diary http:\/\/thom […]","protected":false},"author":1,"featured_media":7111,"comment_status":"open","ping_status":"closed","sticky":false,"template":"","format":"standard","meta":{"_jetpack_newsletter_access":"","_jetpack_dont_email_post_to_subs":false,"_jetpack_newsletter_tier_id":0,"_jetpack_memberships_contains_paywalled_content":false,"_jetpack_feature_clip_id":0,"_jetpack_memberships_contains_paid_content":false,"footnotes":"","jetpack_publicize_message":"[\u624b\u8efd\u306b\u53c2\u7167\u8a2d\u5b9a\u3059\u308b\u305f\u3081\u306eVBA\u30a2\u30c9\u30a4\u30f3]","jetpack_publicize_feature_enabled":true,"jetpack_social_post_already_shared":true,"jetpack_social_options":{"image_generator_settings":{"template":"highway","default_image_id":0,"font":"","enabled":false},"version":2},"jetpack_post_was_ever_published":false},"categories":[48,4],"tags":[],"class_list":["post-6721","post","type-post","status-publish","format-standard","has-post-thumbnail","hentry","category-excel-office","category-office"],"aioseo_notices":[],"aioseo_head":"\n\t\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t