Newsgroup: it.comp.lang.visual-basic
Titolo: ?WriteProperty o LoadPicture

Public Property Set Picture(ByVal newPicture As StdPicture)
    Set buttonPicture = CreaIcona(newPicture, &HC0C0C0, picSize)
    PropertyChanged "MAINPIC"
End Property
Questa č la property che uso per inserire una immagine nello UserControl.
CreaIcona č una Function che salva la Bitmap (newPicture) convertita in un 
file .ico
Per restituire l'immagine la function usa, Set 
CreaIcona=LoadPicture(tmp.ico).
Il file .ico č perfetto, con Microangelo apro l'icona con la normale 
trasparenza.
Il problema č che, se l'icona č 32x32 lo UserControl la memorizza 
normalmente,
se l'icona č 16x16 la visualizza normale, ma la memorizza con sfondo nero 
senza trasparenza.
Il bello č che, se carico direttamente nella property Picture, l'icona 16x16 
precedentemente convertita, la memorizza normalmente con la trasparenza.
Tutto sto sproloquio per farvi capire il problema.
La mia domanda č questa:
LoadPicture non carica le icone 16x16 oppure č WriteProperty che non 
memorizza le icone 16x16?
Grazie
Carmelo

 file .ico
[snip]
Scusa la curiosità ma come crei/salvi l'icona?
-> GbC|
www.gbcweb.com

 Scusa la curiosità ma come crei/salvi l'icona?
Anch'io curioso, mi accodo a GbC =)
Lokar 


Ho scaricato da internet parecchi esempi (non ricordo dove perchè ho girato 
molto per trovare qualcosa) su come salvare le bitmap in .ico e prendendo un 
po di codice da una parte e un po dall'altra ho fatto una function che 
soddisfa le mie esigenze. Crea icone sia 32x32 che 16x16.
Però c'è sempre il problema che ho descritto sopra.
Carmelo

 Però c'è sempre il problema che ho descritto sopra.
E una banale SavePicture?
Dato che usi una LoadPicture...
E poi, perchè PropertyChanged "MAINPIC" se la proprietà si chiama Picture?
E la WriteProperty, se hai dubbi sul suo funzionamento perchè non ne posti 
il codice?
Ciao


Grazie per l'informazione.
Potrei avere magggiori info o magari il codice per vedere come si fa?
Grazie
-> GbC|
www.gbcweb.com

 ha scritto nel messaggio 
news:43d63bc1$0$331$5fc...@news.tiscali.it...

Usa un file binario.
Vi posto il codice in allegato, però non sono riuscito a risolvere un
problema
L'icona a 16x16 viene salvata con gli stessi Kb di quella 32x32. Esempio con
Microangelo la salva di 2 Kb mentre la routine la salva a 5 Kb
Secondo me il problema sta nella quarta riga del file oppure nella riga
lngTrack = Len(ID) + Len(IDE32) + Len(IDE16) + IDE32.dwBytesInRes +
Len(BIH16)
Se risolvete mi postate il codice all'indirizzo 
carme...@libero.it
Option Explicit
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 ICONDIR
    idReserved As Integer
    idType As Integer
    idCount As Integer
End Type
Private Type ICONDIRENTRY
    bWidth As Byte
    bHeight As Byte
    bColorCount As Byte
    bReserved As Byte
    wPlanes As Integer
    wBitCount As Integer
    dwBytesInRes As Long
    dwImageOffset As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private ID As ICONDIR
