Picture Zoom для Zoog (...ну и вообще кому интересно...)

Сразу извенюсь... в прошлый раз забыл про SetStretchBltMode.
Кидаю API объявления...вроде ниче не забыл ...) и функцию для Zoom.
Параметры PictureZoom:
TargetPicObj - объект PictureBox, где надо выполнять рисование.
SourcePic - объект IPictureDisp содержащий картинку которую будем рисовать.
ScaleVal - масштаб в процентах
X - координата X в пикселах, для смещения картинки в объкте TargetPicObj.
Y - координата Y в пикселах, для смещения картинки в объкте TargetPicObj.
Возвращает True при успешном выполнении.
Некоторые условия:
1. Иконки не рисуем.
2. Работает в True Color режимах, и с True Color картинками. Чтобы применять картинки с 256 и 16 цветами, надо добавить работу с палитрой. Попробуй сделать сам, если конечно это надо....хотя, для самообразования неплохо!!!)

0

В предыдушем сообщении надо добавить объявление
Private Declare Function DeleteDC Lib 'gdi32' (ByVal hdc As Long) As Long

и все что ниже метки заменить на:
f_Clear:
GlobalUnlock hMem
GlobalFree hMem

SelectObject memDC, prevBmp
DeleteObject memBmp
DeleteObject hb

DeleteDC memDC

0

Еще один примерчик - параметры как и у предыдущей функции, только работает с контекстом, а не битмапой... Палитру тоже не делал....
Одно приемущество, что в True Color режимах нормально хавает 256 и 16 цветную графику.....и сама задача не падает...
Можешь на нее заменить!

Private Const DIB_RGB_COLORS = 0
Private Const GMEM_MOVEABLE = &H2
Private Const BI_RGB = 0&
Private Const SRCCOPY = &HCC0020
Private Const BLACKONWHITE = 1
Private Const STRETCH_DELETESCANS = 3

Private Type BITMAP '14 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

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 Declare Function CreateCompatibleDC Lib 'gdi32' (ByVal hdc As Long) As Long
Private Declare Function StretchDIBits Lib 'gdi32' (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib 'gdi32' (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib 'gdi32' (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib 'gdi32' (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GlobalAlloc Lib 'kernel32' (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib 'kernel32' (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib 'kernel32' (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib 'kernel32' (ByVal hMem 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 SetStretchBltMode Lib 'gdi32' (ByVal hdc As Long, ByVal nStretchMode 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 GetClientRect Lib 'user32' (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Sub OleTranslateColor Lib 'oleaut32.dll' (ByVal ColorIn As Long, ByVal hPal As Long, ByRef RGBColorOut As Long)
Private Declare Function CreateSolidBrush Lib 'gdi32' (ByVal crCol

0