UG刻字源码VB开发

tony609719845 · 发表于 2018-4-20 17:10

' ug刻字源码 +QQ 609719845
' into geometry using a true type font and
' extrude the result

Option Strict On

Imports System
Imports System.Drawing
Imports System.Drawing.Drawing2D
Imports System.Windows.Forms
Imports System.Collections
Imports NXOpen
Imports NXOpen.Features
Imports NXOpen.UF
Imports NXOpen.Utilities
Imports NXOpenUI

Module DrawText

Private sess As Session
Private ufSess As UFSession
Private origin(2) As Double
Private path As GraphicsPath
Private text As String
Private font As font
Private curves As New ArrayList
Private sketch1 As sketch
Private thickness As String
Private undoMarkId As Session.UndoMarkId

' Prompt the user to select a font.
' Return True if successful
' The Module level variable 'font' is set to the resulting font.
Function SelectFont() As Boolean
      Dim fontDlg As FontDialog = New FontDialog

      SelectFont = False
      If fontDlg.ShowDialog() = DialogResult.OK Then
         font = fontDlg.Font
         SelectFont = True
      End If
End Function
' Prompt the user to select a screen position
' Return True if successful
' The Module level variable 'origin' is set to the resulting point.
Function SelectPosition() As Boolean
      Dim view As Tag
      Dim response As Integer

      ufSess.Ui.LockUGAccess(UFConstants.UF_UI_FROM_CUSTOM)
      SelectPosition = False
      Try
         ufSess.Ui.SpecifyScreenPosition("选择字体", Nothing, IntPtr.Zero, origin, view, response)
         If response = UFConstants.UF_UI_PICK_RESPONSE Then
            SelectPosition = True
         End If
      Finally
         ' Restore UI state always including in case of error.
         ufSess.Ui.UnlockUgAccess(UFConstants.UF_UI_FROM_CUSTOM)
      End Try
End Function
' Prompt the user to input a text string to convert.
' Return True if successful
' The Module level variable 'text' is set to the resulting string.
Function SelectText() As Boolean
      text = NXInputBox.GetInputString("输入文字", "Enter String To Convert")
      SelectText = False
      If text.Length <> 0 Then
         SelectText = True
      End If
End Function
' Prompt the user to input an expresion text string to convert.
' Return True if successful
' The Module level variable 'thickness' is set to the resulting string.
Function SelectThickness() As Boolean
      thickness = NXInputBox.GetInputString("输入高度", "输入高度")
      SelectThickness = False
      If text.Length <> 0 Then
         SelectThickness = True
      End If
End Function
' Given a subset of the graphics path between the given indices
' create lines between the points in the path.
' Assumes that caller has selected an appropriate section of the path.
Sub CreateLinearPath(ByVal startIndex As Integer, ByVal endIndex As Integer)
      Dim j As Integer
      For j = startIndex To endIndex - 1
         Dim stpt As New Point3d
         Dim endpt As New Point3d
         stpt.x = path.PathPoints(j).X + origin(0)
         stpt.y = -path.PathPoints(j).Y + origin(1)
         stpt.z = 0
         endpt.x = path.PathPoints(j + 1).X + origin(0)
         endpt.y = -path.PathPoints(j + 1).Y + origin(1)
         endpt.z = 0
         curves.Add(sess.Parts.Work.Curves.CreateLine(stpt, endpt))
      Next
End Sub
' Given a subset of the graphics path between the given indices
' create splines between the points in the path.
' The path contains bezier segments and this converts then to B-splines.
' Assumes that caller has selected an appropriate section of the path.
Sub CreateSplinePath(ByVal startIndex As Integer, ByVal endIndex As Integer)
      Dim j As Integer
      For j = startIndex To endIndex - 1 Step 3
         Dim poles(3, 3) As Double
         Dim k As Integer
         For k = 0 To 3
            poles(k, 0) = path.PathPoints(j + k).X + origin(0)
            poles(k, 1) = -path.PathPoints(j + k).Y + origin(1)
            poles(k, 2) = 0
            poles(k, 3) = 1
         Next
         Dim knots() As Double = {0, 0, 0, 0, 1, 1, 1, 1}
         Dim spl As UFCurve.Spline
         Dim spline As Tag
         Dim num_states As Integer
         Dim states() As UFCurve.State = Nothing
         spl.start_param = 0
         spl.end_param = 1
         spl.is_rational = 0
         spl.num_poles = 4
         spl.order = 4
         spl.knots = knots
         spl.poles = poles
         ufSess.Curve.CreateSpline(spl, spline, num_states, states)
         curves.Add(NXObjectManager.Get(spline))
      Next
