Перенос числовых данных из чертежа в программу

Julius · 31.10.2010, 14:36

Всем доброго времени суток.
Пишу макрос для автокада. Суть его в том, что пользователь выбирает щелчком мыши некоторые текстовые блоки (text и mtext) в которых содержаться числа. Затем, по окончанию выбора программа выдает сумму всех чисел в выбранных текстовых блоках.
Проблема в том, что я не знаю как присвоить переменной в программе значения числа в текстовом блоке (например, я выбираю на чертеже текстовый блок, в котором написано число 5 и некой переменной в программе присваивается значение 5).
Помогите, пожалуйста.
Заранее спасибо.

Кулик Алексей aka kpblc · 30.04.2015, 00:31

Это не цикл вешает AutoCAD, а неверное построение алгоритма. Вот решение, нарисованное на коленке и без какой бы то ни было оптимизации:

Код:

[Выделить все]

Option Explicit

Public Sub MultiplyText()
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim dRes As Double, dValue As Double
Dim objEnt As AcadEntity
Dim objText As AcadText, objMText As AcadMText
intType(0) = 0: varData(0) = "MTEXT,TEXT"

Dim ssName As String
Dim ssCur As AcadSelectionSet

  ssName = "dwgRuTextSelSet"
Do
On Error Resume Next
  ThisDrawing.SelectionSets(ssName).Delete
  Set ssCur = ThisDrawing.SelectionSets.Add(ssName)
On Error GoTo lErrorSelect
  ssCur.SelectOnScreen intType, varData
  dRes = 1: dValue = 0
  If ssCur.Count > 0 Then
    For Each objEnt In ssCur
      If objEnt.ObjectName = "AcDbText" Then
        Set objText = objEnt
        dValue = CDbl(Replace(Trim(objText.TextString), ".", ","))
      ElseIf objEnt.ObjectName = "AcDbMText" Then
        Set objMText = objEnt
        dValue = CDbl(Replace(Trim(objMText.TextString), ".", ","))
      End If
      If dValue <> 0 Then
        dRes = dRes * dValue
      End If
    Next
    ' Умножение построено. Теперь выводить...
    MsgBox "Res = " & CStr(dRes), vbOKOnly + vbInformation + vbApplicationModal
  Else
    GoTo lErrorSelect
  End If
Loop
  Exit Sub
lErrorSelect:
  MsgBox "Выбор прекращен", vbOKOnly + vbInformation + vbApplicationModal
End Sub

Тут можно и коллекции нарисовать, и массивы, и освобождать их по ходу дела - но мне лень.

scad2015 · 05.05.2015, 18:39

Цитата:

Сообщение от Julius

Summa = Summa + CDbl(item.TextString)

Я ничего не понимаю, эта строчка выдает Type mismatch, в чем проблема? Уже и так и сяк менял

gomer · 05.05.2015, 19:27

Цитата:

Сообщение от scad2015

Я ничего не понимаю, эта строчка выдает Type mismatch, в чем проблема? Уже и так и сяк менял

попробуй Val(), если не изменяет память

Кулик Алексей aka kpblc · 05.05.2015, 20:28

scad2015, во-первых: где чертеж? Во-вторых, у тебя разделителем целой и дробной частей установлена точка или запятая? Я проверял на ACAD2012 и 2013 (если мне не изменяет память) - у меня все работало в ожидаемом режиме.

scad2015 · 05.05.2015, 20:53

gomer, Кулик Алексей aka kpblc, Спасибо, разобрался.

Вся проблема именно в разделителе дробной части,
Offtop: который стоит в настройках в панели управления windows (региональные настройки - разделитель дробной части).

Val(item.TextString) - приводит числа только с десятичным разделителем точкой, если разделитель числа не точка, то он выдает значение до точки.

CDbl(item.TextString) - приводит числа с десятичным разделителем который установлен в системе.
//--------------------------------------------------------------------------

Решил сделать так: Summa = Summa + Val(Replace(item.TextString, ",", "."))

