Attribute VB_Name = "StretchBmp"
Option Explicit

'' StretchBmp.bas
'' By Kirk Siqveland
'' vindalf@minomech.com
''
'' 'Make your modules modular!'
''
'' This module allows you to easily implement multiple dynamically resizing images within
'' PictureBoxes on multiple forms.
''
'' For my part you can use this code in any manner you like, and thank-you to everyone else who posts
'' Code on the web, I am entirely self-taught using mostly just code posted on the web!
''
'' USAGE:
'' Run the 'StretchPrep' routine for each PictureBox (probably in the Form_Load) e.g.:
''
''          StretchPrep Picture1
''
'' Call 'PBStretch' from the _Resize function for each PictureBox and that's it!
''
''        Private Sub PBox_Resize()
''            StretchPB PBox
''        End Sub
''
'' Honest it's that simple!
''
'' The Code accounts for different ScaleModes (pixels, twips, inches...) on the PictureBoxes,
'' But If anyone knows why I still need the XFactor(1.76) I'd love to know so I can
'' eliminate the hard number!
''
'' The Module format, the ScaleMode work-around and the use of Get/SetProp to carry essential
'' information is my own inspiration and work, the core of the actual stretch process is derived
'' from code posted to the Web by By Jamie Plenderleith -
'' http://www.vbforums.com/archive/index.php/t-157521.html
'' plenderj@tcd.ie
''

'I don't know where this value comes from but I needed it to get things to fit right!
Private Const XFactor As Single = 1.76

'The API's:
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" _
        (ByVal hdc As Long) As Long
        
Private Declare Function DeleteObject Lib "gdi32.dll" _
        (ByVal hObject As Long) As Long
        
Private Declare Function SelectObject Lib "gdi32.dll" _
        (ByVal hdc As Long, ByVal hObject As Long) As Long
        
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" _
        (ByVal hwnd As Long, ByVal lpString As String) As Long
        
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" _
        (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
        
Private Declare Function StretchBlt Lib "gdi32.dll" _
        (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
         ByVal nWidth As Long, ByVal nHeight As Long, _
         ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
         ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'


Public Function StretchPrep(frm As Form, PicBox As PictureBox, ByVal Filename As String) As Long
'This must be run before the BPStretch will work!

    Dim NewDC As Long
    Dim picTemp As IPictureDisp
    Dim ptWide As Long
    Dim ptHigh As Long
    
    'Make sure we have a good image file to work with!
        If Dir(Filename) = vbNullString Then
            MsgBox "Invalid filename for PictureBox Image", vbExclamation
            Exit Function
        End If
        
    'Make sure AutoRedraw is On
        PicBox.AutoRedraw = True
        
    'Generate a new Display Context for the image so we have a way to manipulate it later.
        Do Until NewDC <> 0
            NewDC = CreateCompatibleDC(0)
            Set picTemp = LoadPicture(Filename)
                ptHigh = picTemp.Height 'as far as I can tell this is always in twips
                ptWide = picTemp.Width  'ditto
            SelectObject NewDC, picTemp 'This gives us the DC
            DeleteObject picTemp
            Set picTemp = Nothing
        Loop
        
    'Convert the Image dimensions from twips into pixels
        ptHigh = frm.ScaleY(ptHigh, vbTwips, vbPixels)
        ptWide = frm.ScaleX(ptWide, vbTwips, vbPixels)
        
    'Use the SetProp / GetProp API's to package the info we need into the PictureBox itself.
        SetProp PicBox.hwnd, "SrcDC", NewDC
        SetProp PicBox.hwnd, "SrcHigh", ptHigh
        SetProp PicBox.hwnd, "srcWide", ptWide
    
End Function

Public Function StretchPB(PicBox As PictureBox)
    Dim SrcDC As Long
    Dim SrcHigh As Long
    Dim SrcWide As Long
    Dim urScale As Integer  '#!# You can drop these lines if PictureBox ScaleMode
                            '    is set to pixels
    
On Error GoTo ExitNow
    
    With PicBox
        urScale = .ScaleMode    '#!#
        .ScaleMode = vbPixels   '#!#
        'Extract the extra info we added about the original picture:
            SrcDC = GetProp(.hwnd, "SrcDC")
            SrcHigh = GetProp(.hwnd, "SrcHigh")
            SrcWide = GetProp(.hwnd, "SrcWide")
        
        'Now we can do all the work in one line! - pretty easy once we have collected all the information we need!
        'Note we use the Scale Height and Width to be sure we fit the available client area.
            StretchBlt PicBox.hdc, 0, 0, PicBox.ScaleWidth * XFactor, PicBox.ScaleHeight * XFactor, _
                        SrcDC, 0, 0, SrcWide, SrcHigh, vbSrcCopy
        .Refresh
    End With

ExitNow:
    PicBox.ScaleMode = urScale    '#!#
End Function