End Sub
' Create a sketch and add all curves we've created to it.
' Most of this was created by recording create a sketch and editting the result.
' Retries with different sketch names to avoid duplicate names.
Sub CreateSketch()
      Dim theSession As Session = Session.GetSession()
      Dim workPart As Part = theSession.Parts.Work
      Dim displayPart As Part = theSession.Parts.Display

      Dim markId1 As Session.UndoMarkId
      markId1 = theSession.SetUndoMark(Session.MarkVisibility.Visible, "Start")

      Dim nullSketch As Sketch = Nothing

      Dim sketchInPlaceBuilder1 As SketchInPlaceBuilder
      sketchInPlaceBuilder1 = workPart.Sketches.CreateSketchInPlaceBuilder2(nullSketch)

      Dim unit1 As Unit = CType(workPart.UnitCollection.FindObject("Inch"), Unit)

      Dim expression1 As Expression
      expression1 = workPart.Expressions.CreateSystemExpressionWithUnits("0", unit1)

      Dim expression2 As Expression
      expression2 = workPart.Expressions.CreateSystemExpressionWithUnits("0", unit1)

      theSession.SetUndoMarkName(markId1, "'Create Sketch Dialog")

      Dim markId2 As Session.UndoMarkId
      markId2 = theSession.SetUndoMark(Session.MarkVisibility.Invisible, "Create Sketch")

      theSession.DeleteUndoMark(markId2, Nothing)

      Dim markId3 As Session.UndoMarkId
      markId3 = theSession.SetUndoMark(Session.MarkVisibility.Invisible, "Create Sketch")

      ' Inferring constraints and auto dimensions may take long time and is not really required for drawing text.
      theSession.Preferences.Sketch.CreateInferredConstraints = False
      theSession.Preferences.Sketch.ContinuousAutoDimensioning = False
      theSession.Preferences.Sketch.DimensionLabel = Preferences.SketchPreferences.DimensionLabelType.Expression
      theSession.Preferences.Sketch.TextSizeFixed = True
      theSession.Preferences.Sketch.FixedTextSize = 0.12
      theSession.Preferences.Sketch.ConstraintSymbolSize = 3.0
      theSession.Preferences.Sketch.DisplayObjectColor = False
      theSession.Preferences.Sketch.DisplayObjectName = False

      Dim nXObject1 As NXObject
      nXObject1 = sketchInPlaceBuilder1.Commit()
      sketch1 = CType(nXObject1, Sketch)

      Dim markId4 As Session.UndoMarkId
      markId4 = theSession.SetUndoMark(Session.MarkVisibility.Invisible, "update")

      Dim nErrs1 As Integer
      nErrs1 = theSession.UpdateManager.DoUpdate(markId4)

      sketch1.Activate(sketch.ViewReorient.False)

      Dim curve As DisplayableObject
      For Each curve In curves
         Try
            sess.ActiveSketch.AddGeometry(curve)
         Catch ex As Exception
            MessageBox.Show("Could not add: " + curve.ToString + " to sketch " + ex.Message)
         End Try
      Next

      sess.ActiveSketch.Deactivate(sketch.ViewReorient.False, sketch.UpdateLevel.Model)

      theSession.DeleteUndoMark(markId3, Nothing)
      theSession.SetUndoMarkName(markId1, "Create Sketch")
      sketchInPlaceBuilder1.Destroy()

      Try
         ' 'Expression is still in use.
         workPart.Expressions.Delete(expression2)
      Catch ex As NXException
         ex.AssertErrorCode(1050029)
      End Try

      Try
         ' 'Expression is still in use.
         workPart.Expressions.Delete(expression1)
      Catch ex As NXException
         ex.AssertErrorCode(1050029)
      End Try

