| Author |
 Topic  |
|
|
bdfy
Belarus
267 Posts |
 Posted - 02/05/2009 : 20:25:09
|
Есть набор точек узлов, которые нужно соединить линиями при этом нанося на линии опр. инфу (длина). Смартшейп такой линии я без проблем создал, но вытягивать шаблон и присоединять его крайние точки к узлам неудобно. рисовать хочется аки линиями. думаю единственный вариант, это макрос подмены линий на смартшейп написать.
quote:
Private Sub Document_ShapeAdded(ByVal vsoShape As Visio.IVShape)
Dim vsoMaster As Visio.Master
Dim vsoPage As Visio.Page
Dim vsoBegX As Visio.Cell
Dim vsoBegY As Visio.Cell
Dim vsoEndX As Visio.Cell
Dim vsoEndY As Visio.Cell
Dim vsoWidth As Visio.Cell
Dim strBowCell As String
Dim strBowFormula As String
Dim intIndex As Integer
Dim intCounter As Integer
'Set vsoCell to the Scratch.X1 cell and set its formula.
Set vsoBegX = vsoShape.Cells("BeginX")
Set vsoBegY = vsoShape.Cells("BeginY")
Set vsoEndX = vsoShape.Cells("EndX")
Set vsoEndY = vsoShape.Cells("EndY")
Set vsoWidth = vsoShape.Cells("Width")
MsgBox "длина " & vsoWidth * 25.4
End Sub
собственно на этом я и уперся ((
1. как определить что vsoShape именно линия ?
2. как правильно вытянуть на лист мастер ("line" в документе называется) ибо запись макроса дает длиннющий код...
|
|
|
Tumanov
Russia
1198 Posts |
Posted - 02/06/2009 : 18:46:49
|
1. Ненулевое значение (True) свойства OneD.
Можно дополнительно убедиться, что имеется ровно одна секция геометрии и в ней ровно три строки.
Debug.Print sh.OneD
Debug.Print sh.GeometryCount
Debug.Print sh.RowCount(visSectionFirstComponent)
И типы у строк должны быть 137, 138 и 139 (visTagComponent, visTagMoveTo и visTagLineTo соответственно)
Debug.Print sh.RowType(visSectionFirstComponent, 0)
Debug.Print sh.RowType(visSectionFirstComponent, 1)
Debug.Print sh.RowType(visSectionFirstComponent, 2)
И при этом не забывать, что придется отделять "нужные" линии от всех остальных линий.
2. Пример в статье http://visio.artberg.ru/biblio/st005.htm |
 |
|
|
bdfy
Belarus
267 Posts |
Posted - 02/06/2009 : 18:49:58
|
как то сложно в статье...
посидел еще вечер что-то получилось
quote:
Private Sub Document_ShapeAdded(ByVal vsoShape As Visio.IVShape)
Dim vsoMaster As Visio.Master
Set vsoMaster = vsoShape.Master
Dim vsoPage As Visio.Page
Dim vsoBegX As Visio.Cell
Dim vsoBegY As Visio.Cell
Dim vsoEndX As Visio.Cell
Dim vsoEndY As Visio.Cell
Dim vsoWidth As Visio.Cell
Dim strBowCell As String
Dim strBowFormula As String
Dim intIndex As Integer
Dim intCounter As Integer
'Set vsoCell to the Scratch.X1 cell and set its formula.
Set vsoBegX = vsoShape.Cells("BeginX")
Set vsoBegY = vsoShape.Cells("BeginY")
Set vsoEndX = vsoShape.Cells("EndX")
Set vsoEndY = vsoShape.Cells("EndY")
Set vsoWidth = vsoShape.Cells("Width")
Set vsoWidth = vsoShape.Cells("Width")
If (vsoMaster Is Nothing) Then
' vsoShape.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginX).FormulaU = vsoBegX & " mm"
Set vsoLine = Application.ActiveWindow.Page.Drop(Application.Documents.Item("G:\!!!#202;#243;#240;#241;#238;#226;#251;#229; #239;#238; #241;#229;#242;#255;#236;\#226;#224;#240;#232;#224;#237;#242;#251; #234;#238;#237;#244;#232;#227;#243;#240;#224;#246;#232;#232;.vsd").Masters.ItemU("line"), 0, 0)
vsoLine.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginX).FormulaU = vsoBegX
vsoLine.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginY).FormulaU = vsoBegY
vsoLine.CellsSRC(visSectionObject, visRowXForm1D, vis1DEndX).FormulaU = vsoEndX
vsoLine.CellsSRC(visSectionObject, visRowXForm1D, vis1DEndY).FormulaU = vsoEndY
'MsgBox "test " & Round(vsoWidth * 25.4, 1)
'Get the Master property of the shape.
End If
End Sub
работает в принципе. можно ехать дальше. |
|
|
|
bdfy
Belarus
267 Posts |
Posted - 02/08/2009 : 16:25:06
|
| не до конца здорово у меня получилось... ибо если линия была прилеплена к фигуре некой, "подмена" хоть и находится в тех же коорд. но не сцеплена получается. как получить к чему приклеена линия и приклеить так же новую ? |
|
|
|
Tumanov
Russia
1198 Posts |
Posted - 02/08/2009 : 19:41:04
|
К чему приклеена - получается через коллекцию Connects.
Примерно так
sh.Connects(1).ToSheet.NameID
А как прилепить, показано в уже упомянутой статье:
quote:
Получаем ссылку на ячейку шейп-листа, с значением начала коннектора
Set celBeginX = shpConnector.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginX)
Приклеиваем его к текущему шейпу
celBeginX.GlueTo elements(i).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX)
|
|
|
|
bdfy
Belarus
267 Posts |
Posted - 02/09/2009 : 19:00:57
|
нашел в справке код как все коннекты получить последовательно.
quote:
Set vsoConnects = vsoShape.Connects
For intCounter = 1 To vsoConnects.Count
Set vsoConnect = vsoConnects(intCounter)
Set vsoConnectTo = vsoConnect.ToSheet
Next intCounter
но как оказалось привязка мне все равно не поможет ((
ибо даже если в точке привязки сходятся несколько линии - привязка идет только к одной. и возвращаюется тоже одна фигура. что конечно логично.
задачку следовательно можно так выразить:
есть сеть. в простейшем варианте вида:
http://img15.imageshack.us/my.php?image=setvz6.jpg
узлы - один мастер-шейп. линии - другой.
нужно топологию составить по рисунку. т.е описать какие узлы ветви соединяют.
как я вижу:
выбрать все фигуры что под прямоугольником. выделить из них линии.
взять начало и конец линии и посмотреть есть ли в ближайшей окрестности точка узла. вот с этим проблемы. как вернуть ближайшую к точке фигуру заданного типа ? |
Edited by - bdfy on 02/09/2009 19:01:17 |
|
|
|
Tumanov
Russia
1198 Posts |
Posted - 02/09/2009 : 19:21:19
|
Если нужно выбрать шейпы в окрестности точки, пользуйтесь SpatialSearch.
Это примерно так. Здесь в Selection собираются все шейпы, лежащие в радиусе 2 дюймов от центра шейпа sh.
Dim shs As Visio.Selection
Set sh = ActiveWindow.Selection(1)
x = sh.Cells("PinX")
y = sh.Cells("PinY")
Set shs = sh.Parent.SpatialSearch(x, y, visSpatialContainedIn Or visSpatialTouching, 2, 0)
Останется только из выбранных выбрать шейпы нужного типа.
|
|
|
|
bdfy
Belarus
267 Posts |
Posted - 03/25/2009 : 20:15:28
|
вот такой код сейчас использую
Public Function replaceShape(ByVal vsoShape As Visio.IVShape, ByVal newmaster As String) As Visio.IVShape
Dim vsoBegX As Visio.Cell
Dim vsoBegY As Visio.Cell
Dim vsoEndX As Visio.Cell
Dim vsoEndY As Visio.Cell
Dim vsoWidth As Visio.Cell
'Set vsoCell to the Scratch.X1 cell and set its formula.
Set vsoBegX = vsoShape.Cells("BeginX")
Set vsoBegY = vsoShape.Cells("BeginY")
Set vsoEndX = vsoShape.Cells("EndX")
Set vsoEndY = vsoShape.Cells("EndY")
Set vsoWidth = vsoShape.Cells("Width")
Set vsoWidth = vsoShape.Cells("Width")
' vsoShape.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginX).FormulaU = vsoBegX & " mm"
' Set vsoLine = Drop(Application.Documents.Item("G:\!!!#202;#243;#240;#241;#238;#226;#251;#229; #239;#238; #241;#229;#242;#255;#236;\#226;#224;#240;#232;#224;#237;#242;#251; #234;#238;#237;#244;#232;#227;#243;#240;#224;#246;#232;#232;.vsd").Masters.ItemU("line"), 0, 0)
Set vsoNew = Application.ActiveWindow.Page.Drop(Application.Documents.Item("G:\!!!#202;#243;#240;#241;#238;#226;#251;#229; #239;#238; #241;#229;#242;#255;#236;\#226;#224;#240;#232;#224;#237;#242;#251; #234;#238;#237;#244;#232;#227;#243;#240;#224;#246;#232;#232;.vsd").Masters.ItemU(newmaster), 0, 0)
' expression.Drop(ObjectToDrop, xPos, yPos)
vsoNew.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginX).FormulaU = vsoBegX
vsoNew.CellsSRC(visSectionObject, visRowXForm1D, vis1DBeginY).FormulaU = vsoBegY
vsoNew.CellsSRC(visSectionObject, visRowXForm1D, vis1DEndX).FormulaU = vsoEndX
vsoNew.CellsSRC(visSectionObject, visRowXForm1D, vis1DEndY).FormulaU = vsoEndY
vsoShape.Delete
Set replaceShape = vsoNew
End Function
первый параметр - шейп который меняем, второй параметр - имя мастера на который надо заменить.
код заменяет фигуру на новую, вписывает координаты. но это еще не все. нужно скопировать shape data, контролы, углы вращения и т.п - все чем фигуры одного мастера могут отличатся на листе. как это сделать лучше чтобы ручками меньше кода писать ? можно было бы забить массив строк изменяемых - их не так много все таки. но функцию хочется универсальную для любых мастер-шейпов. |
Edited by - bdfy on 03/25/2009 20:16:23 |
|
|
|
Tumanov
Russia
1198 Posts |
Posted - 03/26/2009 : 15:50:59
|
Наверно можно было бы попробовать опрашивать сплошняком по индексам. Проверять, есть ли еще строки в секции, есть ли такая секция и т.д.
Только универсально все равно не получится. Если ячейки ссылаются друг на друга, то будет важен порядок копирования. В другом порядке формула может не прописаться. |
|
|
| |
Topic |
|
|
|
All Forums
Автозамена фигур на странице