by jjo (5 Submissions)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 5th January 2005
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Fits and centers an image on a form.
API Declarations
' You need a form called Form1 with an image control called Image1
' Modify the argument to loadImage in the Form_Load() method with
' an existing file and press f5
VBcoders
Private Sub Form_Load()
ScaleMode = vbPixels
BackColor = vbBlack
loadImage "c:\MyJpeg.jpg"
End Sub
Private Sub Form_Resize()
fitImage
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KeyCodeConstants.vbKeyEscape Then
Unload Me
End If
End Sub
Private Sub loadImage(imageFile As String)
On Error Resume Next
Image1.Picture = LoadPicture(imageFile)
fitImage
If Err.Number Then
MsgBox _
Err.Source & ".loadImage()" & vbLf & _
Err.Description, _
vbApplicationModal + vbMsgBoxSetForeground, _
"Error " & Err.Number
End If
End Sub
Private Function getWidth() As Single
If BorderStyle = vbSizable Then
getWidth = Abs((Width - 8 * Screen.TwipsPerPixelX) / Screen.TwipsPerPixelX)
Else
getWidth = Width / Screen.TwipsPerPixelX
End If
End Function
Private Function getHeight() As Single
If BorderStyle = vbSizable Then
' why 28 ? i have no idea
getHeight = Abs((Height - 28 * Screen.TwipsPerPixelY) / Screen.TwipsPerPixelY)
Else
getHeight = Height / Screen.TwipsPerPixelY
End If
End Function
Private Sub fitImage()
On Error GoTo ERR_HANDLE
Dim w As Single, h As Single, sw As Single, sh As Single
Dim rw As Single, rh As Single
Dim r As Single
Dim b As Boolean
sw = getWidth()
sh = getHeight()
w = Image1.Width
h = Image1.Height
rw = sw / w
rh = sh / h
' box
If (w = h) Then
r = IIf(sh < sw, rh, rw)
' landscape
ElseIf (w > h) Then
r = IIf(h * rw > sh, rh, rw)
' portrait
Else
r = IIf(w * rh > sw, rw, rh)
End If
w = w * r
h = h * r
Image1.Move (sw - w) * 0.5, (sh - h) * 0.5, w, h
Image1.Stretch = True
EXIT_HANDLE:
Exit Sub
ERR_HANDLE:
If Err.Number <> 5 Then
MsgBox _
Err.Description, _
vbApplicationModal + vbMsgBoxSetForeground, _
"Error #" & Err.Number
End If
Err.Clear
GoTo EXIT_HANDLE
End Sub
' end form code