VBA VisualBasic Editor garbling issue
[Problem] Japanese characters on the menus and code window get garbled
Visual Basic Editor does't support Unicode, even though VBA does.
Go to the system rocale in Windows control panel, and check the setting of language for programs that don't support Unicode. Switch it over to the language you desire and restart Windows.
VBA Clipboard trouble in Windows 10
How to find and set properties of shapes
Get and set the sizes of shapes
[Shape Width]
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth)
Return: String (e.g. "10 mm")
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = String
Shape.Cells("Width")
Return:Double
Shape.Cells("Width") = Double
[Shape Height]
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight)
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = Double
[PinX (Horizontal Position of the center of the shape)]
Shape.Cells("PinX")
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX)
Shape.Cells("PinX") = Double
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = Double
[PinY (Vertical Position of the center of the shape)]
Shape.Cells("PinY")
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY)
Shape.Cells("PinY") = Double
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = Double
[Font Size]
Shape.CellsSRC(visSectionCharacter, 0, visCharacterSize)
Shape.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = String (e.g. "1 mm")
[Font Color]
Shape.CellsSRC(visSectionCharacter, 0, visCharacterColor)
Shape.CellsSRC(visSectionCharacter, 0, visCharacterColor).FormulaU = String (e.g. "THEMEGUARD(RGB(255,0,0))")
[Line BeginX, BeginY, EndX, EndY]
Shape.Cells("BeginX")
Shape.Cells("BeginY")
Shape.Cells("EndX")
Shape.Cells("EndY")
Return: Double
Shape.Cells("BeginX") = Double
Shape.Cells("BeginY") = Double
Shape.Cells("EndX") = Double
Shape.Cells("EndY") = Double
[Line Pattern]
Shape.CellsSRC(visSectionObject, visRowLine, visLinePattern)
1: Solid
2: Long-Dash
9: Dash
Return: Integer(e.g. 1)
Shape.CellsSRC(visSectionObject, visRowLine, visLinePattern) = Integer
[Line Weight]
Shape.CellsSRC(visSectionObject, visRowLine, visLineWeight)
Return: String (e.g. "1.5 pt")
Shape.CellsSRC(visSectionObject, visRowLine, visLineColor) = String (e.g. "1.5 pt")
[Line Rounding]
Shape.CellsSRC(visSectionObject, visRowLine, visLineRounding)
Return: String (e.g. "3 mm")
Shape.CellsSRC(visSectionObject, visRowLine, visLineRounding).FormulaU =String (e.g. "3 mm")
Sample Code - Get the properties of the first shape selected and apply them to the other selected shapes
Sub setSamePropertyOfPrimaryShape()
Dim vsoSelection As Visio.Selection
Dim primaryShape As Visio.Shape 'first selected shape
Dim targetShape As Visio.Shape 'other selected shapes
Dim primaryShapePropsCount As Integer ' the number of properties of primaryShape
Dim PropArray() As Variant ' array to strage properties
Set vsoSelection = ActiveWindow.Selection 'current selection
Set primaryShape = vsoSelection.PrimaryItem 'set the first selected shape
primaryShapePropsCount = primaryShape.RowCount(Visio.visSectionProp)
With primaryShape
'Check if primaryShape has a property section
If .SectionExists(visSectionProp, 0) = False Then Exit Sub
ReDim PropArray(primaryShapePropsCount, 9)
For i = 0 To primaryShapePropsCount - 1
PropArray(i, 1) = .Section(visSectionProp).Row(i).NameU
PropArray(i, 2) = .CellsSRC(visSectionProp, i, visCustPropsLabel).FormulaU
PropArray(i, 3) = .CellsSRC(visSectionProp, i, visCustPropsType).FormulaU
PropArray(i, 4) = .CellsSRC(visSectionProp, i, visCustPropsFormat).FormulaU
PropArray(i, 5) = .CellsSRC(visSectionProp, i, visCustPropsLangID).FormulaU
PropArray(i, 6) = .CellsSRC(visSectionProp, i, visCustPropsCalendar).FormulaU
PropArray(i, 7) = .CellsSRC(visSectionProp, i, visCustPropsPrompt).FormulaU
PropArray(i, 8) = .CellsSRC(visSectionProp, i, visCustPropsValue).FormulaU
PropArray(i, 9) = .CellsSRC(visSectionProp, i, visCustPropsSortKey).FormulaU
Next
End With
For Each targetShape In vsoSelection
With targetShape
For i = 0 To primaryShapePropsCount - 1
'Check if the targetShape has a property that begins with Prop.
If .CellExists("Prop." & PropArray(i, 1), 0) = False Then
'If not, add a new row for the property
n = .AddRow(visSectionProp, visRowLast, visTagDefault)
End If
'Check if the name of the property is the same one as primaryShape
If .Section(visSectionProp).Row(i).NameU = PropArray(i, 1) Then
'Apply the properties of primaryShape to the target shape
.Section(visSectionProp).Row(i).NameU = PropArray(i, 1)
.CellsSRC(visSectionProp, i, visCustPropsLabel).FormulaU = PropArray(i, 2)
.CellsSRC(visSectionProp, i, visCustPropsType).FormulaU = PropArray(i, 3)
.CellsSRC(visSectionProp, i, visCustPropsFormat).FormulaU = PropArray(i, 4)
.CellsSRC(visSectionProp, i, visCustPropsLangID).FormulaU = PropArray(i, 5)
.CellsSRC(visSectionProp, i, visCustPropsCalendar).FormulaU = PropArray(i, 6)
.CellsSRC(visSectionProp, i, visCustPropsPrompt).FormulaU = PropArray(i, 7)
.CellsSRC(visSectionProp, i, visCustPropsValue).FormulaU = PropArray(i, 8)
.CellsSRC(visSectionProp, i, visCustPropsSortKey).FormulaU = PropArray(i, 9)
End If
Next
End With
Next
End Sub