StretchBlt() mit GDIplus


Hier mal ein GDI+ Script als Ersatz für die StretchBlt-Funktion.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code Form1
'Erstellen Sie folgende Steuerelemente:
'CommandButton Command1, CommandButton Command2, Form Form1,
'PictureBox Picture1, PictureBox Picture2


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
 

Quell-Code Modul1
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