Change Block Attribute Values from VBA Form

[metal_pro]

I would like to use VBA to select a block and have the attribute values populated on a VBA form. Then after Editing/changing the values on the form have the previously selected block updated with the new values.

 

I have been able to used some modified code from bsamc2000 in another post to read the block's attribute values and populate a form but how would I update the block with all the edited values from the form?

 

Sub Change_it()
Dim obj As AcadBlockReference
   Dim inspt As Variant
ParentSymbolForm.hide
   ThisDrawing.Utility.GetEntity obj, inspt, "Select object:"

   ' Checks if you selected a block.
   If obj.ObjectName = "AcDbBlockReference" Then

       ' Check for attributes.
       If obj.HasAttributes Then

           Dim AttList As Variant

           ' Build a list of attributes for the current block.
           AttList = obj.GetAttributes

           ' Cycle throught the list of attributes.
           For I = LBound(AttList) To UBound(AttList)

               ' Check for the correct attribute tag.
               If AttList(I).TagString = "TAG1" Then
                                                    ParentSymbolForm.ComponetTag.Text = AttList(I).TextString

               End If
               If AttList(I).TagString = "DESC1" Then
                                                    ParentSymbolForm.TextBoxDesc1.Text = AttList(I).TextString

               End If
               If AttList(I).TagString = "DESC2" Then
                                                    ParentSymbolForm.TextBoxDesc2.Text = AttList(I).TextString

               End If
               If AttList(I).TagString = "TERM01" Then
                                                    ParentSymbolForm.TextBoxPin1.Text = AttList(I).TextString

               End If
               If AttList(I).TagString = "POS1" Then
                                                    ParentSymbolForm.TextBoxSwPos1.Text = AttList(I).TextString

               End If

           Next

       End If


ParentSymbolForm.Show



   Else
       MsgBox "You did not select a block."
   End If
End Sub

[fixo]

Try this (see 'Select Case' statement in VBA Help)

Option Explicit
Dim oBlkRef As AcadBlockReference
Sub Change_it()
   Dim inspt As Variant
   Dim oEnt As AcadEntity
   Dim i
   ParentSymbolForm.Hide
   ThisDrawing.Utility.GetEntity oEnt, inspt, "Select object:"
   ' Checks if you selected a block.
   If TypeOf oEnt Is AcadBlockReference Then
       Set oBlkRef = oEnt
       ' Check for attributes.
       If oBlkRef.HasAttributes Then
           Dim AttList As Variant
           ' Build a list of attributes for the current block.
           AttList = oBlkRef.GetAttributes
           ' Cycle throught the list of attributes.
           For i = LBound(AttList) To UBound(AttList)
               ' Check for the correct attribute tag.
               If AttList(i).TagString = "TAG1" Then
                   ParentSymbolForm.ComponetTag.Text = AttList(i).TextString
               End If
               If AttList(i).TagString = "DESC1" Then
                   ParentSymbolForm.TextBoxDesc1.Text = AttList(i).TextString
               End If
               If AttList(i).TagString = "DESC2" Then
                   ParentSymbolForm.TextBoxDesc2.Text = AttList(i).TextString
               End If
               If AttList(i).TagString = "TERM01" Then
                   ParentSymbolForm.TextBoxPin1.Text = AttList(i).TextString
               End If
               If AttList(i).TagString = "POS1" Then
                   ParentSymbolForm.TextBoxSwPos1.Text = AttList(i).TextString
               End If
           Next
       End If

       ParentSymbolForm.Show

   Else
       MsgBox "You did not select a block."
   End If
End Sub

Private Sub SelectButton_Click()
   Call Change_it
End Sub

Private Sub ChangeButton_Click()
   Me.Hide
   Dim AttList As Variant
   Dim i
   ' Change attributes for the selected block.
   AttList = oBlkRef.GetAttributes
   ' Cycle throught the list of attributes.
   For i = LBound(AttList) To UBound(AttList)
       ' Check for the correct attribute tag.
       Select Case AttList(i).TagString
       Case "TAG1"
           AttList(i).TextString = ParentSymbolForm.ComponetTag.Text
       Case "DESC1"
           AttList(i).TextString = ParentSymbolForm.TextBoxDesc1.Text
       Case "DESC2"
           AttList(i).TextString = ParentSymbolForm.TextBoxDesc2.Text
       Case "TERM01"
           AttList(i).TextString = ParentSymbolForm.TextBoxPin1.Text
       Case "POS1"
           AttList(i).TextString = ParentSymbolForm.TextBoxSwPos1.Text
       End Select
   Next

End Sub

 

~'J'~

[BIGAL]

After getting the attributes maybe update them ?

 

attribs(1).TextString = txtx1

attribs(2).TextString = TXTY1

 

attribs(1).Update

attribs(2).Update

 

Just a question why do this ? If you double click a block it comes up with a form all ready allowing you to change any value. _eattedit

