이미지 변환 프로그램 소스

■ jpg 변경 프로그램

Option Explicit
Sub A3PartListJpgExport()
    
On Error GoTo RunError
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection: Set conn = asynconn.Connect("", "", ".", 5)
    Dim oSession As pfcls.IpfcBaseSession: Set oSession = conn.session
    Dim oModel As pfcls.IpfcModel
    
    
    '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
    
    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 Long
    Dim oCreoFileName, str2, ret As String
    Dim Pic As Variant
    Dim Imagecell As Range
    
    
    For i = 0 To rng.Count - 1
        
        oCreoFileName = Cells(i + 10, "C")
        'Cells(i + 5, "E") = Right(UCase(oCroeCellName), 3) 'File Type 표시
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCreoFileName)
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
   
        Set oModel = oSession.CurrentModel
     
        ' View
        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
        oSession.ChangeDirectory ("C:\IDT\TOOLBOX-VBA\JPG_IMAGES")
    
        'jpg image 변환 실행
        Call owindow.ExportRasterImage(oJpgfilename, instructions)
        
        owindow.Close
         
        'jpg image Insert
        str2 = "C:\IDT\TOOLBOX-VBA\JPG_IMAGES\" & oJpgfilename
        ret = Dir(str2)
    
        If ret <> "" Then
            Set Pic = ActiveSheet.Pictures.Insert(str2)
            Set Imagecell = Cells(i + 10, "E")
        
            Cells(i + 10, "E").RowHeight = 50
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 1
                .Top = Imagecell.Top + 1
                .Width = Imagecell.Width - 1
                .Height = Imagecell.Height - 1
            End With
        
        End If
     
   Next i
   
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(Cells(10, "C")) ' Total Assembly Open
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
   
        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

 

주의 > 이미지가 배치될 cell의 폭은 "10.3" ( 110 픽셀)로 하고, VBA 에서  Cells(I + 16, "D").RowHeight = 60로 정의 합니다. 만일 cell의 폭을 증가 또는 축소 하면, RowHeight = 60의 값을 변경 합니다.

---