Code:
Private Sub CmdSave_Click()
Dim fnr As Integer
Dim i As Integer
Dim lreadWrite As Long
Dim lMaskPtr As Long, lShift As Long, lMaskOffset As Long
Dim lScanWidth As Long, lMaskScanWidth As Long
Dim X As Long, Y As Long, bIcon() As Byte
Dim BIH As BITMAPINFOHEADER, ICD As ICONDIR
fnr = FreeFile()
If SaveDir = "" Then
For i = 0 To 9
If Label1(i).BackColor = vbRed Then
X = ScaleX(Picture1(i).Image.Width, vbHimetric, vbPixels)
Y = ScaleY(Picture1(i).Image.Height, vbHimetric, vbPixels)
If X > 256 Or Y > 256 Then
MsgBox "Icons can be no larger than 256x256"
Exit Sub
End If
lScanWidth = ByteAlignOnWord(24, X)
lMaskScanWidth = ByteAlignOnWord(1, X)
ReDim bIcon(0 To 61 + (lScanWidth + lMaskScanWidth) * Y)
With BIH
.biBitCount = 24
.biHeight = Y + Y
.biWidth = X
.biPlanes = 1
.biSize = 40
.biSizeImage = lScanWidth * Y
End With
ICD.idCount = 1
ICD.idType = 1
ReDim ICD.idEntries(0)
With ICD.idEntries(0)
If X < 256 Then .bWidth = X
If Y < 256 Then .bHeight = Y
.wPlanes = 1
.wBitCount = 24
.dwBytesInRes = UBound(bIcon) - 21
.dwImageOffset = 22
End With
CopyMemory bIcon(0), ICD, 6
CopyMemory bIcon(6), ICD.idEntries(0), 16
CopyMemory bIcon(22), BIH, BIH.biSize
BIH.biHeight = Y
GetDIBits Picture1(i).hDC, Picture1(i).Image.Handle, 0, Y, bIcon(62), BIH, 0&
lMaskOffset = Y * lScanWidth + 62
For Y = 0 To Y - 1
lMaskPtr = Y * lMaskScanWidth + lMaskOffset
X = Y * lScanWidth + 62
lShift = 128
For X = X To X + lScanWidth - 2 Step 3
If (bIcon(X) * &H10000 Or bIcon(X + 1) * &H100& Or bIcon(X + 2)) = Picture1(i).BackColor Then
bIcon(lMaskPtr) = bIcon(lMaskPtr) Or lShift
CopyMemory bIcon(X), 0&, 3&
End If
If lShift = 1 Then
lMaskPtr = lMaskPtr + 1
lShift = 128
Else
lShift = lShift \ 2
End If
Next
Next
fnr = FreeFile
Open App.Path & "\TempIcon.ico" For Binary As #fnr
Put #fnr, , bIcon()
Close #fnr
End If
Next
Picture1(0).Cls
Exit Sub
End If
For i = 0 To 9
If Label1(i).BackColor = vbRed Then
X = ScaleX(Picture1(i).Image.Width, vbHimetric, vbPixels)
Y = ScaleY(Picture1(i).Image.Height, vbHimetric, vbPixels)
If X > 256 Or Y > 256 Then
MsgBox "Icons can be no larger than 256x256"
Picture1(0).Cls
Exit Sub
End If
lScanWidth = ByteAlignOnWord(24, X)
lMaskScanWidth = ByteAlignOnWord(1, X)
ReDim bIcon(0 To 61 + (lScanWidth + lMaskScanWidth) * Y)
With BIH
.biBitCount = 24
.biHeight = Y + Y
.biWidth = X
.biPlanes = 1
.biSize = 40
.biSizeImage = lScanWidth * Y
End With
ICD.idCount = 1
ICD.idType = 1
ReDim ICD.idEntries(0)
With ICD.idEntries(0)
If X < 256 Then .bWidth = X
If Y < 256 Then .bHeight = Y
.wPlanes = 1
.wBitCount = 24
.dwBytesInRes = UBound(bIcon) - 21
.dwImageOffset = 22
End With
CopyMemory bIcon(0), ICD, 6
CopyMemory bIcon(6), ICD.idEntries(0), 16
CopyMemory bIcon(22), BIH, BIH.biSize
BIH.biHeight = Y
GetDIBits Picture1(i).hDC, Picture1(i).Image.Handle, 0, Y, bIcon(62), BIH, 0&
lMaskOffset = Y * lScanWidth + 62
For Y = 0 To Y - 1
lMaskPtr = Y * lMaskScanWidth + lMaskOffset
X = Y * lScanWidth + 62
lShift = 128
For X = X To X + lScanWidth - 2 Step 3
If (bIcon(X) * &H10000 Or bIcon(X + 1) * &H100& Or bIcon(X + 2)) = Picture1(i).BackColor Then
bIcon(lMaskPtr) = bIcon(lMaskPtr) Or lShift
CopyMemory bIcon(X), 0&, 3&
End If
If lShift = 1 Then
lMaskPtr = lMaskPtr + 1
lShift = 128
Else
lShift = lShift \ 2
End If
Next
Next
Open SaveDir & "\Icons" & Label1(i).Caption & ".ico" For Binary As #fnr
Put #fnr, , bIcon()
Close #fnr
End If
Next
Picture1(0).Cls
End Sub