Форум пользователей Visio

Форум по вопросам применения и программирования в Visio
Текущее время: 23 окт 2018, 03:21

Часовой пояс: UTC + 3 часа [ Летнее время ]


Правила форума


При размещении файлов предпочтительным является формат vsd (а не vsdx/vsdm)



Начать новую тему Ответить на тему  [ Сообщений: 100 ]  На страницу Пред.  1, 2, 3, 4, 5
Автор Сообщение
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 07 сен 2018, 13:23 
Гость писал(а):
Использовать правильные русские кавычки <<типа >>. Такие как автоматом вставляются в word.
Пишу с телефона
подчеркнул ключевое слово в приведенной выше цитате. попробовал ставить кавычки в тексте шейпа Visio Online Plan 2, при включенной русской раскладке жму кнопки Shift+2 - автоматом кавычки заменяются на рассово-правильные кавычки «ёлочки».
вот если скопировать в тексте фигуры обернутый в «ёлочки» фрагмент текста и вставить в текстовое поле/комбо-бокс на форме все работает корректно
К сожалению в ShapeSheet такой вариант не прокатывает. Можно использовать такой хинт
Изображение
эта картинка поможет набирать правильные кавычки при наличии дополнительного цифрового блока на клавиатуре.
Изображение
Hamit писал(а):
2. Даже при печати "по-русски" в данном форуме "правильные русские кавычки" не заменяются автоматом..))
ну это к администрации хостинга скорее вопрос !
Tumanov писал(а):
Вот этого делать не советую! Решив одну проблему, получите множество других.
у меня был нормоконтролер, который в студенческие годы поработал в типографии.
wiki в статье Кавычки писал(а):
Основные виды кавычек
Французские кавычки («ёлочки»)
«ёлочки»
Немецкие кавычки («лапки»)
„лапки“
Кавычки, используемые в русском языке
В русском языке традиционно применяются французские «ёлочки», а для кавычек внутри кавычек и при письме от руки — немецкие „лапки“[3]
поэтому на заре моей карьеры мне на эту тему активно выносили мозг!
долгие годы я использую именно эти кавычки, проблем не возникало. безусловно это не аргумент, поэтому хочется понять какие возможны потенциальные проблемы ?
ну а если уж хочется поиграться с заменой кавычек в шейпшите, вот вариант
Код:
SUBSTITUTE(SUBSTITUTE(SHAPETEXT(TheText)," "&CHAR(34)," "&CHAR(171)),CHAR(34),CHAR(187))


Пожаловаться на это сообщение
Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 07 сен 2018, 14:23 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1186
Очков репутации: 100588

Добавить очки репутацииУменьшить очки репутации
Цитата:
в студенческие годы поработал в типографии.

Я понял, откуда это идет.
Но сейчас мы живем не с типографиями, а с интернетом и связанными с ним технологиями. А там любое извращение обязательно когда-нибудь выходит боком.
Когда-нибудь вы подсунете пользователю текст, в котором "русские" кавычки превратятся в нечитаемый символ. Или в базе не сравнятся две строки, которые вроде бы обязательно должны были сравниться.
Это раньше пользователь смотрел глазами на напечатанную страницу.
Сейчас он видит текст, которые по пути до него прошел огромную кучу программного обеспечения. И каждый винтик в этой куче мог понять эти русскости или французскости по-разному. Что до вас дойдет в итоге - неизвестно.
Цитата:
Такие как автоматом вставляются в word

Кстати, Word не вставляет извращения автоматом. Он делает это только в случае применения специального настраиваемого списка замены. Хотя да, по умолчанию эта функция включена и ее нужно не забывать отключать.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 07 сен 2018, 16:05 
Tumanov писал(а):
Но сейчас мы живем не с типографиями
дело не в типографиях, а в традиционной орфографии нашего с вами русского языка
Параграфы, посвященные написанию географических и административно-территориальных названий и производных от них слов, названий органов власти, учреждений, организаций, обществ, партий, названий товарных знаков, марок изделий и сортов, нуждаются в дополнительных рекомендациях по применению кавычек в ряде наименований, актуальных для современной письменной речи и вызывающих затруднения у пишущих. К ним, в частности, относятся:
  • Наименования учреждений, организаций, представляющие собой реальные собственные имена, но выступающие в сочетании с родовым наименованием (как правило – обозначением организационно-правовой формы), например: ОАО «Московская типография № 2», государственная корпорация «Фонд содействия реформированию ЖКХ», государственное образовательное учреждение «Гимназия № 1517». Наличие родового слова приводит к написанию подобных наименований в кавычках; при употреблении без родового слова они в кавычки не заключаются: Московская типография № 2, Фонд содействия реформированию ЖКХ, гимназия № 1517.
