VBA : 백업 프로그램

□ 소개 

3D 및 2D 모델을 사용자가 정의한 폴더에 백업 할수 있습니다. 2D 모델을 백업하면, 연관된 3D 모델은 자동으로 백업 됩니다. 3D Assemble 모델을 백업 하면 구성된 3D 모델만 자동으로 백업 됩니다.

>> 참고 사이트

IpfcModel.backup()

□  코드

엑셀 Sheet에 백업 폴더 이름을 정의 합니다.

Option Explicit
Sub selectsurface()
    On Error GoTo RunError
    Application.EnableEvents = False
    
    '// Check if "Program03" worksheet exists
    If Not WorksheetExists("Program03") Then
        MsgBox "Worksheet 'Program03' not found.", vbExclamation, "Error"
        Exit Sub
    End If
    
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection
     
    '// Check Creo Connect
    Set conn = asynconn.Connect("", "", ".", 5)
    
    If conn Is Nothing Then
        MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
        Exit Sub
    End If
    
    Dim BaseSession As pfcls.IpfcBaseSession
    Dim Session As IpfcSession
    Dim model As pfcls.IpfcModel
    Dim Solid As IpfcSolid
    
    '// Current Model Information
    Set BaseSession = conn.Session
    Set model = BaseSession.CurrentModel
    Set Solid = model
    
    Worksheets("Program03").Cells(2, "D") = BaseSession.GetCurrentDirectory
    Worksheets("Program03").Cells(3, "D") = model.filename
    
    '// Current Model Name
    Dim ModelDescriptorCreate As New CCpfcModelDescriptor
	Dim ModelDescriptor As IpfcModelDescriptor
	Set ModelDescriptor = ModelDescriptorCreate.CreateFromFileName(Model.Filename)
    
    '// Backup Folder Name
	Dim PathName As String
	PathName = Worksheets("Program03").Cells(5, "D")
	ModelDescriptor.Path = PathName
    
    '// Backup
    Call Model.backup(ModelDescriptor)
    
    conn.Disconnect (2)
    
    ' Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing
    
Exit Sub

RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed: An error occurred." & vbCrLf & _
               "Error No: " & CStr(Err.Number) & vbCrLf & _
               "Error Description: " & Err.Description & vbCrLf & _
               "Error Source: " & Err.Source, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If
End Sub

Function WorksheetExists(shtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not Worksheets(shtName) Is Nothing
    On Error GoTo 0
End Function

---

영업문의 : lionkk@idt21c.com
카카오 채널 : http://pf.kakao.com/_fItAxb