dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA ожидание выбора точки

VBA ожидание выбора точки

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 07.11.2018, 21:56 #1
VBA ожидание выбора точки
Moker
 
Регистрация: 19.03.2010
Сообщений: 24

Moker вне форума Вставить имя

Добрый вечер!

Штудировал весь вечер поиск, то ли не так ищу, то ли еще чего... Так и не нашел решение которое бы работало.

У меня есть минипрограмма на VBA в Autocad :

Код:
[Выделить все]
Sub TwoPoints()
     
    Dim strLine(0 To 1) As String
    strLine(0) = "first"
    strLine(1) = "second"
        
    For i = 0 To 1
    ThisDrawing.ActiveLayer = ThisDrawing.Layers(strLine(i))
    ThisDrawing.SendCommand "_point" & vbCr
     
    Next i
    
End Sub
Она должна рисовать две точки в разных слоях (first и second) на экране где я нажму. Координат этих точек нет, я их определяю на глаз.
Однако, я не успею выбрать первую точку, цикл просто меня не ждет. Пробовал вставлять паузу - не помогло, тормозит весь макрос и сделать ничего нельзя.

Проверку на нажатие клавиши мыши сделать не получилось.

Вроде бы есть функции LISP Pause For Input User, но лисп вообще темный лес.

Спасибо.

Последний раз редактировалось Кулик Алексей aka kpblc, 07.11.2018 в 22:43.
Просмотров: 626
 
Непрочитано 07.11.2018, 22:51
#2
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,059


А если обойтись без SendCommand?
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 07.11.2018, 23:01
1 | #3
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 5,699


ThisDrawing.Utility.GetPoint
ну и ThisDrawing.ModelSpace.AddPoint скорее всего
Сергей812 вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 07.11.2018, 23:03
1 | #4
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,059


Как вариант:
Код:
[Выделить все]
Option Explicit
Option Base 0

Type tLayer
  Name As String
End Type

Public Sub test()
Dim arLayer(1) As tLayer
  arLayer(0).Name = "First"
  arLayer(1).Name = "Second"
Dim iCount As Integer
Dim cPt As Variant
Dim oPt As AcadPoint
Dim oLayer As AcadLayer

  
  iCount = 0
  While iCount <= UBound(arLayer)
    cPt = ThisDrawing.Utility.GetPoint(, "Check Point : ")
    Set oPt = ThisDrawing.ModelSpace.AddPoint(cPt)
    Set oLayer = ThisDrawing.Layers.Add(arLayer(iCount).Name)
    oPt.Layer = arLayer(iCount).Name
    ' Теоретически здесь можно и цвет задать, и тип линии, и все что угодно
    ' Хоть для точки, хоть для слоя
    iCount = iCount + 1
  Wend
End Sub
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 07.11.2018, 23:21
1 | #5
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 5,699


Немного добавлю - чтобы корректно выйти в середине процесса без "выброса" в код:
1. Перед циклом
Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
While iCount <= UBound(arLayer)
активируете обработчик ошибок
Код:
[Выделить все]
On Error Resume Next
2. После выбора точки:
Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
cPt = ThisDrawing.Utility.GetPoint(, "Check Point : ")
проверяете на наличие ошибок и выходите из процедуры при их наличии:
Код:
[Выделить все]
If Err Then Exit Sub
Сергей812 вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 07.11.2018, 23:36
#6
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,059


Сергей812, не спорю - я не пишу на VBA.
Offtop: P.S. В качестве оффтопа - если не сложно, сбрось(те) в ЛС вариант на C# - просто интересно посмотреть
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 08.11.2018, 09:40
#7
Moker


 
Регистрация: 19.03.2010
Сообщений: 24


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Как вариант:
Код:
[Выделить все]
Option Explicit
Option Base 0

Type tLayer
  Name As String
End Type

Public Sub test()
Dim arLayer(1) As tLayer
  arLayer(0).Name = "First"
  arLayer(1).Name = "Second"
Dim iCount As Integer
Dim cPt As Variant
Dim oPt As AcadPoint
Dim oLayer As AcadLayer

  
  iCount = 0
  While iCount <= UBound(arLayer)
    cPt = ThisDrawing.Utility.GetPoint(, "Check Point : ")
    Set oPt = ThisDrawing.ModelSpace.AddPoint(cPt)
    Set oLayer = ThisDrawing.Layers.Add(arLayer(iCount).Name)
    oPt.Layer = arLayer(iCount).Name
    ' Теоретически здесь можно и цвет задать, и тип линии, и все что угодно
    ' Хоть для точки, хоть для слоя
    iCount = iCount + 1
  Wend
End Sub
Всё заработало! Спасибо большое! С GetPoint у меня самого почему-то не получалось.
Только я убрал tLayer и сделал массив как String, и везде убрал .Name , т.к. basic начал ругаться на него.

