Quantcast
Channel: VBForums
Viewing all articles
Browse latest Browse all 15129

Crop Filter: Crop Picture

$
0
0
This is a tested code, which is perfect. If there is a better way, you can also communicate together.

Code:

Function CutImg(PicFile As String, SaveAs As String, Left As Long, Top As Long, newWidth As Long, newHeight As Long) As Boolean
' Intercept area, how much space is left on the left, how much space is above, width, height
On Error GoTo ERR1
    Dim Img As ImageFile
    Dim IP As ImageProcess
    Set Img = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")
    Dim ImgWidth As Long, ImgHeight As Long
    Img.LoadFile PicFile
    ImgWidth = Img.Width
    ImgHeight = Img.Height
    Dim Right As Long, Bottom As Long
    If Left >= ImgWidth Or Right >= ImgHeight Then Exit Function
   
    Right = ImgWidth - Left - newWidth
    If Right <= 0 Then Right = 0
   
    Bottom = ImgHeight - Top - newHeight
    If Bottom <= 0 Then Bottom = 0
   
   
    IP.Filters.Add IP.FilterInfos("Crop").FilterID
    IP.Filters(1).Properties("Left") = Left
    IP.Filters(1).Properties("Top") = Top
    IP.Filters(1).Properties("Right") = Right
    IP.Filters(1).Properties("Bottom") = Bottom
    Set Img = IP.Apply(Img)

    CutImg = True
    On Error Resume Next
    Kill SaveAs
    Err.Clear
    Img.SaveFile SaveAs
    CutImg = Err.Number = 0
    Exit Function
ERR1:
MsgBox Err.Description
End Function

Function CutImg2(PicFile As String, SaveAs As String, Left As Long, Top As Long, Right As Long, Bottom As Long) As Boolean
' Intercept area, how much empty left, how much empty above, how much empty right, how much empty below

On Error GoTo ERR1
    Dim Img As ImageFile
    Dim IP As ImageProcess
    Set Img = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")
    Img.LoadFile PicFile
    Dim ImgWidth As Long, ImgHeight As Long

    ImgWidth = Img.Width
    ImgHeight = Img.Height
    If Left >= ImgWidth Or Right >= ImgWidth Or Bottom >= ImgHeight Or Top >= ImgHeight Then Exit Function
    IP.Filters.Add IP.FilterInfos("Crop").FilterID
    IP.Filters(1).Properties("Left") = Left
    IP.Filters(1).Properties("Top") = Top
    IP.Filters(1).Properties("Right") = Right
    IP.Filters(1).Properties("Bottom") = Bottom
    Set Img = IP.Apply(Img)
    CutImg2 = True
    On Error Resume Next
    Kill SaveAs
    Err.Clear
    Img.SaveFile SaveAs
    CutImg2 = Err.Number = 0
    Exit Function
ERR1:
End Function


Viewing all articles
Browse latest Browse all 15129

Trending Articles