Private BIH32 As BITMAPINFOHEADER
Private BIH16 As BITMAPINFOHEADER
Private IDE32 As ICONDIRENTRY
Private IDE16 As ICONDIRENTRY
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As 
RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As 
Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal 
hdc As Long) As Integer
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As 
Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As 
Long, ByVal Y As Long, ByVal crColor 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal 
hObject 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
Private rVLen As Long
Private strNomeIco As String
Public Function CreaIcona(ByVal objPicture As StdPicture, ByVal lngMaskColor 
As Long, ByVal lngSize As Long) As IPictureDisp
    Dim X As Integer
    Dim Y As Integer
    Dim pObj As Long
    Dim hdcImage As Long
    Dim hdcColor As Long
    Dim bmpColor As Long
    Dim hdcMono As Long
    Dim bmpMono As Long
    Dim hdcScreen As Long
    Dim mBrush As Long
    Dim R As RECT
    strNomeIco = App.Path & "\Tmp.ico"
    R.Left = 0
    R.Top = 0
    R.Right = lngSize
    R.Bottom = lngSize
    hdcScreen = GetDC(0&)
    hdcImage = CreateCompatibleDC(hdcScreen)
    pObj = SelectObject(hdcImage, objPicture.Handle)
    hdcColor = CreateCompatibleDC(hdcScreen)
    bmpColor = CreateCompatibleBitmap(hdcScreen, lngSize, lngSize)
    SelectObject hdcColor, bmpColor
    hdcMono = CreateCompatibleDC(hdcScreen)
    bmpMono = CreateCompatibleBitmap(hdcScreen, lngSize, lngSize)
    SelectObject hdcMono, bmpMono
    mBrush = CreateSolidBrush(vbWhite)
    SelectObject hdcColor, mBrush
    FillRect hdcColor, R, mBrush
    SelectObject hdcMono, mBrush
    FillRect hdcMono, R, mBrush
    DeleteObject mBrush
    BitBlt hdcColor, 0, 0, lngSize, lngSize, hdcImage, 0, 0, vbSrcCopy
    For X = 0 To lngSize - 1
        For Y = 0 To lngSize - 1
            If GetPixel(hdcImage, X, Y) = lngMaskColor Then
                SetPixel hdcColor, X, Y, vbBlack
                SetPixel hdcMono, X, Y, vbWhite
            Else
                SetPixel hdcMono, X, Y, vbBlack
            End If
        Next
    Next
    If lngSize = 16 Then
        SalvaIcon16 hdcColor, hdcMono
    ElseIf lngSize = 32 Then
        SalvaIcon32 hdcColor, hdcMono
    End If
    Set CreaIcona = LoadPicture(App.Path & "\tmp.ico")
    'Kill App.Path & "\tmp.ico"
    'rilascio gli oggetti
    DeleteObject pObj
    DeleteObject bmpColor
    DeleteObject bmpMono
    ReleaseDC 0&, hdcScreen
    DeleteDC hdcImage
    DeleteDC hdcColor
    DeleteDC hdcMono
End Function
Private Function BinaryStringToByte(ByVal strMask As String) As Byte
    Dim I As Integer
    Dim Rv As Byte
    For I = 1 To 8
        If Mid$(strMask, I, 1) = "1" Then Rv = Rv + 2 ^ (8 - I)
    Next
    BinaryStringToByte = Rv
    rVLen = Len(Rv)
End Function
Private Sub SetIconHeader()
    ID.idReserved = 0
    ID.idType = 1
    ID.idCount = 1
    IDE32.bWidth = 32
    IDE32.bHeight = 32
    IDE32.bColorCount = 0
    IDE32.bReserved = 0
    IDE32.wPlanes = 1
    IDE32.wBitCount = 24
    IDE32.dwBytesInRes = 3240
    IDE32.dwImageOffset = Len(ID) + Len(IDE32) + Len(IDE16)
    IDE16.bWidth = 16
    IDE16.bHeight = 16
    IDE16.bColorCount = 0
    IDE16.bReserved = 0
    IDE16.wPlanes = 1
    IDE16.wBitCount = 24
    IDE16.dwBytesInRes = 872
    IDE16.dwImageOffset = Len(ID) + Len(IDE32) + Len(IDE16) + 
IDE32.dwBytesInRes
    BIH32.biSize = 40
    BIH32.biWidth = 32
    BIH32.biHeight = 64
    BIH32.biPlanes = 1
    BIH32.biBitCount = 24
    BIH32.biCompression = 0
    BIH32.biSizeImage = 3200
    BIH32.biXPelsPerMeter = 0
    BIH32.biYPelsPerMeter = 0
    BIH32.biClrUsed = 0
    BIH32.biClrImportant = 0
    BIH16.biSize = 40
    BIH16.biWidth = 16
    BIH16.biHeight = 32
    BIH16.biPlanes = 1
    BIH16.biBitCount = 24
    BIH16.biCompression = 0
    BIH16.biSizeImage = 832
    BIH16.biXPelsPerMeter = 0
    BIH16.biYPelsPerMeter = 0
    BIH16.biClrUsed = 0
End Sub
Private Sub SalvaIcon16(ByVal hdcBmpColor As Long, ByVal hdcBmpMono As Long)
    On Error GoTo GestioneErrori
    Dim MaskString As String
    Dim FileNum As Integer
    Dim Y As Integer
    Dim X As Integer
    Dim intBitsImage As Integer
    Dim intCounter As Integer
    Dim lngTrack As Long
    Dim lngColorMask As Long
    Dim lngColorMono As Long
    Dim Red As Long
    Dim Green As Long
    Dim Blue As Long
    SetIconHeader
    If Dir$(strNomeIco) <> "" Then Kill strNomeIco
    FileNum = FreeFile
    Open strNomeIco For Binary Access Write As #FileNum
        Put #FileNum, 1, ID
        Put #FileNum, Len(ID) + 1, IDE16
        Put #FileNum, Len(ID) + Len(IDE16) + 1, BIH16
        Put #FileNum, Len(ID) + Len(IDE32) + Len(IDE16) + IDE32.dwBytesInRes 
+ 1, BIH16
        lngTrack = Len(ID) + Len(IDE32) + Len(IDE16) + IDE32.dwBytesInRes + 
Len(BIH16)
        'Scrive image bits
        intBitsImage = Len(ID) + Len(IDE32) + Len(IDE16) + 
