viernes, 15 de septiembre de 2017

VBA Access. Módulo de clase clsImageResize usando WIA. Redimensionar / cambiar de resolución una imagen.

'---------------------------------------------------------------------------------------
' Procedure : WIA_ResizeImage
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Resize an image based on Max width and Max height using WIA
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
' Req'd Refs: Uses Late Binding, so none required
'
' Windows Image Acquisition (WIA)
'             https://msdn.microsoft.com/en-us/library/windows/desktop/ms630368(v=vs.85).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInitialImage : Fully qualified path and filename of the original image to resize
' sResizedImage : Fully qualified path and filename of where to save the resized image
' lMaximumWidth : Maximum allowable image width
' lMaximumHeight: Maximum allowable image height
'
' Usage:
' ~~~~~~
' Call WIA_ResizeImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
'                      "C:\Users\MyUser\Desktop\Chrysanthemum_small.jpg", _
'                      800, 600)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2017-01-18              Initial Release
'---------------------------------------------------------------------------------------
Public Function WIA_ResizeImage(sInitialImage As String, sResizedImage As String, _
                                           lMaximumWidth As Long, lMaximumHeight As Long) As Boolean
    On Error GoTo Error_Handler
    Dim oWIA                  As Object 'WIA.ImageFile
    Dim oIP                   As Object 'ImageProcess

    Set oWIA = CreateObject("WIA.ImageFile")
    Set oIP = CreateObject("WIA.ImageProcess")

    oIP.Filters.Add oIP.FilterInfos("Scale").FilterID
    oIP.Filters(1).Properties("MaximumWidth") = lMaximumWidth
    oIP.Filters(1).Properties("MaximumHeight") = lMaximumHeight

    oWIA.LoadFile sInitialImage
    Set oWIA = oIP.Apply(oWIA)
    oWIA.SaveFile sResizedImage
    WIA_ResizeImage = True

Error_Handler_Exit:
    On Error Resume Next
    If Not oIP Is Nothing Then Set oIP = Nothing
    If Not oWIA Is Nothing Then Set oWIA = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WIA_ResizeImage" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function



No hay comentarios:

Publicar un comentario

VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)

 Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double     'Aplica método medio redondeo (half round ...