I thought you almost had it!
Have a go with this, pretty much along the lines I tried to suggest earlier,
with rescale method rather than frame zoom).
View pictures in a folder
Populates an array with picture files in msPath
If picture too large reduces to max default size
Left click the image +/- 25% original size
Double click image to reset default size
Next button to load next picture
'UserForm StartUpPosition 0 Manual
'Image1 AutoSize True
' PictureSizeMode 3 frmPictureSizeModeZoom
'CommandButton1 caption "Next"
'
'change sPath to some picture folder (in the Initialize event),
'
'Change DEFWIDTH & DEFHEIGHT to suit
' eg can get monitor res' from an API
' then typically need to reduce by 75%
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Const SM_CYCAPTION = 4
Dim mWd As Long, mHt As Long
Dim mCapHt As Long
Dim mnCurrentPic As Long
Dim mButtonBottom As Long
Dim mInc As Long
Dim mdblZoom As Double
Dim mDefScale As Double
Dim msPath As String
Dim masPics() As String
Const cBDR_WD = 4 ' approx image border width
Const DEFWIDTH = 800 * 0.75
Const DEFHEIGHT As Long = 600 * 0.75
Private Sub CommandButton1_Click()
'Next button
If mnCurrentPic = UBound(masPics) Then
mnCurrentPic = 0
Else
mnCurrentPic = mnCurrentPic + 1
End If
LoadPic msPath & masPics(mnCurrentPic)
End Sub
Private Sub Image1_Click()
mdblZoom = (mdblZoom * 100 \ 25) * 0.25
If mdblZoom > 1.25 Then mInc = -1
If mdblZoom < 0.5 Then mInc = 1
mdblZoom = mdblZoom + (0.25 * mInc)
Resize
End Sub
Private Sub Image1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
mdblZoom = mDefScale
Resize
End Sub
Private Sub UserForm_Initialize()
msPath = "C:\Pictures\"
'sPath = "C:\My Documents\My Pictures\"
With Me.CommandButton1
.Caption = "Next"
.Top = 0
.Left = 0
End With
If GetPics(msPath) Then
MsgBox "Error getting picture files"
Else
mCapHt = GetSystemMetrics(SM_CYCAPTION) * 0.75
With Me.CommandButton1
mButtonBottom = .Top + .Height
End With
LoadPic msPath & masPics(0)
End If
End Sub
Function GetPics(sPath As String) As Long
Dim sFile As String
Dim n As Long
Dim i As Long
Dim arr
arr = Array("*.jpg", "*.gif", "*.bmp")
ReDim masPics(0 To 100)
On Error GoTo errH
n = -1
For i = 0 To UBound(arr)
sFile = Dir(sPath & arr(i))
Do While Len(sFile)
n = n + 1
masPics(n) = sFile
sFile = Dir()
Loop
Next
ReDim Preserve masPics(0 To n)
Exit Function
errH:
If n > UBound(masPics) Then
ReDim Preserve masPics(0 To UBound(masPics) + 100)
Resume
End If
GetPics = Err.Number
End Function
Sub LoadPic(sFile As String)
Dim xDiff As Long, yDiff As Long
With Me.Image1
.AutoSize = True
.Left = 0
.Top = mButtonBottom
.Picture = LoadPicture(sFile)
mWd = .Width
mHt = .Height
End With
Me.Top = 0
Me.Left = 0
Me.Width = mWd + cBDR_WD
Me.Height = mHt + mCapHt + mButtonBottom
mInc = -1
With Me
xDiff = .Width - DEFWIDTH
yDiff = .Height - DEFHEIGHT
End With
If xDiff > 0 Or yDiff > 0 Then
If xDiff / DEFWIDTH > yDiff / DEFHEIGHT Then
mDefScale = 1 - (xDiff / mWd)
Else
mDefScale = 1 - (yDiff / mHt)
End If
mdblZoom = mDefScale
Resize
Else
mDefScale = 1
Me.Caption = "100% " & masPics(mnCurrentPic)
End If
Me.Caption = Me.Caption & " " _
& mnCurrentPic + 1 & "\" & UBound(masPics) + 1
End Sub
Private Sub Resize()
With Image1
.Width = Int(mWd * mdblZoom)
.Height = Int(mHt * mdblZoom)
End With
'might want to restrict min width to right edge of rightmost button
Me.Width = Int(mWd * mdblZoom) + cBDR_WD
Me.Height = Int(mHt * mdblZoom) + mCapHt + mButtonBottom
Me.Caption = Int(mdblZoom * 100) & "% " & masPics(mnCurrentPic)
End Sub
Some of the dimension allowances are not quite right but I think near enough
for a light demo.
Regards,
Peter T
PS
Run-time error '-2147352573 (80020003)':
Could not find the specified object.
probably 'LName(1)' not path & name of an image file
