Rysunek z makro notą

Macro
1

Mam makro do szybkiego wstawiania adnotacji w płaszczyźnie, ale brakuje mi pozycji, jak przy przeciągnięciu, którego nie mogę znaleźć, więc szukam pozycji X Y jak na pasku zadań SolidWorks

Sub Note()
Dim swApp As Object
Dim Part As Object
Dim myModelView As Object
Dim myBlockDefinition As Object
Dim myAnnotation As Object
Dim URL_0 As String
Dim URL_1 As String
Dim choix As String


Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set myModelView = Part.ActiveView

URL_0 = "C:\Users\xxx\"

choix = InputBox("1 : Découpe_insert_hex.SLDBLK" & vbCrLf & _
                 "2 : Gousset.sldnotestl" & vbCrLf & _
                 "3 : Soudure.SLDBLK" & vbCrLf & vbCrLf & _
                 "Entrez le numéro du bloc à insérer", "Choix du bloc")

Select Case choix
    Case "1": URL_1 = URL_0 & "Découpe_insert_hex.SLDBLK"
              Echelle = 1
    Case "2": URL_1 = URL_0 & "Gousset.sldnotestl"
              Echelle = 1
    Case "3": URL_1 = URL_0 & "Soudure.SLDBLK"
              Echelle = 0.05
    Case Else: Exit Sub
End Select

If choix = 2 Then
Set myAnnotation = Part.Extension.InsertAnnotationFavorite(URL_1, X_cd, Y_cd, 0)
Else
Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(Nothing, URL_1, False, Echelle, 0)
End If

End Sub

Chcę uchwycić na płaszczyźnie pozycję kursora po kliknięciu

na przykład mam userform2, którego myślałem, że użyję w trybie niemodalnym, klikam na arkusz, wizualizuję pozycję X i Y, waliduję i używam współrzędnych

Private Sub CommandButton1_Click()
'OK

Call Note
End Sub

Private Sub TextBox1_Change()
'X
End Sub

Private Sub TextBox2_Change()
'Y
End Sub

CAPTURE 000717

Nie mogę znaleźć kodu

2

Na marginesie mam ten fragment kodu:

Public X                        As Double
Public Y                        As Double
Public str                      As String        
       posX = width - posX
        posY = height - posY
        insertionNote swModel, posX, posY, str

Zobaczymy, czy to dotyczy bloku.

3

Chcę uchwycić pozycję kliknięcia myszką, ale nie widzę, jak to zrobić tym kodem

4

Witam;

Pewnie jakiś trop:

1 polubienie
5

Nie pasuje, to jest do pokoju i szukam planu

6

Aha, to nie takie proste... ale myślę, że już prawie jestem na miejscu:
W module:

Option Explicit

' Déclaration des variables globales
Dim swApp As SldWorks.SldWorks                ' Application SolidWorks
Dim swModel As SldWorks.ModelDoc2             ' Document actif (feuille de mise en plan)
Dim modelView As SldWorks.modelView           ' Vue modèle dans SolidWorks
Dim swMouse As SwMouseEventHandler            ' Gestionnaire d'événement souris personnalisé

' Macro principale à lancer depuis l'éditeur VBA de SolidWorks
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox "Aucun document actif. Ouvrez une mise en plan."
        Exit Sub
    End If
    
    Set modelView = swModel.IGetFirstModelView()
    
    If modelView Is Nothing Then
        MsgBox "Pas de vue disponible dans le document actif."
        Exit Sub
    End If

    Set swMouse = New SwMouseEventHandler
    swMouse.Init modelView, swApp

    ' Ne pas utiliser MsgBox ici pour éviter de bloquer l'exécution
    swApp.SendMsgToUser "Écoute des clics activée. Cliquez dans la mise en plan."
    
    ' Laisser la macro ouverte pour que les événements soient capturés
End Sub

oraz w module klasy o nazwie " SwMouseEventHandler " :

