Hello Everyone,
After learning Inventor 2010 VBA over past year, I was able to create almost every macro I need for my work (print/convert all, drawing/part copy, automatic dimensioning etc...), mostly thanks to excellent built-in help in Inventor and plenty of very useful examples on internet.
But one important thing, which I cannot accomplish (or find anywhere) is to automatically create surface texture symbol and ATTACH it to diameter dimension.
Problem is with defining geometry Intent to attach surface texture symbol to. I am not able to get text extension line data (DiameterGeneralDimension object only has .dimensionline which is linesegment2D inside of hole geometry curve).
Only way I found, to create surface texture where I want it (under center of text on extension line), is If I create surface texture symbol manually, attach it to this point and then, by using selectset, I can get intent to which surface texture leader(1) is attached to. Then I can use this Intent to create another surface texture on the same spot. (Which is obviously not useful for automation)
So my question is: Is it possible to attach surface texture symbol to dimension text extension line using VBA? And if so, How?
Bellow is Function I use to create surface texture with ladder near dimension text (best I was able to achieve without error)
Public Function Pridej_drsnost_ke_kote(ByVal oPrumer_Kota As DrawingDimension) Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Dim oActiveSheet As sheet Set oActiveSheet = oDrawDoc.ActiveSheet Dim oTG As TransientGeometry Set oTG = ThisApplication.TransientGeometry Dim oLeaderPoints As ObjectCollection Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oPrumer_Kota.Text.Origin.x + 0.5, oPrumer_Kota.Text.Origin.y - 1.5)) Call oLeaderPoints.Add(oTG.CreatePoint2d(oPrumer_Kota.Text.Origin.x + 0.8, oPrumer_Kota.Text.Origin.y - 1.8)) Dim oSymbol As SurfaceTextureSymbol Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, kMaterialRemovalRequiredSurfaceType, False, False, False, "1,6") End Function
This is the result which I would like to achieve:
Thank you very much
Best Regards
Daniel
Try below VBA code if it works for you, say you have an active drawing document with a diameter dimension on the active sheet:
Sub AttachSurfaceTextureSymbolToDim() Dim oDoc As DrawingDocument Set oDoc = ThisApplication.ActiveDocument Dim oSheet As Sheet Set oSheet = oDoc.ActiveSheet Dim oDim As DiameterGeneralDimension Set oDim = oSheet.DrawingDimensions(1) Dim oGI As GeometryIntent Set oGI = oSheet.CreateGeometryIntent(oDim, oDim.Text.RangeBox.MinPoint) Dim oCol As ObjectCollection Set oCol = ThisApplication.TransientObjects.CreateObjectCollection oCol.Add ThisApplication.TransientGeometry.CreatePoint2d(12, 12) oCol.Add oGI Dim oText As SurfaceTextureSymbol Set oText = oSheet.SurfaceTextureSymbols.Add(oCol, kBasicSurfaceType, True, , , "Roughness") End Sub
Thank you for excelent tip Using text.rangebox never came into my mind.
Sadly, at least in Inventor 2010, your solution works only if dimension text is in few specific positions. If I compare this example to clock dial, then add surface texture to diameter dimension only works, if text is located in ranges 1 to 3 or 7 to 9 o'clock. In all other position metod SurfaceTextureSymbols.Add failed.
But this is only minor setback, because it is no problem to move dimension text to where i want it, add surface texture symbol (STS) and finaly move text back to original position. Also if I move text, so its X axis is aligned with drawing X axis then I can simply measure text width and place STS in middle, which is exactly what I wanted.
Only thing which remain unclear to me is, how to update drawing, that after moving dimension to its original position STS moves with it? (In code below i create another dimension and then delete it, to update drawing).
This code should do exactly what I wanted to achieve in my original post:
Sub AttachSurfaceTextureSymbolToDim() Dim oDoc As DrawingDocument Set oDoc = ThisApplication.ActiveDocument Dim oSheet As sheet Set oSheet = oDoc.ActiveSheet Dim oDim As DiameterGeneralDimension Set oDim = oSheet.DrawingDimensions(1) Dim oDimTextPoint As Point2d Set oDimTextPoint = oDim.Text.Origin Dim oDimIntent As GeometryIntent Set oDimIntent = oDim.Intent With ThisApplication.TransientGeometry oDim.Text.Origin = .CreatePoint2d(oDimIntent.Geometry.CenterPoint.x + 10, oDimIntent.Geometry.CenterPoint.y) Dim TextCenterPoint As Point2d Set TextCenterPoint = .CreatePoint2d(((oDim.Text.RangeBox.MinPoint.x + oDim.Text.RangeBox.MaxPoint.x) / 2) + 0.2, oDim.Text.RangeBox.MinPoint.y) Dim oGI As GeometryIntent Set oGI = oSheet.CreateGeometryIntent(oDim, TextCenterPoint) Dim oCol As ObjectCollection Set oCol = ThisApplication.TransientObjects.CreateObjectCollection oCol.Add .CreatePoint2d(TextCenterPoint.x, TextCenterPoint.y - 0.1) oCol.Add oGI End With Dim oText As SurfaceTextureSymbol Set oText = oSheet.SurfaceTextureSymbols.Add(oCol, kMaterialRemovalRequiredSurfaceType, False, False, False, "1,6") oDim.Text.Origin = oDimTextPoint 'I am doing this part below only because I don't know how to update drawing, to move surface texture symbol into right position Set oDim = oSheet.DrawingDimensions.GeneralDimensions.AddDiameter(oDimTextPoint, oDimIntent) oDim.Delete End Sub
Once more Thank You
Best Regards
It looks wierd that add a surface texture symbol fails because of dimension text orientation, can you attach data that can reproduce the problem?
To update a drawing document you can call DrawingDocument.Update.
It is definitely weird.
I added an example with 18 dimensions in attachment (It is meant for use with your code from post 2, by changing oSheet.DrawingDimensions number from 1 to 18).
From 18 dimensions works on my system only 4 (1,7,13,14), all other failed. I tested it on Inventor Professional 2010 SP2; SP3; SP4 (build 284, relase date 06/23/211) running on Windows 7 Ultimate 64 bit. On all service pack which I tested, I have the same result (except above mentioned 4 dimensions)...
Error: Run-time error '-2147467259 (8004005)': Method 'Add' of object 'Surface TextureSymbols' failed
Also update drawing by using thisdrawing.update (or update2) didn't work, because Surface Texture Symbol didn't move into right position, till I create something new on drawing. (Or move view, or edit TitleBlock, or do something similar). It seems like .update did not affect surface texture symbols.
Yes, the RangeBox currently could not work for the dimension text which is not vertical/horizontal alignment. And I think we need new property for dimension text to get the box of it for attach a leader to. But for now a workaround might be to change the dimension style to have dimension text alignment to be horizontal/vertical.
If the DrawingDocument.Update does not work, can you try Sheet.Update?