End Sub
' Extrude the sketch
Sub CreateExtrusion()

      Dim nullFeature As Feature = Nothing

      Dim extrudeBuilder1 As Features.ExtrudeBuilder
      extrudeBuilder1 = sess.Parts.Work.Features.CreateExtrudeBuilder(nullFeature)

      Dim section1 As Section
      section1 = sess.Parts.Work.Sections.CreateSection(0.000001, 0.001, 0.5)

      Dim featureArray1(0) As Feature
      featureArray1(0) = sketch1.Feature
      Dim curveFeatureRule1 As CurveFeatureRule
      curveFeatureRule1 = sess.Parts.Work.ScRuleFactory.CreateRuleCurveFeature(featureArray1)

      Dim rules(0) As SelectionIntentRule
      rules(0) = curveFeatureRule1
      Dim geoms() As NXObject = sketch1.GetAllGeometry()
      Dim helpPoint As Point3d = New Point3d(0, 0, 0)
      section1.AddToSection(rules, geoms(0), Nothing, Nothing, helpPoint, Section.Mode.Create)

      extrudeBuilder1.Section = section1

      Dim direction1 As NXOpen.Direction
      direction1 = sess.Parts.Work.Directions.CreateDirection(sketch1, Sense.Forward, SmartObject.UpdateOption.WithinModeling)
      extrudeBuilder1.Direction = direction1

      extrudeBuilder1.Limits.StartExtend.Value.RightHandSide = "0"
      extrudeBuilder1.Limits.EndExtend.Value.RightHandSide = thickness

      Dim featureOptions1 As GeometricUtilities.FeatureOptions
      featureOptions1 = extrudeBuilder1.FeatureOptions
      featureOptions1.BodyType = GeometricUtilities.FeatureOptions.BodyStyle.Solid

      Dim feature5 As Feature
      feature5 = extrudeBuilder1.CommitFeature()

      extrudeBuilder1.Destroy()

End Sub
' Main routine for this journal
Sub Main()
      sess = Session.GetSession()
      ufSess = UFSession.GetUFSession()

      If Not SelectFont() Then
         Return
      End If
      If Not SelectText() Then
         Return
      End If
      If Not SelectPosition() Then
         Return
      End If

      undoMarkId = sess.SetUndoMark(Session.MarkVisibility.Visible, "Create geometry from text")

      path = New GraphicsPath(FillMode.Alternate)
      Dim zero As New System.Drawing.Point(0, 0)
      Dim format As StringFormat = StringFormat.GenericDefault
      path.AddString(text, font.FontFamily, font.Style, font.SizeInPoints, zero, format)

      Dim bounds As RectangleF = path.GetBounds()
      Dim gpi As New GraphicsPathIterator(path)
      gpi.Rewind()

      origin(0) -= bounds.Left
      origin(1) += bounds.Bottom

      Dim iSubPath As Integer
      Dim subPathCount As Integer = gpi.SubpathCount

      For iSubPath = 0 To subPathCount - 1
         Dim mySubPaths As Integer
         Dim IsClosed As Boolean
         Dim subPathStartIndex, subPathEndIndex As Integer
         Dim stpt As New Point3d
         Dim endpt As New Point3d

         mySubPaths = gpi.NextSubpath(subPathStartIndex, subPathEndIndex, IsClosed)
         Dim pointTypeStartIndex, pointTypeEndIndex As Integer
         Do
            Dim subPathPointType As Byte
            Dim numPointsFound As Integer = gpi.NextPathType(subPathPointType, pointTypeStartIndex, pointTypeEndIndex)
            Dim type As PathPointType = CType(subPathPointType, PathPointType)

            If type = PathPointType.Line Then
                  CreateLinearPath(pointTypeStartIndex, pointTypeEndIndex)
            ElseIf type = PathPointType.Bezier3 Then
                  CreateSplinePath(pointTypeStartIndex, pointTypeEndIndex)
            End If
         Loop While subPathEndIndex <> pointTypeEndIndex
         If IsClosed Then
            stpt.x = path.PathPoints(subPathStartIndex).X + origin(0)
            stpt.y = -path.PathPoints(subPathStartIndex).Y + origin(1)
            stpt.z = 0
            endpt.x = path.PathPoints(subPathEndIndex).X + origin(0)
            endpt.y = -path.PathPoints(subPathEndIndex).Y + origin(1)
            endpt.z = 0
            ' Do not create zero length lines
            If Math.Abs(stpt.x - endpt.x) > 0.000001 Or Math.Abs(stpt.y - endpt.y) > 0.000001 Then
                  curves.Add(sess.Parts.Work.Curves.CreateLine(stpt, endpt))
            End If
         End If
      Next
      If SelectThickness() Then
         CreateSketch()
         CreateExtrusion()
      End If
End Sub
End Module

tony609719845 · 发表于 2018-4-20 17:11

我不是原创，只是搬运工

zmjacky · 发表于 2018-5-11 22:02

看不懂，顶一下

		自动登录	找回密码
密码			注册

[分享] UG刻字源码VB开发

浏览过的版块