Nein, ich validiere beim USF, damit ich bei Bedarf mehrmals klicken kann
Versuche in deinem Sub Notes_01() zu ersetzen
Else
Set swMathUtil = swApp.GetMathUtility
vInsertPoint(0) = X_Value
vInsertPoint(1) = Y_Value
vInsertPoint(2) = Z_Value
Set insPt = swMathUtil.CreatePoint(vInsertPoint)
Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(insPt, REPONSE, False, Echelle, 0)
bis:
Else
*vInsertPoint(0) = X_Value* 'peut être supprimé
*vInsertPoint(1) = Y_Value* 'peut être supprimé
*vInsertPoint(2) = Z_Value* 'peut être supprimé
Set swBlkInst = Insert_Block(Part, REPONSE, X_Value, Y_Value, 1, 0)
und fügt die Funktion hinzu:
Function Insert_Block(ByVal rModel As ModelDoc2, ByVal blkName As String, ByVal Xpt As Double, ByVal Ypt As Double, Optional ByVal sScale As Double = 1, Optional ByVal sAngle As Double = 0) As Object
Dim swBlockDef As SketchBlockDefinition
Dim swMathPoint As MathPoint
Dim swMathUtil As MathUtility
Set swMathUtil = swApp.GetMathUtility
Dim pt(2) As Double
pt(0) = Xpt
pt(1) = Ypt
pt(2) = 0
Set swMathPoint = swMathUtil.CreatePoint(pt)
Set swBlockDef = rModel.SketchManager.MakeSketchBlockFromFile(swMathPoint, blkName, False, sScale, sAngle)
rModel.GraphicsRedraw2
End Function
nach deinem End Sub
1 „Gefällt mir“
Ich habe die Funktion leer gelassen, weil ich anfangs nicht wusste, ob ich sie brauchen würde, sie kann entfernt werden.
Problem mit einer guten Bearbeitung gelöst
Es gibt tatsächlich keine Skalierung für das Einfügen von SLDNOTESTLs
für SLDBLK Skalierung
Nichts Zusammenhängendes in all dem
Da ich kein Experte bin, sind die KIs es auch nicht, habe ich viel Zeit mit ihnen verbracht, ohne Ergebnis.
Ein großes Dankeschön an D ROGER, ohne den dieses Projekt für mich niemals möglich gewesen wäre
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.ModelView
Dim TheMouse As SldWorks.mouse
Public obj As New Classe1
Public X_Value As Double
Public Y_Value As Double
Public Z_Value As Double
Sub Notes_00()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelView = swModel.GetFirstModelView
Set TheMouse = swModelView.GetMouse
obj.init TheMouse, swApp, swModel
UserForm2.Show vbModeless
End Sub
Sub Notes_01()
Dim swApp As Object
Dim Part As Object
Dim myBlockDefinition As Object
Dim myAnnotation As Object
Dim URL As String
Dim NR As String
Dim NUM As String 'Pas byte sinon bt annulé impossible
Dim REPONSE As String
Dim swMathUtil As Object
Dim insPt As Object
Dim vInsertPoint(2) As Double
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
URL = "C:\Users\Notes\"
NUM = InputBox("1 : Tableau découpe insert hexagonal" & vbCrLf & _
"2 : Gousset" & vbCrLf & _
"3 : Soudure" & vbCrLf & vbCrLf & _
"Entrez le numéro du bloc à insérer", "Choix de la note")
Select Case NUM
Case "1": NR = "Découpe_insert_hex.SLDBLK": Echelle = 1: EXT = "A"
Case "2": NR = "Gousset.sldnotestl": EXT = "B"
Case "3": NR = "Soudure.SLDBLK": Echelle = 0.045: EXT = "A"
Case Else: Exit Sub
End Select
REPONSE = URL & NR
If EXT = "B" Then
Set myAnnotation = Part.Extension.InsertAnnotationFavorite(REPONSE, X_Value, Y_Value, 0)
Else
Set swBlkInst = Insert_Block(Part, REPONSE, X_Value, Y_Value, Echelle, 0)
End If
End Sub
Function Insert_Block(ByVal rModel As ModelDoc2, ByVal blkName As String, ByVal Xpt As Double, ByVal Ypt As Double, Optional ByVal sScale As Double = 1, Optional ByVal sAngle As Double = 0) As Object
Dim swBlockDef As SketchBlockDefinition
Dim swMathPoint As MathPoint
Dim swMathUtil As MathUtility
Set swMathUtil = swApp.GetMathUtility
Dim pt(2) As Double
pt(0) = Xpt / obj.cScale
pt(1) = Ypt / obj.cScale
pt(2) = 0
Set swMathPoint = swMathUtil.CreatePoint(pt)
Set swBlockDef = rModel.SketchManager.MakeSketchBlockFromFile(swMathPoint, blkName, False, sScale, sAngle)
rModel.GraphicsRedraw2
End Function
Modul der Klasse 1
Dim WithEvents ms As SldWorks.mouse
Private cSwApp As SldWorks.SldWorks
Private cswModelView As SldWorks.ModelView
Private cswModel As SldWorks.ModelDoc2
Private cswDraw As SldWorks.DrawingDoc
Private cswSheet As SldWorks.Sheet
Private cswView As SldWorks.View
Public ech As Variant
Public cScale As Double
Public Sub init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
Set ms = mouse
Set cSwApp = sldw
Set cswModel = slddoc
Set cswDraw = cswModel
Set cswSheet = cswDraw.GetCurrentSheet
Set cswView = cswDraw.GetFirstView
End Sub
Private Function ms_MouseSelectNotify(ByVal Ix As Long, ByVal Iy As Long, ByVal x As Double, ByVal y As Double, ByVal z As Double) As Long
ech = cswView.ScaleRatio
cScale = ech(0) / ech(1)
UserForm2.TextBox1.Value = Round(x, 4)
UserForm2.TextBox2.Value = Round(y, 4)
End Function
Public Sub Terminer()
Set ms = Nothing
Set cSwApp = Nothing
Set cswModel = Nothing
End Sub
userform2
Private Sub CommandButton1_Click()
'OK
If TextBox1.Value = "" Or TextBox2.Value = "" Then Exit Sub
X_Value = CDbl(Me.TextBox1.Value)
Y_Value = CDbl(Me.TextBox2.Value)
Z_Value = 0#
obj.Terminer
Unload UserForm2
Set UserForm2 = Nothing
Notes_01
Set obj = Nothing
End Sub
2 „Gefällt mir“