[kat9ivesna]

Здравствуйте, я только начинаю разбираться в VBA, касающегося Autocad.

Возникла следующая задача: в чертеже есть однострочный текст, в конце его пишется L и после нее цифра (длина). Нужно эту длину просуммировать, текст при этом в чертеже есть и лишний многострочный и однострочный

Я сделала программку, которая суммирует длины, учитывая слои, но при этом при выполнении программы, приходится выбирать каждую строчку отдельно. Если выделить сразу весь чертеж длина не суммируется (0)
Помогите сделать так, чтобы можно было вообще не выделять текст, чтобы она работала для данного открытого чертежа, чтобы не надо было выделять отдельно текст.
Заранее благодарна

Код:

Код:

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

Sub qqq()
Dim intDXF(3) As Integer
  Dim varVal(3) As Variant
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objEnt As AcadText
  Dim strText As String
Dim l1a As Double
Dim l1u As Double
Dim l2a As Double
Dim l2u As Double
Dim k As Integer
l1a = 0
l1u = 0
l2a = 0
l2u = 0
k = 0
 On Error Resume Next
Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "Textonly" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("Textonly")
  ' Обеспечиваем фильтр выбора объектов
  intDXF(0) = -4
  varVal(0) = "<OR"
  intDXF(1) = 0
  varVal(1) = "MTEXT"
  intDXF(2) = 0
  varVal(2) = "TEXT"
  intDXF(3) = -4
  varVal(3) = "OR>"
  objSelSet.SelectOnScreen intDXF, varVal
  For Each objEnt In objSelSet
      k = Len(objEnt.TextString) - InStr(objEnt.TextString, "L")
  strTxt = Right(objEnt.TextString, k)
  If strTxt = "" Then
  strTxt = "0"
End If
If objEnt.Layer = "G1A" Then
  l1a = CDbl(strTxt) + l1a
    End If
  If objEnt.Layer = "G1U" Then
  l1u = CDbl(strTxt) + l1u
  End If
  If objEnt.Layer = "G2A" Then
  l2a = CDbl(strTxt) + l2a
  End If
  If objEnt.Layer = "G2U" Then
  l2u = CDbl(strTxt) + l2u
End If
Next
MsgBox ("Длина G1A " + Str(l1a))
MsgBox ("Длина G1U " + Str(l1u))
MsgBox ("Длина G2A " + Str(l2a))
MsgBox ("Длина G2U " + Str(l2u))
End Sub

[Олег (jr.)]

Пробуй снова

Код:

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

Option Explicit

' MAKE SURE YOU CHECK IN TOOLS --> OPTIONS --> GENERAL --> ERROR TRAPPING -->
' Break on Unhandled Errors !

Sub TryIt()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oText As AcadText
Dim fcode(3) As Integer
Dim fData(3) As Variant
Dim dxfCode, dxfData
Dim i As Integer
Dim tot As Double
Dim SetName As String

' create filter
fcode(0) = -4: fcode(1) = 0: fcode(2) = 8: fcode(3) = -4
' include the following entity types:
' TEXT:
fData(0) = "<and": fData(1) = "text": fData(2) = "G#@": fData(3) = "and>":
'
dxfCode = fcode
dxfData = fData
'
SetName = "$Total$"
' delete all selection sets to make sure that named selection does not exist
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .item(0).Delete
               Wend
          End With
' add empty selection into selectionsets collection
Set oSset = ThisDrawing.SelectionSets.Add(SetName)
' select on screen
oSset.SelectOnScreen dxfCode, dxfData
' display result
If oSset.Count > 0 Then

' create collection to store layer names
Dim lrColl As New Collection
''collect unique layer names into the collection for the future use
For Each oEnt In oSset
On Error Resume Next
lrColl.Add oEnt.Layer
Next
Dim item As Variant
' create collection to store pairs:  layer-lengths
Dim totColl As New Collection
Dim k As Integer

For Each item In lrColl
'create temp array for every pairs (layer-lengths)
Dim leg(0 To 1) As Variant
leg(0) = CStr(item)
leg(1) = 0#
' iterate through selection set
For Each oEnt In oSset
Set oText = oEnt
Dim legTxt As String
If oEnt.Layer = item Then
legTxt = oText.TextString
'check if letter "L" is contains in the text
If Not IsNull(InStr(legTxt, "L")) Then
'legTxt = Trim(Right(legTxt, Len(legTxt) - InStr(legTxt, "L")))
'replace comma with dot by suit
'legTxt = Replace(legTxt, ",", ".", 1, -1, vbTextCompare)
 k = Len(legTxt) - InStr(legTxt, "L")
  legTxt = Right(legTxt, k)
  If legTxt = "" Then
  legTxt = "0"
End If
'sum lengths in the last item in the temp array
leg(1) = leg(1) + CDbl(legTxt)
End If
End If
Next
'add array to collection
totColl.Add leg, CStr(item)

Next

Else
MsgBox "0 texts selected, try again"
End If
tot = 0#
Dim msg As String
'summary total length
For Each item In totColl
tot = tot + CDbl(item(1))
Next
For Each item In totColl
msg = msg & "Layer: " & item(0) & vbTab & CStr(Round(item(1), 3)) & vbCr
Next
msg = msg & vbCr & vbCr & "Total:" & vbTab & CStr(Round(tot, 3))
'display resulting message:

MsgBox "Result: " & vbCr & vbCr & msg, vbInformation, "Total Length"
'clean up collection
Set lrColl = Nothing
Set totColl = Nothing

End Sub

[kat9ivesna]

Пример текста, который нужно считать ∅25L21,56(суммируем то, что идет после L)
Спасибо за ответ, попробовала. Выдает ошибку на строке If lrColl Is Not Nothing Then
Ошибка invalid use of object

[Олег (jr.)]

Сообщение от kat9ivesna Пример текста, который нужно считать ∅25L21,56(суммируем то, что идет после L) Спасибо за ответ, попробовала. Выдает ошибку на строке If lrColl Is Not Nothing Then Ошибка invalid use of object

Пробуй еще раз код изменил

[kat9ivesna]

Теперь при выполнении макроса, когда просит выделить объекты, объекты не выделяются вообще((

[Олег (jr.)]

Сообщение от kat9ivesna Теперь при выполнении макроса, когда просит выделить объекты, объекты не выделяются вообще((

Копай глубже, може найдешь чего

[kat9ivesna]

Форумы я "люблю" вас.называется проще сделать самому.
Олег (jr.) спасибо за попытки

[gomer]

Странно, но у мну все ок сработало, может у вас ручки из эксцентрика растут, Катерин

[kat9ivesna]

gomer, точно оттуда(((текст был многострочный

[Олег (jr.)]

Сообщение от kat9ivesna Форумы я "люблю" вас.

Это называется проще задавай нормальные и точные вопросы