Editing a Toolbar written in VBA

I have the following DVB file that I need to add a function to. This is for a toolbar that runs three buttons. The first two are copy text buttons and they copy text and attributed text but they do not do mtext. I want to add that function to it but I'm a beginner and have no idea where to start. Can anyone help?

Option Explicit
' Copy an attribute value within a block if it has "COPY" in the attribute name
' Another sub could be used with another search word utilizing the CopyAttVal Function below
Public Sub CopyAttWithinBlock()
 CopyAttVal "COPY"
End Sub
' Function to perform the Attribute Copy within a block
Private Function CopyAttVal(SearchWord As String) As Boolean
 Dim objBlkRef As AcadBlockReference
 Dim objAtt As AcadAttributeReference
 Dim objSet As AcadSelectionSet
 Dim varData(0 To 0) As Variant
 Dim intType(0 To 0) As Integer
 Dim varAtts() As AcadAttributeReference
 Dim strValues() As String
 Dim strTag As String
 Dim lngCnt As Long
 Dim lngLoop As Long
 Set objSet = ThisDrawing.PickfirstSelectionSet
 varData(0) = "INSERT"
 intType(0) = 0
 objSet.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
 For Each objBlkRef In objSet
   If objBlkRef.HasAttributes Then
     varAtts = objBlkRef.GetAttributes
     For lngCnt = 0 To UBound(varAtts)
       Set objAtt = varAtts(lngCnt)
       If objAtt.TagString Like SearchWord & "*" Then
         strTag = Mid(objAtt.TagString, Len(SearchWord) + 1)
         For lngLoop = 0 To UBound(varAtts)
           If varAtts(lngLoop).TagString = strTag Then
             objAtt.TextString = varAtts(lngLoop).TextString
             Exit For
           End If
         Next lngLoop
       End If
     Next lngCnt
   End If
 Next objBlkRef
End Function
' This Routine will allow you to pick on any attribute value and copy it to another attribute
Public Sub AttCopy()
 Dim objEnt As AcadEntity
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strVal As String
 Dim strPrmt As String
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
 strPrmt = vbCr & "Pick source attribute: "
 objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
 If TypeOf objEnt Is IAcadAttributeReference Then
   Set objAtt = objEnt
 Else
   MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
   GoTo Exit_Here
 End If
 strVal = objAtt.TextString
RETRY_HERE:
     strPrmt = vbCr & "Pick destination attribute: "
     objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
     If TypeOf objEnt Is IAcadAttributeReference Then
       Set objAtt = objEnt
       objAtt.TextString = strVal
' Allows for Continued selections
   GoTo RETRY_HERE
     Else
       MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
       GoTo RETRY_HERE
     End If
Exit_Here:
 Exit Sub
Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
End Sub
'This routine is the same as above except is intended to copy an Attribute value and then allows
'for a Source then Destination Attribute and Loops
Public Sub AttCopyLoop()
 Dim objEnt As AcadEntity
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strVal As String
 Dim strPrmt As String
 Dim Counter
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
For Counter = 1 To 100 Step 1
   strPrmt = vbCr & "Pick source attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
   If TypeOf objEnt Is IAcadAttributeReference Then
     Set objAtt = objEnt
   Else
     MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
     GoTo Exit_Here
   End If
   strVal = objAtt.TextString
RETRY_HERE:
     'Original Attribute Value placed to destination
       strPrmt = vbCr & "Pick destination attribute: "
       objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal
         strPrmt = vbCr & "Mission accomplished." & vbCr
         objUtil.Prompt strPrmt
       Else
         MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
Next Counter
Exit_Here:
   Exit Sub
Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
 
End Sub
'This routine is the same as above except is intended to copy an Attribute value and then allows
'for three picks that will take the original value and append a "+" (1st Pick), a "-" (2nd Pick),
'and a "-S" (3rd Pick)
Public Sub CableLabelToConductor()
 Dim objEnt As AcadEntity
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strVal As String
 Dim strPrmt As String
 Dim IsFinished As Boolean
 Dim Counter
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
For Counter = 1 To 100 Step 1
   strPrmt = vbCr & "Pick source attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
   If TypeOf objEnt Is IAcadAttributeReference Then
     Set objAtt = objEnt
   Else
     MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
     GoTo Exit_Here
   End If
   strVal = objAtt.TextString
RETRY_HERE:
     'Append "+" to Original Attribute Value and place on first destination
       strPrmt = vbCr & "Pick destination attribute: "
       objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal & "+"
         strPrmt = vbCr & "Mission accomplished." & vbCr
         objUtil.Prompt strPrmt
       Else
         MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
     'Append "-" to Original Attribute Value and place on second destination
       strPrmt = vbCr & "Pick destination attribute: "
       objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal & "-"
         strPrmt = vbCr & "Mission accomplished." & vbCr
         objUtil.Prompt strPrmt
       Else
         MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
     'Append "-S" to Original Attribute Value and place on third destination
       strPrmt = vbCr & "Pick destination attribute: "
       objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal & "-S"
         strPrmt = vbCr & "Mission accomplished." & vbCr
         objUtil.Prompt strPrmt
       Else
         MsgBox "Selected object is not an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
Next Counter
Exit_Here:
   Exit Sub

Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
 
End Sub

Sub Example_GetSubEntity()
   ' This example prompts the user to select on object on the screen with a mouse click,
   ' and returns some information about the selected object.
   ' This routine originated in the Help file and is placed here to give ideas for returning
   ' entity types.
   
   Dim Object As Object
   Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant
   Dim HasContextData As String
   
   On Error GoTo NOT_ENTITY
       
TRYAGAIN:
       
   MsgBox "Use the mouse to click on an object in the current drawing after dismissing this dialog box."
       
   ' Get information about selected object
   ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData
   
   ' Process and display selected object properties
   HasContextData = IIf(VarType(ContextData) = vbEmpty, " does not ", " does ")
   
   MsgBox "The object you chose was an: " & TypeName(Object) & vbCrLf & _
           "Your point of selection was: " & PickedPoint(0) & ", " & _
                                             PickedPoint(1) & ", " & _
                                             PickedPoint(2) & vbCrLf & _
           "This object" & HasContextData & "have nested objects."
   
   Exit Sub
   
NOT_ENTITY:
   ' If you click on empty space or do not select an entity,
   ' this error will be generated
   If MsgBox("You have not selected an object.  Click OK to try again.", _
              vbOKCancel & vbInformation) = vbOK Then
       Resume TRYAGAIN
   End If
End Sub

Public Sub IncNum()
Dim i As Double
Dim ss As AcadSelectionSet
Dim iNum(0) As Integer
Dim vType(0) As Variant
Dim txt As AcadText
Dim dIncrement As Double
  
   dIncrement = ThisDrawing.Utility.GetReal("Enter Increment> ")
   
   
   On Error Resume Next
   ThisDrawing.SelectionSets("a").Delete
   On Error GoTo 0
   
   Set ss = ThisDrawing.SelectionSets.Add("a")
   
   iNum(0) = 0: vType(0) = "TEXT"
   
   
   ThisDrawing.Utility.Prompt "Select numbers to increment"
   ss.SelectOnScreen iNum, vType
   
   For Each txt In ss
       On Error Resume Next
       i = CDbl(txt.TextString)
       If Err.Number = 0 Then
           txt.TextString = i + dIncrement
       End If
       On Error GoTo 0
   Next txt
       
End Sub

Public Sub IncAll() 'Increment or decrement text or various attributes
Dim iB As Double
Dim ssB As AcadSelectionSet
Dim iBNum(0) As Integer
Dim vBType(0) As Variant
Dim blkref As AcadBlockReference
Dim vB
Dim attref As AcadAttributeReference
Dim txt As AcadText
Dim ent As AcadEntity
Dim dIncrement As Double
  
   dIncrement = ThisDrawing.Utility.GetReal("Enter Increment> ")
   
   
   On Error Resume Next
   ThisDrawing.SelectionSets("B").Delete
   On Error GoTo 0
   Err.Clear
   Set ssB = ThisDrawing.SelectionSets.Add("B")
   
   iBNum(0) = 0: vBType(0) = "INSERT,TEXT"
   
   ThisDrawing.Utility.Prompt "Select numbers to increment"
   ssB.SelectOnScreen iBNum, vBType
   
   For Each ent In ssB
       If TypeOf ent Is AcadBlockReference Then
           Set blkref = ent
           If blkref.HasAttributes = True Then
               For Each vB In blkref.GetAttributes
                   Set attref = vB
                   If attref.TagString = "TAG1" Or attref.TagString = "TAG2" _
                     Or attref.TagString = "TERM01" Or attref.TagString = "B_ITEM" _
                     Or attref.TagString = "P_TAG1" Or attref.TagString = "N_ITEM" _
                     Or attref.TagString = "TERM" Or attref.TagString = "WIRENO" _
                     Or attref.TagString = "WIRECOPY" Or attref.TagString = "WIRENOF" _
                     Or attref.TagString = "COLUMN-LINE" Then
                       On Error Resume Next
                       iB = CDbl(attref.TextString)
                       If Err.Number = 0 Then
                           attref.TextString = iB + dIncrement
                       End If
                       On Error GoTo 0
                   End If
               Next vB
           End If
       Else
           Set txt = ent
           On Error Resume Next
           Debug.Print Err.Description
           iB = CDbl(txt.TextString)
           If Err.Number = 0 Then
               txt.TextString = iB + dIncrement
           End If
           On Error GoTo 0
       End If
   Next ent
   
