Guten Morgen,
Solidworks Macros sind echt eine gute Sache, aber ich hab mir als erstes Projekt ein sehr schweren Projekt aufgenommen.
Anbei ist ein Programm, der Aufgabenstellung ist so
1- Von Baugruppe aus jeden Bauteil öffnen. ( auch in Unterbaugruppen)
2- in jedem Bauteil ein neuen Koordinaten System erstellen, der bündig mit den Faces ist, ein 3d Skizze erstellen, die in jede Mid Punkt von jeder Edge ein Punkt zeichnet.
3- Danach kommt der excel Datei erstellung
und das passiert zu jedem Bauteil
der Excel Import habe ich in einem Forum gefunden, und der andere von Codesstack.com sollte jede Edge mit Punkten Teilen... das habe ich als Alternative für die Midpunkte genommen, jedoch leider es erstellt keine Punkte ):
mit dem Koordinaten System habe ich mich auch noch nicht beschäftigt.... ich würde mich auf euren Tips freuen. Danke sehr im Voraus
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim BGpath As String
Dim DocType As Integer
Dim OpenErrors As Long
Dim swAsm As SldWorks.AssemblyDoc
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swApp.ActiveDoc Is Nothing Then
MsgBox "mach Baugruppe Auf"
Exit Sub
End If
If swModel.GetType <> 2 Then
MsgBox "mach Baugruppe Auf"
Exit Sub
End If
Set swAsm = swModel
BGpath = swModel.GetPathName
Dim CompCount As Long
CompCount = swAsm.GetComponentCount(False)
Dim aComp As Variant
aComp = swAsm.GetComponents(False)
Dim C As Long
For C = 1 To UBound(aComp)
Dim swcomp2 As SldWorks.Component2
Set swcomp2 = aComp(C)
Dim CompName As String
CompName = Left(swcomp2.Name2, Len(swcomp2.Name2) - 2)
Dim CompPath As String
CompPath = Left(BGpath, Len(BGpath) - 13) & CompName & ".SLDPRT"
Dim swPartModel As SldWorks.ModelDoc2
Set swPartModel = swApp.ActivateDoc3(CompPath, False, swRebuildOnActivation_e.swRebuildActiveDoc, OpenErrors)
Dim SelMgr As SldWorks.SelectionMgr
Set SelMgr = swPartModel.SelectionManager
Dim EdgeN As Integer
Dim myModelView As Object
Set myModelView = swPartModel.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
swPartModel.ViewZoomtofit2
swPartModel.ViewZoomtofit2
swPartModel.ShowNamedView2 "*Isometrisch", 7
swPartModel.SketchManager.Insert3DSketch True
'swPartModel.Extension.SelectAll
'EdgeN = SelMgr.GetSelectedObjectCount2(-1)
Dim Edg As SldWorks.Edge
swModel.Extension.SelectByID2 Empty, swSelectType_e.swSelEDGES, Empty, Empty, Empty, True, Empty, Nothing, swSelectOption_e.swSelectOptionDefault
Edg = SelMgr.GetSelectedObject6(1, -1)
Debug.Print EdgeN = SelMgr.GetSelectedObjectCount2(-1)
Dim swBody As SldWorks.Body2
Set swBody = Edg.GetBody
Dim AEdges As Variant
AEdges = swBody.GetEdges
Dim SpecEdg As SldWorks.Edge
Dim i As Long
For i = 0 To UBound(AEdges)
Set SpecEdg = AEdges(i)
Dim swCurve As SldWorks.Curve
Set swCurve = SpecEdg.GetCurve
Dim vPts As Variant
Dim PointsproEdge As Integer
PointsproEdge = 2
vPts = SplitCurveByPoints(swCurve, PointsproEdge)
swPartModel.ClearSelection2 True
Dim p As Integer
For p = 0 To (UBound(vPts) + 1) / 3 - 1
swPartModel.SketchManager.CreatePoint vPts(p * 3), vPts(p * 3 + 1), vPts(i * 3 + 2)
Next p
Next i
swPartModel.SketchManager.Insert3DSketch True
Sketchy (CompName)
'swPartModel.Save3 8, Empty, Empty
swApp.CloseDoc CompPath
Next C
End Sub
Function Sketchy(CompName2)
Dim swApp As SldWorks.SldWorks
Dim doc As SldWorks.ModelDoc2
Dim part As SldWorks.PartDoc
Dim sm As SldWorks.SelectionMgr
Dim feat As SldWorks.Feature
Dim Sketch As SldWorks.Sketch
Dim v As Variant
Dim i As Long
Dim sseg As SldWorks.SketchSegment
Dim sline As SldWorks.SketchLine
Dim sp As SldWorks.SketchPoint
Dim ep As SldWorks.SketchPoint
Dim s As String
Dim exApp As Object
Dim Sheet As Object
Set exApp = CreateObject("Excel.Application")
If Not exApp Is Nothing Then
exApp.Visible = True
If Not exApp Is Nothing Then
exApp.Workbooks.Add
Set Sheet = exApp.ActiveSheet
If Not Sheet Is Nothing Then
Sheet.Cells(1, 1).Value = "X"
Sheet.Cells(1, 2).Value = "Y"
Sheet.Cells(1, 3).Value = "Z"
Sheet.Cells(1, 4).Value = CompName2
Sheet.Cells(1, 5).Value = "A"
Sheet.Cells(1, 6).Value = "B"
Sheet.Cells(1, 7).Value = "C"
Sheet.Cells(2, 5).Value = "=(MAX(A2:A999)-MIN(A2:A999))*1000"
Sheet.Cells(2, 6).Value = "=(MAX(B2:B999)-MIN(B2:B999))*1000"
Sheet.Cells(2, 7).Value = "=(MAX(C2:C999)-MIN(C2:C999))*1000"
Sheet.Cells(4, 8).Value = "A ist maserrichtung? (1 wenn ja, sonst 0)"
End If
End If
End If
Set swApp = GetObject(, "sldworks.application")
If Not swApp Is Nothing Then
Set doc = swApp.ActiveDoc
If Not doc Is Nothing Then
If doc.GetType = swDocPART Then
Set part = doc
Set sm = doc.SelectionManager
If Not part Is Nothing And Not sm Is Nothing Then
If sm.GetSelectedObjectType2(1) = swSelSKETCHES Then
Set feat = sm.GetSelectedObject4(1)
Set Sketch = feat.GetSpecificFeature
If Not Sketch Is Nothing Then
v = Sketch.GetSketchPoints
For i = LBound(v) To UBound(v)
Set sp = v(i)
If Not sp Is Nothing And Not Sheet Is Nothing And Not exApp Is Nothing Then
Sheet.Cells(2 + i, 1).Value = (sp.X)
Sheet.Cells(2 + i, 2).Value = (sp.Y)
Sheet.Cells(2 + i, 3).Value = (sp.Z)
exApp.Columns.AutoFit
End If
Next i
End If
End If
End If
End If
End If
End If
End Function
'**********************
'Copyright(C) 2020 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/geometry/selected-edge-create-sketch-points/
'License: https://www.codestack.net/license/
'**********************
Function SplitCurveByPoints(swCurve As SldWorks.Curve, pointsNumber As Integer) As Variant
Dim nStartParam As Double
Dim nEndParam As Double
Dim bIsClosed As Boolean
Dim bIsPeriodic As Boolean
Dim incr As Double
Dim i As Integer
Dim vParam As Variant
Dim retVal() As Double
ReDim retVal(pointsNumber * 3 - 1)
swCurve.GetEndParams nStartParam, nEndParam, bIsClosed, bIsPeriodic
incr = (nEndParam - nStartParam) / (pointsNumber - 1)
For i = 0 To pointsNumber - 1
vParam = swCurve.Evaluate(nStartParam + i * incr)
retVal(i * 3) = vParam(0)
retVal(i * 3 + 1) = vParam(1)
retVal(i * 3 + 2) = vParam(2)
Next
SplitCurveByPoints = retVal
End Function
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP