jpoww Posted July 21, 2015 Share Posted July 21, 2015 (edited) 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 Edited August 7, 2015 by SLW210 Added Code Tags! Quote Link to comment Share on other sites More sharing options...
SLW210 Posted July 22, 2015 Share Posted July 22, 2015 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 Quote Link to comment Share on other sites More sharing options...
BlackBox Posted August 6, 2015 Share Posted August 6, 2015 FWIW - It may also be helpful to clarify the thread title, as VBA != VB (.NET) Quote Link to comment Share on other sites More sharing options...
SLW210 Posted August 7, 2015 Share Posted August 7, 2015 FWIW - It may also be helpful to clarify the thread title, as VBA != VB (.NET) I fixed it. Quote Link to comment Share on other sites More sharing options...
jpoww Posted August 7, 2015 Author Share Posted August 7, 2015 Sorry guys. How do I remove this thread? if I can't do it, could the moderator please remove it for me. Thank You Quote Link to comment Share on other sites More sharing options...
SLW210 Posted August 7, 2015 Share Posted August 7, 2015 Why do you need it removed? Did you find your answer? Quote Link to comment Share on other sites More sharing options...
jpoww Posted August 7, 2015 Author Share Posted August 7, 2015 no I have not. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.