XProfan

****************** Demo: OLE-Unterstützung für RichEdit-Controls
****************** XProfan² (Profan² 7.9)  Min: Win9x   Max:Win??
****************** © by TCS (Uwe "Pascal" Niemeier) 112003
window 50,10-650,570
usermessages 16,1066--WM_Close + Kontextmenü-Message von OLE-Interface
declare a%,b%,c%
declare a$,b$,c$
declare a&,b&,c&
declare a!,b!,c!
declare a#,b#,c#
declare Edit&,Test1&,Test2&,Test3&
 $H Messages.ph---Standart
 $H Windows.ph----Standart
 $I IRichEditOleCallback.inc---------IRichEditOleCallback-Interface
 $U OleUIInsertObject.pcu = RTF_-----"Objekt einfügen"-Dialog
Edit&=create("RichEdit",%hwnd,"",10,40,620,470)
setfocus(Edit&)
Init-OLE Edit&
Test1&=create("button",%hwnd,"Load",100,10,80,22)
Test2&=create("button",%hwnd,"Save",200,10,80,22)
Test3&=create("button",%hwnd,"Objekt einfügen",300,10,140,22)

while 1

    waitinput
    case %umessage=16:break

    if getfocus(Test1&)------------------------------------------------Öffnen

        a$=loadfile$("Bitte RTF-Datei wählen","*.rtf")
        case len(a$):RTF("LoadRTF",Edit&,a$)
        setfocus(%hwnd)

    elseif getfocus(Test2&)--------------------------------------------Speichern

        a$=savefile$("RTF-Datei speichern","*.rtf")
        case len(a$):RTF("SaveRTF",Edit&,a$)
        setfocus(%hwnd)

    elseif getfocus(Test3&)--------------------------------------------Einbinden

        RTF_Einfügen-OLE Edit&--aus Unit
        setfocus(%hwnd)

    elseif %umessage=1066--wird bei IRichEditOleCallback::GetContextMenu gesendet

        createmenu
        appendmenu 101,"Kopieren"
        appendmenu 102,"Ausschneiden"
        appendmenu 103,"Einfügen"
        appendmenu 104,"Objekt einfügen"
        trackmenu %mousex,%mousey
        case %menuitem=101:sendmessage(Edit&,~WM_COPY,0,0)
        case %menuitem=102:sendmessage(Edit&,~WM_CUT,0,0)
        case %menuitem=103:sendmessage(Edit&,~WM_PASTE,0,0)
        case %menuitem=104:RTF_Einfügen-OLE Edit&

    endif

endwhile

destroywindow(Edit&)
DeInit-OLE
4 href='./../../funktionsreferenzen/xprofan/end/'>end

SET("FastMode",1)
 $H windows.ph
 $H messages.ph
DEF &EM_STREAMIN  1097
DEF &EM_STREAMOUT 1098
DEF &SF_RTF  2
DEF &SF_TEXT 1
Struct EDITSTREAM =  dwCookie&,dwError&,pfnCallback&

Proc RTF_StreamIn_Callback

    Parameters hFile&,pbBuff&,cb&,pcb&
    Return XOR(~ReadFile(hFile&,pbBuff&,cb&,pcb&,0),1)

EndProc

Proc RTF_StreamOut_Callback

    Parameters hFile&,pbBuff&,cb&,pcb&
    Return XOR(~WriteFile(hFile&,pbBuff&,cb&,pcb&, 0),1)

EndProc

Proc RTF_StreamIn

    Parameters FileName$,RTFControl&,RTF_Flag&
    Declare StreamData#,FileID&
    FileID& = ~CreateFile(Addr(FileName$),~GENERIC_READ,~FILE_SHARE_READ,0,~OPEN_EXISTING,~FIL E_ATTRIBUTE_NORMAL,0)

    If FileID&

        Dim StreamData#,EDITSTREAM
        StreamData#.dwCookie& = FileID&
        StreamData#.dwError& = 0
        StreamData#.pfnCallback& = ProcAddr(RTF_StreamIn_Callback,4)
        SendMessage(RTFControl&,&EM_STREAMIN,RTF_Flag&, StreamData#)
        ~CloseHandle(FileID&)
        Dispose StreamData#

    Endif

EndProc

Proc RTF_StreamOut

    Parameters FileName$,RTFControl&,RTF_Flag&
    Declare StreamData#,FileID&
    FileID& = ~CreateFile(Addr(FileName$),~GENERIC_WRITE,~FILE_SHARE_WRITE,0,~CREATE_ALWAYS,~F ILE_ATTRIBUTE_NORMAL,0)

    If FileID&

        Dim StreamData#,EDITSTREAM
        StreamData#.dwCookie& = FileID&
        StreamData#.dwError& = 0
        StreamData#.pfnCallback& = ProcAddr(RTF_StreamOut_Callback,4)
        SendMessage(RTFControl&,&EM_STREAMOUT,RTF_Flag&,StreamData#)
        ~CloseHandle(FileID&)
        Dispose StreamData#

    Endif

EndProc

Declare Ende&,EndeButton&,GetButton&,SaveAsTextButton&,SaveAsRTFButton&,RTF&,File$
Cls ~GetSysColor(~COLOR_BTNFACE)
SetDialogFont ~GetStockObject(~DEFAULT_GUI_FONT)
EndeButton& = Create("Button",%hwnd,"Ende",10,2,80,24)
GetButton& = Create("Button",%hwnd,"Load",100,2,80,24)
SaveAsTextButton& = Create("Button",%hwnd,"Save as TXT",190,2,80,24)
SaveAsRTFButton& = Create("Button",%hwnd,"Save as RTF",280,2,80,24)
RTF& = Create("RichEdit",%hwnd,"",10,30,Width(%hwnd)-20,Height(%hwnd)-80)
UserMessages ~WM_COMMAND

WhileNot Ende&

    waitinput

    If %UMessage = ~WM_COMMAND

        If &ULparam = EndeButton&

            Ende& = 1

        ElseIf &ULparam = GetButton&

            File$ = LoadFile$("Datei laden :","Textdatei|*.TXT|Richtext|*.RTF")

            If File$ <> ""

                If Upper$(Right$(File$,4)) = ".RTF"

                    RTF_StreamIn(File$,RTF&,&SF_RTF)

                ElseIf Upper$(Right$(File$,4)) = ".TXT"

                    RTF_StreamIn(File$,RTF&,&SF_TEXT)

                Endif

            Endif

        ElseIf &ULparam = SaveAsTextButton&

            File$ = SaveFile$("Speichere als TXT","unbenannt.TXT")

            If File$ <> ""

                RTF_StreamOut(File$,RTF&,&SF_TEXT)

            Endif

        ElseIf &ULparam = SaveAsRTFButton&

            File$ = SaveFile$("Speichere als RTF","unbenannt.RTF")

            If File$ <> ""

                RTF_StreamOut(File$,RTF&,&SF_RTF)

            Endif

        Endif

    Endif

EndWhile