Спасибо еще раз!
Moker вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 08.11.2018, 09:45
1 | #8
Boxa

КЖ; C#
 
Регистрация: 03.11.2005
Санкт-Петербург
Сообщений: 1,849


Думаю для пользы дела, а не в качестве оффтопа:
Код:
[Выделить все]
 using System;
using System.Collections.Generic;
using App = Autodesk.AutoCAD.ApplicationServices;
using Db = Autodesk.AutoCAD.DatabaseServices;
using Ed = Autodesk.AutoCAD.EditorInput;
using Rtm = Autodesk.AutoCAD.Runtime;

[assembly: Rtm.CommandClass(typeof(AddPoint.Commands))]
namespace AddPoint
{
    public class Commands
    {
        [Rtm.CommandMethod("AddPoint")]
        public static void AddPoint()
        {
            List<string> arLayer = new List<string>() { "First", "Second" };
            // Получение текущего документа и базы данных
            App.Document acDoc = App.Application.DocumentManager.MdiActiveDocument;
            if (acDoc == null) return;
            Db.Database acCurDb = acDoc.Database;
            Ed.Editor acEd = acDoc.Editor;

            foreach (string layer in arLayer)
            {
                Ed.PromptPointOptions pntOpt = new Ed.PromptPointOptions("\nPick a point");
                pntOpt.AllowNone = false;
                Ed.PromptPointResult pntRes = acEd.GetPoint(pntOpt);
                if (pntRes.Status != Ed.PromptStatus.OK) return;

                using (Db.Transaction acTrans = acCurDb.TransactionManager.StartOpenCloseTransaction())
                {
                    Db.BlockTableRecord acBlkTblRec = 
             acTrans.GetObject(acCurDb.CurrentSpaceId, Db.OpenMode.ForWrite) as Db.BlockTableRecord;
                    // Создание точки
                    Db.DBPoint acPoint = new Db.DBPoint(pntRes.Value);
                    acPoint.LayerId = crLayers(acCurDb, layer) != Db.ObjectId.Null ? 
                        crLayers(acCurDb, layer) : 
                        acCurDb.Clayer;
                    acPoint.SetDatabaseDefaults();
                    // Добавление нового объекта в запись таблицы блоков и в транзакцию
                    acBlkTblRec.AppendEntity(acPoint);
                    acTrans.AddNewlyCreatedDBObject(acPoint, true);
                    acTrans.Commit();
                }
            }
        }


        private static Db.ObjectId crLayers(Db.Database acCurDb, string layerName)
        {
            Db.ObjectId result = Db.ObjectId.Null;
            // старт транзакции
            using (Db.Transaction acTrans = acCurDb.TransactionManager.StartOpenCloseTransaction())
            {
                // Открытие таблицы слоев для чтения
                using (Db.LayerTable acLyrTbl = 
                    acCurDb.LayerTableId.Open(Db.OpenMode.ForWrite) as Db.LayerTable)
                {
                    if (!acLyrTbl.Has(layerName))
                    {
                        Db.LayerTableRecord acLyrTblRec = new Db.LayerTableRecord();
                        acLyrTblRec.Name = layerName;
                        //acLyrTblRec.Color = Autodesk.AutoCAD.Colors.Color.FromColorIndex(
                        //    Autodesk.AutoCAD.Colors.ColorMethod.ByAci, 1);

                        acLyrTblRec.Description = layerName + " создан программой";
                        acLyrTblRec.LineWeight = Db.LineWeight.LineWeight015;

                        acLyrTblRec.IsPlottable = true;
                        acLyrTblRec.IsOff = false;
                        acLyrTblRec.IsFrozen = false;
                        acLyrTblRec.IsLocked = false;

                        result = acLyrTbl.Add(acLyrTblRec);
                        acTrans.AddNewlyCreatedDBObject(acLyrTblRec, true);
                    }
                    else
                        result = acLyrTbl[layerName];
                }
                acTrans.Commit();
            }
            return result;
        }
    }
}
__________________
_бложиг

Последний раз редактировалось Boxa, 17.11.2018 в 09:45.
Boxa на форуме вставить имя Обратить внимание модератора на это сообщение  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > VBA ожидание выбора точки

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Не работает относительный ввод координат первой точки zaabifff AutoCAD 32 13.01.2017 14:42
Круги в точки Димас AutoCAD 11 26.06.2014 09:37
Как найти предельно допустимое расстояние от наиболее удаленной точки помещения до ближайшего эвакуационного выхода. RuMan Архитектура 1 21.12.2013 21:59
AutoCAD Civil 3D 2011 (Rus) - неактивна функция изменения стиля метки точки в палитре свойств rollstream Вертикальные решения на базе AutoCAD 5 13.11.2013 14:37
Как вычислить расстояние от точки до точки методами ActiveX? Supermax Программирование 31 20.11.2009 12:23

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||