Hallo Bernd, hallo Heinz,
wir müssen bei uns nun Sartbohrungen in den Teilen mit einbringen und so sollen alle User immer den selben Block benutzen und nicht irgendwelche. Außerdem sollte es eine Hilfe sein, einfach das Makro starten und sich keine Gedanken machen wo der Block liegt.
Nach einigen Recherchen im Internet habe ich ein Makro gefunden was ungefähr das macht was ich suche. Der User klickt einen Punkt an und dort wird dann der Block eingefügt, nächster Punkt wird geklickt und an der Stelle wird dann der Block eingefügt usw usw. Das läuft so lange bis über die ESC Taste das Makro gestoppt wird.
Hier mal der Code des Makros.
Option Explicit
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Const VK_ESCAPE As Long = &H1B ' Esc Key
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMathUtility As SldWorks.MathUtility
Dim swMathPoint As SldWorks.MathPoint
Dim swSktManager As SldWorks.SketchManager
Dim swSktBlkDef As SldWorks.SketchBlockDefinition
Dim scl As Double
Dim angle As Double
Dim inPtA As Variant
Dim swSketchResult As SketchSegment
Dim swSketchMgr As SldWorks.SketchManager
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim lSng_Start As Single, lSng_End As Single
Sub GetPoint()
On Error Resume Next
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
Set swDraw = swModel
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Es ist kein Einzelteil geöffnet!", swMbInformation, swMbOk
Exit Sub
End If
Set swSktManager = swModel.SketchManager
Set swMathUtility = swApp.GetMathUtility
' Clear prior buffers, selections and points
GetAsyncKeyState VK_ESCAPE
swModel.ClearSelection2 True
inPtA = Empty ' Clear pick point
Do While GetAsyncKeyState(VK_ESCAPE) = 0
Pause 1 ' Pause to give time to click point
If swDraw Is Nothing Then ' This is a Part or Assembly
inPtA = swSelMgr.GetSelectionPoint2(1, -1)
Else ' This is a Drawing
inPtA = swSelMgr.GetSelectionPointInSketchSpace2(1, -1)
End If
If IsEmpty(inPtA) Then ' Point not selected
' Continue Loop
Else
Set swSketchMgr = swModel.SketchManager
Set swMathPoint = swMathUtility.CreatePoint(inPtA)
scl = 1
angle = 0
Set swSktBlkDef = swSktManager.MakeSketchBlockFromFile(swMathPoint, "V:\SW_Templates\2185\Blöcke\Sartbohrung ø6,8mm.SLDBLK", False, scl, angle)
'Do something with collected point
swApp.SendMsgToUser2 "Point Coords" & vbCrLf & _
"X: = " & inPtA(0) & vbCrLf & _
"Y: = " & inPtA(1) & vbCrLf & _
"Z: = " & inPtA(2), swMbWarning, swMbOk
inPtA = Empty ' Clear pick point
swModel.ClearSelection2 True ' Clear selection
End If
Loop
' If no pick point then Exit routine
If IsEmpty(inPtA) Then
swModel.ClearSelection2 True
swApp.SendMsgToUser2 "Das Makro wird nun beendet", swMbWarning, swMbOk
End If
End Sub
' Pause Event
Public Sub Pause(ByVal pSng_Secs As Single)
'Wait for the number of seconds given by pSng_Secs
On Error GoTo Err_Pause
lSng_Start = Timer
lSng_End = Timer + pSng_Secs
Do While Timer < lSng_End
'' Correction if the timer moves over to a new day (midnight)
'' 86400-num of secs in a day
If Timer < lSng_Start Then lSng_End = lSng_End - 86400
DoEvents ' Yield to other processes
Loop
Err_Pause:
Exit Sub
End Sub
Gruß Stefan
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP