Creo 라이브러리 관리 프로그램

라이브러리들을 편리하게 사용 할수 있는 프로그램 입니다. 어셈 블리 모드에서 엑셀 파일에 표시된 라이브러리 파일들을 쉽게 검색하여, 사용 가능 합니다. Windchill 프로그램이 없는 여러 사용자가 협업 하는 곳에 필수로 입니다.

■ 프로그램 파일 Download

ToolBOXVBA01_LIB_MG.xlsm

0.11MB

 

라이브러리는 중앙에서 관리 합니다. 중복데이터를 생성 하면 안됩니다. 라이브러리를 구성 하기 위해서는 수동으로 작업을 해야 합니다. Window 공유 폴더를 사용 합니다. Nas 장비를 사용 하는곳은 FTP 서버를 설정 하여 사용 가능 합니다.
공유 PC가 준비되면 Window 공유 폴더를 설정 하고, config.pro > Search.pro 파일을 설정 합니다

1. Window 공유 폴더 사용
- 관리자가 공유 폴더를 설정 합니다. 관리자만 공유 폴더 아래에 라이브러리 폴더를 구성 할수 있습니다
- 관리자만 공유 폴더 아래의 라이브러리 폴더에 파일을 저장 할 수 있습니다

윈도우 11 에서 특정 폴더 네트워크 공유 및 네트워크 드라이브 추가하는 방법 - SoEasyGuide

 

2. config.pro 파일을 설정 합니다.
- Creo가 Window 공유 폴더를 인식할수 있도록 Path 설정을 해야 합니다. config.pro 에 설정 합니다
- Window 메모장으로 "std_search.pro" 파일을 생성 합니다. Path를 설정 합니다.
- config.pro 파일에  search_path_file 추가 합니다. 아래 예시를 참고 합니다.
  예제 ) search_path_file     c:\ptc\creo_stds\configs\std_search.pro
- std_search.pro 파일 안에 아래 예시와 같이 추가 합니다
  예제 ) c:\ptc\creo_stds\std_library\screw
            c:\ptc\creo_stds\std_library\bolt
            c:\ptc\creo_stds\std_library\nut

라이브러리 저장소로 FTP 서버 구축 하기

 

3. 엑셀 VBA 프로그 이용하여 라이브러리 구축 하기 
PC 서버에 공유 폴더를 구축 하고,  > Creo 파일이 저장 될 폴더들을 만듭니다.  > Creo에서  폴더들을 인식 할수 있도록 Config.pro 파일을 구성 하였습니다. 

설계자가 쉽게 검색하여 라이브러리를 어셈블 모드에서 사용 할수 있도록 만들어야 합니다.

1) 탭을 복사하여 새로운 라이브러리 카테고리를 만듭니다. 구분자 Maker, Size, Length, DIA . . .등을 변경 할수 있습니다.
    탭 이름은 라이브러리 카테고리 이름입니다. 대문자를 사용 하십시요

 2) 라이브러리 구성 하기
- Parameter List 탭을선택 합니다

. Folder Select : 라이브러리 파일이 있는 폴더를 선택 합니다.
. New (Part) : 라이브러리 폴더에 있는 모든 "PRT" 파일일 표시됩니다
. Jpg : 이미지 파일일 생성 됩니다
. send : 입력된 Sheet 탭에 이미지와 함께, 파일 이름이 표시 됩니다.
. Clear : 데이터 영역이 제거 됩니다.

* 어셈블 입력 및 Parameter 입력,  표시 기능 버튼은 추가 하지 않았습니다.
   추가는 가능 합니다.  메일 주십시요    lionkk@idt21c.com

4. 동영상

 

 

 

코드 - 선택한 Cell 의 파일 이름으로 어셈블 하기

Sub CreoFileassy()

        Application.EnableEvents = False
        
        Call Creo_Connect

On Error GoTo RunError

        Dim oAssembly As IpfcAssembly
        Dim oAsmcomp As IpfcComponentFeat
        Dim oCreoFileName As String
        
        If oModel Is Nothing Then
        
           MsgBox "Open The Assemble File", vbInformation, "www.idt21c.com"
           
           
        ElseIf oModel.Type <> 0 Then
        
           MsgBox "Open The Assemble File", vbInformation, "www.idt21c.com"
                
        Else
        
            Dim oCreateModelDescriptor As New CCpfcModelDescriptor
            Dim oModelDescriptor As IpfcModelDescriptor
    
            '// cells Selecte File Open
            oCreoFileName = Selection.Value
            Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
            Set oSolid = oSession.RetrieveModel(oModelDescriptor)  '// Session으로 모델 불러오기
            
            Set oAssembly = oModel
            Set oAsmcomp = oAssembly.AssembleComponent(oSolid, Nothing)
            oAsmcomp.RedefineThroughUI
            
        End If
        
        
        conn.Disconnect (2)
    
        'Cleanup
        Set asynconn = Nothing
        Set conn = Nothing
        Set oSession = Nothing
        Set oModel = Nothing

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

 

