|
Новичок |
Зарегистрирован: 19 мар 2018, 14:10 Сообщений: 45 Использую Visio c: 2010 Очков репутации: 0
|
Данный "проект" реализовался быстрее, чем предыдущий..)) Получилось, по мне так, очень даже хорошо на схеме visio, где отображено более 1000 включений и неимоверное количество фигур, поиск теперь "летает" Как это выглядит: Код: Содержимое спрятано под спойлер ↓Код: 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
Приму все замечания и предложения к коду
|
|
|