Código:
Option Explicit
'Function: FillRectEx
'Autor Leandro Ascierto
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetTickCount& Lib "kernel32" ()
Private Sub Pintar()
Dim x As Long
Dim y As Long
Do While y < Me.ScaleHeight
Do While x < Me.ScaleWidth
BitBlt Me.hdc, x, y, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, vbSrcCopy
x = x + Picture1.ScaleWidth
Loop
y = y + Picture1.ScaleHeight
x = 0
Loop
End Sub
Private Sub Form_Load()
Me.Show
DoEvents
Me.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Form_Resize
End Sub
Private Sub Form_Resize()
Dim i As Integer
Dim lTime As Long
'lTime = GetTickCount&
'For i = 0 To 100
FillRectEx Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight
'call Pintar
'Next
'Debug.Print GetTickCount& - lTime
End Sub
Private Sub FillRectEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, SrcDC As Long, SrcX As Long, SrcY As Long, SrcWidth As Long, SrcHeight As Long)
Dim DC As Long
Dim hDCMemory As Long
Dim hBmp As Long
Dim mBrush As Long
Dim Rec As RECT
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, SrcWidth, SrcHeight)
Call SelectObject(hDCMemory, hBmp)
BitBlt hDCMemory, 0, 0, SrcWidth, SrcHeight, SrcDC, SrcX, SrcY, vbSrcCopy
mBrush = CreatePatternBrush(hBmp)
SetRect Rec, DestX, DestY, DestWidth + DestX, DestHeight + DestY
FillRect DestDC, Rec, mBrush
DeleteObject mBrush
DeleteObject hBmp
DeleteDC DC
DeleteDC hDCMemory
End Sub
Saludos