코드 - 선택한 Cell 의 파일 이름 open 하기

Sub CreoFileOpen()

        Application.EnableEvents = False
        
        Call Creo_Connect

On Error GoTo RunError

        Dim owindow As IpfcWindow
        Dim oCreoFileName As String
                
        Dim oCreateModelDescriptor As New CCpfcModelDescriptor
        Dim oModelDescriptor As IpfcModelDescriptor
    
        '// cells Selecte File Open
        oCreoFileName = Selection.Value
        Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
        Set owindow = oSession.OpenFile(oModelDescriptor)  '// Window로 모델 불러오기
        
        owindow.Activate
        
 conn.Disconnect (2)
    
        'Cleanup
        Set asynconn = Nothing
        Set conn = Nothing
        Set oSession = Nothing
        Set oModel = Nothing

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

 

폴더 선택 하기

Sub selectFolder()
    
    With Application.FileDialog(msoFileDialogFolderPicker)
         .Show
         Worksheets("Parameter List").Cells(6, "E") = .SelectedItems(1)
    End With
    
End Sub

 

하드디스에서 모델을 불러  이미지 만들기
-  디스크에서 session으로 > Window로 표시

Sub jpgexport()

    Application.EnableEvents = False
    
    Call Creo_Connect
    
            
    '// Workfolder change
    oSession.ChangeDirectory (Cells(6, "E"))
    
    On Error GoTo RunError
        
        
        '// Back Ground Color White
        Dim BackgroundWhitemacro As String
        BackgroundWhitemacro = "al_screen_cap @MAPKEY_LABEL스크린 샷을 찍기위해서 흰배경으로 변경;\mapkey(continued) ~ Select `main_dlg_cur` `appl_casc`;~ Close `main_dlg_cur` `appl_casc`;\mapkey(continued) ~ Command `ProCmdRibbonOptionsDlg` ;\mapkey(continued) ~ Select `ribbon_options_dialog` `PageSwitcherPageList` 1 `colors_layouts`;\mapkey(continued) ~ Open `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Close `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Select `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu` 1 `2`;\mapkey(continued) ~ Activate `ribbon_options_dialog` `OkPshBtn`;\mapkey(continued) ~ Command `ProCmdViewSpinCntr`  0;nCntr`  0;"
        oSession.RunMacro (BackgroundWhitemacro)
        
        
        Call oSession.SetConfigOption("display_planes", "no")
        Call oSession.SetConfigOption("display_axes", "no")
        Call oSession.SetConfigOption("display_coord_sys", "no")
        Call oSession.SetConfigOption("display_points", "no")
        Call oSession.SetConfigOption("display_annotations", "no")
        Call oSession.SetConfigOption("display", "shadewithedges")
        
        
        '// sheet scale
        ActiveWindow.Zoom = 100
        Application.ScreenUpdating = True
            
        '// jpg 변환 옵션변수 정의
        Dim rasterHeight As Double: rasterHeight = 22
        Dim rasterWidth As Double: rasterWidth = 17
                            
        Dim JPEGImageExportCreate As New CCpfcJPEGImageExportInstructions
        Dim oJPEGExport As IpfcJPEGImageExportInstructions
        Set oJPEGExport = JPEGImageExportCreate.Create(rasterHeight, rasterWidth)
        Dim instructions As IpfcRasterImageExportInstructions
        Set instructions = oJPEGExport
        
        Dim oJpgfoldername As String: oJpgfoldername = Worksheets("DATA").Cells(3, "B") '// jpg Location
        
        
        instructions.DotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
        instructions.ImageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_8

         '// Part list 파일 개수
        Dim rng As Range: Set rng = Range("A10", Cells(rows.Count, "A").End(xlUp))
        
        Dim oModelDescriptorCreate As New CCpfcModelDescriptor
        Dim oModelDescriptor As IpfcModelDescriptor
        Dim owindow As IpfcWindow
        
        Dim i As Integer
        Dim oCreoFileName As String
        
        Dim str2, ret As String
        Dim Pic As Variant
        Dim Imagecell As Range
        
        Dim oFailedFeatures As IpfcFeatures
        
        
        For i = 0 To rng.Count - 1
            
            oCreoFileName = Cells(i + 10, "D")
            Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCreoFileName)
            Set oModel = oSession.RetrieveModel(oModelDescriptor)
            Set owindow = oSession.OpenFile(oModelDescriptor)
            
            owindow.Activate
            

     
            ' // jpg View Name
            Dim oViewOwner As IpfcViewOwner: Set oViewOwner = oSession.CurrentModel
            Dim oIpfcView As IpfcView: Set oIpfcView = oViewOwner.RetrieveView("ISOVIEW")
            
            
            If oIpfcView Is Nothing Then
            
                Set oIpfcView = oViewOwner.RetrieveView("default")
                
            End If
            
            Dim oJpgFileName As String: oJpgFileName = oModel.InstanceName & ".JPG"
            
            
        '// jpg image location
        oSession.ChangeDirectory (oJpgfoldername)
    
        '// jpg image 변환 실행
        Call owindow.ExportRasterImage(oJpgFileName, instructions)
        
        owindow.Close
        
        
        '//****************************************************************************************
        '// jpg image Insert
        '//****************************************************************************************
        
        str2 = oJpgfoldername & "\" & oJpgFileName
        ret = Dir(str2)
    
        If ret <> "" Then
            Set Pic = ActiveSheet.Pictures.Insert(str2)
            Set Imagecell = Cells(i + 10, "B")
            Cells(i + 10, "B").RowHeight = 60
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 5
                .Top = Imagecell.Top + 5
                .Width = Imagecell.Width - 5
                .Height = Imagecell.Height - 5
            End With
        
        End If
        
         oSession.ChangeDirectory (Cells(6, "E"))
     
   Next i
            
                
    '// Workfolder change
    oSession.ChangeDirectory (Cells(6, "E"))
           
    MsgBox ("JPG 변환 : " & rng.Count & " 개를 완료 하였습니다"), vbInformation, "www.idt21c.com"
        
   
    'Disconnect with Creo
    conn.Disconnect (2)
    
    'Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set oSession = Nothing
    Set oModel = Nothing
       
    
