XProfan

 $H Messages.ph
var id% = 1
Struct CREATESTRUCT = lpCreateParams&, hInstance&, hMenu&, hwndParent&, cy%, cx%, y%, x%, style&, lpszName&, lpszClass&, dwExStyle&
Struct LVCOLUMN = Mask&, FMT&, CX&, Text&, cchTextMaxLen&, Subitem&
Struct LVITEM = IMASK&, ITEM&, ISUBITEM&, State&, StateMask&, ITEXT&, ITEXTMAX&, IIMAGE&, ILPARAM&

proc UTF

    parameters text$
    declare b#
    Dim b#,2*len(text$)+2
    StringW b#,0 = text$
    text$ = Char$(b#,0,SizeOf(b#)-2)
    return text$

endproc

proc CreateW

    if %pCount > 10

        parameters Class$,Name$,style&,x%,y%,dx%,dy%,pWnd&,pid%,hInst&,exstyle&

    else

        parameters Class$,Name$,style&,x%,y%,dx%,dy%,pWnd&,pid%,hInst&
        var exstyle& = 0

    endif

    Class$ = UTF(Class$)
    Name$ = UTF(Name$)
    var cs# = New(CREATESTRUCT)

    With cs#

        .lpCreateParams& = SizeOf(cs#)
        .hInstance& = hInst&
        .hMenu& = if(u_IsMenu(id%),id%,0)
        .hwndParent& = pWnd&
        .cy% = dy%
        .cx% = dx%
        .y% = y%
        .x% = x%
        .style& = style&
        .lpszName& = Addr(Name$)
        .lpszClass& = Addr(Class$)
        .dwExStyle& = exstyle&

    EndWith

    var handle& = u_CreateWindowExW(exstyle&,Addr(Class$),Addr(Name$),style&,x%,y%,dx%,dy%,pWnd&,id%,hInst&,cs#)
    inc id%

    ifnot handle&

        Class$ = WinError$(%WinError)
        MessageBox("Es trat folgender Fehler auf:
        " + Class$,"F E H L E R !!!",4096)

    endif

    Dispose cs#
    return handle&

endproc

 $200 = edierbar
 $10 = von A-Z
 $20 = von Z-A
 $04 = keine Mehrfachauswahl

subproc Create.GridBoxW

    parameters pWnd&,def$,stl%,x%,y%,dx%,dy%
    declare s$
    var hList& = CreateW("SysListView32","",$50000009 + stl%,x%,y%,dx%,dy%,pWnd&,0,%hInstance,$200)
    u_SendMessageW(hList&,$1036,0,$00000023)
    var LVC# = New(LVCOLUMN)

    With LVC#

        .Subitem& = 0
        .MASK& = $7

        whileloop 0,(len(def$,";")  3) - 1

            s$ = SubStr$(def$,3*&loop + 1,";")
            .TEXT& = Addr(s$)
            .FMT&  = val(SubStr$(def$,3*&loop + 2,";"))
            .CX&   = val(SubStr$(def$,3*&loop + 3,";"))
            .cchTextMaxLen& = len(s$)
            u_SendMessageW(hList&,$1061,&loop,LVC#)

        EndWhile

    EndWith

    Dispose LVC#
    return hList&

endproc

proc InsertStringW

    parameters pList&,s$,index%
    declare ss$
    var LVI# = New(LVITEM)
    var d$ = UTF(Get("ListDel"))

    With LVI#

        .IMASK&=$1
        .ITEM& = index%

        whileloop len(s$,d$)

            ss$ = SubStr$(s$,&loop,d$)
            .iText& = Addr(ss$)
            .ITEXTMAX& = len(ss$)
            .ISUBITEM& = &loop - 1

            ifnot &loop - 1

                u_SendMessageW(pList&,$104D,index%,LVI#)

            else

                u_SendMessageW(pList&,$104C,index%,LVI#)

            endif

        EndWhile

    EndWith

endproc

proc LoadText

    parameters d$
    case d$ = "" : return
    Die CSV-Datei wird eingelesen
    declare b#,t$,tt$
    Dim b#,FileSize(d$)
    BlockRead(d$,b#,0,SizeOf(b#))
    d$ = Char$(b#,2,SizeOf(b#)-2)
    Dispose b#
    Die Zeilen werden im Sortier-Listview alphabetisch geordnet

    whileloop 0,len(d$,"x0Dzx0Az")-1

        InsertStringW(hSort&,SubStr$(d$,&loop+1,"x0Dzx0Az"),&loop)

    EndWhile

    Die Substrings jeder Zeile sind mit einem Semikolon getrennt
    Set("ListDel",";")
    Das Sortier-Listview wird ins Anzeigelistview übertragen
    Aus einer Spalte werden zwei
    var LVI# = New(LVITEM)
    LVI#.IMASK&= $1
    LVI#.ITEXT&= LVI#+36
    LVI#.ITEXTMAX& = 200
    LVI#.ISUBITEM& = 0

    whileloop 0, Getcount(hSort&) -1

        LVI#.ITEM& = &loop
        u_SendMessageW(hSort&,$1073,&loop,LVI#)Text auslesen
        Dim b#,200
        b# = LVI#.iText&
        d$ = Char$(b#,0,SizeOf(b#))In Stringvariable schreiben
        InsertStringW(hList&,d$,&loop)übertragen
        Dispose b#

    EndWhile

    Dispose LVI#

endproc

proc Save

    declare z%,s$,b#
    var d$ = SaveFile$("Unicode-Text speichern","DeuPol2.txt")
    case d$ = "" : return
    WindowTitle "Es wird gesichert ..."
    var LVI# = New(LVITEM)
    LVI#.IMASK&= $1
    LVI#.ITEXT&= LVI#+36
    LVI#.ITEXTMAX& = 200
    Dim b#,200
    b# = LVI#.ITEXT&
    clear b#
    Dispose b#
    var gesamt$ = ""

    whileloop 0,GetCount(hList&) - 1

        z% = &loop
        LVI#.ITEM& = z%

        whileloop 0,1

            LVI#.ISUBITEM& = &loop
            Dim b#,2 * u_SendMessageW(hList&,$1073,z%,LVI#) Text auslesen; dem Bereich wird das doppelte zugewiesen,
            weil die Message die Textlänge und nicht den Speicher ausgibt
            b# = LVI#.ITEXT&
            gesamt$ = gesamt$ + Char$(b#,0,SizeOf(b#)) + if(&loop,"x0Dzx0Az",";z")
            clear b#
            Dispose b#

        EndWhile

    EndWhile

    gesamt$ = Translate$(del$(gesamt$,len(gesamt$)-4,4),"x7Cz","x7Cx01")
    gesamt$ = del$(gesamt$,len(gesamt$)-4,4)
    Dim b#,len(gesamt$)+2
    Char b#,0 = "xFFxFE" + gesamt$
    BlockWrite d$,b#,0,SizeOf(b#)
    Dispose b#

endproc

declare hUser&,hGDI&,hKrnl&
declare hSort&,hList&
cls
var font& = Create("Font","Times New Roman",16,0,0,0,0)
hUser& = ImportDLL("USER32","u_")
hSort& = Create("GridBoxW",%hWnd,UTF("Sortieren")+";0;100",$10,0,0,0,0)
ShowWindow(hSort&,0)
hList& = Create("GridBoxW",%hWnd,UTF("Deutsch")+";0;300;"+UTF("Polnisch")+";2;300",$00,0,0,width(%hWnd),height(%hWnd))
SetFont hList&,font&
WindowTitle "Bitte warten, Wortliste wird geladen ..."
Format
"Wort1;Wort2
Wort3;Wort4;..."
LoadText LoadFile$("Quelldatei laden ...","deupol.txt")
WindowTitle "Je 100 deutsche und polnische Wörter (ESC um zu sichern)"

whilenot IsKey(27)

    waitinput

wend

Save
FreeDLL hUser&
FreeDLL hGDI&
FreeDLL hKrnl&
DeleteObject font&
end