[fixo]

After getting the attributes maybe update them ?

 

attribs(1).TextString = txtx1

attribs(2).TextString = TXTY1

 

attribs(1).Update

attribs(2).Update

 

Just a question why do this ? If you double click a block it comes up with a form all ready allowing you to change any value. _eattedit

IMO 'Update' is optional in this case

 

~'J'~

[metal_pro]

After getting the attributes maybe update them ?

 

attribs(1).TextString = txtx1

attribs(2).TextString = TXTY1

 

attribs(1).Update

attribs(2).Update

 

Just a question why do this ? If you double click a block it comes up with a form all ready allowing you to change any value. _eattedit

 

For editing symbols using a custom form is much better then the standard Attribute Editor. I have attached a preliminary JPG of my form for editing electrical symbols. The Data I will need to change is presented in a much more orderly function and Attributes that do not normally require editing are hidden. Plus I will be able to add auto Tagging functions etc. to this form

[rickjamieh13]

Hello,

Can someone help me with this macro I have for starting a detail template?

Everything works fine for this macro, the text updates based on the input info, and the scale changes, but I cannot get the strings to change for the Block Name: "DETAIL LABEL".

I also need the Tag: "DETAILNAME" Value: "DETAIL NAME"

And the Tag: "FULL" and Value: "FULL" to update as well.

see below.

'This program is designed for automating the way details are created.
'There is a template file that is called from this program. It is called
'"dwgName" and its value is "C:\Users\holguinr\Documents\DG_Office\CAD\DG_CAD\Custom\Detail Library\DGFS_DET_TEMPLATE.dwg". Make sure
'that the path is correct for this file.
Private Sub CreateDetail()
Dim StrScale As Variant
Dim intSDI As Integer
Dim entity As Object
Dim sset As AcadSelectionSet
Dim msSpace As Object
Dim acadDoc As Object
Dim acadApp As Object
Dim strFileName As String
Dim StrScale2 As Variant
Set acadApp = GetObject(, "Autocad.Application")
   
   If Err Then
   MsgBox Err.Description
   Exit Sub
   End If
   
Set acadDoc = acadApp.ActiveDocument
' Open detail temp drawing
   Dim dwgName As String
   dwgName = "C:\Users\holguinr\Documents\DG_Office\CAD\DG_CAD\Custom\Detail Library\DGFS_DET_TEMPLATE.dwg"
   If Dir(dwgName) <> "" Then
      If intSDI = 0 Then
         ThisDrawing.Application.Documents.Open dwgName
      Else
         ThisDrawing.Open dwgName
      End If
   Else
       MsgBox "File " & dwgName & " does not exist."
       Unload Me
   End If
   
Dim strPath As String
strPath = ThisDrawing.Application.Path
   
Debug.Print strPath
'Set the drawing name and path
StrDwgName = "S:\ACA 2011 Support\Template\CA_Detail_Template.dwt"
ThisDrawing.SendCommand ("Filedia 0 ")
'Uncomment these lines if you want to be able to save the detail
'Check to see if file already exists
'Dim Fsys As New FileSystemObject
'Dim Msg, Style, Title, Help, Ctxt, Response, MyString
'Msg = "File Aready Exists, " & Chr(13) & "Do you wish to Overide?"   ' Define message.
'Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
'Title = "File Aready Exists"  ' Define title.
'strFileName = "R:\ACAD\DETAIL\TEMP\" & txtName.Value & ".dwg"
'If Fsys.FileExists(strFileName) Then
   ' Display message.
   'Response = MsgBox(Msg, Style, Title)
       'If Response = vbYes Then    ' User chose Yes.
          ' ThisDrawing.SendCommand ("_saveas 2000 " & strFileName & Chr(13))
           'ThisDrawing.SendCommand ("y ")
           'ThisDrawing.SendCommand ("Filedia 1 ")
       'Else    ' User chose No.
           'End
           'Unload Me
       'End If
   'Else
   'ThisDrawing.SendCommand ("_saveas 2000 " & strFileName & Chr(13))
'End If
'Set the scale for the drawing
'This can also be done with a control array
If Opt1.value = True Then
   StrScale = "Aec_Full_CA"
   StrSc = "FULL"
   StrScale2 = "1"
End If
If Opt2.value = True Then
   StrScale = "Aec_Half_Full_CA"
   StrSc = "HALF"
End If
If Opt3.value = True Then
   StrScale = "Aec_3_CA"
   StrSc = "3" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "4"
End If
If Opt4.value = True Then
   StrScale = "Aec_1_1-2_CA"
   StrSc = "1 1/2" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "8"
End If
If Opt5.value = True Then
   StrScale = "Aec_1_CA"
   StrSc = "1" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "12"
End If
If Opt6.value = True Then
   StrScale = "Aec_3-4_CA"
   StrSc = "3/4" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "16"