Exit Sub
    
RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
                "Error No: " + CStr(Err.Number) + Chr(13) + _
                "Error: " + Err.Description, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If
            
End Sub

 

다른 worksheet로 데이터 보내기

Sub CellSend()

    '// WorkSheet Name
    Dim oWsName As String
    oWsName = Cells(7, "D")
    
    Dim rng As Range
    Set rng = Range("D10", Cells(rows.Count, "D").End(xlUp))
    
    
    Dim oJpgFileName As String, str2 As String, ret As String
    Dim Pic As Variant
    Dim Imagecell As Range
    Dim oJpgfoldername As String
    oJpgfoldername = Worksheets("DATA").Cells(3, "B")
    
    '// Worksheets(oWsName).Activate
    
    
    Dim i As Integer
    
    For i = 0 To rng.Count - 1
    
      
        Worksheets(oWsName).Cells(i + 8, "A") = i + 1
        Worksheets(oWsName).Cells(i + 8, "C") = Worksheets("Parameter List").Cells(i + 10, "D")
        
        oJpgFileName = Worksheets("Parameter List").Cells(i + 10, "D")
        oJpgFileName = Replace(oJpgFileName, "prt", "jpg")
        
        
        '//****************************************************************************************
        '// jpg image Insert
        '//****************************************************************************************
        
        str2 = oJpgfoldername & "\" & oJpgFileName
        ret = Dir(str2)
    
        If ret <> "" Then
            Set Pic = Worksheets(oWsName).Pictures.Insert(str2)
            Set Imagecell = Worksheets(oWsName).Cells(i + 8, "B")
            Worksheets(oWsName).Cells(i + 8, "B").RowHeight = 60
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 5
                .Top = Imagecell.Top + 5
                .Width = Imagecell.Width - 5
                .Height = Imagecell.Height - 5
            End With
        
        End If
                
    Next i
    
    Worksheets("Parameter List").Activate
    
     MsgBox ("Sheet > " & oWsName & " 전송 완료"), vbInformation, "www.idt21c.com"
    
End Sub

 

 

위코드 일부는 인공지능 ChatGPT를 이용하여 코드를 만들었습니다

---

by lionkk@idt21c.com