picture dimmer?

[prye]

anyone know a good way to make a picture looked dimmed like win does when it pops up the shutdown dialog?

[Aaron Young]

Try:

Private Sub Command1_Click()
    Dim lX As Long, lY As Long, lVal As Long
    
    With Picture1
        .ScaleMode = vbPixels
        lX = .ScaleWidth
        lY = .ScaleHeight
        lVal = lX
        If lY < lX Then
            lX = lY
            lY = lVal
        End If
        
        For lVal = 0 To lY Step 2
            Picture1.Line (lVal, 0)-Step(lX, lX), RGB(20, 20, 20)
            Picture1.Line (0, lVal)-Step(lX, lX), RGB(20, 20, 20)
        Next
    End With
End Sub

[Mad Compie]

This may be a faster solution, using BitBlt:

Function DuoTone(hSrcDC As Long, nWidth As Integer, nHeight As Integer, DuoColor As Long, hDestDC As Long) As Boolean
    Dim CopyDC As Long, CopyBitmap As Long, mBrush As Long, R As RECT
    CopyDC = CreateCompatibleDC(hSrcDC)
    CopyBitmap = CreateCompatibleBitmap(hSrcDC, nWidth, nHeight)
    If SelectObject(CopyDC, CopyBitmap) = 0 Then Exit Function
    
    SetRect R, 0, 0, nWidth, nHeight
    mBrush = CreateSolidBrush(DuoColor)
    If FillRect(CopyDC, R, mBrush) = 0 Then Exit Function
    
    BitBlt CopyDC, 0, 0, nWidth, nHeight, hSrcDC, 0, 0, vbSrcAnd
    If BitBlt(hDestDC, 0, 0, nWidth, nHeight, CopyDC, 0, 0, vbSrcCopy) = 0 Then Exit Function

    DeleteObject mBrush
    DeleteObject CopyBitmap
    DeleteDC CopyDC
    DuoTone = True
End Function

You can call it like this:

  DuoTone picA.hdc, picA.ScaleWidth, picA.ScaleHeight, &H808080, OutputDC

[prye]

cool, thanks

[PaulLewis]

Can you please post with declares and please define OutputDC as well?

Thanks
Paul Lewis

[Mad Compie]

Yes, here it is:

Option Explicit

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

Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount 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 Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Const TA_CENTER = 6

Private Sub Form_Click()
  DuoTone Me.hdc, Me.ScaleWidth, Me.ScaleHeight, &H808080, Me.hdc
End Sub

Private Sub Form_DblClick()
  Unload Me
End Sub

Private Sub Form_Load()
    Dim S As String
    
    Me.AutoRedraw = True
    
    Me.Width = 9030
    Me.Height = 6930
    
    Me.Picture = LoadPicture("C:\windows\setup.bmp")
    Me.FontName = "Arial"
    Me.FontBold = True
    Me.FontSize = 22
    Me.ScaleMode = vbPixels
    
    SetTextAlign Me.hdc, TA_CENTER
    
    S = "Picture dimmer"
    Me.ForeColor = &H0&
    TextOut Me.hdc, Me.ScaleWidth / 2, 20, S, Len(S)
    Me.ForeColor = &HFFFFFF
    TextOut Me.hdc, Me.ScaleWidth / 2 - 1, 19, S, Len(S)
    
    S = "Click on the form to dim"
    Me.ForeColor = &H0&
    TextOut Me.hdc, Me.ScaleWidth / 2, 50, S, Len(S)
    Me.ForeColor = &HC06060
    TextOut Me.hdc, Me.ScaleWidth / 2 - 1, 49, S, Len(S)
    
    S = "Dblclick to end"
    Me.ForeColor = &H0&
    TextOut Me.hdc, Me.ScaleWidth / 2, 90, S, Len(S)
    Me.ForeColor = &HC0&
    TextOut Me.hdc, Me.ScaleWidth / 2 - 1, 89, S, Len(S)
    
    Me.AutoRedraw = False
End Sub

Function DuoTone(hSrcDC As Long, nWidth As Integer, nHeight As Integer, DuoColor As Long, hDestDC As Long) As Boolean
    Dim CopyDC     As Long
    Dim CopyBitmap As Long
    Dim mBrush     As Long
    Dim R          As RECT
    
    DuoTone = False
    
    CopyDC = CreateCompatibleDC(hSrcDC)
    CopyBitmap = CreateCompatibleBitmap(hSrcDC, nWidth, nHeight)
    If SelectObject(CopyDC, CopyBitmap) = 0 Then Exit Function
    
    SetRect R, 0, 0, nWidth, nHeight
    mBrush = CreateSolidBrush(DuoColor)
    If FillRect(CopyDC, R, mBrush) = 0 Then Exit Function
    
    BitBlt CopyDC, 0, 0, nWidth, nHeight, hSrcDC, 0, 0, vbSrcAnd
    If BitBlt(hDestDC, 0, 0, nWidth, nHeight, CopyDC, 0, 0, vbSrcCopy) = 0 Then Exit Function

    DeleteObject mBrush
    DeleteObject CopyBitmap
    DeleteDC CopyDC
    DuoTone = True
End Function

Private Sub Form_Unload(Cancel As Integer)
  Me.Picture = LoadPicture()
  Set Form1 = Nothing
End Sub

[PaulLewis]

Good way to learn for me

Cheers
Paul Lewis