Tumanov писал(а):
Сейчас он видит текст, которые по пути до него прошел огромную кучу программного обеспечения.
в этом вы правы, это настоящая боль !
Tumanov писал(а):
не сравнятся две строки, которые вроде бы обязательно должны были сравниться
для этого никакие экзотические кавычки не нужны. реальная ситуация на работе моей жены. есть некая база данных в которой содержатся заявки на выполнение ремонтных работ и отчеты подрядчиков о проделанных работах. жене нужно сначала выгрузить из базы эти две разные таблицы и потом в экселе выцепить какие из заявок закрыты, какие нет и где время закрытия заявки превышает регламентное. причин несовпадения множество, где-то подрядчик в названии организации-заявителя напишет ООО + три пробела + Рога и копыта. и это не совпадет с записью в списке клиентов.
где-то при экспорте таблицы с сайта в отдельные столбцы в конце или начале ячейки добавились лишние пробелы или другие непечатаемые знаки. вот и приходится им это удалять кто как может. кто руками, кто средствами экселя.
в итоге каждый вечер большим боссам выдают таблицу с диаграммами о процентах закрытия заявок-жалоб, от которого зависит их премия.
тут основная проблема скорее в качестве того самого софта, скриптов и т.п.


Пожаловаться на это сообщение
Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 07 сен 2018, 16:35 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Чувствуется, что "наболело"
Или, простите, «наболело»..))


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 13 сен 2018, 09:08 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
В общем почти готовый вариант получился таким:
phpBB [media]

Хочу и говорю огромное спасибо всем тем, кто помог разобраться и осуществить данный "проект".
Особенное спасибо господам:
Tumanov
Shishok
nbelyh
Прям жму ваши руки, Вы молодцы!
Следующее, за что возьмусь, это таки улучшить поиск в visio через свою UserForm, ибо встроенный не оптимален и "тупит".
С П А С И Б О :D


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 13 сен 2018, 10:27 
Вы тоже молодец, многому научились и проделали большую работу ! И самое главное не бросили свою затею :D
Также здорово, что у вас появляются новые идеи!!!!

А ведь в декабре прошлого года вы еще ничего не знали про макросы. Когда на форуме появляются люди готовые учиться, разбираться и творить, значит форум существует не зря ! :!:
Но существуют и другие персонажи: которые не первый год пасутся на этом форуме и других форумах, берутся программировать на разных языках, выклянчивают код, не желают прочесть рекомендованные книги или статьи и скверно выражаются. :x
Очень хотелось бы, чтобы форум способствовал увеличению количества энтузиастов, а не халявщиков «партнеров»!!


Пожаловаться на это сообщение
Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 03 окт 2018, 11:14 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Рискну продолжить данную тему, если по правилам форума требуется создать новую - прошу сообщить.
Ранее:
Shishok писал(а):
Вот сделал примерчик:

Изображение

Скачать FindShapes.zip
https://yadi.sk/d/qbpj9WI9d2eqF

Где shapes добавляются в отдельную коллекцию:
Код:
Private Sub AddToCol(sh, pg)  ' добавление элементов в коллекции
On Error GoTo ExitLine
    ShCol.Add sh.ID, Str(sh.ID) & "/" & Str(pg.Index) ' коллекция ID шейпов
    PgCol.Add pg.Name ' коллекция имен страниц
ExitLine:
End Sub

1. Почему в коллекцию добавляется не весь sh, а только его ID и "ключ", состоящий из текстового значения sh.ID/pg.Index?
Вот так не проще?:
Код:
Private Sub AddToColl(sh)
On Error Resume Next
    shColl.Add sh
    'Debug.Print "Item is add"
End Sub

