Rysunek z makro notą

Macro
41

Nie, sprawdzam to w USF, więc mogę klikać kilka razy w razie potrzeby

42

W Twoim Sub Notes_01() spróbuj wymienić

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)

przez:

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)

oraz dodanie funkcji:

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

po twoim End Sub

1 polubienie
43

Zostawiłem funkcję pustą, bo na początku nie wiedziałem, czy będzie potrzebna, można ją usunąć.

44

Problem rozwiązany dzięki dobrej edycji
Rzeczywiście, nie ma skalowania przy wstawianiu SLDNOTESTL
dla SLDBLK, skalowanie

Nic spójnego w tym wszystkim

Nie będąc ekspertem, AI też nie są, spędziłem z nimi dużo czasu, ale nie przyniosłem żadnego rezultatu

Wielkie podziękowania dla D ROGERA, bez którego ten projekt nigdy nie byłby możliwy dla mnie

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

Moduł klasy 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 polubienia