Hi there,
neither in German or English environment I found an answer to the question:
Is it possible to create a shortcut in Visio 2010?
Actually I have to allocate hundreths of shapes to layers and always have to mouseclick layer -> add to layer... blabla.
I know, it's a more general question and I've read that it's possible to create a macro and I'm about to create one but I'm not really experienced with that. So if there is a solution out there I would appreciate any advice.
Thanks,
Peter
You can do more than one shape at a time ...
But other than that ...
ribbon File -> Options -> Quick Access Toolbar
Choose commands from: all commands
Scroll down to Assign to Layer
and click add.
The button is now on the quick access toolbar.
To extend Paul's advice, you can write a VBA form which once called lets you assign the layer to one shape after the other, or whole selections of shapes.
Make a form and add the following controls to it:
- a list, name it ListValue
- a text field, name it tValue
- a checkbox, name it CheckAktiv
Set the showmodal value of the form to false.
And here's the code:
Option Explicit
Private WithEvents winObj As Visio.Window
Private Sub ListValue_Change()
tValue.Value = ListValue.Value
End Sub
Private Sub UserForm_Initialize()
Dim temp As String
Dim arVals() As String
Dim f As Variant
temp = "Layer1,Layer2,Layer3"
arVals = Split(temp, ",")
With ListValue
For Each f In arVals
.AddItem f
Next f
End With
Set winObj = Application.ActiveWindow
End Sub
Private Sub winObj_SelectionChanged(ByVal Window As IVWindow)
Dim shp As Visio.Shape
Dim sel As Visio.Selection
Set sel = ActiveWindow.Selection
sel.IterationMode = visSelModeSkipSuper
If sel.Count > 0 And CheckAktiv.Value Then
For Each shp In sel
setValue shp, tValue.Value
Next shp
End If
End Sub
Private Function setValue(shp As Visio.Shape, layerName As String)
n = ActivePage.Layers(layerName).Index
shp.Cells("layerMember").FormulaU = Chr(34) & n - 1 & Chr(34)
End Function
Note:
- the layer names are hard coded. Change them to your needs or write something more dynamic.
- the layer is only assigned if the checkbox is checked. This way you can uncheck the checkbox, do something else, recheck and resume the assigning process
- the routine works with both single shapes and whole selections
- the listbox is there to let you chose which layer to assign
I use this tool on a daily basis - not for layers, but to populate prop fields.
Viel Erfolg,
Y.
Hi Paul,
yes, the 'button' Assign to layer is already at the toolbar. The toolbar is meanwhile a bit huge...
@yacine:
Thanks a lot!
I've changed the script like this and that works great!
Set winObj = Application.ActiveWindow
ListValue.Clear
For Each laylayer In ActivePage.Layers
laylist = laylist & laylayer.Name & ","
Next
laylist = Left(laylist, Len(laylist) - 1)
arVals = Split(laylist, ",")
With ListValue
For Each f In arVals
.AddItem f
Next f
End With
Writing code is a Little bit different from Excel but it's not rocket science ;)
Thanks a lot!!
Peter
But back to the question: is it possible to create own shortcuts? (as we know it from others)
Found this thread http://visguy.com/vgforum/index.php?topic=5424.0
I think you're better off with the macro above.
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