Теперь все работает =) ...и вроде без костылей...

В итоге:

Код:

[Выделить все]

Sub Summa()

Dim SelSetColl As AcadSelectionSets
Dim CirSet As AcadSelectionSet
Dim item As AcadEntity
Dim Summa As Double

For Each CirSet In ThisDrawing.SelectionSets
 If CirSet.Name = "Mt" Then
    CirSet.Delete
    Exit For
 End If
Next

Set SelSetColl = ActiveDocument.SelectionSets
Set CirSet = SelSetColl.Add("Mt")
CirSet.SelectOnScreen


For Each item In CirSet
   If item.ObjectName = "AcDbMText" Or item.ObjectName = "AcDbText" Then
     Summa = Summa + Val(Replace(item.TextString, ",", "."))
   End If
Next item

CirSet.Delete
Set CirSet = Nothing
Set SelSetColl = Nothing

'-----------Вставка текста суммы---------------------
ThisDrawing.Utility.Prompt "Выберите текст для вставки:"

Set SelSetColl = ActiveDocument.SelectionSets
Set CirSet = SelSetColl.Add("Mt")
CirSet.SelectOnScreen


For Each item In CirSet
   If item.ObjectName = "AcDbMText" Or item.ObjectName = "AcDbText" Then
     item.TextString = Summa
   End If
Next item


Summa = 0

End Sub

Кулик Алексей aka kpblc, я балда такая, пост 21 пропустил, извиняюсь, там уже все написано было. Невнимательность моя..... Спасибо!

pekar83 · 15.01.2016, 11:38

подскажите пожалуста
идея почти таже самя
щёлкаем мыщью то текстовым блока и они выводятся в таблицу excel или в Autocad на этом же листе

Tom2k7 · 15.01.2016, 13:43

Цитата:

Сообщение от pekar83

щёлкаем мыщью то текстовым блока и они выводятся в таблицу excel или в Autocad на этом же листе

как раз набросал недавно себе для скорости код для сбора в таблицу autocad-а текстовых полей
сначала выбирается существующая таблица
затем текстовые поля
непустая таблица дополняется и расширяется по мере того как

Код:

[Выделить все]

Public Sub Text2Table()
    Dim pnt As Variant
    Dim Obj As AcadObject
    Dim Tabl As AcadTable
    Dim Txt As AcadText
    Dim MTxt As AcadMText
    Dim i As Integer
    
 
    On Error Resume Next
    
    ThisDrawing.Utility.GetEntity Obj, pnt, "Pick a Table"
    
    If Err = 0 Then
        If TypeOf Obj Is AcadTable Then
            Set Tabl = Obj
            i = 0
            While Tabl.GetText(i, 0) <> ""
                i = i + 1
            Wend
            Do
                Err.Clear
                ThisDrawing.Utility.GetEntity Obj, pnt, "Pick a Text"
                If Err <> 0 Then Exit Do
                If TypeOf Obj Is AcadText Then
                    Set Txt = Obj
                    If Tabl.Rows <= i Then Tabl.InsertRows i, Tabl.GetRowHeight(0), 1
                    Tabl.SetText i, 0, Txt.TextString
                    i = i + 1
                End If
                If TypeOf Obj Is AcadMText Then
                    Set MTxt = Obj
                    If Tabl.Rows <= i Then Tabl.InsertRows i, Tabl.GetRowHeight(0), 1
                    Tabl.SetText i, 0, MTxt.TextString
                    i = i + 1
                End If

            Loop While True
        Else
            MsgBox "not table selected"
        End If
    Else
        Err.Clear
        MsgBox "nothing selected"
    End If
    On Error GoTo 0
End Sub

pekar83 · 16.01.2016, 04:07

спасибо большое сейчас буду пробовать
для это надо устанвливать https://knowledge.autodesk.com/suppo...odule-vba.html

pekar83 · 16.01.2016, 05:19

Цитата:

сначала выбирается существующая таблица

как выбрить существующюю таблицу
это какая таблица? внутри чертежа или xls