2. Ну и заодно, подскажите, пожалуйста, как заменить имя ячейки данных фигуры, к примеру "Prop.Row_10" на "Prop.IP_address" в самой фигуре?
я тут обнаружил, что часть фигур на моей схеме имеет дефолтное имя одной из ячеек, хочу привести к единообразию.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 03 окт 2018, 11:52 
Цитата:
Рискну продолжить данную тему, если по правилам форума требуется создать новую - прошу сообщить
да кто вообще на этом форуме соблюдает какие-то условности ;)
Уж написали здесь, разделять тему уже никто не будет.
По п. 2 открывайте свойства фигуры и приводите к общему знаменателю. Ручками
Если очень много, включите макрорекордер измените одно поле ручками. Посмотрите как в полученном коде работает метод RowNameT


Пожаловаться на это сообщение
Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 03 окт 2018, 16:50 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
все таки придется обратиться за помощью с знатокам..))
весь день бьюсь на кодом, но не выходит каменный цветок..
Код:
Option Explicit
Dim sh As Visio.Shape
Dim shColl As Collection
Dim i As Integer
Dim txt As String

Private Sub FindData()
Set shColl = New Collection
Debug.Print "before: "; shColl.Count
'Const txt As String = "10.2."
On Error Resume Next
            Call AddToColl(sh)
        End If
    End If
    If sh.CellExists("Prop.IP_address", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.IP_address").ResultStr(visNone), txt) > 0 Then
'            Debug.Print "Name: "; sh.Name; " IP address: "; sh.CellsU("Prop.IP_address").ResultStr(visNone)
            Call AddToColl(sh)
        End If
    End If
Debug.Print "After: "; shColl.Count
For i = 1 To shColl.Count
    Debug.Print shColl.item(i).Name; " "; shColl.item(i).CellsU("Prop.Network_Name").ResultStr(visNone); " "; shColl.item(i).CellsU("Prop.Row_10").ResultStr(visNone)
Next i
Call Fill_ListView
End Sub

Private Sub AddToColl(sh)
On Error Resume Next
    shColl.Add sh
    'Debug.Print "Item is add"
End Sub
Private Sub Fill_ListView()
On Error Resume Next
    Dim i As Integer
    Dim itmx As ListItem
    ListViewFindResult.ListItems.Clear
'
    For i = 1 To shColl.Count
        With ActivePage.Shapes.ItemFromID(shColl.item(i))
        Set itmx = ListViewFindResult.ListItems.Add(, , .NameID)
            itmx.SubItems(1) = shColl.item(i)
'            itmx.SubItems(2) = shColl.item(i).CellsU("Prop.Network_Name").ResultStr(visNone)
        End With
    Debug.Print shColl.item(i)
    Next i
    ListViewFindResult.View = lvwReport
End Sub
Private Sub FindAll_Click()
    txt = FindTextBox.Value
    Call FindData
End Sub

Private Sub UserForm_Initialize()
    With ListViewFindResult.ColumnHeaders
        .Add , , "NameID": .Add , , "Hostname":
    End With
End Sub

Но не получается вывести в ListViewFindResult найденные значения.
Что не так?
Я, честно говоря, не особо разобрался с методом добавления Fill_ListView, не до конца понял весь принцип.
Думаю что где то в нем "собака зарыта".
Ну и очень странный баг:
на userform на ListView (ListViewFindResult) параметр "View" в разделе "Properties" почему то упорно возвращается каждый раз на "0-lvwIcon", хотя не раз выставлял значение "3-lvwReport"


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 04 окт 2018, 10:32 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Кажется разобрался сам..))
Вместо:
Код:
For i = 1 To shColl.Count
        With ActivePage.Shapes.ItemFromID(shColl.item(i))
        Set itmx = ListViewFindResult.ListItems.Add(, , .NameID)
            itmx.SubItems(1) = shColl.item(i)
'            itmx.SubItems(2) = shColl.item(i).CellsU("Prop.Network_Name").ResultStr(visNone)
        End With
    Debug.Print shColl.item(i)
    Next i

надо:
Код:
    For i = 1 To shColl.Count
        With ActivePage.Shapes.ItemFromID(shColl.item(i))
        Set itmx = ListViewFindResult.ListItems.Add(, , shColl.item(i).Name)
            itmx.SubItems(1) = shColl.item(i).CellsU("Prop.Network_Name").ResultStr(visNone)
'            itmx.SubItems(2) = shColl.item(i).CellsU("Prop.Network_Name").ResultStr(visNone)
        End With
    Debug.Print shColl.item(i).Name
    Next i