End Sub
' This Routine will allow you to pick on any text or attribute value and copy it to another text or attribute value
Public Sub TextOrAttCopy()
 Dim objEnt As AcadEntity
 Dim objText As AcadText
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strVal As String
 Dim strPrmt As String
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
   strPrmt = vbCr & "Pick source Text or Attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is AcadText Then
         Set objText = objEnt
         strVal = objText.TextString
       ElseIf TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         strVal = objAtt.TextString
       Else
         MsgBox "Selected object is not text or an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo Exit_Here
       End If
   
RETRY_HERE:
   strPrmt = vbCr & "Pick destination Text or Attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is AcadText Then
         Set objText = objEnt
         objText.TextString = strVal
         GoTo RETRY_HERE
       ElseIf TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal
' Allows for Continued selections
         GoTo RETRY_HERE
       Else
         MsgBox "Selected object is not text or an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
Exit_Here:
 Exit Sub
Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
End Sub
' This Routine will allow you to pick on any text or attribute value and copy it to another text or attribute value and Loop
Public Sub TextOrAttCopyLoop()
 Dim objEnt As AcadEntity
 Dim objText As AcadText
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strVal As String
 Dim strPrmt As String
 Dim Counter
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
   
For Counter = 1 To 100 Step 1
   strPrmt = vbCr & "Pick source Text or Attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is AcadText Then
         Set objText = objEnt
         strVal = objText.TextString
       ElseIf TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         strVal = objAtt.TextString
       Else
         MsgBox "Selected object is not text or an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo Exit_Here
       End If
   
RETRY_HERE:
   strPrmt = vbCr & "Pick destination Text or Attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is AcadText Then
         Set objText = objEnt
         objText.TextString = strVal
       ElseIf TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = strVal
       Else
         MsgBox "Selected object is not text or an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
Next Counter
Exit_Here:
 Exit Sub
Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
End Sub

' This Routine will allow you to blank any text or attribute value
Public Sub TextOrAttBlank()
 Dim objEnt As AcadEntity
 Dim objText As AcadText
 Dim objAtt As IAcadAttributeReference
 Dim objUtil As IAcadUtility
 Dim varPnt As Variant
 Dim varMatrix As Variant
 Dim varData As Variant
 Dim strPrmt As String
 On Error GoTo Err_Control
 Set objUtil = ThisDrawing.Utility
RETRY_HERE:
   strPrmt = vbCr & "Pick destination Text or Attribute: "
   objUtil.GetSubEntity objEnt, varPnt, varMatrix, varData, strPrmt
       If TypeOf objEnt Is AcadText Then
         Set objText = objEnt
         objText.TextString = ""
         GoTo RETRY_HERE
       ElseIf TypeOf objEnt Is IAcadAttributeReference Then
         Set objAtt = objEnt
         objAtt.TextString = ""
' Allows for Continued selections
         GoTo RETRY_HERE
       Else
         MsgBox "Selected object is not text or an attribute, try again.", , "INVALID OBJECT SELECTION"
         GoTo RETRY_HERE
       End If
Exit_Here:
 Exit Sub
Err_Control:
 
 Select Case Err.Number
   Case Is = -2147352567
     Err.Clear
     Resume Exit_Here
   Case Else
     MsgBox Err.Description
     Err.Clear
     Resume Exit_Here
 End Select
End Sub

Please read the Code Posting Guidelines and edit your post to include the Code in Code Tags. [NOPARSE]

Your Code Here

[/NOPARSE]

Your Code Here

FWIW -

It may also be helpful to clarify the thread title, as VBA != VB (.NET)

FWIW -

 

It may also be helpful to clarify the thread title, as VBA != VB (.NET)

I fixed it.

Sorry guys. How do I remove this thread? if I can't do it, could the moderator please remove it for me.

Thank You

Why do you need it removed?

Did you find your answer?

no I have not.