VBNet - Форум - Превратить битмап в иконку

Вопрос: Превратить битмап в иконку Добавлено: 25.09.04 18:51

Автор вопроса: Comanche

Помещаю 16-цветную иконку в пикчербокс picSource (белый символ на красном фоне). Также делаю на форме пикчербокс picDestination. Далее пишу вот такой код (API-декларации опускаю):

Private Sub Form_Load()
    Dim mDC As Long, mBitmap As Long, mIcon As Long, tmp As Long, bmpPrev As Long

    mDC = CreateCompatibleDC(0)
    mBitmap = CreateCompatibleBitmap(mDC, 16&, 16&)
    bmpPrev = SelectObject(mDC, mBitmap)

    tmp = BitBlt(mDC, 0&, 0&, 16&, 16&, picSource.hdc, 0&, 0&, vbSrcCopy)

    Set picDestination.Picture = hDCToPicture(mDC, 0, 0, 16, 16)

    DeleteObject mBitmap
    DeleteDC mDC

End Sub

Public Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Set the palette version
        LogPal.palVersion = &H300
        'Number of palette entries
        LogPal.palNumEntries = 256
        'Retrieve the system palette entries
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        'Create the palette
        hPal = CreatePalette(LogPal)
        'Select the palette
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        'Realize the palette
        R = RealizePalette(hDCMemory)
    End If

    'Copy the source image to our compatible device context
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Select the palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With

    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    Set CreateBitmapPicture = IPic
End Function

====================================================

В итоге, пикчербокс picDestination становится ЧЁРНО-БЕЛОЙ копией исходного пикчербокса picSource. ПОЧЕМУ?

Если же поставить вот такую строчку:

    Set picDestination.Picture = hDCToPicture(picSource.hdc, 0, 0, 16, 16)

- то всё нормально. Т.е. проблема явно в виртуальном контексте mDC.

Уже голову сломал. Где-то я спотыкаюсь на API...
Ответить

Ответы Всего ответов: 3

Номер ответа: 1 Автор ответа: Comanche Вопросов: 87 Ответов: 459	Профиль \| \| #1	Добавлено: 25.09.04 18:56
	Хм... а вот так всё заработало: mDC = CreateDC("ISPLAY", vbNullString, vbNullString, ByVal 0& Разве это не эквивалент "mDC = CreateCompatibleDC(0)" ?!?!?! Ответить

Номер ответа: 2 Автор ответа: Comanche Вопросов: 87 Ответов: 459	Профиль \| \| #2	Добавлено: 25.09.04 19:04
	А вот так - работает: mDC = CreateCompatibleDC(GetDC(GetDesktopWindow)) mBitmap = CreateCompatibleBitmap(GetDC(GetDesktopWindow), 16&, 16& Причина описана вот здесь: http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/bitmaps_1cxc.asp?frame=true в секции "Remarks". Эх, Команч, RTFM )) Ответить

Номер ответа: 3 Автор ответа: sne Разработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445	Web-сайт: hw.t-k.ru Профиль \| \| #3	Добавлено: 26.09.04 11:21
	Гляди пример на сайте... CrIco, кажется так зовется + прозрачный фон так же имеется Ответить

Страница: 1 |