Помогите кто сможет. Требуется создать маску(растровый файл, точки, которые непрозрачные становяться черными, а белые остаются), с картинки. Картинка на белом фоне. Вот текст кода:
| Код |
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 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" (ByVal hObject As Long) As Long
Private hdcMono, hbmpMono, hbmpOld As Long
Private dx, dy As Long
Private Sub Form_Load()
With PicOut
.AutoSize = True
.AutoRedraw = True
.ScaleMode = vbPixels
dx = .ScaleWidth
dy = .ScaleHeight
End With
With PicInp
.Width = PicOut.Width
.Height = PicOut.Height
.ScaleMode = vbPixels
.AutoRedraw = True
End With
hdcMono = CreateCompatibleDC(0)
hbmpMono = CreateCompatibleBitmap(hdcMono, dx, dy)
hbmpOld = SelectObject(hdcMono, hbmpMono)
BitBlt hdcMono, 0, 0, dx, dy, PicOut.hdc, 0, 0, vbcopy
BitBlt PicInp.hdc, 0, 0, dx, dy, hdcMono, 0, 0, vbcopy
PicInp.Refresh
SelectObject hdcMono, hbmpOld
DeleteDC hdcMono
DeleteObject hbmpMono
End Sub
|
Но почему-то не хочет работать.... |