End If
If Opt7.value = True Then
   StrScale = "Aec_1-2_CA"
   StrSc = "1/2" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "24"
End If
If Opt8.value = True Then
   StrScale = "Aec_3-8_CA"
   StrSc = "3/8" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "32"
End If
If Opt9.value = True Then
   StrScale = "Aec_1-4_CA"
   StrSc = "1/4" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "48"
End If
If Opt10.value = True Then
   StrScale = "Aec_1-8_CA"
   StrSc = "1/8" & Chr(34) & "=1" & Chr(39) & "-0" & Chr(34)
   StrScale2 = "96"
End If


Debug.Print StrScale
Dim strCommand As String
Dim SC As Variant
Dim strheight As Double
Dim Height As Double
Dim limx As Double
Dim limy As Double
Dim strLimits As String
'set the drawing limits
limx = 6.8 * CDbl(StrScale2)
limy = (5 + (77 / 128)) * CDbl(StrScale2)
strLimits = CStr(limx) & "," & CStr(limy)
Debug.Print strLimits
'set the text height
strheight = CDbl(StrScale2)
Height = 0.09375 * strheight
Debug.Print "Height = " & Height
'set the scale value
SC = StrScale2
'scale the detail block to the proper scale
ThisDrawing.SendCommand ("_scale all  0,0 " & StrScale2 & " ")
'set the dimension scale
ThisDrawing.SendCommand ("-dimstyle " & "R" & Chr(13) & StrScale & Chr(13) & " ")
'set the linetype scale
ThisDrawing.SendCommand ("Ltscale " & StrScale2 & " ")
'regenerate drawing
ThisDrawing.SendCommand ("regen ")
'set the drawing limits
ThisDrawing.SendCommand ("limits" & Chr(13) & Chr(13) & strLimits & Chr(13))
'set the filedia variable to 1
ThisDrawing.SendCommand ("Filedia 1 ")
'set the text style for the drawing
ThisDrawing.SendCommand ("TEXTSTYLE" & Chr(13) & "Notes_CA" & Chr(13))
'set the text height for the drawing
ThisDrawing.SendCommand ("TEXTSIZE " & CStr(Height) & " ")
Debug.Print StrSc
Dim elem As Object
Dim found As Boolean
Dim txtStr As String
Dim txtTemp As String

txtStr = "Half"
   
' Cycle through the entities in the ModelSpace
' and change the text
  
   For Each elem In ThisDrawing.ModelSpace
       With elem
           If (.EntityName = "AcDbText") Or (.EntityName = "AcDbMText") Then
               ' Change the height of the text entity
               '.TextString = "test"
               '.Update
               'found = True
           'End If
               txtTemp = .TextString
                   If txtTemp = "FULL" Then
                   .TextString = StrSc
                   End If
                   If txtTemp = "DETAIL NAME" Then
                   .TextString = txtName
                   End If
               .Update
               found = True
           End If
       End With
       Set elem = Nothing
       
   Next elem
   Dim attributeObj As AcadAttribute
Dim Tag1 As String
Dim value1 As String
Tag1 = "DETAILNAME"
value1 = "DETAIL NAME"
Dim Tag2 As String
Dim value2 As String
Tag2 = "FULL"
value2 = "FULL"
   For Each elem In ThisDrawing.ModelSpace
       With elem
           If (.EntityName = AcadAttribute) Then
               ' Change the height of the text entity
               '.TextString = "test"
               '.Update
               'found = True
           'End If
               txtTemp = .TextString
                   If value2 = "FULL" Then
                   .TextString = StrSc
                   End If
                   If value1 = "DETAIL NAME" Then
                   .TextString = txtName
                   End If
               .Update
               found = True
           End If
       End With
       Set elem = Nothing
       
   Next elem
ThisDrawing.Application.ZoomExtents
ThisDrawing.Regen acAllViewports
Unload Me
End Sub
Private Sub CmdOk_Click()
Call CreateDetail
End Sub
Private Sub FrmScale_Click()
End Sub
Private Sub lblName_Click()
End Sub
Private Sub Opt10_Click()
End Sub
Private Sub Opt5_Click()
End Sub
Private Sub Opt6_Click()
End Sub
Private Sub txtName_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then CmdOk.SetFocus
End Sub
Private Sub CmdCancel_Click()
Unload Me
End
End Sub
Private Sub UserForm_Initialize()
Opt1.value = True
End Sub

New_det.zip

DGFS_DET_TEMPLATE.zip

Edited May 10, 2018 by SLW210
Code Tags Added

[SLW210]

Please read the Code Posting Guidelines and have your Code to be included in Code Tags.[NOPARSE]

Your Code Here[/NOPARSE]

=

Your Code Here

[rickjamieh13]

I did use the # sign icon and show my Code in the code box.

it doesn't change the text and code I am posting.