SSCommand - Have U ever dealed with the enabling/disabling pictures??

**Mc Brain** · Apr 12th, 2000, 03:45 AM

Hi Everybody. Have you ever used a SSCommand? Let's first introduce you on the subject. For the one who doesn't, it's similar to the VB Command control, but a bit different. For example, the caption in the VB is placed beneath the graphic, that means that if you don't enlarge you button, the graphic could probably be "cut". On the other hand, the SSCommand place the caption where he "can", I mean, it tries to place it beneath, but if not possible, it places over the image (not above, over). This is why I was using this controls in my forms. Another main difference is the VB command button would "disable" the picture if you disable the button. However the SScommand, would only disable the caption. So if your button has no caption the would be no visual difference between the "Enabled SSCommand" and the "Disabled SSCommand". And this is where I want to "reach". I've made a class (the code is in this message) that changes the picture of your control to a gray-scale if you disable it. I won't explain how it works 'cos it would be much longer, the code is commented, though. But I would like that the one who could "optimize" it, let me know. It works great with the "Windows Standard Configuration", but if you have some "strange" colors in your configuration, it would be rather "tough". I mean... it will keep on changing the colors to a gray-scale (dispite the colors of your windows), and that would not be nice to the sight (as you could imagine it) The other thing that would have to be changed, is that it uses 16 colors BMPs. This mean that your original picture will not have the exactly same colors when re-enable the control.
Here's is the code (let me know if you have any idea)

On your form, place a SSCommand and name it "CMD", a PictureBox and name it "TPict" (TargetPicture) set Autosize to true, and visible to false. Finally, place a Command1.

'**** Code for the form
Private Sub Command1_Click()
Dim ED As New En_Dis

ED.En_Dis Cmd, TPict, Not Cmd.Enabled
End Sub

