VBA Export Small JPG While Maintaining Aspect Ratio

I know there are some great macros out there that can do this, but I'm trying to implement it into my own macro.

I'm trying to export a small jpg at 2000px on the longest end while maintaining the aspect ratio.

I found the StructExportOptions.MaintainAspect property, but I'm having a hard time getting it to work.

Sub ExportJPGTest()
    Dim sr As ShapeRange
    Set sr = ActiveSelectionRange
    Dim X As Double, Y As Double, w As Double, h As Double
    Dim strFileName$, myPath$
    Dim opt As New StructExportOptions
    Dim flt As ExportFilter
    
    myPath = "C:\Users\jchestnut\Proofs" 'change path here
    strFileName = ActiveDocument.Name
    
    With opt
        .AntiAliasingType = cdrNormalAntiAliasing
        .ImageType = cdrRGBColorImage
        .Overwrite = True
        .Compression = 5
        .MaintainAspect = True
        .ResolutionX = 300
        .ResolutionY = 300
    End With
    
    sr.CreateSelection
    sr.GetBoundingBox X, Y, w, h
    
    If sr.SizeWidth > sr.SizeHeight Then
    
        With opt
        .SizeX = 2000
        End With
    
    ElseIf sr.SizeHeight > sr.SizeWidth Then
    
        With opt
        .SizeY = 2000
        End With
    
    ElseIf sr.SizeHeight = sr.SizeWidth Then
    
        With opt
        .SizeX = 2000
        .SizeY = 2000
        End With
    
    End If
    
    Set flt = ActiveDocument.ExportEx("C:\Users\jchestnut\Proofs\" & strFileName & ".jpg", cdrJPEG, cdrSelection, opt)
    flt.Finish
    
    If ActiveSelection.Shapes.Count = 0 Then MsgBox "Make a selection for export.": Exit Sub

End Sub

Top Replies

Mek over 1 year ago +1 verified

not answer to your question, but you can try to look here https://community.coreldraw.com/talk/coreldraw_graphics_suite_x8/f/coreldraw-graphics-suite-x8/53547/default-setting-for-export/256436#256436...

Parents

No Data

Reply

+1 Mek over 1 year ago

not answer to your question, but you can try to look here

https://community.coreldraw.com/talk/coreldraw_graphics_suite_x8/f/coreldraw-graphics-suite-x8/53547/default-setting-for-export/256436#256436
Cancel
Up +1 Down

Reply

Reject Answer

Cancel

Children

0 Jamie Chestnut over 1 year ago in reply to Mek

This equation is what I was missing! opt.SizeY = 900 / ((w - x) / (h - y))

Thanks, Mek!

Sub ExportJPGTest()
    Dim sr As ShapeRange
    Set sr = ActiveSelectionRange
    Dim X As Double, Y As Double, w As Double, h As Double
    Dim strFileName$
    Dim opt As New StructExportOptions
    Dim flt As ExportFilter
    
    strFileName = ActiveDocument.Name
    
    With opt
        .AntiAliasingType = cdrNormalAntiAliasing
        .ImageType = cdrRGBColorImage
        .Overwrite = True
        .Compression = 5
        .MaintainAspect = True
        .ResolutionX = 300
        .ResolutionY = 300
    End With
    
    sr.CreateSelection
    sr.GetBoundingBox X, Y, w, h
    
    If sr.SizeWidth > sr.SizeHeight Then
    
        With opt
        .SizeX = 2000
        .SizeY = 2000 / ((w - X) / (h - Y))
        End With
    
    ElseIf sr.SizeHeight > sr.SizeWidth Then
    
        With opt
        .SizeY = 2000
        .SizeX = 2000 / ((w - X) / (h - Y))
        End With
    
    ElseIf sr.SizeHeight = sr.SizeWidth Then
    
        With opt
        .SizeX = 2000
        .SizeY = 2000
        End With
    
    End If
    
    Set flt = ActiveDocument.ExportEx("C:\Users\jchestnut\Proofs\" & strFileName & ".jpg", cdrJPEG, cdrSelection, opt)
    flt.Finish
    
    If ActiveSelection.Shapes.Count = 0 Then MsgBox "Make a selection for export.": Exit Sub

End Sub