Option Explicit
 
Private Declare Function StretchBlt Lib "gdi32" (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
 
'Parameter -> StretchBlt
'X -> Die x-Koordinate der linken oberen Ecke des Zielrechtecks, angegeben in logischen Einheiten.
'Y -> Die y-Koordinate der linken oberen Ecke des Zielrechtecks, angegeben in logischen Einheiten.
'nWidth -> Die Breite des Zielrechtecks, angegeben in logischen Einheiten.
'nHeight -> Die Höhe des Zielrechtecks, angegeben in logischen Einheiten.
'xSrc -> Die x-Koordinate der linken oberen Ecke des Quell-Rechtecks, angegeben in logischen Einheiten.
'ySrc -> Die x-Koordinate der linken oberen Ecke des Quell-Rechtecks, angegeben in logischen Einheiten.
'nSrcWidth -> Die Breite des Quellrechtecks, angegeben in logischen Einheiten.
'nSrcHeight -> Die Höhe des Quellrechtecks, angegeben in logischen Einheiten.

 
Private Sub Command1_Click()
   Dim token    As Long 'GDI+
 
   Picture2.Picture = LoadPicture("")
   Picture1.AutoRedraw = True
   Picture2.AutoRedraw = True
 
    ' Initialise GDI+
    token = InitGDIPlus
 
   Picture2.Picture = StretchBltGDI(20, 20, Picture2.ScaleWidth - 40, Picture2.ScaleHeight - 40, Picture1.Picture.Handle, _
                                             Picture1.Picture.Type, 100, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbWhite)
 
   ' Free GDI+
    FreeGDIPlus token
 
    Picture1.AutoRedraw = False
    Picture2.Refresh
    Picture2.AutoRedraw = False
 
End Sub

 
Private Sub Command2_Click()
   Picture2.Picture = LoadPicture("")
    Picture1.AutoRedraw = True
   Picture2.AutoRedraw = True
 
 
    StretchBlt Picture2.hDC, 20, 20, Picture2.ScaleWidth + 47, Picture2.ScaleHeight - 40, Picture1.hDC, 100, 0, _
                                                                   Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy
 
    Picture1.AutoRedraw = False
    Picture2.Refresh
    Picture2.AutoRedraw = False
End Sub

 
Private Sub Form_Load()
   Form1.ScaleMode = 3
   Command1.Caption = "GDI+"
   Command2.Caption = "StretchBlt"
   Picture1.ScaleMode = 3
   Picture2.ScaleMode = 3
   Picture1.Width = 200
   Picture1.Height = 200
   Picture2.Width = 127
   Picture2.Height = 265
   Picture2.BackColor = vbWhite
   Picture1.Picture = LoadPicture(App.Path & "\Test.jpg") '-- 200 x 200 Pixel
End Sub

Option Explicit
 
Private Type GUID
   Data1    As Long
   Data2    As Integer
   Data3    As Integer
   Data4(7) As Byte
End Type
 
Private Type PictDesc
   Size     As Long
   Type     As Long
   hBmp     As Long
   hPal     As Long
   Reserved As Long
End Type
 
Private Type GDIPlusStartupInput
    GdiPlusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
 
Private Type PWMFRect16
    Left   As Integer
    Top    As Integer
    Right  As Integer
    Bottom As Integer
End Type
 
Private Type wmfPlaceableFileHeader
    Key         As Long
    hMf         As Integer
    BoundingBox As PWMFRect16
    Inch        As Integer
    Reserved    As Long
    CheckSum    As Integer
End Type
 
' GDI Functions
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, _
                 RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
'Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, _
                                        ByVal nWidth As Long, ByVal nHeight As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, _
                              ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, _
                             ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
 
' GDI+ functions
'Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal FileName As Long, _
                                                                   GpImage As Long) As Long
 
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (token As Long, gdipInput As GDIPlusStartupInput, _
                                                                  GdiplusStartupOutput As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "GdiPlus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
Private Declare Function GdipSetInterpolationMode Lib "GdiPlus.dll" (ByVal graphics As Long, _
                                                                               ByVal InterMode As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, _
                                                                               GpBitmap As Long) As Long
Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function GdipCreateMetafileFromWmf Lib "GdiPlus.dll" (ByVal hWmf As Long, ByVal deleteWmf As Long, _
                                                    WmfHeader As wmfPlaceableFileHeader, Metafile As Long) As Long
Private Declare Function GdipCreateMetafileFromEmf Lib "GdiPlus.dll" (ByVal hEmf As Long, ByVal deleteEmf As Long, _
                                                                               Metafile As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "GdiPlus.dll" (ByVal hIcon As Long, GpBitmap As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal GpImage As Long, _
      ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, _
      ByVal SrcX As Long, ByVal SrcY As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, _
      ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal Callback As Long, ByVal CallbackData As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal token As Long)
 
' GDI and GDI+ constants
Private Const Planes = 14            '  Number of planes
Private Const BITSPIXEL = 12         '  Number of bits per pixel
Private Const PATCOPY = &HF00021     ' (DWORD) dest = pattern
Private Const PICTYPE_BITMAP = 1     ' Bitmap type
Private Const InterpolationModeHighQualityBicubic = 7
Private Const GDIP_WMF_PLACEABLEKEY = &H9AC6CDD7
Private Const UnitPixel = 2
 
' Initialises GDI Plus

Public Function InitGDIPlus() As Long
    Dim token    As Long
    Dim gdipInit As GDIPlusStartupInput
 
    gdipInit.GdiPlusVersion = 1
    GdiplusStartup token, gdipInit, ByVal 0&
    InitGDIPlus = token
End Function

 
' Frees GDI Plus
Public Sub FreeGDIPlus(token As Long)
    GdiplusShutdown token
End Sub

 
' Initialises the hDC to draw
Private Sub InitDC(hDC As Long, hBitmap As Long, BackColor As Long, Width As Long, Height As Long)
    Dim hBrush As Long
 
    ' Create a memory DC and select a bitmap into it, fill it in with the backcolor
    hDC = CreateCompatibleDC(ByVal 0&)
    hBitmap = CreateBitmap(Width, Height, GetDeviceCaps(hDC, Planes), GetDeviceCaps(hDC, BITSPIXEL), ByVal 0&)
    hBitmap = SelectObject(hDC, hBitmap)
    hBrush = CreateSolidBrush(BackColor)
    hBrush = SelectObject(hDC, hBrush)
    PatBlt hDC, 0, 0, Width, Height, PATCOPY
    DeleteObject SelectObject(hDC, hBrush)
End Sub

 
' Replaces the old bitmap of the hDC, Returns the bitmap and Deletes the hDC
Private Sub GetBitmap(hDC As Long, hBitmap As Long)
    hBitmap = SelectObject(hDC, hBitmap)
    DeleteDC hDC
End Sub

 
' Creates a Picture Object from a handle to a bitmap
Private Function CreatePicture(hBitmap As Long) As IPicture
    Dim IID_IDispatch As GUID
    Dim Pic           As PictDesc
    Dim ipic          As IPicture
 
    ' Fill in OLE IDispatch Interface ID
    IID_IDispatch.Data1 = &H20400
    IID_IDispatch.Data4(0) = &HC0
    IID_IDispatch.Data4(7) = &H46
 
    ' Fill Pic with necessary parts
    Pic.Size = Len(Pic)        ' Length of structure
    Pic.Type = PICTYPE_BITMAP  ' Type of Picture (bitmap)
    Pic.hBmp = hBitmap         ' Handle to bitmap
 
    ' Create the picture
    OleCreatePictureIndirect Pic, IID_IDispatch, True, ipic
    Set CreatePicture = ipic
End Function

 
Public Function StretchBltGDI(X As Long, Y As Long, nWidth As Long, nHeight As Long, Handle As Long, _
              picType As PictureTypeConstants, xSrc As Long, ySrc As Long, Optional nSrcWidth As Long = 0, _
              Optional nSrcHeight As Long = 0, Optional BackColor As Long = vbWhite) As IPicture
 
    Dim img       As Long
    Dim hDC       As Long
    Dim hBitmap   As Long
    Dim graphics   As Long ' Graphics Object Pointer
    Dim WmfHeader As wmfPlaceableFileHeader
 
 
    ' Determine pictyre type
    Select Case picType
    Case vbPicTypeBitmap
         GdipCreateBitmapFromHBITMAP Handle, ByVal 0&, img
    Case vbPicTypeMetafile
         FillInWmfHeader WmfHeader, nWidth, nHeight
         GdipCreateMetafileFromWmf Handle, False, WmfHeader, img
    Case vbPicTypeEMetafile
         GdipCreateMetafileFromEmf Handle, False, img
    Case vbPicTypeIcon
         ' Does not return a valid Image object
         GdipCreateBitmapFromHICON Handle, img
    End Select
 
    ' Continue with resizing only if we have a valid image object
    If img Then
        InitDC hDC, hBitmap, BackColor, nWidth + X, nHeight + Y
 
        GdipCreateFromHDC hDC, graphics
        GdipSetInterpolationMode graphics, InterpolationModeHighQualityBicubic
 
        If nSrcWidth = 0 Or nSrcHeight = 0 Then
           GdipGetImageWidth img, nSrcWidth
           GdipGetImageHeight img, nSrcHeight
        End If
 
        GdipDrawImageRectRectI graphics, img, X, Y, nWidth, nHeight, xSrc, ySrc, nSrcWidth - xSrc, _
                                                   nSrcHeight - ySrc, UnitPixel, 0, 0, 0
 
        GdipDeleteGraphics graphics
 
        GdipDisposeImage img
        GetBitmap hDC, hBitmap
        Set StretchBltGDI = CreatePicture(hBitmap)
    End If
End Function

 
' Fills in the wmfPlacable header
Private Sub FillInWmfHeader(WmfHeader As wmfPlaceableFileHeader, Width As Long, Height As Long)
    WmfHeader.BoundingBox.Right = Width
    WmfHeader.BoundingBox.Bottom = Height
    WmfHeader.Inch = 1440
    WmfHeader.Key = GDIP_WMF_PLACEABLEKEY
End Sub