개발 요청] 이미지 생성 프로그램 #4

이미지 변환 코드

Sub JPGEportUtils01()

    On Error GoTo RunError
    Application.EnableEvents = False
    
     '//Image storage folder
     If Dir("c:\toolbox\images", vbDirectory) = "" Then
        
        MkDir ("c:\toolbox")
        MkDir ("c:\toolbox\images")
     
     End If

    '// Module Name : CreoVBAStart
    Call CreoVBAStart.CreoConnt01
    Dim owindow As IpfcWindow
    Set owindow = BaseSession.GetModelWindow(Model)
    
    '// Function SimplifiedRep :
    Dim SimplifiedRepSolid As IpfcSolid
    Dim Simrep As IpfcSimpRep
    Set SimplifiedRepSolid = Model
    
    Call BaseSession.SetConfigOption("display_planes", "no")
    Call BaseSession.SetConfigOption("display_axes", "no")
    Call BaseSession.SetConfigOption("display_coord_sys", "no")
    Call BaseSession.SetConfigOption("display_points", "no")
    Call BaseSession.SetConfigOption("display_annotations", "no")
    Call BaseSession.SetConfigOption("display", "shadewithedges")
    
    '// Define JPG Files conversion options variables
    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
    
    
    '// Number of Part Files
    Dim rng As Range: Set rng = Worksheets("Suppress").Range("A6", Cells(Rows.Count, "A").End(xlUp))
    
    Dim oModelDescriptorCreate As New CCpfcModelDescriptor
    Dim oModelDescriptor As IpfcModelDescriptor
    
    Dim i As Long
    Dim oCreoFileName, str2, ret As String
    Dim Pic As Variant
    Dim Imagecell As Range
    Dim oJpgfilename As String
    
    For i = 0 To rng.Count - 1
        
        oJpgfilename = Worksheets("Suppress").Cells(i + 6, "F") & ".JPG"
        
        Set Simrep = SimplifiedRepSolid.GetSimpRep(Worksheets("Suppress").Cells(i + 6, "F"))
        Call SimplifiedRepSolid.ActivateSimpRep(Simrep)
        
        '// Jpg Image Location
        BaseSession.ChangeDirectory ("c:\toolbox\images")
        
        '// Run Jpg Image Conversion
        Call owindow.ExportRasterImage(oJpgfilename, instructions)
        
        '// Jpg Image Insert
        str2 = "c:\toolbox\images\" & oJpgfilename
        ret = Dir(str2)
    
        If ret <> "" Then
            Set Pic = Worksheets("Suppress").Pictures.Insert(str2)
            Set Imagecell = Worksheets("Suppress").Cells(i + 6, "G")
        
             Worksheets("Suppress").Cells(i + 6, "G").RowHeight = 100
        
            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
        
    
    MsgBox "Completed Creation of JPG Files", vbInformation, "korealionkk@gmail.com"
       
    conn.Disconnect (2)
    
    
    '// Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set Model = Nothing
    
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

 

참고 사이트

이미지 변환 프로그램 소스

 

프로그램 실행 결과

by korealionkk@gmail.com

---