Option Explicit
'Declare globals and Win32 API functions

Private Declare Function GetActiveWindow Lib "user32" () As Long

Public Sub Start()
  Dim InputPath, OutputPath, filename, x
  InputPath = BrowseForFolderDlg("c:\", "Choose Source Folder", GetActiveWindow)
  If InputPath = "" Then End
  If Right(InputPath, 1) <> "\" Then InputPath = InputPath + "\"
  Dim filenames() As String
  ReDim Preserve filenames(0)
  filename = Dir(InputPath + "*.jpg")  ' Retrieve the first entry.
  Do While filename <> ""    ' Start the loop.
    ' Use bitwise comparison to make sure FileName is a file.
    If (GetAttr(InputPath & filename) And vbNormal) = vbNormal And _
        (GetAttr(InputPath & filename) And vbDirectory) <> vbDirectory Then
      ReDim Preserve filenames(UBound(filenames) + 1)
      filenames(UBound(filenames)) = filename
    End If
    filename = Dir    ' Get next entry.
  Loop
  Dim frames
  frames = UBound(filenames)
  If frames = 0 Then
    MsgBox "No JPG files found in " + InputPath
    End
  End If
  OutputPath = InputPath + "output\"
  If Dir(OutputPath, vbDirectory) = "" Then
    MsgBox "Creating output directory:" + Chr$(13) + OutputPath
    MkDir OutputPath
  End If
  Dim OffsetX, OffsetY
  Dim OriginalHeight, OriginalWidth
  Dim NewHeight, NewWidth
  Dim parabola
  Dim MinHeight, MinWidth
  For x = 1 To frames
    ' Open the original image
    PHOTOPAINT.OpenDocument (InputPath + filenames(x))
    OriginalHeight = PHOTOPAINT.ActiveDocument.SizeHeight
    OriginalWidth = PHOTOPAINT.ActiveDocument.SizeWidth
        
    MinWidth = 450 ' How far in does the width get?
    MinHeight = Int(OriginalHeight / OriginalWidth * MinWidth + 0.5) ' Preserve the aspect ratio.
    ' Calculate perspective sensitivity
    parabola = (frames - x) ^ 2 / (frames - 1) ^ 2
    
    ' Zoom
    NewHeight = Int(parabola * (OriginalHeight - MinHeight) + MinHeight + 0.5)
    NewWidth = Int(parabola * (OriginalWidth - MinWidth) + MinWidth + 0.5)
        
    ' Pan
    OffsetX = Int((parabola - 1) * 550 + 0.5)
    OffsetY = -Int((parabola - 1) * 220 + 0.5)
    
    ' Convert the offset into absolute coordinates.
    OffsetX = OriginalWidth / 2 - OffsetX - NewWidth / 2
    OffsetY = OriginalHeight / 2 - OffsetY - NewHeight / 2
        
    ' Crop
    PHOTOPAINT.ActiveDocument.Crop OffsetX, OffsetY, NewWidth, NewHeight
    
    ' Resize all
    PHOTOPAINT.ActiveDocument.Resample MinWidth, MinHeight, True
    
    ' Save the new image
    Dim expflt As ExportFilter
    Set expflt = PHOTOPAINT.ActiveDocument.Export(OutputPath + filenames(x), cdrJPEG)
    With expflt
        .Progressive = False
        .Optimized = False
        .SubFormat = 0
        .Compression = 10
        .Smoothing = 5
        .Finish
    End With
    PHOTOPAINT.ActiveDocument.Close
  Next x
End Sub


' Everything below is just to get a directory picker dialog.
' It is copied from the HTMLSlideshow example.

Option Explicit

Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type


'****************
'API declarations
'****************
 Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                          (lpBrowseInfo As BROWSEINFO) As Long

 Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                          (ByVal pidl As Long, _
                          ByVal pszPath As String) As Long
    
 Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
 
 Public Declare Sub MoveMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
   (pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)
    
    Public Declare Function LocalAlloc Lib "kernel32" _
   (ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long
    
Public Declare Function LocalFree Lib "kernel32" _
   (ByVal hMem As Long) As Long

Public Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
  lParam As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Const MAX_PATH = 255
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)

Public Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

Select Case uMsg
    Case BFFM_INITIALIZED
            Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
                          True, ByVal lpData)
    Case Else
