- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I need to be able to project the connection points from sketched symbols to a drawing sketch. Since we can't project geometry from sketched symbols I fleshed out some code to do it. I know it won't be linked the the symbol entity but it's better than nothing.
The problem now is that the SketchToSheetSpace and SheetToSketchSpace methods of the drawing sketch object don't change the sketch coordinates to sheet coordinates, so the points that get added don't line up with the connection points on the symbols. I don't get any errors, there's just no coordinate conversion.
Do these methods work for sketched symbol drawings? Thanks!
Sub projectSymbol() Dim oDwg As DrawingDocument Set oDwg = ThisApplication.ActiveDocument Dim oSht As Sheet Set oSht = oDwg.ActiveSheet Dim symSketch As DrawingSketch Dim oSketch As DrawingSketch Dim sketchName As String sketchName = "SymbolSketch" 'Get or create the symbol sketch ----- For Each oSketch In oSht.Sketches If oSketch.name = sketchName Then Set symSketch = oSketch Exit For End If Next If symSketch Is Nothing Then Set symSketch = oSht.Sketches.Add symSketch.name = sketchName End If '------------ symSketch.Edit 'add unique symbol connection points to sketch ------ Dim oSym As SketchedSymbol Dim oSymPoint As SketchPoint Dim oPoint As Variant Dim ptColl As Collection: Set ptColl = New Collection Dim flag As Boolean Dim i Dim newPointDef As Point2d Dim newPoint As SketchEntity For Each oSym In oSht.SketchedSymbols For Each oSymPoint In oSym.Definition.Sketch.SketchPoints If oSymPoint.ConnectionPoint = True Then 'only transfer connection points flag = True 'reset the flag Set newPointDef = oSym.Definition.Sketch.SketchToSheetSpace(oSymPoint.Geometry) Debug.Print "Symbol Sketch: " & oSymPoint.Geometry.X & " | " & oSymPoint.Geometry.Y Debug.Print "New Point: " & newPointDef.X & " | " & newPointDef.Y & vbCrLf For i = 1 To ptColl.Count Set oPoint = ptColl.Item(i) If oPoint.X = oSymPoint.Geometry.X And oPoint.Y = oSymPoint.Geometry.Y Then flag = False Exit For End If Next If flag Then 'only add point if not duplicate Set newPoint = symSketch.SketchPoints.Add(symSketch.SheetToSketchSpace(newPointDef)) 'create the new point Call symSketch.GeometricConstraints.AddGround(newPoint) 'ground the new point Call ptColl.Add(oSymPoint.Geometry) 'save the point in the collection End If End If Next Next '----------- symSketch.ExitEdit End Sub
Solved! Go to Solution.