Первая задача тоже решается, но несколько сложнее.
До оптимизации я не добрался, но принцип вроде работает.
Причина отказа при многократном нажатии скорее всего в том, что Visio очень долго выполняет перестановку шейпов. И во время перестановки оператор успевает нажать на кнопку еще раз. А некоторые шейпы уже переставлены. Но и предыдущий процесс не закончен.
Я предлагаю просто запустить макрос несколько раз. Для этого делаем следующее:
Если макрос почувствовал, что что-то нужно переставить, то начинаем отслеживать событие NoEventsPending. Причем отслеживаем его 3 раза, а потом уничтожаем переменную Dim WithEvents a As Visio.Application.
Код:
Dim WithEvents a As Visio.Application
Dim PendCount As Integer
Sub SetA()
PendCount = 3
Set a = ActiveDocument.Application
End Sub
Private Sub a_NoEventsPending(ByVal app As IVApplication)
Debug.Print "Pending " & Timer()
If PendCount > 0 Then
PendCount = PendCount - 1
Module1.ttt
Else
Set a = Nothing
End If
End Sub
А если макрос видит, что перестановка не нужна, то он не обращается к Sub SetA() и тем самым не ставит процесс на счетчик.
То есть все должно быстро вертеться до тех пор, пока порядок не станет нормальным.
По ходу экспериментов я разделил макрос на две части - проверка и исполнение. Но скорее всего можно обойтись и без этого. Код макроса:
Код:
Public Col As Collection
Sub ttt()
Dim shp As Visio.Shape
'On Error Resume Next
For Each shp In Application.ActiveWindow.Selection
If shp.CellExists("User.Index", 0) <> 0 Then
Set Col = New Collection
indx = shp.Index
Col.Add shp
indx1 = Application.ActivePage.Shapes.ItemFromID(1).Index
indx2 = Application.ActivePage.Shapes.ItemFromID(2).Index
Debug.Print "before " & CStr(shp.Index) & _
" " & CStr(ActivePage.Shapes.ItemFromID(1).Index) & _
" " & CStr(ActivePage.Shapes.ItemFromID(2).Index)
If (indx >= indx1) Then
s = Timer()
Col.Add Application.ActiveWindow.Page.Shapes.ItemFromID(1)
'Application.ActiveWindow.Page.Shapes.ItemFromID(1).bringtofront
'shp.Cells("User.Index").Formula = indx
Debug.Print s & " " & Timer()
End If
If (indx >= indx2) Then
s = Timer()
Col.Add Application.ActiveWindow.Page.Shapes.ItemFromID(2)
'Application.ActiveWindow.Page.Shapes.ItemFromID(2).bringtofront
'shp.Cells("User.Index").Formula = indx
Debug.Print s & " " & Timer()
End If
Debug.Print "after " & CStr(shp.Index) & _
" " & CStr(ActivePage.Shapes.ItemFromID(1).Index) & _
" " & CStr(ActivePage.Shapes.ItemFromID(2).Index)
End If
Next shp
If Col.Count > 1 Then
ThisDocument.SetA
tttExe
End If
End Sub
Sub tttExe()
If Col.Count > 1 Then
indx = Col(1).Index
For i = 2 To Col.Count
Col(i).bringtofront
Col(1).Cells("User.Index").Formula = indx
Next
Set Col = New Collection
End If
End Sub
Еще раз повторю, что оптимизацией не занимался, только хотел проверить принцип.
Отладочный мусор с функцией Timer() и Debug.Print убирать не стал.