' Initialisation : affecte la vue, l'application et récupère l'objet souris
Public Sub Init(mv As SldWorks.modelView, sw As SldWorks.SldWorks)
    Set pModelView = mv
    Set pSwApp = sw
    
    ' Récupération de l'objet souris lié à la vue modèle
    Set pMouse = pModelView.GetMouse()
End Sub

' Gestionnaire d'événement appelé à chaque clic gauche de souris
Private Function pMouse_MouseLBtnDownNotify(ByVal ix As Long, ByVal iy As Long, ByVal wParam As Long) As Long
    ' Affiche les coordonnées brutes du clic reçues
    pSwApp.SendMsgToUser "Clic détecté - Coordonnées écran brutes: x=" & ix & ", y=" & iy
    Dim mt As SldWorks.MathTransform      ' Transformation inverse de la vue
    Dim pt As SldWorks.MathPoint          ' Point mathématique initial
    Dim coords(2) As Double               ' Tableau 3D pour coordonnées écran
    Dim newCoor As Variant                ' Tableau contenant coordonnées transformées

    ' Obtention de la transformation inverse de la vue (écran -> coordonnées modèle)
    Set mt = pModelView.Transform.IInverse()

    ' Préparation du tableau avec coordonnées écran du clic (x, y, 0)
    coords(0) = ix
    coords(1) = iy
    coords(2) = 0

    ' Création d'un point mathématique dans le système écran
    Set pt = pSwApp.GetMathUtility.CreatePoint(coords)

    ' Transformation des coordonnées écran en coordonnées modèle (locales)
    Set pt = pt.IMultiplyTransform(mt)

    ' Récupération du tableau des coordonnées transformées
    newCoor = pt.ArrayData

    ' Indiquer que l'événement a été traité
    pMouse_MouseLBtnDownNotify = 1
End Function

Teoretycznie prawie osiągamy cel.

7

Witam
Nie działa ze mną, nie monitoruje kliknięcia, czegoś musi brakować

8

Komunikaty o błędach?
Czy moduł klasowy został przemianowany?' (SwMouseEventHandler)
Bo w domu nie działa to zbyt źle...

1 polubienie
9

może to odniesienie do aktywacji, u mnie to nie działa, SW2025
Animation 01
Animation 02

image

10

Brak szczególnych odniesień do aktywacji (przynajmniej nic nadzwyczajnego): (Solidworks 2022)
00_test_Get mouse coordinate.swp (47,5 KB)

image
Uważaj, to jest makro oparte na " event listenerze ", tryb krok po kroku w edytorze nie powinien działać.

1 polubienie
11

Jestem zdezorientowany, że musiałem to skopiować i wkleić, ale to nie działa

12

Spróbuj makro w trybie samodzielnym na początku (bez próby kojarzenia go z istniejącymi makrami...) Dołączyłem plik *.swp w moim poprzednim poście. Mogą być pasożytnicze " wentylacje " między twoim makro a moim, kto wie. :melting_face:

13

Działa :wink:

14

Wciąż istnieje problem z współrzędnymi, które nie są tymi w Solidworks

15

… Super! Nigdy nie wspomniałeś o danych kontaktowych związanych ze Solidworks...

16

Kiedy umieszczam klocki, musi to być w samolocie, a nie na zewnątrz

17

Witam
W przykładach Maclane jest wszystko, czego potrzebujesz, ale zamiast przechodzić przez MouseLBtnDownNotify musisz przejść przez MouseSelectNotify i uzyskać wartości x, y i z zamiast wartości Ix i Iy, może to na przykład wyglądać tak:

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.ModelView
Dim TheMouse As SldWorks.mouse
Dim obj As New Classe1

Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swModelView = swModel.GetFirstModelView
    Set TheMouse = swModelView.GetMouse

    obj.init TheMouse, swApp, swModel
    
    swApp.SendMsgToUser "Veuillez définir la position de la note."