IDE32.dwBytesInRes + Len(BIH16) + 1
        For Y = 15 To 0 Step -1
            For X = 0 To 15
                lngColorMask = GetPixel(hdcBmpColor, X, Y)
                lngColorMono = GetPixel(hdcBmpMono, X, Y)
                If lngColorMono = vbWhite Then
                    Put #FileNum, intBitsImage, 0
                    Put #FileNum, intBitsImage + 1, 0
                    Put #FileNum, intBitsImage + 2, 0
                Else
                    Blue = lngColorMask \ 65536
                    Green = (lngColorMask - Blue * 65536) \ 256
                    Red = lngColorMask - Blue * 65536 - Green * 256
                    Put #FileNum, intBitsImage, Blue
                    Put #FileNum, intBitsImage + 1, Green
                    Put #FileNum, intBitsImage + 2, Red
                End If
                intBitsImage = intBitsImage + 3
                lngTrack = lngTrack + 3
            Next
        Next
        'Scrive Mask bits
        intBitsImage = 0: intCounter = 0
        lngTrack = lngTrack + 1
        For Y = 15 To 0 Step -1
            For X = 0 To 31
                If GetPixel(hdcBmpMono, X, Y) = vbWhite Then
                    MaskString = MaskString & "1"
                Else
                    MaskString = MaskString & "0"
                End If
                intBitsImage = intBitsImage + 1
                If intBitsImage = 8 Then
                    intBitsImage = 0
                    Put #FileNum, intCounter + lngTrack, 
BinaryStringToByte(MaskString)
                    MaskString = ""
                    intCounter = intCounter + 1
                End If
            Next
        Next
    Close #FileNum
    Exit Sub
GestioneErrori:
    MsgBox Err.Description
End Sub
Private Sub SalvaIcon32(ByVal hdcBmpColor As Long, ByVal hdcBmpMono As Long)
    On Error GoTo GestioneErrori
    Dim MaskString As String
    Dim FileNum As Integer
    Dim Y As Integer
    Dim X As Integer
    Dim intBitsImage As Integer
    Dim intCounter As Integer
    Dim lngTrack As Long
    Dim lngColorMask As Long
    Dim lngColorMono As Long
    Dim Red As Long
    Dim Green As Long
    Dim Blue As Long
    SetIconHeader
    If Dir$(strNomeIco) <> "" Then Kill strNomeIco
    FileNum = FreeFile
    Open strNomeIco For Binary Access Write As #FileNum
        Put #FileNum, 1, ID
        Put #FileNum, Len(ID) + 1, IDE32
        Put #FileNum, Len(ID) + Len(IDE32) + 1, IDE16
        Put #FileNum, Len(ID) + Len(IDE32) + Len(IDE16) + 1, BIH32
        lngTrack = Len(BIH32) + Len(ID) + Len(IDE32) + Len(IDE16) 'bPut 
keeps track of pointer
        'scrive image bits
        intBitsImage = Len(ID) + Len(IDE32) + Len(IDE16) + Len(BIH32) + 1 
'63 + Len(IDE16)
        For Y = 31 To 0 Step -1
            For X = 0 To 31
                lngColorMask = GetPixel(hdcBmpColor, X, Y)
                lngColorMono = GetPixel(hdcBmpMono, X, Y)
                If lngColorMono = vbWhite Then
                    Put #FileNum, intBitsImage, 0
                    Put #FileNum, intBitsImage + 1, 0
                    Put #FileNum, intBitsImage + 2, 0
                    lngTrack = lngTrack + 3
                Else
                    Blue = lngColorMask \ 65536
                    Green = (lngColorMask - Blue * 65536) \ 256
                    Red = lngColorMask - Blue * 65536 - Green * 256
                    Put #FileNum, intBitsImage, Blue
                    Put #FileNum, intBitsImage + 1, Green
                    Put #FileNum, intBitsImage + 2, Red
                    lngTrack = lngTrack + 3
                End If
                intBitsImage = intBitsImage + 3
            Next
        Next
        'scrive mask bits
        intBitsImage = 0: intCounter = 0
        lngTrack = lngTrack + 1
        For Y = 31 To 0 Step -1
            For X = 0 To 31
                If GetPixel(hdcBmpMono, X, Y) = vbWhite Then
                    MaskString = MaskString & "1"
                Else
                    MaskString = MaskString & "0"
                End If
                intBitsImage = intBitsImage + 1
                If intBitsImage = 8 Then
                    intBitsImage = 0
                    Put #FileNum, intCounter + lngTrack, 
BinaryStringToByte(MaskString)
                    MaskString = ""
                    intCounter = intCounter + 1
                End If
            Next
        Next
    Close #FileNum
    On Error GoTo 0
    Exit Sub
GestioneErrori:
    MsgBox "WriteDataToFile " & Err.Number & " " & Err.Description
    Err.Clear
End Sub