USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (ActiveX/Controles/DLL)

Título da Dica:  converter imagens coloridas em Preto e branco
Postada em 5/4/2006 por Geronimo            
Esse código é, originalmente, do papa do VB Steve McMahon (http://www.vbaccelerator.com). Ele possibilita que vc troque uma cor por outra numa imagem que esteja dentro de um picturebox.

Para testar desenhe 1 picturebox com autosize=true, 3 commandbuttons com Style=1- Graphical, 1 CommonDialog e cole o seguinte código:

Option Explicit

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()

    ReplaceColor Picture1, Command2.BackColor, Command3.BackColor

End Sub

Private Sub Command2_Click()

    On Error GoTo there
    
    With CommonDialog1
        .ShowColor
        Command2.BackColor = .Color
    End With
    
there:

End Sub

Private Sub Command3_Click()

    On Error GoTo there
    
    With CommonDialog1
        .ShowColor
        Command3.BackColor = .Color
    End With
    
there:

End Sub

Private Sub Form_Load()

    Command1.Caption = "Trocar a 1ª pela 2ª"
    Command2.Caption = ""
    Command3.Caption = ""
    Command2.BackColor = vbBlack
    Command3.BackColor = vbWhite
    
    With Picture1
        .AutoSize = True
        .AutoRedraw = True
        ' Troque pela sua imagem
        Set .Picture = LoadPicture("c:imagem.gif")
    End With

End Sub

Quando vc clicar em command1, o programa troca a cor do command2 pela do command3, para escolher essas cores clique o botão correspondente
 


CyberWEB Network Ltda.    © Copyright 2000-2021   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página