• ol-1
  • Участник
  • На форуме с 18 мая 2009г.
  • Сообщений: 16
  • Спасибо: 1

Тема: взять данные из автокада (текст) и экспортировать в VBA

Нужно считать определенный текст из автокада, т.е. выделить его и чтобы этот текст отобразился в VBA в TextBox. Заранее спасибо!!!

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: взять данные из автокада (текст) и экспортировать в VBA

Oleg пишет:

Нужно считать определенный текст из автокада, т.е. выделить его и чтобы этот текст отобразился в VBA в TextBox. Заранее спасибо!!!

Очень просто:

TextBox1.Text=myTextObj.TextString

~'J'~

  • ol-1
  • Участник
  • На форуме с 18 мая 2009г.
  • Сообщений: 16
  • Спасибо: 1

Re: взять данные из автокада (текст) и экспортировать в VBA

fixo. myTextObj объявлять как какой объект? и еще как зайти в автокад,чтобы выбрать текст
заранее спасибо

  • ol-1
  • Участник
  • На форуме с 18 мая 2009г.
  • Сообщений: 16
  • Спасибо: 1

Re: взять данные из автокада (текст) и экспортировать в VBA

помогите как выделить текст в автокаде?

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: взять данные из автокада (текст) и экспортировать в VBA

Oleg пишет:

помогите как выделить текст в автокаде?

Например так:

Dim oText as acadtext
dim oent as acadentity
dim pickpt as variant

Thisdrawing.Utility.Getentity oent, pickpt, vbcr & "Выбери текст"
if TypeOf oent is AcadText then
set oText = oent
msgbox oText.Textstring
End if

~'J'~

  • ol-1
  • Участник
  • На форуме с 18 мая 2009г.
  • Сообщений: 16
  • Спасибо: 1

Re: взять данные из автокада (текст) и экспортировать в VBA

fixo, спасибо,все получилось, а не мог бы ты еще подсказать код, чтобы выбрать сразу несколько однострочных текстов, а не по одному

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: взять данные из автокада (текст) и экспортировать в VBA

Oleg пишет:

fixo, спасибо,все получилось, а не мог бы ты еще подсказать код, чтобы выбрать сразу несколько однострочных текстов, а не по одному

Надо бы тебе немного в Хэлпе покопаться
Все оч просто

Option Explicit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Sub TextSelectionDemo()

Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oText As AcadText
Dim i As Long

Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "TEXT" ''<--если нужно выбрать и ТЕКСТ И МТЕКСТ замени на "*TEXT"

Dim dxftype As Variant
Dim dxfdata As Variant

dxftype = ftype
dxfdata = fdata

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
On Error GoTo Err_Control

          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add("$Texts$")
          End With
          
oSset.SelectOnScreen dxftype, dxfdata

MsgBox "Выбрано: " & oSset.Count & " текстов"

For Each oEnt In oSset

Set oText = oEnt

''тут меняешь какие нужно свойства к примеру добавляешь префикс и суффикс

oText.TextString = "Prefix-" & oText.TextString & "-Suffix"

oText.Update

Next

Exit_Here:
Exit Sub

Err_Control:

If Err.Number <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Exit_Here
End If

End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

~'J'~

  • ol-1
  • Участник
  • На форуме с 18 мая 2009г.
  • Сообщений: 16
  • Спасибо: 1

Re: взять данные из автокада (текст) и экспортировать в VBA

еще вопрос?
с помощью этого кода, fixo:
выбор происходит по индивидуальным номерам, т.е. как я понимаю каждому текстовому объекту присвоен свой номер, и в таком же порядке он он представляет этот выбор в VB, а не по порядку как расположены на чертеже (слева направо, а потом сверху вниз)
можешь помочь как сделать, чтобы выбор считывал слева направо, а потом сверху вниз
Заранее, огромное спасибо!!!

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: взять данные из автокада (текст) и экспортировать в VBA

Oleg пишет:

еще вопрос?
с помощью этого кода, fixo:
выбор происходит по индивидуальным номерам, т.е. как я понимаю каждому текстовому объекту присвоен свой номер, и в таком же порядке он он представляет этот выбор в VB, а не по порядку как расположены на чертеже (слева направо, а потом сверху вниз)
можешь помочь как сделать, чтобы выбор считывал слева направо, а потом сверху вниз
Заранее, огромное спасибо!!!

Переделай под свою ситуацию, настоящая рутина
просто перенумеровывает текст по порядку как в таблице

Option Explicit


Sub TableSortText()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oText As AcadText
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim i As Integer

On Error Resume Next
ThisDrawing.SelectionSets.Item("$Texts$").Delete
If Err Then
Err.Clear
End If
On Error GoTo 0
Set oSset = ThisDrawing.SelectionSets.Add("$Texts$")

ftype(0) = 0
fdata(0) = "TEXT"

oSset.SelectOnScreen ftype, fdata
'MsgBox oSset.Count '// debug only
ReDim txtArr(0 To oSset.Count - 1, 0 To 2) As Variant
For Each oEnt In oSset
Set oText = oEnt
txtArr(i, 0) = oText.ObjectID: txtArr(i, 1) = oText.InsertionPoint(0): txtArr(i, 2) = oText.InsertionPoint(1)
i = i + 1
Next
' sort objects by coordinate X by ascending
txtArr = TableSort(txtArr, 2, True)
' sort objects by coordinate Y by  descending
txtArr = TableSort(txtArr, 3, False)
For i = 0 To UBound(txtArr, 1)
Set oText = ThisDrawing.ObjectIdToObject(txtArr(i, 0))
oText.TextString = CStr(i + 1)
Next i
ThisDrawing.Regen acActiveViewport 'optional

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by fixo (Fateev O.I.) (c)2010 * all rights reserved '
' SourceArr - two-dimensional array '
' iPos - "column" number (starting from 1) '
' Ascending - boolean, if true then sort by ascending
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function TableSort(SourceArr As Variant, iPos As Integer, Ascending As Boolean) As Variant

Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer

iPos = iPos - 1
Check = False

Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1

If (IIf(Ascending = True, _
SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos), _
SourceArr(iCount, iPos) < SourceArr(iCount + 1, iPos))) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop

TableSort = SourceArr

End Function

~'J'~