Using Excel VBA to change TEXT in Autocad

[Anonymous]

Hello,

I am trying to create a drawing generator, in which the user can specify the dimensions of the item and then these dimensions are written in the drawing. The drawing already has the required text fields, so in the code I just need to get the right textstring and then edit its content. On the drawing it looks like this:

OD1:

OD2:

W:

ID:

T:

So for instance, I need to find the string containing "OD1:" and replace it with "OD1: Ø10 %%p 0.05" 

Does anyone know if I can do this using EXCEL VBA (Not VBA in autocad!) , and give an example of the required code? 

Thanks! 

[drslayer35]

I am trying to do the very same thing. I have a charted drawing that I need to feed text into the dimensions.

My cad files are embedded as OLE objects into excel. Have you found any information yet that may help. My results thus far are not too encouraging.

Thanks,

[Ed__Jobe]

The best way to do what you want is to fully constrain the dwg and drive the constraint dimensions with user parameters. However, vba can't access constraints and parameters. You need to use .Net for that. The best thing I can think of using vba is to create user variables in the dwg properties and then use fields to map the text to those properties. You can then use vba to update the file properties and then update the fields. However, this will only affect the text and not the actual dimension of your model.

[drslayer35]

Ed,

This is the workflow I have been trying to achieve. I have created custom properties in the drawing and placed them in the dimensions. I am having trouble accessing the custom properties thru VBA.

Any ideas?

[Anonymous]

This is the way....u can search about summaryinfo in help.

---

---

ThisDrawing.SummaryInfo.GetCustomByKey "ndoorfrWidth", FrameWidth
    If Err.Number <> 0 Then
       If DwgUnit = 2 Then
          FrameWidth = 0.115
       Else
          FrameWidth = 4.5
       End If
       ThisDrawing.SummaryInfo.AddCustomInfo "ndoorfrWidth", FrameWidth
       GoTo FrameWidth
    End If

[Anonymous · Accepted solution]

Yes I have solved the problem using code found here and via google. 

Sub AutocadInsertText(SearchText, Dimension, ToleranceString, ToleranceNumber, SpecialChar, useSearchText)
    ' MHJ april 2018
    'Tilføjer "Dimension" til textbox i autocad baseret på søgeordet "SearchText"
    
    ' https://forums.autodesk.com/t5/visual-basic-customization/extract-text-from-autocad-to-ms-excel/td-p/5515864
    Dim Application As AcadApplication
    Dim Document As AcadDocument
    Const SelectionObjectTypeName As String = "TEXT"      'to search for TEXT/AcDbText only
    Const SelectionSpace As String = "Model"              'to search in modelspace only
    Dim InsertionDone As Integer
    Dim test, test2 As Variant
    Dim Res As String
    
    On Error Resume Next
    Set Application = GetObject(, "AutoCAD.Application")
    Set Document = Application.ActiveDocument
    
    Dim Selection As AcadSelectionSet
    'filter definition for selection
    Dim Codes(1) As Integer
    Dim Values(1) As Variant
    Codes(0) = 0
    Values(0) = SelectionObjectTypeName    'that's to get only objects of type "TEXT"
    Codes(1) = 410
    Values(1) = SelectionSpace
    'create the selection
    Set Selection = Document.SelectionSets.Item("myTempSelSet")
    If Selection Is Nothing Then
        'then this selectionset didn't exist yet, so create a new one
        Set Selection = Document.SelectionSets.Add("myTempSelSet")
    End If
    Selection.Clear
    'now run the selection
    Err.Clear
    Selection.Select acSelectionSetAll, , , Codes, Values
    
    Dim tTextObj As acadText
    Dim tRowIndex As Integer: tRowIndex = 1
    For Each tTextObj In Selection
'        Excel.ActiveSheet.Cells(tRowIndex, 1) = tTextObj.TextString
'        Excel.ActiveSheet.Cells(tRowIndex, 2) = tTextObj.Layer
'        tRowIndex = tRowIndex + 1

        
        InsertionDone = 0
        test = tTextObj.TextString
        test2 = InStr(tTextObj.TextString, SearchText)
        If InStr(UCase(tTextObj.TextString), UCase(SearchText)) > 0 And InStr(UCase(tTextObj.TextString), UCase("Nom")) = 0 Then
            
            If InStr(UCase(tTextObj.TextString), UCase("%%p")) = 0 And useSearchText = 1 Then
                ' Fjern tolerance ved felter for %%p ikke er i
                ToleranceString = ""
                ToleranceNumber = ""
            End If
            If InStr(UCase(tTextObj.TextString), "SPOR") > 0 Then
                ' Søger for at den ikke skriver partnummer i sporstål feltet. Eks tætning 30311 bruger sporstål 30311, og så skrev den part nr i sporstål feltet.
                GoTo GoNext
            End If
            If InStr(UCase(tTextObj.TextString), "OPEN") > 0 Or InStr(UCase(tTextObj.TextString), "MS") > 0 Or InStr(UCase(tTextObj.TextString), "WR") Or InStr(UCase(tTextObj.TextString), "TR") > 0 Or InStr(UCase(tTextObj.TextString), "OX") Or InStr(UCase(tTextObj.TextString), "BX") Then
                ' Søger for at den ikke skriver partnummer i Program feltet. Eks tætning 30312 bruger program med 30312 i navnet, og så skrev den part nr i der :/.
                GoTo GoNext
            End If
            If useSearchText = 1 Then
                tTextObj.TextString = SearchText & SpecialChar & Dimension & " " & ToleranceString & " " & ToleranceNumber
            Else
                tTextObj.TextString = Dimension
            End If
            InsertionDone = 1
            Exit For
        End If
GoNext:
    Next
    
    If InsertionDone = 0 Then
        Res = MsgBox("Fandt ikke søgeteksten: " & SearchText & vbNewLine & "TJEK TEGNING GRUNDIGT!!", vbCritical)
    End If
 
End Sub

I call the macro using 

       InsertThis = OD1   ' Læbe OD
        ToleranceString = "%%p"
        ToleranceNumber = Sheets("Input").Range("F8").Value
        SearchText = "OD1:"
        SpecialChar = " "
useSearchText = 1 ' 1 or 0
        Call AutocadInsertText(SearchText, InsertThis, ToleranceString, ToleranceNumber, SpecialChar, useSearchText)

and I use this macro to check if autocad is open, if not open it and then also open the drawing I want to change. 

Sub AutocadOpenFile(Filename, folder)
    ' MHJ april 2018
    'Tjek om autocad er åbent og ellers så åben det.
    ' http://www.vbaexpress.com/forum/showthread.php?3514-Solved-open-acad-drawings-within-excel-VBA
    Dim AcadApp As AcadApplication
    Dim Res, path, filepath As String
    
    
    path = folder & Filename
    filepath = Dir( .... insert your folder here.... )
    ' Tjek om filnavn eksisterer i mappen
    If Dir(filepath) <> "" Then
        Res = MsgBox("Programmet fandt ikke masterfilen: " & Filename & vbNewLine & "på filstien: " & folder & vbNewLine & vbNewLine & "Tjek om filen overhovedet eksisterer som tegning", vbCritical, "Fandt ikke tegning :-(")
        End
    End If

    
    On Error Resume Next
    Set AcadApp = GetObject(, "AutoCAD.Application")
    If Err.Description > vbNullString Then
        Err.Clear
        Set AcadApp = CreateObject("AutoCAD.Application")
        
    End If
    AcadApp.Visible = True
    
     
    AcadApp.Documents.Add (path)
    On Error GoTo 0
End Sub