Visual Basic, .NET, ASP, VBA, VBScript
 
  Библиотека кодов  
  Стандартные элементы >>> PictureBox/Image  
     
  Замена одних цветов другими  
  Данный пример покажет, как можно заменить один цвет другим в картинке.
Private Type RECT
left As Long
Top As Long
Right As Long
Bottom As Long
End Type

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 DeleteObject Lib "gdi32" (ByVal hObject 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 Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCPAINT = &HEE0086
Private Const SRCINVERT = &H660046
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Public Sub ReplaceColor(ByRef picThis As PictureBox, ByVal lFromColour As Long, ByVal lToColor As Long)
Dim lW As Long
Dim lH As Long
Dim lMaskDC As Long, lMaskBMP As Long, lMaskBMPOLd As Long
Dim lCopyDC As Long, lCopyBMP As Long, lCopyBMPOLd As Long
Dim tR As RECT
Dim hBr As Long
' Cache the width & height of the picture:
lW = picThis.ScaleWidth \ Screen.TwipsPerPixelX
lH = picThis.ScaleHeight \ Screen.TwipsPerPixelY
' Create a Mono DC & Bitmap
If (CreateDC(picThis, lW, lH, lMaskDC, lMaskBMP, lMaskBMPOLd, True)) Then
' Create a DC & Bitmap with the same colour depth as the picture:
If (CreateDC(picThis, lW, lH, lCopyDC, lCopyBMP, lCopyBMPOLd)) Then
' Make a mask from the picture which is white in the replace colour area:
SetBkColor picThis.hDC, lFromColour
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCCOPY
' Fill the colour DC with the colour we want to replace with
tR.Right = lW: tR.Bottom = lH
hBr = CreateSolidBrush(lToColor)
FillRect lCopyDC, tR, hBr
DeleteObject hBr
' Turn the colour DC black except where the mask is white:
BitBlt lCopyDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
' Create an inverted mask, so it is black where the colour is to be replaced but white otherwise:
hBr = CreateSolidBrush(&HFFFFFF)
FillRect lMaskDC, tR, hBr
DeleteObject hBr
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCINVERT
' AND the inverted mask with the picture. The picture
' goes black where the colour is to be replaced, but is
' unaffected otherwise.
SetBkColor picThis.hDC, &HFFFFFF
BitBlt picThis.hDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
' Finally, OR the coloured item with the picture. Where
' the picture is black and the coloured DC isn't,
' the colour will be transferred:
BitBlt picThis.hDC, 0, 0, lW, lH, lCopyDC, 0, 0, SRCPAINT
picThis.Refresh
' Clear up the colour DC:
SelectObject lCopyDC, lCopyBMPOLd
DeleteObject lCopyBMP
DeleteObject lCopyDC
End If
' Clear up the mask DC:
SelectObject lMaskDC, lMaskBMPOLd
DeleteObject lMaskBMP
DeleteObject lMaskDC
End If
End Sub

Public Function CreateDC(ByRef picThis As PictureBox, ByVal lW As Long, ByVal lH As Long, ByRef lhDC As Long, ByRef lhBmp As Long, ByRef lhBmpOld As Long, Optional ByVal bMono As Boolean = False) As Boolean
If (bMono) Then
lhDC = CreateCompatibleDC(0)
Else
lhDC = CreateCompatibleDC(picThis.hDC)
End If
If (lhDC <> 0) Then
If (bMono) Then
lhBmp = CreateCompatibleBitmap(lhDC, lW, lH)
Else
lhBmp = CreateCompatibleBitmap(picThis.hDC, lW, lH)
End If
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
CreateDC = True
Else
DeleteObject lhDC
lhDC = 0
End If
End If
End Function

Private Sub Command1_Click()
Static i As Integer
ReplaceColor Picture1, QBColor(i), &HFFFF&
i = i + 1
If (i > 15) Then
MsgBox "All colours replaced."
End If
End Sub

Private Sub Form_Load()
Dim i As Long
Dim x As Long, y As Long, w As Long, h As Long
Picture1.BackColor = &HFFFF00
For i = 1 To 200
x = Rnd * Picture1.ScaleWidth: y = Rnd * Picture1.ScaleHeight
w = Rnd * Picture1.ScaleWidth: h = Rnd * Picture1.ScaleHeight
Picture1.Line (x, y)-(x + w, y + h), QBColor(Rnd * 15), BF
Picture1.CurrentX = x: Picture1.CurrentY = y
Picture1.Print "vbAccelerator Mask Demo"
Next i
End Sub
 
     
  VBNet online (всего: 51566)  
 

Логин:

Пароль:

Регистрация, забыли пароль?


В чате сейчас человек
 
     
  VBNet рекомендует  
   
     
  Лучшие материалы  
 
ActiveX контролы (112)
Hitman74_Library (36119)
WindowsXPControls (20739)
FlexGridPlus (19374)
DSMAniGifControl (18295)
FreeButton (15157)
Примеры кода (546)
Parol (18027)
Passworder (9299)
Screen saver (7654)
Kerish AI (5817)
Folder_L (5768)
Статьи по VB (136)
Мое второе впечатление... (11236)
VB .NET: дорога в будущее (11161)
Основы SQL (9225)
Сообщения Windows в Vi... (8788)
Классовая теория прогр... (8619)
 
     
Техническая поддержка MTW-хостинг | © Copyright 2002-2011 VBNet.RU | Пишите нам