иконка в Picture с ресаизом

[Avtopic]

Люди, Спасите!
ест функция от tyomitch-а

Код: Выделить всё

Private Function CreatePictureFromBitmap(ByVal hBmp As Long, PicType As Long) As StdPicture
Dim Pic As PicBmp, IID_IDispatch As GUID
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    With Pic
       .Size = Len(Pic)
       .Type = PicType
       .hBmp = hBmp
       .hPal = 0
    End With
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, CreatePictureFromBitmap
End Function

и иконка в Picture с ресаизом

Код: Выделить всё

Private Function FitIconToPicture(ByVal hIcon As Long) As Picture
    Dim hDC As Long, hBmp As Long, hBmpOld As Long

    Set Picture1.Picture = CreatePictureFromBitmap(hIcon, &H3)    ‘1


    hDC = CreateCompatibleDC(Picture1.hDC)
    hBmp = CreateCompatibleBitmap(hDC, 20, 20)
    hBmpOld = SelectObject(hDC, hBmp)
    StretchBlt hDC, 0, 0, 20, 20, Picture1.hDC, 0, 0, 32, 32, vbSrcCopy
    SelectObject hDC, hBmpOld
    DeleteDC hDC

    Set Picture1.Picture = CreatePictureFromBitmap(hBmp, &H1)    ‘2

    Set FitIconToPicture = Picture1.Picture
End Function

После первого Set Picture1.Picture = CreatePictureFromBitmap
рисунок цветной
После второго, черно-белый. причем, "черно" как уголь
Где я ошибаюсь?

[keks-n]

А из одного и того же битмапа, да?

[Avtopic]

Пробовал и на двух пикчербоксах тоже, но раз результат был один и тот же, второй убрал.
По идее и на одном должен работать.

[tyomitch]

ест функция от tyomitch-а

Код не мой! Я только разместил пример!

CreateCompatibleBitmap(hDC, 20, 20) замени хотя бы на CreateCompatibleBitmap(Picture1.hDC, 20, 20)

А лично я все апи бы выкинул из FitIconToPicture, и растягивал вызовом PaintPicture

[Avtopic]

zzzzz

Код: Выделить всё

hBmp = CreateCompatibleBitmap(Picture1.hDC, 20, 20)

-----------------------------------

Oп.. не успел
Все ровно, спасибо!

[Avtopic]

А лично я все апи бы выкинул из FitIconToPicture, и растягивал вызовом PaintPicture

Понимаете, в конце второй функции здесь для наглядности сидит

Код: Выделить всё


Set Picture1.Picture = CreatePictureFromBitmap(hBmp, &H1)   
Set FitIconToPicture = Picture1.Picture

реально, в коде выглядит так

Код: Выделить всё

Set FitIconToPicture = CreatePictureFromBitmap(hBmp, &H1)

даже FitIconToPicture реально, в коде называется ResizeIcon и она присваивается
MSFlexGrid.CellPicture-у

[tyomitch]

Ну и какая разница?

Код: Выделить всё

Private Function FitIconToPicture(ByVal hIcon As Long) As Picture
' Задай для Picture1 AutoRedraw=True и нужные размеры

    With Picture1
        .PaintPicture CreatePictureFromBitmap(hIcon, 3), 0, 0, .ScaleWidth, .ScaleHeight
        ' Любители API могут заменить предыдущую строку вызовом DrawIconEx
        Set FitIconToPicture = .Image
    End With
End Function


[Avtopic]

Никакой разницы . Спасибо!

[Avtopic]

Хотя, там не хватает
.Picture = LoadPicture() или .Cls