Właściwości elementu do tabelki, jak? MAKRO
: 04 lis 2009, 21:34
NIe moge poradzić sobie z nastepującym problemem chciałbym wyrzucić współrzedne punktu do tabelki. Próbowałem coś takiego "x@punk1@szkic1" no ale nic z tego, ktos wie jak to zrobić?
Znalazłem makro, ale ono dziła na zaznaczony punkt, czy da sie je tak przerobić zeby wszystkie punkty wywalało ?
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swMathUtils As SldWorks.MathUtility
Dim swSelMgr As SldWorks.SelectionMgr
Dim NumSelects As Long
Dim swSketchPt As SldWorks.SketchPoint
Dim swVertex As SldWorks.Vertex
Dim vPoint As Variant
Const UnitFactor As Double = 1000 'Get from m to mm
Sub PointsCoords()
Set swApp = Application.SldWorks
Set swMathUtils = swApp.GetMathUtility
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
NumSelects = swSelMgr.GetSelectedObjectCount
If NumSelects = 0 Then
MsgBox "Pick a points and run macro again"
Exit Sub
End If
Dim i As Integer
For i = 1 To NumSelects
If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelSKETCHPOINTS Or _
swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelEXTSKETCHPOINTS Then
Set swSketchPt = swSelMgr.GetSelectedObject6(i, -1)
Dim dPoint(2) As Double
Dim swMathPt As SldWorks.MathPoint
dPoint(0) = swSketchPt.X
dPoint(1) = swSketchPt.Y
dPoint(2) = swSketchPt.Z
Set swMathPt = swMathUtils.CreatePoint(dPoint)
Set swMathPt = swMathPt.MultiplyTransform(swSketchPt.GetSketch().ModelToSketchTransform.Inverse)
vPoint = swMathPt.ArrayData
Debug.Print vPoint(0) * UnitFactor & "; " & vPoint(1) * UnitFactor & "; " & vPoint(2) * UnitFactor
ElseIf swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelVERTICES Then
Set swVertex = swSelMgr.GetSelectedObject6(i, -1)
vPoint = swVertex.GetPoint
Debug.Print vPoint(0) * UnitFactor & "; " & vPoint(1) * UnitFactor & "; " & vPoint(2) * UnitFactor
sMsg = "X: " & vPoint(0) * UnitFactor & vbCrLf & _
"Y: " & vPoint(1) * UnitFactor & vbCrLf & _
"Z: " & vPoint(2) * UnitFactor
MsgBox sMsg
End If
Next
End Sub
Znalazłem makro, ale ono dziła na zaznaczony punkt, czy da sie je tak przerobić zeby wszystkie punkty wywalało ?
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swMathUtils As SldWorks.MathUtility
Dim swSelMgr As SldWorks.SelectionMgr
Dim NumSelects As Long
Dim swSketchPt As SldWorks.SketchPoint
Dim swVertex As SldWorks.Vertex
Dim vPoint As Variant
Const UnitFactor As Double = 1000 'Get from m to mm
Sub PointsCoords()
Set swApp = Application.SldWorks
Set swMathUtils = swApp.GetMathUtility
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
NumSelects = swSelMgr.GetSelectedObjectCount
If NumSelects = 0 Then
MsgBox "Pick a points and run macro again"
Exit Sub
End If
Dim i As Integer
For i = 1 To NumSelects
If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelSKETCHPOINTS Or _
swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelEXTSKETCHPOINTS Then
Set swSketchPt = swSelMgr.GetSelectedObject6(i, -1)
Dim dPoint(2) As Double
Dim swMathPt As SldWorks.MathPoint
dPoint(0) = swSketchPt.X
dPoint(1) = swSketchPt.Y
dPoint(2) = swSketchPt.Z
Set swMathPt = swMathUtils.CreatePoint(dPoint)
Set swMathPt = swMathPt.MultiplyTransform(swSketchPt.GetSketch().ModelToSketchTransform.Inverse)
vPoint = swMathPt.ArrayData
Debug.Print vPoint(0) * UnitFactor & "; " & vPoint(1) * UnitFactor & "; " & vPoint(2) * UnitFactor
ElseIf swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelVERTICES Then
Set swVertex = swSelMgr.GetSelectedObject6(i, -1)
vPoint = swVertex.GetPoint
Debug.Print vPoint(0) * UnitFactor & "; " & vPoint(1) * UnitFactor & "; " & vPoint(2) * UnitFactor
sMsg = "X: " & vPoint(0) * UnitFactor & vbCrLf & _
"Y: " & vPoint(1) * UnitFactor & vbCrLf & _
"Z: " & vPoint(2) * UnitFactor
MsgBox sMsg
End If
Next
End Sub