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.
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.