함께 VBA 만들기 #4 - Creo 3D 모델 정보 보기

■ 이미지 삽입 기능

이미지를 넣는 기능 입니다. 현재 모델의 "ISOVIEW" 이름 또는 기본 뷰를 이용하여 이미지를 만듭니다.

이미지 파일 저장 위치는 관리자 페이지에서 정의 합니다.

 

■ 전체 코드

Sub Jpg_export()


    '// 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)
        
    '// config.pro
    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
    
    instructions.DotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
    instructions.ImageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_8
    
    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.FullName & ".JPG"
    
    '// jpg image location
    Dim oWorkfolder As String
    oWorkfolder = Worksheets("data").Cells(17, "B")
        
    oSession.ChangeDirectory (oWorkfolder)
    
    '// jpg image 변환 실행
    Dim oWindow As IpfcWindow
    Set oWindow = oSession.CurrentWindow
    Call oWindow.ExportRasterImage(oJpgfilename, instructions)

    oSession.ChangeDirectory (Cells(4, "E"))
    
    
    '// jpg image Insert
    
     Dim str2 As String, ret As String
     Dim Pic As Picture
     Dim Imagecell As Range
     
     
     str2 = oWorkfolder & "\" & oJpgfilename
     ret = Dir(str2)
    
     If ret <> "" Then
            Set Pic = Worksheets("File Info").Pictures.Insert(str2)
            Set Imagecell = Range("A4:C9")
        
            Range("A4:C9").RowHeight = 18
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 1
                .Top = Imagecell.Top + 1
                .Width = Imagecell.Width - 4
                .Height = Imagecell.Height - 4
            End With
        
      End If


End Sub

 

▶ 배경 색상 흰색으로 변경 하기
Creo Mapkey를 사용 합니다.  Mapkey를 호출 하는 방법 입니다.  BackgroundWhitemacro = ~ 애서 "~" 부분은 Mapkey 내용을 넣습니다. 

예제: "al_screen_cap @MAPKEY_LABEL스크린 샷을 찍기위해서 흰배경으로 경;\mapkey(continued) ~ Select `  ~~~~~~ 

'// Back Ground Color White
    Dim BackgroundWhitemacro As String
    BackgroundWhitemacro = ~
    oSession.RunMacro (BackgroundWhitemacro)
    

▶ config.pro를 이용하여, 모델의 불필요한 Feature 감추기

'// config.pro
    Call oSession.SetConfigOption("display_planes", "no")
    Call oSession.SetConfigOption("display_axes", "no")
    Call oSession.SetConfigOption("display_coord_sys", "no")

 

▶ Creo의 jpg 이미지 환경 설정 하기

 '// 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
    
    instructions.DotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
    instructions.ImageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_8
    
    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.FullName & ".JPG"

 

▶ 엑셀 Sheet에  jpg 이미지 환경 설정 하기

'// jpg image Insert
     Dim str2 As String, ret As String
     Dim Pic As Picture
     Dim Imagecell As Range
     
     str2 = oWorkfolder & "\" & oJpgfilename
     ret = Dir(str2)
    
     If ret <> "" Then
            Set Pic = Worksheets("File Info").Pictures.Insert(str2)
            Set Imagecell = Range("A4:C9")
        
            Range("A4:C9").RowHeight = 18
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 1
                .Top = Imagecell.Top + 1
                .Width = Imagecell.Width - 4
                .Height = Imagecell.Height - 4
            End With
        
      End If