좌표계 생성 매크로

티스토리 뷰

프로그래밍/SolidEdge

좌표계 생성 매크로

.가끔은 2018. 2. 26. 22:14

Solid Edge 좌표계 자동 작성 매크로 입니다.

Excel 이용해 좌표계 생성 하는 매크로입니다.

코드 소스

Option Explicit
 
'Excel -> Edge
Sub Make_Coordnate()
On Error Resume Next
 
Dim EDGE As SolidEdgeFramework.Application
Dim EDoc As SolidEdgePart.PartDocument
Dim OldStBar As String
 
Set EDGE = GetObject(, "SolidEdge.Application")
If EDGE Is Nothing Then
    Err.Clear
    Set EDGE = CreateObject("SolidEdge.Application")
    Set EDoc = EDGE.Documents.Add("SolidEdge.PartDocument")
    EDGE.Visible = True
    EDGE.DisplayFullScreen = True
Else
      Set EDoc = EDGE.Documents.Add("SolidEdge.PartDocument")
End If
 
EDoc.Application.ScreenUpdating = False
OldStBar = EDGE.StatusBar
 
Dim AXIS As Object
Dim i As Integer
Dim K As Integer
Dim X As Double
Dim Y As Double
Dim Z As Double
Dim No As String
 
On Error GoTo ET
 
K = Cells(Rows.Count, "a").End(xlUp).Row
 
For i = 4 To K Step 3
If Cells(i + 2, 3) <> 0 And Cells(i + 1, 3) <> 0 And Cells(i, 3) <> 0 Then
    X = Cells(i, 3) / 1000
    Y = Cells(i + 1, 3) / 1000
    Z = Cells(i + 2, 3) / 1000
    No = Cells(i, 1)
    EDGE.StatusBar = "  Task Progress   " & Round(i / K * 100, 0) & "%"
    Set AXIS = EDoc.CoordinateSystems.Add(X, Y, Z)
    AXIS.Name = No
End If
 
Next
 
EDGE.StatusBar = OldStBar
EDoc.Application.ScreenUpdating = True
Call EDoc.Recompute
 
Exit Sub
 
ET:
EDoc.Application.ScreenUpdating = True
Call EDoc.Recompute
MsgBox "Error...", "wkdghfl@gmail.com"
 
End Sub