Author Topic: VBA for changing Autocad block attribute Value  (Read 489 times)

0 Members and 1 Guest are viewing this topic.

rickjamieh13

  • Mosquito
  • Posts: 1
VBA for changing Autocad block attribute Value
« on: May 11, 2018, 11:53:46 AM »
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

WILL HATCH

  • Bull Frog
  • Posts: 448
Re: VBA for changing Autocad block attribute Value
« Reply #1 on: May 11, 2018, 01:19:22 PM »
you won't find many attributereferences kicking around in modelspace, but you will find block references that own attributes. Grab the blocks, then for each attribute in the collection do your magic

BIGAL

  • Newt
  • Posts: 200
  • 30 + years of using Autocad
Re: VBA for changing Autocad block attribute Value
« Reply #2 on: May 11, 2018, 10:26:51 PM »
One of the nice things in VBA is the block attributes when retrieved can be referenced by their order att(1) etc rather than tag name.

Code: [Select]
For Cntr = 0 To SS.Count - 1

If SS.Item(Cntr).Name = BLOCK_NAME Then

     attribs = SS.Item(Cntr).GetAttributes
       
     If attribs(0).TextString = pitname Then
       pt1 = ThisDrawing.Utility.GetPoint(, " pick first point")

       txtx1 = CStr(FormatNumber(pt1(0), 3))
       TXTY1 = CStr(FormatNumber(pt1(1), 3))
       
        attribs(1).TextString = txtx1
        attribs(2).TextString = TXTY1
       
        attribs(1).Update
        attribs(2).Update
        Cntr = SS.Count
     
     Else: End If
     
 Else: End If

Next Cntr
A man who never made a mistake never made anything

BIGAL

  • Newt
  • Posts: 200
  • 30 + years of using Autocad
Re: VBA for changing Autocad block attribute Value
« Reply #3 on: May 18, 2018, 04:07:27 AM »
You need to get a block 1st then you can get the attribute

If (.EntityName = AcadAttribute) I suspect returns the error you PM to me.
A man who never made a mistake never made anything