simple vba: copy all images with "same length and breadth" to another folder

[jadgon]

vba: copy all images with same length and breadth [250 X 250 px] to another folder. Or just only that are not in that dimension.

[mdmackillop]

Something like this

Public Sub SquarePics()
strPath = "C:\Users\Emachine\Pictures\" 'Specify the Image folder name
MkDir strPath & "Square" 'Specify the Target folder name
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPath)


tgt = strPath & "Square\"
For Each f In objFolder.Items
PicDim = objFolder.GetDetailsOf(f, 31)
If InStr(1, PicDim, "x") > 0 Then
PicDim = Mid(PicDim, 2, Len(PicDim) - 2)
siz = Split(PicDim, "x")
If Trim(siz(0)) = Trim(siz(1)) And Trim(siz(0)) = 250 Then
'If Trim(siz(0)) = Trim(siz(1)) Then
FileCopy strPath & f, tgt & f
End If
End If
Next
End Sub

[jadgon]

Thank you.
If my image dimension is 700 X 800 the code fails.

[mdmackillop]

As intended. 700 x 800 is not the same length and breadth

[jadgon]

Help me with this.

[mdmackillop]

You need to be more specific.

copy all images with same length and breadth [250 X 250 px] to another folder.

This is what I've done


Or just only that are not in that dimension.
I don't know what this means.

[jadgon]

I mean if my image length is 700 and breadth is 800 in dimension instead of 250 (length) x 250 (breadth).
Then how can i copy files with vba as this code is not working with 700 x 800 dimension ?

[mdmackillop]

Public Sub NotSquarePics()
L = 700: W = 800
strPath = "C:\Users\Emachine\Pictures\" 'Specify the Image folder name
subF = "NotSquare" 'Specify the Target folder name

On Error Resume Next
MkDir strPath & subF
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPath)

tgt = strPath & subF & "\"
For Each f In objFolder.Items
PicDim = objFolder.GetDetailsOf(f, 31)
If InStr(1, PicDim, "x") > 0 Then
PicDim = Mid(PicDim, 2, Len(PicDim) - 2)
siz = Split(PicDim, "x")
If CLng(Trim(siz(0))) = W And CLng(Trim(siz(1))) = L Then
FileCopy strPath & f, tgt & f
End If
End If
Next
End Sub