FillRectPlus

Esta función la misma pero utilizando GDI Plus con más opciones, es muy útil a hora de trabajar con gráficos ya que se gana mucha velocidad.

Option Explicit
'------------------------------------------------------
'Autor: Leandro Ascierto
'Web:   www.leandroascierto.com.ar
'Fecha  02/04/2010
'------------------------------------------------------
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipCreateTexture Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mWrapMode As WrapMode, ByRef mTexture As Long) As Long
Private Declare Function GdipFillRectangle Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipScaleTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mSx As Single, ByVal mSy As Single, ByVal mOrder As Long) As Long
Private Declare Function GdipTranslateTextureTransform Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mDx As Single, ByVal mDy As Single, ByVal mOrder As Long) As Long
 
Private Enum WrapMode
    WrapModeTile = &H0
    WrapModeTileFlipX = &H1
    WrapModeTileFlipy = &H2
    WrapModeTileFlipXY = &H3
    WrapModeClamp = &H4
End Enum
 
Private Type GDIPlusStartupInput
    GdiPlusVersion                      As Long
    DebugEventCallback                  As Long
    SuppressBackgroundThread            As Long
    SuppressExternalCodecs              As Long
End Type
 
Private Const GdiPlusVersion            As Long = 1&
 
Dim GdipToken As Long
 
Private Function FillRectPlus(ByVal hdc As Long, _
                                ByVal hImage As Long, _
                                ByVal x As Single, _
                                ByVal y As Single, _
                                ByVal Width As Single, _
                                ByVal Height As Single, _
                                Optional ByVal nScaleX As Single = 1, _
                                Optional ByVal nScaleY As Single = 1, _
                                Optional EnuWrapMode As WrapMode) As Boolean 
 
    Dim hGraphics As Long
    Dim hBrush As Long
 
    If GdipCreateFromHDC(Me.hdc, hGraphics) = 0 Then 
        If GdipCreateTexture(hImage, EnuWrapMode, hBrush) = 0 Then 
            Call GdipTranslateTextureTransform(hBrush, x, y, 0) 
            Call GdipScaleTextureTransform(hBrush, nScaleX, nScaleY, 0) 
            FillRectPlus = GdipFillRectangle(hGraphics, hBrush, x, y, Width, Height) = 0 
            Call GdipDeleteBrush(hBrush)
        End If 
        Call GdipDeleteGraphics(hGraphics) 
    End If
 
End Function 
 
Private Sub InitGDI()
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = GdiPlusVersion
    Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub 
 
Private Sub TerminateGDI()
    Call GdiplusShutdown(GdipToken)
End Sub
  
Private Sub Form_Load()
    Dim hImage As Long 
    Me.AutoRedraw = True 
    InitGDI 
    If GdipLoadImageFromFile(StrPtr(App.Path & "\Text.png"), hImage) = 0 Then 
        FillRectPlus Me.hdc, hImage, 10, 10, 200, 200 
        Call GdipDisposeImage(hImage)
    End If 
    TerminateGDI
End Sub