Кулик Алексей aka kpblc · 16.01.2016, 10:41

Offtop:

Цитата:

Сообщение от pekar83

как выбрить существующюю таблицу

Чего с ней сделать? Выбрить?

pekar83 · 16.01.2016, 15:57

подскажите как пользоваться
как выбирать таблицу
Autocad таблицу просит но как как выбрать не могу

Tom2k7 · 19.01.2016, 11:53

да, надо выбрать существующую таблицу акада
это сделано чтобы можно было дописывать в одну и ту же таблицу, если понадобится
таблицу, понятно, надо просто создать в акаде

pekar83 · 20.01.2016, 11:28

можно ли как нибуть дописать чтобы
разные числа слова выводились в первый столбик таблицы
а числа с % во второй столбик
спасибо

Tom2k7 · 20.01.2016, 14:59

ну примерно так
теперь таблица должна быть из двух столбцов

Код:

[Выделить все]

Public Sub Text2Table2()
    Dim pnt As Variant
    Dim Obj As AcadObject
    Dim Tabl As AcadTable
    Dim Txt As AcadText
    Dim MTxt As AcadMText
    Dim i, j As Integer
    Dim s As String
 
    On Error Resume Next
    
    ThisDrawing.Utility.GetEntity Obj, pnt, "Pick a Table"
    
    If Err = 0 Then
        If TypeOf Obj Is AcadTable Then
            Set Tabl = Obj
            i = 0
            j = 0
            While Tabl.GetText(i, 0) <> ""
                i = i + 1
            Wend
            While Tabl.GetText(j, 1) <> ""
                j = j + 1
            Wend
            Do
                Err.Clear
                ThisDrawing.Utility.GetEntity Obj, pnt, "Pick a Text"
                If Err <> 0 Then Exit Do
                s = ""
                If TypeOf Obj Is AcadText Then
                    Set Txt = Obj
                    s = Txt.TextString
                End If
                If TypeOf Obj Is AcadMText Then
                    Set MTxt = Obj
                    s = MTxt.TextString
                End If
                If s > "" Then
                    If InStr(s, "%") = 0 Then
                        If Tabl.Rows <= i Then Tabl.InsertRows i, Tabl.GetRowHeight(0), 1
                        Tabl.SetText i, 0, s
                        i = i + 1
                    Else
                        If Tabl.Rows <= j Then Tabl.InsertRows j, Tabl.GetRowHeight(0), 1
                        Tabl.SetText j, 1, s
                        j = j + 1
                    End If
                End If
            Loop While True
        Else
            MsgBox "not table selected"
        End If
    Else
        Err.Clear
        MsgBox "nothing selected"
    End If
    On Error GoTo 0
End Sub

pekar83 · 21.01.2016, 04:55

огромное спасибо всё работет

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Команда для экспорта ряда числовых значений из чертежа в Excel	AllA	AutoCAD	1	20.09.2010 10:22
Перенос данных из таблицы Автокада в Excel - дубль2	Таня.	AutoCAD	1	02.03.2009 16:08
Создание базы данных атрибутов текста чертежа в VBA	-still alive-	Программирование	4	26.08.2008 15:10
Параметрическое черчение в AutolLisp с использованием базы данных чертежа	Danger_pgs	LISP	31	02.04.2008 08:38

31.10.2010, 14:36
Перенос числовых данных из чертежа в программу Julius Регистрация: 30.10.2010 Сообщений: 5 Всем доброго времени суток. Пишу макрос для автокада. Суть его в том, что пользователь выбирает щелчком мыши некоторые текстовые блоки (text и mtext) в которых содержаться числа. Затем, по окончанию выбора программа выдает сумму всех чисел в выбранных текстовых блоках. Проблема в том, что я не знаю как присвоить переменной в программе значения числа в текстовом блоке (например, я выбираю на чертеже текстовый блок, в котором написано число 5 и некой переменной в программе присваивается значение 5). Помогите, пожалуйста. Заранее спасибо.
Просмотров: 9548

	Реклама i