Announcement

Collapse
No announcement yet.

RichEdit - Programmatically Display Image

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • RichEdit - Programmatically Display Image

    Recent posts have discussed how to insert a bitmap in a RichEdit control - by putting it in an RTF file and loading the file, and by pasting it into the RichEdit control using the IRichEditOLECallback code that Jose has posted.

    A third approach is using the IRichEditOLE::InsertObject method, discussed here and here. With that approach you should be able to programmatically read an image file and display it in the RichEdit control without using the clipboard.

    Pierre and I have been working on the approach and he has come up with a translation to PowerBASIC on the topic (code below).

    But the result of the code is that it puts an icon in the RichEdit control, where double-clicking on the icon will then display the image in the default image viewer application.

    What we want is for the image to be displayed immediately in the RichEdit control.

    The function "ObjectInsert" is the translated function. The rest of the code, mostly from Jose, enables OLE objects in the RichEdit control (allowing pasting of images, for example).

    That's where we're stuck. We're hoping someone can see where the translation falls short. If so, please speak up!

    Code, EXE and image are here.

    Code:
    'How to Use OLE in Rich Edit Controls https://docs.microsoft.com/en-us/windows/desktop/controls/using-rich-edit-com
    'https://www.codeproject.com/Articles/12135/Inserting-images-into-a-RichTextBox-control-the-OL
    'https://www.purebasic.fr/english/viewtopic.php?p=199940
    
    ' ########################################################################################
    ' RichOle demo from José Roca
    ' ObjectInsert function added, converted from MS C++ to PowerBASIC by Pierre (Work in progress...)
    ' Change sImageFileName
    ' ########################################################################################
    
    #Dim All
    #Compile Exe '#Win 11.00 (D:\Basic\Bas\Jose Roca\Forum\Jose\Windows API Headers\3.1.07\uz)#
    %UNICODE = 1
    %USERICHEDIT = 1
    
    'Include files for external files
    #Include Once "CWindow.inc"   'CWindow class
    #Include Once "RichOle.inc"
    
    Global hRichEdit As Dword
    
    %IDC_RICHEDIT = 1001
    
    '______________________________________________________________________________
    
    'How to Use OLE in Rich Edit Controls https://docs.microsoft.com/en-us/windows/desktop/controls/using-rich-edit-com
    '{
    '    HRESULT hr;
    '
    '    LPRICHEDITOLE pRichEditOle;
    '    SendMessage(hRichEdit, EM_GETOLEINTERFACE, 0, (LPARAM)&pRichEditOle);
    '
    '    if (pRichEditOle == NULL)
    '    {
    '        return FALSE;
    '    }
    '
    '    LPLOCKBYTES pLockBytes = NULL;
    '    hr = CreateILockBytesOnHGlobal(NULL, TRUE, &pLockBytes);
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    LPSTORAGE pStorage;
    '    hr = StgCreateDocfileOnILockBytes(pLockBytes,
    '           STGM_SHARE_EXCLUSIVE | STGM_CREATE | STGM_READWRITE,
    '           0, &pStorage);
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    FORMATETC formatEtc;
    '    formatEtc.cfFormat = 0;
    '    formatEtc.ptd = NULL;
    '    formatEtc.dwAspect = DVASPECT_CONTENT;
    '    formatEtc.lindex = -1;
    '    formatEtc.tymed = TYMED_NULL;
    '
    '    LPOLECLIENTSITE pClientSite;
    '    hr = pRichEditOle->GetClientSite(&pClientSite);
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    LPUNKNOWN pUnk;
    '    CLSID clsid = CLSID_NULL;
    '
    '    hr = OleCreateFromFile(clsid, pszFileName, IID_IUnknown, OLERENDER_DRAW,
    '           &formatEtc, pClientSite, pStorage, (void**)&pUnk);
    '
    '    pClientSite->Release();
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    LPOLEOBJECT pObject;
    '    hr = pUnk->QueryInterface(IID_IOleObject, (void**)&pObject);
    '    pUnk->Release();
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    OleSetContainedObject(pObject, TRUE);
    '    REOBJECT reobject = { sizeof(REOBJECT)};
    '    hr = pObject->GetUserClassID(&clsid);
    '
    '    if (FAILED(hr))
    '    {
    '        pObject->Release();
    '        return FALSE;
    '    }
    '
    '    reobject.clsid = clsid;
    '    reobject.cp = REO_CP_SELECTION;
    '    reobject.dvaspect = DVASPECT_CONTENT;
    '    reobject.dwFlags = REO_RESIZABLE | REO_BELOWBASELINE;
    '    reobject.dwUser = 0;
    '    reobject.poleobj = pObject;
    '    reobject.polesite = pClientSite;
    '    reobject.pstg = pStorage;
    '    SIZEL sizel = { 0 };
    '    reobject.sizel = sizel;
    '
    '    SendMessage(hRichEdit, EM_SETSEL, 0, -1);
    '    DWORD dwStart, dwEnd;
    '    SendMessage(hRichEdit, EM_GETSEL, (WPARAM)&dwStart, (LPARAM)&dwEnd);
    '    SendMessage(hRichEdit, EM_SETSEL, dwEnd+1, dwEnd+1);
    '    SendMessage(hRichEdit, EM_REPLACESEL, TRUE, (WPARAM)L"\n");
    '
    '    hr = pRichEditOle->InsertObject(&reobject);
    '    pObject->Release();
    '    pRichEditOle->Release();
    '
    '    if (FAILED(hr))
    '    {
    '        return FALSE;
    '    }
    '
    '    return TRUE;
    '}
    '______________________________________________________________________________
    
    '______________________________________________________________________________
    
    ' ========================================================================================
    ' Main
    ' ========================================================================================
    Function WinMain (ByVal hInstance As Dword, ByVal hPrevInstance As Dword, ByVal lpszCmdLine As WStringZ Ptr, ByVal nCmdShow As Long) As Long
    
       'Set process DPI aware
       If AfxGetWindowsVersion => 6 Then AfxSetProcessDPIAware
    
       'Create an instance of the class
       Local pWindow As IWindow
       pWindow = Class "CWindow"
       If IsNothing(pWindow) Then Exit Function
    
       'Create the main window
       'Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
       pWindow.CreateWindow(%NULL, "Rich Ole Demo", 0, 0, 0, 0, 0, 0, CodePtr(WindowProc))
       'Set the client size
       pWindow.SetClientSize 600, 400
       'Center the window
       pWindow.CenterWindow
    
       'Add a subclassed rich edit control without coordinates (it will be resized in WM_SIZE, below)
       'LOCAL hRichEdit AS DWORD
       hRichEdit = pWindow.AddRichEdit(pWindow.hwnd, %IDC_RICHEDIT, "RichEdit box", 0, 0, 0, 0, 0, 0, CodePtr(RichEditSubclassProc))
       'Specify which notifications the control sends to its parent window
       RichEdit_SetEventMask hRichEdit, %ENM_CHANGE
    
       'Set the IRichEditOleCallback object.
       'The control calls the AddRef function for the object before returning.
       Local pRichEditOleCallback As IRichEditOleCallbackImpl
       pRichEditOleCallback = Class "CRichEditOleCallback"
       RichEdit_SetOleCallback hRichEdit, ObjPtr(pRichEditOleCallback)
    
       'Load the file
       RichEdit_LoadRtfFromFile hRichEdit, Exe.Path$ & "files\gbtweet.rtf"
    
       'Default message pump (you can replace it with your own)
       pWindow.DoEvents(nCmdShow)
    
    End Function
    ' ========================================================================================
    
    ' ========================================================================================
    ' Main window callback
    ' ========================================================================================
    Function WindowProc (ByVal hwnd As Dword, ByVal uMsg As Dword, ByVal wParam As Dword, ByVal lParam As Long) As Long
    
       Local tlf             As LOGFONT                  ' font attributes
       Local tcf             As CHARFORMAT               ' rich edit character formatting information
       Local ptnmhdr         As NmHdr Ptr                ' information about a notification message
       Local ptmmi           As MINMAXINFO Ptr           ' pointer to the maximized and tracking info
       Local hwndChild       As Dword                    ' handle of child window
       Local hFont           As Dword                    ' handle of font used by form
       Local dwMask          As Dword                    ' specifies the attributes of an item to retrieve or set
       Local hDC             As Dword                    ' handle of memory device context
       Static pWindow        As IWindow                  ' Reference to the IWindow interface
    
       Select Case uMsg
    
          Case %WM_Create
             'Get a reference to the IWindow interface from the CREATESTRUCT structure
             pWindow = CWindow_GetObjectFromCreateStruct(lParam)
             PostMessage(hwnd, %WM_APP, 0, 0)
             Exit Function
    
          Case %WM_APP
             Local sImageFileName  As String
             sImageFileName = "list.gif" & $Nul
             ObjectInsert(hRichEdit, UCode$(sImageFileName))
             'ObjectInsert(hRichEdit, sImageFileName)
    
          Case %WM_Command
             Select Case Lo(Word, wParam)
                Case %IdCancel
                   'If the Escape key has been pressed...
                   If Hi(Word, wParam) = %BN_Clicked Then
                      '... close the application by sending a WM_CLOSE message
                      SendMessage hwnd, %WM_Close, 0, 0
                      Exit Function
                   End If
                Case %IDC_RICHEDIT
                   If Hi(Word, wParam) = %EN_Change Then
                   End If
             End Select
    
          Case %WM_Notify
             ptnmhdr = lParam
             Select Case @ptnmhdr.idFrom
             End Select
    
          Case %WM_SetFocus
             ' Set the keyboard focus to the first control that is
             ' visible, not disabled, and has the WS_TABSTOP style
             SetFocus GetNextDlgTabItem(hwnd, %NULL, %FALSE)
    
          Case %WM_Destroy
             PostQuitMessage 0
             Exit Function
    
          Case %WM_Size
             If wParam <> %SIZE_MINIMIZED Then
                pWindow.MoveWindow GetDlgItem(hwnd, %IDC_RICHEDIT), 10, 10, pWindow.ClientWidth - 20, pWindow.ClientHeight - 20, %TRUE
             End If
    
       End Select
    
       Function = DefWindowProc(hwnd, uMsg, wParam, lParam)
    
    End Function
    ' ========================================================================================
    
    ' ========================================================================================
    ' RichEdit control subclassed procedure
    ' ========================================================================================
    Function RichEditSubclassProc ( _
       ByVal hwnd    As Dword, _ ' control handle
       ByVal uMsg    As Dword, _ ' type of message
       ByVal wParam  As Dword, _ ' first message parameter
       ByVal lParam  As Long _   ' second message parameter
       ) As Long
    
       Local lpOldWndProc As Dword    ' address of original window procedure
    
       lpOldWndProc = GetProp(hwnd, "OLDWNDPROC")
    
       Select Case uMsg
          Case %WM_Destroy
             'Remove control subclassing
             SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
       End Select
    
       Function = CallWindowProc(lpOldWndProc, hwnd, uMsg, wParam, lParam)
    
    End Function
    ' ========================================================================================
    
    
    ' ########################################################################################
    ' IRichEditOleCallback interface
    ' IID = 00020D03-0000-0000-C000-000000000046
    ' Inherited interface = IUnknown
    ' Custom implementation of the IRichEditOleCallback interface.
    ' Used by the RichEdit to get OLE-related stuff from the application using RichEdit.
    ' Note: Callback interfaces must be declared AS COMMON to avoid code removal.
    ' ########################################################################################
    
    Class CRichEditOleCallback As Common
    
    Interface IRichEditOleCallbackImpl $IID_IRichEditOleCallback
    
       Inherit IUnknown
    
       ' =====================================================================================
       Method GetNewStorage ( _                             ' VTable offset = 12
         ByRef lplpstg As IStorage _                        ' LPSTORAGE FAR * lplpstg
       ) As Long                                            ' HRESULT
    
         Local hr As Long
         Local pILockBytes As ILockBytes
         hr = CreateILockBytesOnHGlobal(%NULL, %TRUE, pILockBytes)
         If FAILED(hr) Then Method = hr : Exit Method
         hr = StgCreateDocfileOnILockBytes(pILockBytes, _
              %STGM_SHARE_EXCLUSIVE Or %STGM_READWRITE Or %STGM_CREATE, _
              0, lplpstg)
         Method = hr
    
       End Method
       ' =====================================================================================
       Method GetInPlaceContext ( _                         ' VTable offset = 16
         ByRef lplpFrame As IOleInPlaceFrame _              ' LPOLEINPLACEFRAME FAR * lplpFrame
       , ByRef lplpDoc As IOleInPlaceUIWindow _             ' LPOLEINPLACEUIWINDOW FAR * lplpDoc
       , ByRef lpFrameInfo As OLEINPLACEFRAMEINFO _         ' LPOLEINPLACEFRAMEINFO lpFrameInfo
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method ShowContainerUI ( _                           ' VTable offset = 20
         ByVal fShow As Long _                              ' BOOL fShow
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method QueryInsertObject ( _                         ' VTable offset = 24
         ByRef lpclsid As Guid _                            ' LPCLSID lpclsid
       , ByVal lpstg As IStorage _                          ' LPSTORAGE lpstg
       , ByVal cp As Long _                                 ' LONG cp
       ) As Long                                            ' HRESULT
    
         Method = %S_Ok
    
       End Method
       ' =====================================================================================
       Method DeleteObject ( _                              ' VTable offset = 28
         ByVal lpoleobj As IOleObject _                     ' LPOLEOBJECT lpoleobj
       ) As Long                                            ' HRESULT
    
         Method = %S_Ok
    
       End Method
       ' =====================================================================================
       Method QueryAcceptData ( _                           ' VTable offset = 32
         ByVal lpdataobj As IOleObject _                    ' LPDATAOBJECT lpdataobj
       , ByRef lpcfFormat As Dword _                        ' CLIPFORMAT FAR * lpcfFormat
       , ByVal reco As Dword _                              ' DWORD reco
       , ByVal fReally As Long _                            ' BOOL fReally
       , ByVal hMetaPict As Dword _                         ' HGLOBAL hMetaPict
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method ContextSensitiveHelp ( _                      ' VTable offset = 36
         ByVal fEnterMode As Long _                         ' BOOL fEnterMode
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method GetClipboardData ( _                          ' VTable offset = 40
         ByRef lpchrg As CHARRANGE _                        ' CHARRANGE FAR * lpchrg
       , ByVal reco As Dword _                              ' DWORD reco
       , ByRef lplpdataobj As IOleObject _                  ' LPDATAOBJECT FAR * lplpdataobj
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method GetDragDropEffect ( _                         ' VTable offset = 44
         ByVal fDrag As Long _                              ' BOOL fDrag
       , ByVal grfKeyState As Dword _                       ' DWORD grfKeyState
       , ByRef pdwEffect As Dword _                         ' LPDWORD pdwEffect
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
       Method GetContextMenu ( _                            ' VTable offset = 48
         ByVal seltype As Word _                            ' WORD seltype
       , ByVal lpoleobj As IOleObject _                     ' LPOLEOBJECT lpoleobj
       , ByRef lpchrg As CHARRANGE _                        ' CHARRANGE FAR * lpchrg
       , ByRef lphmenu As Dword _                           ' HMENU FAR * lphmenu
       ) As Long                                            ' HRESULT
    
         Method = %E_NotImpl
    
       End Method
       ' =====================================================================================
    
    End Interface
    
    End Class
    ' ========================================================================================
    
    Function ObjectInsert(hEdit As Dword, pwsFileName As String)As Long
     Local formatEtcClipboard As FORMATETC
     Local pLockBytes         As ILockBytes
     Local pRichEditOle       As IRichEditOle
     Local pStorage           As IStorage
     Local pClientSite        As IOleClientSite
     Local pUnk               As IUnknown
     Local pObject            As IOleObject
     Local ReObj              As REOBJECT
     Local SizeObj            As SIZEL
     Local clsidComponent     As Guid
     Local Id                 As String
     Local dwStart            As Dword
     Local dwEnd              As Dword
     Local hr                 As Long
    
     'Retrieves an IRichEditOle object that a client can use to access a rich edit control's Component Object Model (COM) functionality.
     SendMessage(hEdit, %EM_GETOLEINTERFACE, 0, VarPtr(pRichEditOle)) 'Vista+
     If IsNothing(pRichEditOle) Then Exit Function
    
     hr = CreateILockBytesOnHGlobal(%NULL, %TRUE, pLockBytes)
     If FAILED(hr) Then Exit Function
    
     hr = StgCreateDocfileOnILockBytes(pLockBytes, %STGM_SHARE_EXCLUSIVE Or %STGM_CREATE Or %STGM_READWRITE, 0, pStorage)
     If FAILED(hr) Then Exit Function
    
     formatEtcClipboard.cfFormat = 0 '%CF_BITMAP
     formatEtcClipboard.ptd      = %NULL
     formatEtcClipboard.dwAspect = %DVASPECT_CONTENT
     formatEtcClipboard.lindex   = -1
     formatEtcClipboard.tymed    = %TYMED_NULL '%NULL %TYMED_GDI %TYMED_NULL
    
     hr = pRichEditOle.GetClientSite(pClientSite)
     If FAILED(hr) Then Exit Function
    
     hr = OleCreateFromFile(clsidComponent, ByVal StrPtr(pwsFileName), $IID_IUnknown, %OLERENDER_DRAW, _
                            formatEtcClipboard, pClientSite, pStorage, pUnk)
     If FAILED(hr) Then Exit Function
    
     Id = $IID_IOleObject
     hr = pUnk.QueryInterface(ByVal StrPtr(Id), ByVal VarPtr(pObject))
     'pUnk.Release()
     If FAILED(hr) Then Exit Function
    
     'Notifies an object that it is embedded in an OLE container, which ensures that reference counting is done correctly for containers that support links to embedded objects.
     hr = OleSetContainedObject(pObject, %TRUE)
     If hr <> %S_Ok Then Exit Function
    
     ReObj.cbStruct = SizeOf(ReObj)
    
     hr = pObject.GetUserClassID(clsidComponent)
     If FAILED(hr) Then
      'pObject.Release()
      Exit Function
     End If
    
     ReObj.sizel    = SizeObj
     ReObj.clsid    = clsidComponent
     ReObj.cp       = %REO_CP_SELECTION
     ReObj.dvaspect = %DVASPECT_CONTENT
     ReObj.dwFlags  = %REO_RESIZABLE Or %REO_BELOWBASELINE
     ReObj.dwUser   = 0
     ReObj.poleobj  = ObjPtr(pObject)     'An instance of the IOleObject interface for the object.
     ReObj.polesite = ObjPtr(pClientSite) 'An instance of the IOleClientSite interface.
     ReObj.pstg     = ObjPtr(pStorage)    'An instance of the IStorage interface.
    
     SendMessage(hEdit, %EM_SETSEL, -1, -1)
     SendMessage(hEdit, %EM_GETSEL, VarPtr(dwStart), VarPtr(dwEnd))
     SendMessage(hEdit, %EM_SETSEL, dwEnd + 1, dwEnd + 1)
     Local sBuffer As String
     sBuffer = UCode$("[image here]")
     SendMessage(hEdit, %EM_REPLACESEL, %TRUE, ByVal StrPtr(sBuffer))
    
     hr = -1
     hr = pRichEditOle.InsertObject(ReObj)
     If SUCCEEDED(hr) Then
       'pObject.Release()
       'pRichEditOle.Release()
       Function = %TRUE
     End If
    
    End Function
Working...
X