'**** Add a new Class module and name it En_Dis, here's what
'**** should be paste in it.

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD '16 colors
End Type
Private Type BITMAPFILEHEADER
bfType(1) As Byte
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Const BI_RGB = 0&
Private Const GMEM_MOVEABLE = &H2
Private Const DIB_RGB_COLORS = 0

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function lwrite Lib "kernel32" Alias "_lwrite" (ByVal hFile As Long, lpBuffer As Any, ByVal wBytes As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long

Public Sub Save4bitPicture(PBox As PictureBox, Dest As String)
Dim tempDC As Long
Dim bm As BITMAP
Dim bi As BITMAPINFO
Dim retVal As Long
Dim bufSize As Long
Dim ghnd As Long
Dim gptr As Long
Dim bmfh As BITMAPFILEHEADER
Dim hFile As Long
Dim Cntr As Integer
Dim Kolor As Long

' Create a temporary memory DC and select into it
' the background picture of the picture control.
tempDC = CreateCompatibleDC(PBox.hdc)
' Get the size of the picture bitmap
retVal = GetObjectAPI(PBox.Image, Len(bm), bm)
' Fill the BITMAPINFO for the desired DIB
bi.bmiHeader.biSize = Len(bi.bmiHeader)
bi.bmiHeader.biWidth = bm.bmWidth
bi.bmiHeader.biHeight = bm.bmHeight
bi.bmiHeader.biPlanes = 1
' Set to 24 here to create a 24 bit DIB
' Set to 8 here to create an 8 bit DIB
bi.bmiHeader.biBitCount = 4
bi.bmiHeader.biCompression = BI_RGB
' Now calculate the data buffer size needed
bufSize = bi.bmiHeader.biWidth

' Figure out the number of bytes based on the
' number of pixels in each byte. In this case we
' really don't need all this code because this example
' always uses a 16 color DIB, but the code is shown
' here for your future reference
Select Case bi.bmiHeader.biBitCount
Case 1
bufSize = (bufSize + 7) / 8
Case 4
bufSize = (bufSize + 1) / 2
Case 24
bufSize = bufSize * 3
End Select
' And make sure it aligns on a long boundary
bufSize = ((bufSize + 3) / 4) * 4
' And multiply by the # of scan lines
bufSize = bufSize * bi.bmiHeader.biHeight

' Now allocate a buffer to hold the data
' We use the global memory pool because this buffer
' could easily be above 64k bytes.
ghnd = GlobalAlloc(GMEM_MOVEABLE, bufSize)
gptr = GlobalLock(ghnd)

' now copy the picturebox image to the DIB
retVal = GetDIBits(tempDC, PBox.Image, 0, bm.bmHeight, ByVal gptr, bi, DIB_RGB_COLORS)
For i = 0 To 15
Red = bi.bmiColors(i).rgbRed
Blue = bi.bmiColors(i).rgbBlue
Green = bi.bmiColors(i).rgbGreen
'Changing the colors
If Blue = Red And Red = Green Then
If Blue > 200 Then
'It's too light (probably near white)... let's make it light grey
Grey = 192
ElseIf Blue = 0 Then
'It's Black... let's make it dark grey
Grey = 92
Else
'It's any other color... let's have the mean value of the components
Grey = (Red + Green + Blue) / 3
End If
Else
'It's any other color... let's have the mean value of the components
Grey = (Red + Green + Blue) / 3
End If
'Set the New Color
Kolor = RGB(Grey, Grey, Grey)
'Set the Components of the BMP, with the "Changed Color"
bi.bmiColors(i).rgbRed = Kolor \ (256 ^ 2)
bi.bmiColors(i).rgbGreen = (Kolor And 65535) \ 256
bi.bmiColors(i).rgbBlue = Kolor And 255
Next i
' write the bitmapfileheader
With bmfh
.bfType(0) = &H42
.bfType(1) = &H4D ' the string "BM", I have split the integer into two bytes because the bytes got swapped
.bfSize = Len(bmfh) + Len(bi) + bufSize
.bfReserved1 = 0
.bfReserved2 = 0
'experiments proved that 14 has to be added, I don't know if this is different at a different color depth
.bfOffBits = Len(bi) + 14
End With

' create the file, I've chosen the api way because
' it's an easy way to copy the data block
hFile = lcreat(Dest, 0)
' write the bitmapfileheader to the file,
' for some strange reasons the structure can't be copied at once
retVal = lwrite(hFile, bmfh.bfType(0), 1)
retVal = lwrite(hFile, bmfh.bfType(1), 1)
retVal = lwrite(hFile, bmfh.bfSize, 4)
retVal = lwrite(hFile, bmfh.bfReserved1, 2)
retVal = lwrite(hFile, bmfh.bfReserved2, 2)
retVal = lwrite(hFile, bmfh.bfOffBits, 4)
' write the bitmapinfo to the file
retVal = lwrite(hFile, bi, Len(bi))
' write the data to the file
retVal = lwrite(hFile, ByVal gptr, bufSize)
' and close the file
retVal = lclose(hFile)
' Dump the global memory block
retVal = GlobalUnlock(ghnd)
retVal = GlobalFree(ghnd)
retVal = DeleteDC(tempDC)
' and were done
End Sub

Sub En_Dis(obj As Object, TempObj As Object, Status As Boolean)
On Error GoTo NoIndex
Dim IArray As Boolean
Dim ED As New En_Dis
'To see whether the control is an Array
IArray = True
Indice = obj.Index
'Set the Name for the File that will retrieve the Original Image
If IArray Then
Nombre = obj.Parent.Name + "_" + obj.Name + "(" + Trim$(Str$(obj.Index)) + ")"
Else
Nombre = obj.Parent.Name + "_" + obj.Name
End If
If Status Then
'Enable the Image
'Load the Original Image
obj.Picture = LoadPicture(App.Path + "\" + Nombre + ".ico")
Kill App.Path + "\" + Nombre + ".ico"
Else
'Disabled the Image.
'Copy the Image to the PictureBox to save it to a file.
TempObj.Picture = obj.Picture
SavePicture TempObj, App.Path + "\" + Nombre + ".ico"
'This was to be able to retrieve the Original Image in the
'future when enable the control.

'Save the Image to a Temporary BMP (Image.BMP),
'This BMP has been altered. His colors won't be originals
ED.Save4bitPicture TempObj, App.Path + "\image.bmp"
'Load the TEmporary BMP in the picture
obj.Picture = LoadPicture(App.Path + "\image.bmp")
Kill App.Path + "\Imagen.bmp"
End If
obj.Enabled = Status
Exit Sub

NoIndex:
If Err = 343 Then
'It's not an array
IArray = False
Resume Next
ElseIf Err = 53 Then
'The file doesn't exist. Probably because was not saved yet.
Resume Next
End If
End Sub

That's all... try it, study it, and let me know what you achieved.

**Mc Brain** · Apr 13th, 2000, 02:47 AM

I've made it!!
I don't know whether you dont' mind or couldn't do it, but if you want to, here's the way to change the image of a SSCommand when you disable it
with any configuration (of colors). Here's the example:

Code:

'**** On your form, place a SSCommand and name it "CMD", a PictureBox and name it "TPict"
'**** (TargetPicture) set Autosize=true, and Visible=false. Finally, place a Command1.
'**** Oh, forgot to say: Set a Picture to the SSCommand (obviously)

'**** Code for the form 
Private Sub Command1_Click() 
     Dim ED As New En_Dis 

     ED.En_Dis Cmd, TPict, Not Cmd.Enabled 
End Sub 

'**** Class Code named En_Dis
Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors(15) As RGBQUAD   '16 colors
End Type
Private Type BITMAPFILEHEADER
        bfType(1) As Byte
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End Type

Private Const BI_RGB = 0&
Private Const GMEM_MOVEABLE = &H2
Private Const DIB_RGB_COLORS = 0

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject _ 
   As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal _ 
   dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap _ 
   As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As _ 
   BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function lwrite Lib "kernel32" Alias "_lwrite" (ByVal hFile As Long _
   , lpBuffer As Any, ByVal wBytes As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) _
    As Long
Private Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As _ 
   String, ByVal iAttribute As Long) As Long

Public Sub Save4bitPicture(PBox As PictureBox, Dest As String, ButtonFace As Long, _ 
   DisabledText As Long)
Dim tempDC As Long
Dim bm As BITMAP
Dim bi As BITMAPINFO
Dim retVal As Long
Dim bufSize As Long
Dim ghnd As Long
Dim gptr As Long
Dim bmfh As BITMAPFILEHEADER
Dim hFile As Long
Dim Cntr As Integer
Dim Kolor As Long


    ' Create a temporary memory DC and select into it
    ' the background picture of the picture control.
    tempDC = CreateCompatibleDC(PBox.hdc)
    ' Get the size of the picture bitmap
    retVal = GetObjectAPI(PBox.Image, Len(bm), bm)
    ' Fill the BITMAPINFO for the desired DIB
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    bi.bmiHeader.biWidth = bm.bmWidth
    bi.bmiHeader.biHeight = bm.bmHeight
    bi.bmiHeader.biPlanes = 1
    ' Set to 24 here to create a 24 bit DIB
    ' Set to 8 here to create an 8 bit DIB
    bi.bmiHeader.biBitCount = 4
    bi.bmiHeader.biCompression = BI_RGB
    ' Now calculate the data buffer size needed
    bufSize = bi.bmiHeader.biWidth

    ' Figure out the number of bytes based on the
    ' number of pixels in each byte. In this case we
    ' really don't need all this code because this example
    ' always uses a 16 color DIB, but the code is shown
    ' here for your future reference
    Select Case bi.bmiHeader.biBitCount
        Case 1
            bufSize = (bufSize + 7) / 8
        Case 4
            bufSize = (bufSize + 1) / 2
        Case 24
            bufSize = bufSize * 3
    End Select
    ' And make sure it aligns on a long boundary
    bufSize = ((bufSize + 3) / 4) * 4
    ' And multiply by the # of scan lines
    bufSize = bufSize * bi.bmiHeader.biHeight
    
    ' Now allocate a buffer to hold the data
    ' We use the global memory pool because this buffer
    ' could easily be above 64k bytes.
    ghnd = GlobalAlloc(GMEM_MOVEABLE, bufSize)
    gptr = GlobalLock(ghnd)
    
    ' now copy the picturebox image to the DIB
    retVal = GetDIBits(tempDC, PBox.Image, 0, bm.bmHeight, ByVal gptr, bi, DIB_RGB_COLORS)
    For i = 0 To 15
        Red = bi.bmiColors(i).rgbRed
        Blue = bi.bmiColors(i).rgbBlue
        Green = bi.bmiColors(i).rgbGreen
        'Changing the colors
        If Red > 191 Or Green > 191 Or Blue > 191 Then
            'Too light
            Kolor = ButtonFace
            'CAUTION: (if you want to change this IF statement)
            'The RGB(192,192,192) -stands for grey- seems to be the transparent color.
            'Therefore, you should be sure that KOLOR=ButtonFace. Otherwise, the
            'transparent section of your ICO would not be "transparent"
        Else
            'Too Dark
            Kolor = DisabledText
        End If
        'Set the New Color
        'Set the Components of the BMP, with the "Changed Color"
        bi.bmiColors(i).rgbRed = Kolor And vbRed
        bi.bmiColors(i).rgbGreen = (Kolor And vbGreen) / (2 ^ 8)
        bi.bmiColors(i).rgbBlue = (Kolor And vbBlue) / (2 ^ 16)
    Next i
    ' write the bitmapfileheader
    With bmfh
        .bfType(0) = &H42
        .bfType(1) = &H4D   ' the string "BM", I have split the integer into two bytes because the bytes got swapped
        .bfSize = Len(bmfh) + Len(bi) + bufSize
        .bfReserved1 = 0
        .bfReserved2 = 0
        'experiments proved that 14 has to be added, I don't know if this is different at a different color depth
        .bfOffBits = Len(bi) + 14
    End With
    
    ' create the file, I've chosen the api way because
    ' it's an easy way to copy the data block
    hFile = lcreat(Dest, 0)
    ' write the bitmapfileheader to the file,
    ' for some strange reasons the structure can't be copied at once
    retVal = lwrite(hFile, bmfh.bfType(0), 1)
    retVal = lwrite(hFile, bmfh.bfType(1), 1)
    retVal = lwrite(hFile, bmfh.bfSize, 4)
    retVal = lwrite(hFile, bmfh.bfReserved1, 2)
    retVal = lwrite(hFile, bmfh.bfReserved2, 2)
    retVal = lwrite(hFile, bmfh.bfOffBits, 4)
    ' write the bitmapinfo to the file
    retVal = lwrite(hFile, bi, Len(bi))
    ' write the data to the file
    retVal = lwrite(hFile, ByVal gptr, bufSize)
    ' and close the file
    retVal = lclose(hFile)
    ' Dump the global memory block
    retVal = GlobalUnlock(ghnd)
    retVal = GlobalFree(ghnd)
    retVal = DeleteDC(tempDC)
    ' and were done
End Sub

Sub En_Dis(obj As Object, TempObj As Object, Status As Boolean)
    On Error GoTo NoIndex
    Dim IArray As Boolean
    Dim ButtonFace As Long
    Dim DisabledText As Long
    Dim ED As New En_Dis
    'To see whether the control is an Array
    IArray = True
    Indice = obj.Index
    'Set the Colors for DisabledText and ButtonFace
    obj.Parent.PSet (0, 0), &H8000000F: ButtonFace = obj.Parent.Point(0, 0)
    obj.Parent.PSet (0, 0), &H80000011:  DisabledText = obj.Parent.Point(0, 0)
    'Set the Name for the File that will retrieve the Original Image
    If IArray Then
        Nombre = obj.Parent.Name + "_" + obj.Name + "(" + Trim$(Str$(obj.Index)) + ")"
    Else
        Nombre = obj.Parent.Name + "_" + obj.Name
    End If
    If Status Then
        'Enable the Image
        'Load the Original Image
        obj.Picture = LoadPicture(App.Path + "\" + Nombre + ".ico")
        Kill App.Path + "\" + Nombre + ".ico"
    Else
        'Disabled the Image.
        'Copy the Image to the PictureBox to save it to a file.
        TempObj.Picture = obj.Picture
        SavePicture TempObj, App.Path + "\" + Nombre + ".ico"
        'This was to be able to retrieve the Original Image in the
        'future when enable the control.
        
        'Save the Image to a Temporary BMP (Image.BMP),
        'This BMP has been altered. His colors won't be originals
        ED.Save4bitPicture TempObj, App.Path + "\image.bmp", ButtonFace, DisabledText
        'Load the TEmporary BMP in the picture
        obj.Picture = LoadPicture(App.Path + "\image.bmp")
        Kill App.Path + "\Imagen.bmp"
    End If
    obj.Enabled = Status
    Exit Sub
    
NoIndex:
    If Err = 343 Then
        'It's not an array
        IArray = False
        Resume Next
    ElseIf Err = 53 Then
        'The file doesn't exist. Probably because was not saved yet.
        Resume Next
    End If
End Sub

Thread: SSCommand - Have U ever dealed with the enabling/disabling pictures??

Thread Tools

Display

I'VE MADE IT!!!

Posting Permissions