Attribute VB_Name = "Module1" Option Explicit ' ------------------------------------------------ ' CODE FOR ' Developing Visual Basic Add-ins ' by ' Steven Roman ' ' O'Reilly & Associates ' ' Search by Example number, e.g. Example 2-2 ' ' ------------------------------------------------ ' ------------------------------------------------- ' Example 2-1 ' ''Declare Function WritePrivateProfileString& Lib _ '' "kernel32" Alias "WritePrivateProfileStringA" _ '' (ByVal AppName$, ByVal KeyName$, _ '' ByVal keydefault$, ByVal FileName$) ' Execute ONCE from the Immediate window to add ' reference to add-in in the vbaddin.ini file. ' ' Don't forget to change the sProgID variable ' to the correct programmatic ID, i.e. ' ' ProjectName.ConnectClassName ' Sub AddToINI() Dim Resp As Long Dim sProgID As String sProgID = "AddInShell.Connect" ' CHANGE THIS! Resp = WritePrivateProfileString("Add-Ins32", _ sProgID, "0", "vbaddin.ini") If Resp = 0 Then MsgBox "Error adding add-in to vbaddin.ini." Else MsgBox "Reference placed in vbaddin.ini." End If End Sub ' ------------------------------------------------- ' Example 2-2 Private Sub IDTExtensibility_OnConnection( _ ByVal VBInst As Object, _ ByVal ConnectMode As vbext_ConnectMode, _ ByVal AddInInst As VBIDE.AddIn, _ custom() As Variant) On Error GoTo ERROR_CONNECT ' Save the instance of VB Set oVBE = VBInst ' Place code in following TEST AREA for testing ' objects of the VBIDE object model. '---------------------------------------- '---------------------------------------- ' Set breakpoint on following line for testing. Debug.Print "*** Started " & Now & " ***" Exit Sub ERROR_CONNECT: MsgBox Err.Description End Sub ' ------------------------------------------------- ' Example 4-1 Private Sub CommandBarObjects() ' The CommandBars Collection ' Listing CommandBar objects ' In the test area of the OnConnection method (for the add-in shell project), add the following code: Dim sType As String Dim cbar As Office.CommandBar Debug.Print "Count: " & oVBE.CommandBars.Count Debug.Print "NAME,TYPE,VISIBLE" For Each cbar In oVBE.CommandBars Select Case cbar.Type Case msoBarTypeNormal ' a toolbar sType = "Normal" Case msoBarTypeMenuBar ' a menu bar sType = "Menu bar" Case msoBarTypePopup ' a shortcut menu sType = "Popup" ' Next line is for later use ' If cbar.Name = "Document" Then _ cbar.ShowPopup End Select Debug.Print cbar.Name & "," & sType _ & "," & cbar.Visible Next End Sub ' ------------------------------------------------- ' Example 4-2 Private Sub CommandBarControlIDs() Dim fr As Integer Dim cbar As Office.CommandBar Dim ctl As CommandBarControl Dim i As Integer Const maxid = 4000 fr = FreeFile Open "d:\temp\ids.txt" For Output As #fr ' Create temporary toolbar Set cbar = oVBE.CommandBars.Add("temporary", msoBarTop, _ False, True) For i = 1 To maxid On Error Resume Next ' skip if cannot add cbar.Controls.Add Id:=i Next i On Error GoTo 0 For Each ctl In cbar.Controls Print #fr, ctl.Caption & " (" & ctl.Id & ")" Next cbar.Delete Close #fr End Sub ' ------------------------------------------------- ' Example 4-5 ''Implements IDTExtensibility ' Menu items ''Private cbcCustom As Office.CommandBarControl ''Private cbcFeature1 As Office.CommandBarControl ''Private cbcFeature2 As Office.CommandBarControl ' To hook menu events ''Private WithEvents cbeFeature1 As CommandBarEvents ''Private WithEvents cbeFeature2 As CommandBarEvents '----- Private Sub cbeFeature1_Click( _ ByVal CommandBarControl As Object, _ handled As Boolean, _ CancelDefault As Boolean) MsgBox "Add-in Feature 1" End Sub '----- Private Sub cbeFeature2_Click( _ ByVal CommandBarControl As Object, _ handled As Boolean, _ CancelDefault As Boolean) MsgBox "Add-in Feature 2" End Sub '----- Private Sub IDTExtensibility_OnConnection( _ ByVal VBInst As Object, _ ByVal ConnectMode As VBIDE.vbext_ConnectMode, _ ByVal AddInInst As VBIDE.AddIn, _ custom() As Variant) On Error GoTo ERROR_CONNECT ' Save the instance of VB Set oVBE = VBInst ' Place code in following TEST AREA for testing ' objects of the VBIDE object model. '------------------------------------------ '------------------------------------------ ' Set breakpoint for testing. Debug.Print "*** Started " & Now & " ***" ' Make menu CreateCustomMenu ' Hook menu events Set cbeFeature1 = _ oVBE.Events.CommandBarEvents(cbcFeature1) Set cbeFeature2 = _ oVBE.Events.CommandBarEvents(cbcFeature2) Exit Sub ERROR_CONNECT: MsgBox Err.Description End Sub '----- Private Sub IDTExtensibility_OnDisconnection( _ ByVal RemoveMode As VBIDE.vbext_DisconnectMode, _ custom() As Variant) cbcCustom.Delete Debug.Print "*** Ended " & Now & " ***" End Sub '----- Private Sub IDTExtensibility_OnStartupComplete( _ custom() As Variant) ' End Sub '----- Private Sub IDTExtensibility_OnAddInsUpdate( _ custom() As Variant) ' End Sub '----- Public Sub CreateCustomMenu() ' Create popup control on main menu bar Set cbcCustom = oVBE.CommandBars("Menu bar"). _ Controls.Add(Type:=msoControlPopup) cbcCustom.Caption = "&Custom" ' Add menu item Set cbcFeature1 = cbcCustom.Controls.Add( _ Type:=msoControlButton) cbcFeature1.Caption = "Feature&1" ' Add menu item Set cbcFeature2 = cbcCustom.Controls.Add( _ Type:=msoControlButton) cbcFeature2.Caption = "Feature&2" End Sub ' ------------------------------------------------- ' Example 4-8 Public Sub CreateCustomMenu() Dim cbsub As Office.CommandBarControl ' Create popup control on main menu bar Set cbcCustom = oVBE.CommandBars("Menu bar"). _ Controls.Add(Type:=msoControlPopup) cbcCustom.Caption = "&Custom" ' Add menu item Set cbcFeature1 = cbcCustom.Controls.Add( _ Type:=msoControlButton) cbcFeature1.Caption = "Feature&1" ' Add menu item Set cbcFeature2 = cbcCustom.Controls.Add( _ Type:=msoControlButton) cbcFeature2.Caption = "Feature&2" ' Add popup for a submenu Set cbsub = _ cbcCustom.Controls.Add(Type:=msoControlPopup) cbsub.Caption = "&SubMenu" ' Add menu item to submenu Set cbcFeature3 = _ cbsub.Controls.Add(Type:=msoControlButton) cbcFeature3.Caption = "Feature&3" End Sub ' ------------------------------------------------- ' Example 4-10 Sub CreateCustomToolbar() Dim cbctl As Office.CommandBarControl ' Create a floating toolbar Set cbCustom = oVBE.CommandBars.Add( _ Name:="Toolbar Example", _ Position:=msoBarFloating) cbCustom.Visible = True ' Add a custom button control Set cbcFeature3 = cbCustom.Controls.Add( _ Type:=msoControlButton) ' The following is needed for caption cbcFeature3.Style = msoButtonCaption cbcFeature3.Caption = "CustomButton" ' Add built-in Find... control Set cbctl = cbCustom.Controls.Add(Id:=141) ' Icon for button cbctl.FaceId = 141 ' Add a list box Set cbcListBox = cbCustom.Controls.Add( _ Type:=msoControlDropdown) ' Set list properties of the list box With cbcListBox .Caption = "Composers" .AddItem "Chopin", 1 .AddItem "Mozart", 2 .AddItem "Bach", 3 .DropDownLines = 0 .DropDownWidth = 75 ' select nothing to start .ListIndex = 0 End With End Sub ' ------------------------------------------------- ' Example 4-12 Sub ShowFaceIDs() Const max = 4000 Dim bars As Integer, i As Integer Dim firstID As Integer, lastId As Integer Dim tb As Office.CommandBar Dim btn As Office.CommandBarControl On Error GoTo PastLastButton For bars = 0 To 13 firstID = bars * 300 lastId = firstID + 299 Set tb = oVBE.CommandBars.Add( _ Name:=CStr(firstID) & "-" & CStr(lastId), _ Temporary:=True) For i = firstID To lastId If i >= 3519 Then GoTo PastLastButton Set btn = tb.Controls.Add btn.FaceId = i btn.ToolTipText = "FaceID " & i Next tb.Visible = True tb.Width = 591 Next PastLastButton: End Sub ' ------------------------------------------------- ' Example 5-2 Sub PrintToDebug(sText As String) ' Print sText to Immediate window of client Dim wActive As Window Dim wImm As Window ' Save active window Set wActive = oVBE.ActiveWindow ' Reference to Immediate window Set wImm = oVBE.Windows("Immediate") ' If none, then exit If wImm Is Nothing Then Exit Sub ' Proceed only if visible If wImm.Visible = True Then wImm.SetFocus SendKeys "^({End})", True SendKeys sText, True End If ' Restore original focus wActive.SetFocus End Sub ' ------------------------------------------------- ' Example 7-3 Sub ClearImmediateWindow() Dim winActive As VBIDE.Window Dim winImm As VBIDE.Window Set winImm = gVBInst.Windows("Immediate") If winImm Is Nothing Then Exit Sub ' Save the currently active window Set winActive = gVBInst.ActiveWindow 'Do not clear if Window Not Visible If winImm.Visible = True Then winImm.SetFocus SendKeys "^({Home})", True SendKeys "^(+({End}))", True SendKeys "{Del}", True End If ' Return to active window winActive.SetFocus Set winImm = Nothing End Sub ' ------------------------------------------------- ' Code for scrolling a code pane Private Sub Form_Activate() ' Set form dimensions to be out of the way Me.Top = 0 Me.Left = 0 Me.Width = 5000 Me.Height = 10 End Sub Private Sub Form_KeyDown(KeyCode As Integer, _ Shift As Integer) Select Case KeyCode Case vbKeyEscape bStopScrolling = True Case vbKeyUp ' Subtract 0.02 to delay rate rDelayRate = rDelayRate - 0.02 ' Validate If rDelayRate <= 0.02 Then rDelayRate = 0.02 Beep End If Case vbKeyDown ' Add 0.02 to delay rate rDelayRate = rDelayRate + 0.02 End Select Me.Caption = "Scrolling ... " & rDelayRate End Sub Private Sub Form_Load() Me.KeyPreview = True Me.Caption = "Scrolling ... " & rDelayRate End Sub Sub Delay(rTime As Single) 'Delay rTime seconds (min=.01, max=300) Dim OldTime As Variant 'Safty net If rTime < 0.01 Or rTime > 300 Then rTime = 1 OldTime = Timer Do DoEvents Loop Until Timer - OldTime >= rTime End Sub Sub ScrollCodePane() Dim lPrevLine As Long Dim lSafe As Long rDelayRate = 0.1 frmScroll.Show oVBE.ActiveCodePane.TopLine = 1 lSafe = 0 lPrevLine = -1 Do lSafe = lSafe + 1 ' Check for Escape key If bStopScrolling Then bStopScrolling = False Exit Do End If ' Save this to check for end of code pane lPrevLine = oVBE.ActiveCodePane.TopLine ' Scroll one line oVBE.ActiveCodePane.TopLine = _ oVBE.ActiveCodePane.TopLine + 1 ' If no more lines, get out If oVBE.ActiveCodePane.TopLine = lPrevLine _ Then Exit Do ' Wait Delay rDelayRate Loop Until lSafe > 10000 Unload frmScroll End Sub ' ------------------------------------------------- ' Code for setting tab stops ' Example 9-1 ''Private cmpCurrent As VBComponent Private Sub cmdDown_Click() On Error Resume Next Dim iItem As Integer With lstTabs If .ListIndex < 0 Then Exit Sub iItem = .ListIndex ' Cannot move last item down If iItem = .ListCount - 1 Then Exit Sub ' Move item down one .AddItem .Text, iItem + 2 ' Remove old item .RemoveItem iItem ' Select the item again .Selected(iItem + 1) = True End With Err.Clear End Sub '----- Private Sub cmdUp_Click() Dim iItem As Integer On Error Resume Next With lstTabs If .ListIndex <= 0 Then Exit Sub iItem = .ListIndex ' Move item up .AddItem .Text, iItem - 1 ' Remove old item .RemoveItem iItem + 1 ' Select the item again .Selected(iItem - 1) = True End With Err.Clear End Sub '----- Private Sub Form_Load() RefreshList End Sub Private Sub Form_Resize() lstTabs.Width = ScaleWidth - _ (lstTabs.Left * 2 + cmdUp.Width + 100) lstTabs.Height = ScaleHeight - _ (cmdSetTabIndex.Height + 100) End Sub '----- Sub RefreshList() Dim ctl As VBControl lstTabs.Clear 'Get selected component Set cmpCurrent = oVBE.SelectedVBComponent ' Is there a current component? If cmpCurrent Is Nothing Then Exit Sub ' Is it of correct type? If (cmpCurrent.Type <> vbext_ct_VBForm) And _ (cmpCurrent.Type <> vbext_ct_UserControl) And _ (cmpCurrent.Type <> vbext_ct_DocObject) And _ (cmpCurrent.Type <> vbext_ct_PropPage) Then Exit Sub End If ' OK to procede Me.Caption = oVBE.SelectedVBComponent.Name For Each ctl In cmpCurrent.Designer.VBControls lstTabs.AddItem Format$( _ ctl.Properties!TabIndex, "000") & ": " & _ ControlDesc(ctl) Next End Sub '----- Function ControlDesc(ctl As VBIDE.VBControl) As String ' Description of control for list box On Error Resume Next Dim sName As String Dim sCaption As String Dim i As Integer sName = ctl.Properties!Name sCaption = "" ' If there is no caption, then ' error is trapped so sCaption will be sCaption = ctl.Properties!Caption i = ctl.Properties!Index If i >= 0 Then sName = sName & "(" & i & ")" End If If Len(sCaption) > 0 Then ControlDesc = sName & " - '" & sCaption & "'" Else ControlDesc = sName End If Err.Clear End Function '----- Private Sub cmdSetTabIndex_Click() On Error GoTo cmdSetTabIndex_ERROR Dim i As Integer Dim sName As String Dim iCtlArrayIdx As Integer Screen.MousePointer = vbHourglass For i = 0 To lstTabs.ListCount - 1 GetNameAndIndex lstTabs.List(i), _ sName, iCtlArrayIdx If iCtlArrayIdx >= 0 Then ' This control is a member of an array cmpCurrent.Designer.VBControls.Item( _ sName, iCtlArrayIdx).Properties!TabIndex = i Else ' Not part of control array -- no index value cmpCurrent.Designer.VBControls.Item(sName). _ Properties!TabIndex = i End If Next RefreshList Screen.MousePointer = vbDefault Exit Sub cmdSetTabIndex_ERROR: If MsgBox(Err.Description & vbCrLf & _ "Resume?", vbYesNo) = vbYes Then Resume Next End If Screen.MousePointer = vbDefault End Sub '----- Sub GetNameAndIndex(ByVal sItem As String, ByRef sName As String, ByRef iIndex As Integer) ' Fills out parameters sName with control's name ' and iIndex with control's index (or -1) ' NOTE: item has form: ' number: name(index) - 'caption' Dim x As Integer Dim sTemp As String ' First trim away number sTemp = Trim$(Mid$(sItem, InStr(sItem, ":") + 1)) ' Look for ( to signal index x = InStr(sTemp, "(") If x > 0 Then sName = Left$(sTemp, x - 1) iIndex = Val(Mid$(sTemp, x + 1)) Else ' No index. iIndex = -1 'Name is to left of - x = InStr(sTemp, "-") If x > 0 Then sName = Trim$(Left$(sTemp, x - 1)) Else sName = Trim$(sTemp) End If End If End Sub ' ------------------------------------------------- ' Methods to add to the connect class ' Example 10-1 ' File events Private Sub evFiles_AfterAddFile(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal FileName As String) aiMsg.AddItem "File added: " & FileName End Sub Private Sub evFiles_AfterChangeFileName(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal NewName As String, ByVal OldName As String) aiMsg.AddItem "File changed: " & OldName & " to " & NewName End Sub Private Sub evFiles_AfterCloseFile(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal FileName As String, ByVal WasDirty As Boolean) aiMsg.AddItem "File closed: " & FileName & " WasDirty: " & WasDirty End Sub Private Sub evFiles_AfterRemoveFile(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal FileName As String) aiMsg.AddItem "File removed: " & FileName End Sub Private Sub evFiles_AfterWriteFile(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal FileName As String, ByVal Result As Integer) aiMsg.AddItem "File written to: " & FileName & " Result: " & Result End Sub Private Sub evFiles_BeforeLoadFile(ByVal VBProject As VBIDE.VBProject, FileNames() As String) If UBound(FileNames) = 1 Then aiMsg.AddItem "File loaded: " & FileNames(0) ElseIf UBound(FileNames) = 2 Then aiMsg.AddItem "File loaded: " & FileNames(0) & " / " & FileNames(1) End If End Sub Private Sub evFiles_DoGetNewFileName(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, NewName As String, ByVal OldName As String, CancelDefault As Boolean) aiMsg.AddItem "File DoGetNewFileName: " & OldName & " to " & NewName & " CancelDef: " & CancelDefault End Sub Private Sub evFiles_RequestChangeFileName(ByVal VBProject As VBIDE.VBProject, ByVal FileType As VBIDE.vbext_FileType, ByVal NewName As String, ByVal OldName As String, Cancel As Boolean) aiMsg.AddItem "File RequestChangeFileName: " & OldName & " to " & NewName & " Cancel: " & Cancel End Sub Private Sub evFiles_RequestWriteFile(ByVal VBProject As VBIDE.VBProject, ByVal FileName As String, Cancel As Boolean) aiMsg.AddItem "File RequestWriteName: " & FileName & " Cancel: " & Cancel End Sub ' Reference events Private Sub evRefs_ItemAdded(ByVal Reference As VBIDE.Reference) aiMsg.AddItem "Reference added: " & Reference.Description End Sub Private Sub evRefs_ItemRemoved(ByVal Reference As VBIDE.Reference) aiMsg.AddItem "Reference removed: " & Reference.Description End Sub ' Selected controls Private Sub evSelCtrls_ItemAdded(ByVal VBControl As VBIDE.VBControl) aiMsg.AddItem "Selected control added: " & VBControl.ClassName & " Name: " & VBControl.Properties("Name").Value End Sub Private Sub evSelCtrls_ItemRemoved(ByVal VBControl As VBIDE.VBControl) aiMsg.AddItem "Selected control removed: " & VBControl.ClassName & " Name: " & VBControl.Properties("Name").Value '''& " / " & oVBE.ActiveVBProject.VBComponents("form1").Designer.SelectedVBControls.Count End Sub ' Components Private Sub evComps_ItemActivated(ByVal VBComponent As VBIDE.VBComponent) aiMsg.AddItem "Component activated: " & VBComponent.Name End Sub Private Sub evComps_ItemAdded(ByVal VBComponent As VBIDE.VBComponent) aiMsg.AddItem "Component added: " & VBComponent.Name End Sub Private Sub evComps_ItemReloaded(ByVal VBComponent As VBIDE.VBComponent) aiMsg.AddItem "Component reloaded: " & VBComponent.Name End Sub Private Sub evComps_ItemRemoved(ByVal VBComponent As VBIDE.VBComponent) aiMsg.AddItem "Component removed: " & VBComponent.Name End Sub Private Sub evComps_ItemRenamed(ByVal VBComponent As VBIDE.VBComponent, ByVal OldName As String) aiMsg.AddItem "Component renamed: " & OldName & " to " & VBComponent.Name End Sub Private Sub evComps_ItemSelected(ByVal VBComponent As VBIDE.VBComponent) aiMsg.AddItem "Component selected: " & VBComponent.Name End Sub ' Controls Private Sub evCtrls_ItemAdded(ByVal VBControl As VBIDE.VBControl) aiMsg.AddItem "Control added: " & VBControl.ClassName & " Name: " & VBControl.Properties("Name").Value End Sub Private Sub evCtrls_ItemRemoved(ByVal VBControl As VBIDE.VBControl) aiMsg.AddItem "Control removed: " & VBControl.ClassName & " Name: " & VBControl.Properties("Name").Value End Sub Private Sub evCtrls_ItemRenamed(ByVal VBControl As VBIDE.VBControl, ByVal OldName As String, ByVal OldIndex As Long) aiMsg.AddItem "Control renamed: " & OldName & " to " & VBControl.Properties("Name").Value & " OldIndex: " & OldIndex End Sub ' Projects Private Sub evProjs_ItemActivated(ByVal VBProject As VBIDE.VBProject) aiMsg.AddItem "Project activated: " & VBProject.Name End Sub Private Sub evProjs_ItemRemoved(ByVal VBProject As VBIDE.VBProject) aiMsg.AddItem "project removed " & VBProject.Name End Sub Private Sub evProjs_ItemAdded(ByVal VBProject As VBIDE.VBProject) aiMsg.AddItem "Project added: " & VBProject.Name End Sub Private Sub evProjs_ItemRenamed(ByVal VBProject As VBIDE.VBProject, ByVal OldName As String) aiMsg.AddItem "Project renamed: " & OldName & " To " & VBProject.Name End Sub ' ------------------------------------------------- ' Pushing/Poping Prefixes ' Example 11-1 Private Sub PushPop() ' Get the selection in the active code pane ' and append or remove a prefix Dim i As Integer Dim sPrefix As String Dim fRemove As Boolean Dim startline As Long, startcol As Long Dim endline As Long, endcol As Long fRemove = False sPrefix = InputBox("Enter prefix. Precede with - to remove string.", "Push or pop a prefix", "'''") ' Check for - to signal removal If Left$(sPrefix, 1) = "-" Then fRemove = True sPrefix = Mid$(sPrefix, 2) End If If sPrefix = "" Then Exit Sub ' Get startline and endline of current selection With oVBE.ActiveCodePane .GetSelection startline, startcol, _ endline, endcol ' If CR at end of line is selected then ' do not include the last line. If endcol = 1 Then endline = endline - 1 With oVBE.ActiveCodePane.CodeModule For i = startline To endline If Not fRemove Then ' Add prefix .ReplaceLine i, sPrefix & .Lines(i, 1) Else ' Remove prefix if it exists If Left$(.Lines(i, 1), Len(sPrefix)) _ = sPrefix Then .ReplaceLine i, Mid$(.Lines(i, 1), _ Len(sPrefix) + 1) End If End If Next i End With ' Shrink selection .SetSelection endline, 1, endline, 1 End With End Sub