End Select
End Function

Public Function GetWindowHandle(strClassName As String, strWindowName As String) As Long
'as VBA does not support a Hwnd(window handle)property, we have to
'use this function to get the hwnd
'"ThunderDFrame" is the classname for VBA forms, but "ThunderFormDC"
'is the classname for VB forms, although this function is not needed
'for VB. The windowname is always the form's caption property.
GetWindowHandle = FindWindow(strClassName, strWindowName)

End Function
Public Function AddressOfCallBack(Address As Long) As Long
  
  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.
 
  'Obtain and set the address of the callback
  'This workaround is needed as you can't assign
  'AddressOf directly to a member of a user-
  'defined type, but you can assign it to another
  'long and use that (as returned here)
 
   AddressOfCallBack = Address

End Function
'---------------------------------------------
' Function: BrowseForFolderDlg
' Action: Invokes the Windows Browse for Folder dialog
' Return: If successful, returns the selected folder's full path,
' returns an empty string otherwise.
' -------------------------------------------------
Public Function BrowseForFolderDlg(strInitialFolder As String, strDialogPrompt As String, hwnd As Long) As String
    Dim BI As BROWSEINFO
    Dim lngPidlRtn As Long
    Dim strPath As String * MAX_PATH ' buffer
    Dim lpPath As Long
    
    On Error GoTo ErrHandler
    'If Right$(strInitialFolder, 1) <> "\" Then strInitialFolder = strInitialFolder & "\"
    With BI
        'verify that the directory is valid
        If strInitialFolder <> "" Then
            If GetAttr(strInitialFolder) And vbDirectory Then
                'CurrentDir = strInitialFolder
                'allocate memory for our string
                lpPath = LocalAlloc(LPTR, Len(strInitialFolder))
                'fill the memory with the contents of the string
                MoveMemory ByVal lpPath, ByVal strInitialFolder, Len(strInitialFolder)
                .lpfn = AddressOfCallBack(AddressOf BrowseCallbackProc)
                .lParam = lpPath
                '.lParam = SHSimpleIDListFromPath(strInitialFolder)
            End If
        End If
       
        .ulFlags = 1
        ' Whoever owns the handle that we pass will own the dialog
        ' The desktop folder will be the dialog's root folder if this
        'is initialized to 0.
        .hOwner = hwnd
        
        'SHSimpleIDListFromPath can also be used to set this value.
        .pidlRoot = 0
        ' Set the dialog's prompt string
        .lpszTitle = strDialogPrompt
    End With
    
    ' Shows the browse dialog and doesn't return until the dialog is
    ' closed. lngpidlRtn will contain the pidl of the selected folder if the dialog is not cancelled.
    lngPidlRtn = SHBrowseForFolder(BI)
    
    If lngPidlRtn Then
    ' Get the path from the selected folder's pidl returned
    ' from the SHBrowseForFolder call (rtns True on success,
    ' strPath must be pre-allocated!)
        If SHGetPathFromIDList(lngPidlRtn, strPath) Then
      ' Return the path
            BrowseForFolderDlg = Left$(strPath, InStr(strPath, vbNullChar) - 1)
        End If
    ' Free the memory the shell allocated for the selected folder's pidl.
        Call CoTaskMemFree(lngPidlRtn)
        
    End If
    'free the memory that we allocated for the pre-selected folder's pidl
    Call LocalFree(BI.lParam)
    
    Exit Function
ErrHandler:
    If lngPidlRtn Then
       Call CoTaskMemFree(lngPidlRtn)
    End If
    If lpPath Then
        Call LocalFree(lpPath)
    End If
    BrowseForFolderDlg = ""
End Function