TheSwamp
Code Red => VB(A) => Topic started by: rickjamieh13 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
-
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
-
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.
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
-
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.