hi there,
inbetween I've worked with the list. The first was to add a functionality to sort the list alphabetically. Y'know- you add layers later and due to a late index they appear anywhere at the end.
The userform owns now 2 listboxes with MultiSelectMulti and a CommandButton (and some Labels).
The width of the ListBox depends on the layer's names.
The second is to choose the layer from ListBox2 (only!) and 'update' the shape's properties by pushing the button.
Currently it's for a single shape only- feel free to edit it.
The code is here - for whom it may interest.
Option Explicit
Private WithEvents winObj As Visio.Window
Private Sub sort()
ListBox1.BackColor = &H80000000
ListBox2.BackColor = &HFFFFFF
Dim i As Integer, j As Integer
i = ListBox1.ListCount
Dim laylist As String
Dim laylayer As Layer
Dim arLay() As String
Dim lIndex As Long
Dim lCount As Long
Dim fa As Variant
Dim fb As Variant
Set winObj = Application.ActiveWindow
With ListBox1
If .ListCount > 0 Then
lIndex = -1
For lCount = 0 To .ListCount - 1
'If .Selected(lCount) = True Then
lIndex = lIndex + 1
ReDim Preserve arLay(lIndex)
arLay(lIndex) = .List(lCount)
'End If
Next
End If
End With
QuickSort_Feld arLay, 0, lIndex, False
With ListBox2
lIndex = -1
For lCount = 0 To i - 1
lIndex = lIndex + 1
fa = Left(arLay(lCount), InStr(1, arLay(lCount), "-") - 1)
fb = Mid(arLay(lCount), InStr(1, arLay(lCount), "-") + 1, Len(arLay(lCount)) - InStr(1, arLay(lCount), "-"))
.AddItem fa
.List(.ListCount - 1, 1) = fb
Next
End With
End Sub
Private Sub CommandButton1_Click()
Dim a As String: a = Chr(34)
Dim b As String
Dim shp As Visio.Shape
Dim lay As Layer
Dim n
Dim sel As Visio.Selection
Set sel = ActiveWindow.Selection
sel.IterationMode = visSelModeSkipSuper
Dim listc As Integer
listc = ListBox2.ListCount
Dim i As Integer
For i = 0 To listc - 1
If ListBox2.Selected(i) = True Then
n = ListBox2.List(i, 1) - 1
a = a & n & Chr(59)
End If
Next i
a = Left(a, Len(a) - 1)
a = a & Chr(34)
If sel.Count = 1 Then
For Each shp In sel
shp.Cells("layerMember").FormulaU = a
Next shp
End If
End Sub
Private Sub UserForm_Initialize() 'Layer auslesen
Dim temp As String
Dim arVals() As String
Dim f As Variant
Dim fa As Variant
Dim fb As Variant
Dim laylist As String
Dim laylayer As Layer
Dim arLay() As String
ListBox2.BackColor = &H80000000
ListBox1.BackColor = &HFFFFFF
Set winObj = Application.ActiveWindow
ListBox1.Clear
For Each laylayer In ActivePage.Layers
laylist = laylist & laylayer.Name & "-" & laylayer.Index & ","
Next
laylist = Left(laylist, Len(laylist) - 1)
arVals = Split(laylist, ",")
With ListBox1
For Each f In arVals
.AddItem f
Next f
End With
sort
End Sub
Private Sub QuickSort_Feld(DasFeld, StartUnten, EndeOben, Absteigend As Boolean)
'QuickSort Standard
Dim iUnten As Long, iOben, iMitte, y
iUnten = StartUnten
iOben = EndeOben
iMitte = DasFeld((StartUnten + EndeOben) / 2)
While (iUnten <= iOben)
If Not Absteigend Then
While (DasFeld(iUnten) < iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte < DasFeld(iOben) And iOben > StartUnten)
iOben = iOben - 1
Wend
Else
While (DasFeld(iUnten) > iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte > DasFeld(iOben) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten <= iOben) Then
y = DasFeld(iUnten)
DasFeld(iUnten) = DasFeld(iOben)
DasFeld(iOben) = y
iUnten = iUnten + 1
iOben = iOben - 1
End If
Wend
If (StartUnten < iOben) Then Call QuickSort_Feld(DasFeld, StartUnten, iOben, Absteigend)
If (iUnten < EndeOben) Then Call QuickSort_Feld(DasFeld, iUnten, EndeOben, Absteigend)
End Sub
Private Sub winObj_SelectionChanged(ByVal Window As IVWindow)
Dim shp As Visio.Shape
Dim x As String
Dim a As Variant
Dim b As Integer
Dim c As String
Dim i As Integer
Dim j As Integer
Dim listc As Integer
Dim abc() As String
Dim layla As Layer
listc = ListBox1.ListCount
For i = 1 To listc
ListBox1.Selected(i - 1) = False
ListBox2.Selected(i - 1) = False
Next i
Dim sel As Visio.Selection
Set sel = ActiveWindow.Selection
sel.IterationMode = visSelModeSkipSuper
If sel.Count > 1 Then
MsgBox "Please select only one shape."
ElseIf sel.Count > 0 Then
For Each shp In sel
If shp.Cells("layerMember").FormulaU = "" Then Exit Sub
x = shp.Cells("layerMember").FormulaU '"a;b;c..." ein Wort
x = Left(x, Len(x) - 1) 'rechtes Anführungszeichen löschen
x = Right(x, Len(x) - 1) 'linkes Anführungszeichen löschen
abc = Split(x, ";")
i = 1
With ListBox1
For Each a In abc 'für jeden Layer des Objekts
b = a * 1 ' eine Zahl draus machen
Set layla = shp.Layer(i)
c = layla.Name ' den Namen aus dem Index ermitteln
.Selected(b) = True 'in der Liste markieren
i = i + 1 'nächster Layer
Next a
End With
i = 1
j = 1
With ListBox2
For Each a In abc 'für jeden Layer des Shapes
b = a * 1 'Zahl
Set layla = shp.Layer(i)
c = layla.Name ' c = Name des Layer
For j = 1 To ListBox2.ListCount ' alle listeneinträge durchgehen
If .List(j - 1, 0) = c Then 'wenn der Name in der Liste gleich Name Layer ist
ListBox2.Selected(j - 1) = True
End If
Next j
i = i + 1
Next a
End With
Next shp
End If
End Sub
sorry for German comments- it should be clear what happens.. it's just a remark for later use (as always).
a Special thank to Yacine for pushing into the right direction.
Peter