с багом 3-lvwReport тоже разобрался, использовав другой ListView, почему то у меня в списке доступных оказалось их 4 шт.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 08:36 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Как навести фокус на выбранную фигуру из ListView?
Как вообще навести фокус на выбранную фигуру?
гугл по тэгам "focus", "go to shape", "move cursor to shape", "follow to shape" и т.п. - не находит ничего полезного..
у самого visio есть вариант гиперссылки по субадресу, состоящему из имени фигуры, записанный макрос делает так:
Код:
Application.ActiveWindow.Page.Shapes.ItemFromID(26).Hyperlinks.Item(1).Follow

но для этого надо на фигуру навесить эту гиперссылку..

второй вариант, который я вижу, получить координаты shape и навести фокус на них

Как правильно то?


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 09:03 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1186
Очков репутации: 100588

Добавить очки репутацииУменьшить очки репутации
Что значит "навести фокус"?
Напрашивается - поместить в центр экрана. То есть сдвинуть экран так, чтобы нужный шейп попал в центр. Ну и масштаб изображения подправить.
Есть функция окна - expression.SetViewRect(dLeft, dTop, dWidth, dHeight),
где expression - это window.
Зная PinX, PinY и прибавляя какую-то дельту (масштаб изображения), можно рассчитать, координаты рисунка, которые мы хотим видеть по краям окна.
-----------
О, и вопрос похожий уже был...
viewtopic.php?f=6&t=295&st=0&sk=t&sd=a


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 09:35 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Спасибо за наводку, нашел там текст про CenterViewOnShape, сделал так:
Код:
Private Sub ListViewFindResult_ItemClick(ByVal Item As MSComctlLib.ListItem)
    ActiveWindow.Select ActivePage.Shapes(Item.Text), visDeselectAll + visSelect
    ActiveWindow.CenterViewOnShape ActivePage.Shapes(Item.Text), visCenterViewSelectShape
End Sub

вроде работает 8-)


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 13:37 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Очень интересное свойство..
На примере файла от Shishok, после формирования ListView первый столбец доступен для редактирования и, в случае изменения, приводит к ошибке:

Изображение
Каким образом можно запретить подобную возможность редактирования, почему то именно первого, столбца?

Поторопился я с постом..))
решение:
set LabelEdit to 1 - lvwManual


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 13:45 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1186
Очков репутации: 100588

Добавить очки репутацииУменьшить очки репутации
Не совсем понял, где Вы это редактируете...
Но само по себе NameID является самым главным идентификатором шейпа и не подлежит вмешательству. Так что, если Вы пытаетесь своим редактированием мешать Visio, то он естественно возмущается.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 05 окт 2018, 13:51 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Tumanov писал(а):
Не совсем понял, где Вы это редактируете...
Но само по себе NameID является самым главным идентификатором шейпа и не подлежит вмешательству. Так что, если Вы пытаетесь своим редактированием мешать Visio, то он естественно возмущается.

Это редактирование возможно в сформировавшемся ListView, при выборе строки почему то становится возможным редактировать NameID..
Помог параметр LabelEdit в настройках самого ListView


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 08 окт 2018, 09:44 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Данный "проект" реализовался быстрее, чем предыдущий..))
Получилось, по мне так, очень даже хорошо 8-)
на схеме visio, где отображено более 1000 включений и неимоверное количество фигур, поиск теперь "летает" :D
Как это выглядит:
Изображение
Изображение
Изображение
Код:
Код:
Option Explicit

Dim shColl As Collection
Dim i As Integer
Dim txt As String
Option Compare Text

Private Sub IPAddressCheckBox_Change()
    If IPAddressCheckBox = True Then
        HostnameCheckBox = False
        VlanCheckBox = False
        ClientNameCheckBox = False
        ClientAddressCheckBox = False
        FindTextCheckBox = False
    End If
End Sub
Private Sub HostnameCheckBox_Change()
    If HostnameCheckBox = True Then
        VlanCheckBox = False
        ClientNameCheckBox = False
        ClientAddressCheckBox = False
        FindTextCheckBox = False
        IPAddressCheckBox = False
    End If
