А вот и она:
- Код: Выделить всё
Sub ClipBltRect(DestW As Long, DestH As Long, dr As RECT, sr As RECT)
'DestH-высота целевой поверхности
'DestW-ширина целевой поверхности
'dr-Прямоугольник назначения
'sr-Прямоугольник исходный
'Функция вызывается после расчета dr и sr перед блиттингом
'Параметры sr и dr передаються по ссылке и изменяються функцией
Dim KoefX As Single
Dim KoefY As Single
KoefX = (sr.Right - sr.Left) / (dr.Right - dr.Left)
KoefY = (sr.Top - sr.Bottom) / (dr.Top - dr.Bottom)
If (dr.Left >= 0) And (dr.Top >= 0) And _
(dr.Right) <= DestW And (dr.Bottom) <= DestH Then
Exit Sub
End If
If dr.Left < 0 Then sr.Left = sr.Left - dr.Left * KoefX: dr.Left = 0
If dr.Top < 0 Then sr.Top = sr.Top - dr.Top * KoefY: dr.Top = 0
If (dr.Right) > DestW Then sr.Right = sr.Right - _
(dr.Right - DestW) * KoefX: dr.Right = DestW
If (dr.Bottom) > DestH Then sr.Bottom = sr.Bottom - _
(dr.Bottom - DestH) * KoefY: dr.Bottom = DestH
End Sub
Прошу заценить