End Sub

a dla klasy:

'Classe1
Dim WithEvents ms As SldWorks.mouse

Private cSwApp As SldWorks.SldWorks
Private cswModel As SldWorks.ModelDoc2

Private Sub Class_Initialize()
End Sub

Public Sub init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
    Set ms = mouse
    Set cSwApp = sldw
    Set cswModel = slddoc
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
    Set myNote = cswModel.InsertNote("C'est ma note")
    If Not myNote Is Nothing Then
       Set myAnnotation = myNote.GetAnnotation()
       If Not myAnnotation Is Nothing Then
          boolstatus = myAnnotation.SetPosition(x, y, 0)
       End If
    End If
    cswModel.ClearSelection2 True
    cswModel.WindowRedraw

    End
End Function

Private Function ms_MouseLBtnDownNotify(ByVal x As Long, ByVal y As Long, ByVal WParam As Long) As Long
    
End Function

Pozdrowienia

1 polubienie
18

Ach! Cześć @d_roger , miło znów cię czytać. :grinning:.

2 polubienia
19

Mam jeszcze jeden problem, podsumuję go

Moduł Standardowy

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelView As SldWorks.modelView
Dim TheMouse As SldWorks.mouse
Dim obj As New Classe1

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

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, UserForm2.TextBox1.Value, UserForm2.TextBox2.Value, 0)
Else
Set myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(Nothing, REPONSE, False, Echelle, 0)

End If

End Sub

Moduł klasy 1

Dim WithEvents ms As SldWorks.mouse

Private cSwApp As SldWorks.SldWorks
Private cswModel As SldWorks.ModelDoc2


Public Sub Init(mouse As Object, sldw As SldWorks.SldWorks, slddoc As SldWorks.ModelDoc2)
Set ms = mouse
Set cSwApp = sldw
Set cswModel = slddoc
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
UserForm2.TextBox1.Value = x
UserForm2.TextBox2.Value = y
End Function

userform2

Private Sub CommandButton1_Click()
'OK

If TextBox1.Value = "" Or TextBox2.Value = "" Then Exit Sub

Notes_01
Unload Me
End Sub

Cokolwiek się dzieje, na USB-F pojawia się nakładka dialogów w Inputbox, to nic wielkiego, przewróciłem to na wszystkie strony, nie działa, nadal jest widoczne, nawet po wyładowaniu notes_01

Rekord życiowy jest stąd
Ustaw myBlockDefinition = Part.SketchManager.MakeSketchBlockFromFile(Nothing, ANSWER, False, Scale, 0)

co nie pozwala na instalację w samolocie z współrzędnymi

20

Witam

Dla mnie problem tkwi w argumentach Part.SketchManager.MakeSketchBlockFromFile.
Czego się spodziewać:
InsertPoint
Pod nazwą
LinkToFile
Skala
Kąt

To, że włożyłem Nothing w miejsce włożenia, myślę, że to właśnie blokuje.
Musisz wstrzyknąć współrzędne x,y, zgodnie z oczekiwaniami SW
Z mojej strony mam taki kod do nakładania bloku

Sub AddBlock()
    bAddBlock = False
    swDraw.EditTemplate
    Set swMathUtil = swApp.GetMathUtility
    For j = 0 To nInstanceCount - 1
        npt(0) = dInstPoint(j * nInstanceCount)
        npt(1) = dInstPoint(j * nInstanceCount + 1)
        npt(2) = dInstPoint(j * nInstanceCount + 2)
        vInsertPoint = npt
        Set insPt = swMathUtil.CreatePoint(vInsertPoint)
        sBlockPath = cDirBlock & cBlock
        
        Set pBlock = skMgr.MakeSketchBlockFromFile(insPt, sBlockPath, False, 1#, 0#)
    Next j
    swDraw.EditSheet
End Sub
1 polubienie