Смайлики

[tyomitch]

Но от примера, хотя бы схематичного (скелета) я не отказался бы.

Держи - для хорошего человека ничего не жалко
В левом пикчербоксе иконка, в правом появляется битмап.

[artyuha]

Zer, ты обещался описание gif файла скинуть – скинь мне или подскажи где путёвое скачать.

[Ruslan Demidow]

Ruslan: нет, иконку в буфер действительно невозможно кинуть. То, что она из гифа, тут не при чём.
Готовый пример чтения гифа тоже есть на vbrussian

Посмотрю, Артём. Но меня всё же интересует в первую очередь "чистая" вставка в RTB смайла. Ведь Аська же как-то отображает смайлы (имхо, там тоже RTB используется).

[gaidar]

В аське смайлы не анимированные. А что там используется легко узнать с помощью Spy++

[Ruslan Demidow]

В аське смайлы не анимированные. А что там используется легко узнать с помощью Spy++

А мне хотя бы не анимированные...
Посмотрел Spy - оба контрола в форме чата - RichEdit20A
И получается же у них (разработчики Аськи).

[tyomitch]

Ruslan, ты посмотрел, как сконвертировать иконку в битмап с нужным фоном?
Если да, то оставшееся очень просто - в начале использовать не Picture1.Picture.Handle, а ListImages(...).ExtractIcon.Handle, и в конце битмап класть не в Picture2.Picture, а в буфер. Должно работать

[Ruslan Demidow]

Ruslan, ты посмотрел, как сконвертировать иконку в битмап с нужным фоном?

Посмотрел, Артём, но... Или я не понял принципа (читай тупой ) или ещё чего.
Код интересный. Про DC я читал у Эпллмана (но только вскользь).
При запуске оба пикчербокса пустые, при нажатии Command1 - во втором появляется чёрный квадрат, который не закрывает полностью второй пикчербокс снизу и справа по длинне сторон (примерно на 1/16).
То же самое происходит если перед запуском в первый пикчербокс запихать картинку.

Если да, то оставшееся очень просто - в начале использовать не Picture1.Picture.Handle, а ListImages(...).ExtractIcon.Handle, и в конце битмап класть не в Picture2.Picture, а в буфер. Должно работать :

Я попробую, СПАСИБО.
Ага... Я понял. У меня во-первых картинка не 32х32, а 24х24.
Во-вторых, я в первый пикчербокс запихивал bmp - поэтому не работало.
Вставил иконку - сработало. Только на втором получилась как-бы текстура (не знаю как и сказать). В общем как будто взяли иконку выложили из неё несколько столбцов и рядов, а потом крайний левый вырезали, но не аккуратно, захватив немножко от соседних смайлов.

Теперь вопросы: почему в начале процедуры идёт

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

    hDesktop = GetDesktopWindow
    hDesktopDC = GetDC(hDesktop)

[code]
Зачем получать хендл DeskctopWindow? Или без него никак?
Что-то я не пойму его роль...

[Ruslan Demidow]

Ruslan, ты посмотрел, как сконвертировать иконку в битмап с нужным фоном?
Если да, то оставшееся очень просто - в начале использовать не Picture1.Picture.Handle, а ListImages(...).ExtractIcon.Handle, и в конце битмап класть не в Picture2.Picture, а в буфер. Должно работать

Артём, что бы я без тебя делал?!?
Работает. Доработаю код - отпишу в форум.
СПАСИБО ОГРОМНОЕ!!!

[Ruslan Demidow]

To tyomitch
Артём, тот метод что ты предложил работает идеально. Даже переделывать ничего не пришлось. Спасибо.
Вот как выглядит вставка смайлов в RTB у меня:

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

Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) 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 PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As Guid, ByVal fOwn As Long, lplpvObj As iPicture) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Sub ShowSmailes()
    Dim Pic As StdPicture
    Dim sSmail As String
    Dim sStart As Long, i As Integer
 
    For i = 1 To UBound(arrSmail)
        SmailImageList.BackColor = MsgTextBox.BackColor
        Set Pic = SmailImageList.ListImages("Smail" & i).ExtractIcon
        With MsgTextBox
            Do While .SelStart <> 0
                .SelStart = InStr(1, .Text, arrSmail(i))
                If .SelStart <> 0 Then
                    .SelStart = .SelStart - 1
                    .SelLength = Len(arrSmail(i))
                    GetSmailToClipboard Pic
                    SendMessage .hwnd, WM_PASTE, 0, 0
                End If
            Loop
            .SelStart = 1
        End With
    Next i
End Sub


Sub GetSmailToClipboard(ByVal iPicture As Variant)
Dim ii As ICONINFO
    GetIconInfo iPicture.Handle, ii
   
Dim hDesktopDC As Long, hDesktop As Long
    hDesktop = GetDesktopWindow
    hDesktopDC = GetDC(hDesktop)

Dim hdc As Long, hOldBmp As Long, hNewBmp As Long
    hdc = CreateCompatibleDC(hDesktopDC)
    hNewBmp = CreateCompatibleBitmap(hDesktopDC, 20, 20)
    hOldBmp = SelectObject(hdc, hNewBmp)
   
    ReleaseDC hDesktop, hDesktopDC
   
Dim hBrush As Long, hOldBrush As Long
    hBrush = CreatePatternBrush(ii.hbmColor)
    hOldBrush = SelectObject(hdc, hBrush)
    PatBlt hdc, 0, 0, 20, 20, vbPatCopy
    SelectObject hdc, hOldBrush
    DeleteObject hBrush
   
    SetBkColor hdc, MessBackGRNDColor
    hBrush = CreatePatternBrush(ii.hbmMask)
    hOldBrush = SelectObject(hdc, hBrush)
    PatBlt hdc, 0, 0, 20, 20, vbPatInvert
    SelectObject hdc, hOldBrush
    DeleteObject hBrush
   
    SelectObject hdc, hOldBmp
    DeleteDC hdc
   
    Clipboard.Clear
    Clipboard.SetData CreatePictureFromBitmap(hNewBmp)
End Sub


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


Ещё раз спасибо.

[Zer]

To Ruslan Demidow: так тебе куда текстовичёк кинуть?

[Ruslan Demidow]

To Ruslan Demidow: так тебе куда текстовичёк кинуть?

В смысле? Извини, может я чего-то забыл?...