End Sub
Private Sub VlanCheckBox_Change()
    If VlanCheckBox = True Then
        HostnameCheckBox = False
        ClientNameCheckBox = False
        ClientAddressCheckBox = False
        FindTextCheckBox = False
        IPAddressCheckBox = False
    End If
End Sub
Private Sub ClientNameCheckBox_Change()
    If ClientNameCheckBox = True Then
        HostnameCheckBox = False
        VlanCheckBox = False
        ClientAddressCheckBox = False
        FindTextCheckBox = False
        IPAddressCheckBox = False
    End If
End Sub
Private Sub ClientAddressCheckBox_Change()
    If ClientAddressCheckBox = True Then
        VlanCheckBox = False
        ClientNameCheckBox = False
        HostnameCheckBox = False
        FindTextCheckBox = False
        IPAddressCheckBox = False
    End If
End Sub
Private Sub FindTextCheckBox_Change()
    If FindTextCheckBox = True Then
        VlanCheckBox = False
        ClientNameCheckBox = False
        ClientAddressCheckBox = False
        HostnameCheckBox = False
        IPAddressCheckBox = False
    End If
End Sub

Private Sub FindIP()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes

    If sh.CellExists("Prop.Row_10", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.Row_10").ResultStr(visNone), txt) > 0 Then
'            Debug.Print "Name: "; sh.Name; " IP address: "; sh.CellsU("Prop.Row_10").ResultStr(visNone)
            Call AddToColl(sh)
        End If
    End If
    If sh.CellExists("Prop.IP_address", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.IP_address").ResultStr(visNone), txt) > 0 Then
'            Debug.Print "Name: "; sh.Name; " IP address: "; sh.CellsU("Prop.IP_address").ResultStr(visNone)
            Call AddToColl(sh)
        End If
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If

Call FillHostOrIP_ListView
End Sub
Private Sub FindHost()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes
    If sh.CellExists("Prop.Network_name", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.Network_name").ResultStr(visNone), txt) > 0 Then
            Call AddToColl(sh)
        End If
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If
Call FillHostOrIP_ListView
End Sub
Private Sub FindVlan()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes
    If sh.CellExists("Prop.ШПД_vlan", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.ШПД_vlan").ResultStr(visNone), txt) > 0 Then
            Call AddToColl(sh)
        End If
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If
Call FillClent_ListView
End Sub
Private Sub FindClientName()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes
    If sh.CellExists("Prop.ШПД_Клиент", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.ШПД_Клиент").ResultStr(visNone), txt) > 0 Then
            Call AddToColl(sh)
        End If
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If
Call FillClent_ListView
End Sub
Private Sub FindClientAddress()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes
    If sh.CellExists("Prop.ШПД_Адрес", 0) = -1 Then
        If InStr(1, sh.CellsU("Prop.ШПД_Адрес").ResultStr(visNone), txt) > 0 Then
            Call AddToColl(sh)
        End If
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If
Call FillClent_ListView
End Sub
Private Sub FindShapeText()
Dim sh As Visio.Shape
Set shColl = New Collection
On Error Resume Next
For Each sh In ActivePage.Shapes
    If InStr(1, sh.Characters.Text, txt) > 0 Then
        Call AddToColl(sh)
    End If
Next
If shColl.Count = 0 Then
    MsgBox "Ничего не найдено, попробуйте изменить критерии поиска"
    Exit Sub
End If
Call FillShapeFindText_ListView
End Sub
Private Sub AddToColl(sh)
On Error Resume Next
    shColl.Add sh
'    Debug.Print "Item is add"
End Sub
Private Sub FillHostOrIP_ListView()
On Error Resume Next
Dim i As Integer
Dim itmx As ListItem
Dim sh As Visio.Shape
ListViewFindResult.ColumnHeaders.Clear
ListViewFindResult.ListItems.Clear
With ListViewFindResult.ColumnHeaders
    .Add , , "NameID", 0: .Add , , "Hostname", 150: .Add , , "IP Address": .Add , , "BS Num", 40: .Add , , "Parent", 150:
End With
'
    For i = 1 To shColl.Count
'        With ActivePage.Shapes.ItemFromID(shColl.item(i))
        Set itmx = ListViewFindResult.ListItems.Add(, , shColl.Item(i).NameID)
            If shColl.Item(i).CellExists("Prop.Network_Name", 0) = -1 Then itmx.SubItems(1) = shColl.Item(i).Cells("Prop.Network_Name").ResultStr(visNone) Else itmx.SubItems(1) = "-"

            If shColl.Item(i).CellExists("Prop.Row_10", 0) = -1 Then
                itmx.SubItems(2) = shColl.Item(i).Cells("Prop.Row_10").ResultStr(visNone)
            Else
                If shColl.Item(i).CellExists("Prop.IP_address", 0) = -1 Then
                    itmx.SubItems(2) = shColl.Item(i).Cells("Prop.IP_address").ResultStr(visNone)
                Else
                    itmx.SubItems(2) = "-"
                End If
            End If
            If shColl.Item(i).CellExists("Prop.BS_num", 0) = -1 Then itmx.SubItems(3) = CInt(shColl.Item(i).Cells("Prop.BS_num").ResultStr(visNone)) Else itmx.SubItems(3) = "-"
            If shColl.Item(i).CellExists("Prop.Parent", 0) = -1 Then
                itmx.SubItems(4) = shColl.Item(i).Cells("Prop.Parent").ResultStr(visNone)
            Else
                If shColl.Item(i).CellExists("Prop.Row_6", 0) = -1 Then
                    itmx.SubItems(4) = shColl.Item(i).Cells("Prop.Row_6").ResultStr(visNone)
                Else
                    itmx.SubItems(4) = "-"
                End If
            End If
       
'            itmx.SubItems(2) = Switch(shColl.item(i).CellExistsU("Prop.Row_10", 0) = -1, shColl.item(i).CellsU("Prop.Row_10").ResultStr(visNone), shColl.item(i).CellExistsU("Prop.IP_address", 0) = -1, shColl.item(i).CellsU("Prop.IP_address").ResultStr(visNone))
'            Debug.Print shColl.Item(i).CellExistsU("Prop.Row_10", 0)
'            Debug.Print shColl.Item(i).CellExistsU("Prop.IP_address", 0)
'        End With
'    Debug.Print shColl.Item(i).Name
    Next i
'    ListViewFindResult.View = lvwReport
End Sub
Private Sub FillClent_ListView()
On Error Resume Next
Dim i As Integer
Dim itmx As ListItem
Dim sh As Visio.Shape
ListViewFindResult.ColumnHeaders.Clear
ListViewFindResult.ListItems.Clear
With ListViewFindResult.ColumnHeaders
    .Add , , "NameID", 0: .Add , , "Vlan", 30: .Add , , "Clent Name", 100: .Add , , "Address", 150: .Add , , "BS Num", 40: .Add , , "Parent", 150:
End With
    For i = 1 To shColl.Count
        Set itmx = ListViewFindResult.ListItems.Add(, , shColl.Item(i).NameID)
            If shColl.Item(i).CellExists("Prop.ШПД_vlan", 0) = -1 Then itmx.SubItems(1) = CInt(shColl.Item(i).Cells("Prop.ШПД_vlan").ResultStr(visNone)) Else itmx.SubItems(1) = "-"
            If shColl.Item(i).CellExists("Prop.ШПД_Клиент", 0) = -1 Then itmx.SubItems(2) = shColl.Item(i).Cells("Prop.ШПД_Клиент").ResultStr(visNone) Else itmx.SubItems(2) = "-"
            If shColl.Item(i).CellExists("Prop.ШПД_Адрес", 0) = -1 Then itmx.SubItems(3) = shColl.Item(i).Cells("Prop.ШПД_Адрес").ResultStr(visNone) Else itmx.SubItems(3) = "-"
           
            If shColl.Item(i).CellExists("Prop.ШПД_БС_номер", 0) = -1 Then itmx.SubItems(4) = CInt(shColl.Item(i).Cells("Prop.ШПД_БС_номер").ResultStr(visNone)) Else itmx.SubItems(4) = "-"
            If shColl.Item(i).CellExists("Prop.ШПД_Родитель", 0) = -1 Then
                itmx.SubItems(5) = shColl.Item(i).Cells("Prop.ШПД_Родитель").ResultStr(visNone)
            Else
                If shColl.Item(i).CellExists("Prop.Row_6", 0) = -1 Then
                    itmx.SubItems(5) = shColl.Item(i).Cells("Prop.Row_6").ResultStr(visNone)
                Else
                    itmx.SubItems(5) = "-"
                End If
            End If
    Next i
End Sub
Private Sub FillShapeFindText_ListView()
On Error Resume Next
Dim i As Integer
Dim itmx As ListItem
Dim sh As Visio.Shape
ListViewFindResult.ColumnHeaders.Clear
ListViewFindResult.ListItems.Clear
With ListViewFindResult.ColumnHeaders
    .Add , , "NameID", 0: .Add , , "Text Of Shape", 350:
End With
    For i = 1 To shColl.Count
        Set itmx = ListViewFindResult.ListItems.Add(, , shColl.Item(i).NameID)
            itmx.SubItems(1) = shColl.Item(i).Characters.Text
    Next i
End Sub
Private Sub FindAll_Click()
    If FindTextBox.Value = "" Then
        MsgBox "Не понятно что искать"
        Exit Sub
    End If
    If FindTextCheckBox = False And VlanCheckBox = False And ClientNameCheckBox = False And ClientAddressCheckBox = False And HostnameCheckBox = False And IPAddressCheckBox = False And txt = FindTextBox.Value Then
        MsgBox "Не понятно где искать"
        Exit Sub
    End If
    txt = FindTextBox.Value
    If IPAddressCheckBox = True Then Call FindIP
    If HostnameCheckBox = True Then Call FindHost
    If VlanCheckBox = True Then Call FindVlan
    If ClientNameCheckBox = True Then Call FindClientName
    If ClientAddressCheckBox = True Then Call FindClientAddress
    If FindTextCheckBox = True Then Call FindShapeText
   
End Sub
Private Sub FindTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Call FindAll_Click
End Sub
Private Sub ListViewFindResult_ItemClick(ByVal Item As MSComctlLib.ListItem)
    ActiveWindow.Select ActivePage.Shapes(Item.Text), visDeselectAll + visSelect
    ActiveWindow.CenterViewOnShape ActivePage.Shapes(Item.Text), visCenterViewSelectShape
End Sub

Private Sub ListViewFindResult_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader) ' сортировка при клике по заголовку
   
With ListViewFindResult
    .Sorted = False
    .SortKey = ColumnHeader.SubItemIndex
    'изменить порядок сортировки на обратный имеющемуся
    .SortOrder = Abs(.SortOrder Xor 1)
    .Sorted = True
End With 
End Sub

Приму все замечания и предложения к коду ;)


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 12 окт 2018, 14:09 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Кто нибудь подскажите, пожалуйста, как в VBA открыть файл из той же папки, где расположен файл visio?
т.е. заменить строку кода:
Код:
Set oWorkbook = GetObject("D:\Ðàçíûå îò÷åòû IT\BS_data_from_MC.xlsx")

на такую, чтобы не указывать конкретное местоположение, а брать данные в папке, где лежит файл visio, вызывающий макрос


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 12 окт 2018, 14:42 
например можно использовать свойство Path
Код:
Dim pth As String, ea As Object, wb As Object
Set ea = CreateObject("Excel.Application")
ea.Visible = True
pth = ActiveDocument.Path
Set wb = ea.workbooks.Open(pth & "OrgChartData.xlsx")


Пожаловаться на это сообщение
Вернуться к началу
  
Ответить с цитатой  
 Заголовок сообщения: Re: Атоматизация рисования схема visio через VBA
СообщениеДобавлено: 12 окт 2018, 14:57 
Не в сети
Новичок

Зарегистрирован: 19 мар 2018, 14:10
Сообщений: 45
Использую Visio c: 2010
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Гость писал(а):
например можно использовать свойство Path
Код:
Dim pth As String, ea As Object, wb As Object
Set ea = CreateObject("Excel.Application")
ea.Visible = True
pth = ActiveDocument.Path
Set wb = ea.workbooks.Open(pth & "OrgChartData.xlsx")

Примерно так и сделал, спасибо :)
Код:
Set oWorkbook = GetObject(Visio.Documents(1).Path & "\BS_data_from_MC.xlsx")


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 100 ]  На страницу Пред.  1, 2, 3, 4, 5

Часовой пояс: UTC + 3 часа [ Летнее время ]



Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
cron
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
Вы можете создать форум бесплатно PHPBB3 на Getbb.Ru, Также возможно сделать готовый форум PHPBB2 на Mybb2.ru
Русская поддержка phpBB