XProfan

 $I Profalt.inc
'################################
'Drucken mit dem Richedit-Control
'################################
DEF StartDoc(2)      ! "gdi32","StartDocA"
DEF StartPage(1)     ! "gdi32","StartPage"
DEF EndPage(1)       ! "gdi32","EndPage"
DEF EndDoc(1)        ! "gdi32","EndDoc"
DEF CreateDC(4)      ! "gdi32","CreateDCA"
DEF DeleteDC(1)      ! "gdi32","DeleteDC"
DEF GetDeviceCaps(2) ! "gdi32","GetDeviceCaps"
DEF PrintDlg(1)      ! "comdlg32","PrintDlgA"
Declare Richedit&,RichDLL&,Ende&,Print&,Exit&,FileName$,Driver$,Printer$
Declare Horzres&,Vertres&,PixelsX&,PixelsY&,iWidthTwips&,iHeightTwips&
Declare iTextOut&,iTextLength&,DocName$
Declare PrinterDC&
Declare FormatRange#,PrintDLG#,cRect#
Declare DocInfo#
Dim FormatRange#,48
Dim DocInfo#,12
Clear DocInfo#
Dim PrintDLG#,66
Clear PrintDLG#
Dim cRect#,16
SetTrueColor 1
Window 0,0-640,480
CLS RGB(196,196,196)
Print& = CreateButton(%hwnd,"Drucken",500,40,80,24)
Exit& = CreateButton(%hwnd,"Ende",500,70,80,24)
RichEdit& = Create("RichEdit",%hwnd,"",0,2,460,430)
FileName$ = LoadFile$("Als RTF öffnen","*.RTF")

If FileName$ <> ""

    RTF("LoadRTF",Richedit&,Filename$)

EndIf

DocName$ = "Profan-RTFPrinter"

Whilenot Ende&

    Waitinput

    If GetFocus(Exit&)

        Ende& = 1

    ElseIf GetFocus(Print&)

        Long PrintDLG#,0  = 66
        Long PrintDLG#,4  = %hwnd
        Long PrintDLG#,20 = $0140'PD_RETURNDC,PD_PRINTSETUP
        PrintDlg(PrintDLG#)
        PrinterDC& = Long(PrintDLG#,16)

        If PrinterDC&

            HorzRes& = GetDeviceCaps(PrinterDC&,8)
            VertRes& = GetDeviceCaps(PrinterDC&,10)
            PixelsX& = GetDeviceCaps(PrinterDC&,88)
            PixelsY& = GetDeviceCaps(PrinterDC&,90)
            iWidthTwips& = Int((HorzRes&/PixelsX&))*1440
            iHeightTwips& = Int((VertRes&/PixelsY&))*1440
            Long cRect#,0 = 0
            Long cRect#,4 = 0
            Long cRect#,8 = iWidthTwips&
            Long cRect#,12 = iHeightTwips&
            Long DocInfo#,0 = 12
            Long DocInfo#,4 = ADDR(Docname$)
            Long FormatRange#,0 = PrinterDC&'HDC
            Long FormatRange#,4 = PrinterDC&'TargetHDC
            Long FormatRange#,8 = 0'linker Rand in Twips
            Long FormatRange#,12 = 0'oberer Rand in Twips
            Long FormatRange#,16 = iWidthTwips&'rechter Rand in Twips
            Long FormatRange#,20 = iHeightTwips&'unterer Rand in Twips
            Long FormatRange#,24 = 0'linker Rand in Twips
            Long FormatRange#,28 = 0'oberer Rand in Twips
            Long FormatRange#,32 = iWidthTwips&'rechter Rand in Twips
            Long FormatRange#,36 = iHeightTwips&'unterer Rand in Twips
            Long FormatRange#,40 = 0'CharRange-MIN
            Long FormatRange#,44 = -1'CharRange MAX ( -1 = alles )
            iTextOut& = 0
            iTextLength& = SendMessage(RichEdit&, 14, 0, 0)- SendMessage(RichEdit&,186,0,0)
            StartDoc(PrinterDC&,DocInfo#)

            Whilenot OR(iTextOut& >= iTextLength&,itextOut& = -1)

                StartPage(PrinterDC&)
                Long FormatRange#,44 = -1
                iTextOut& = SendMessage(RichEdit&, 1081, 1, FormatRange#)
                Long FormatRange#,40 = iTextOut&
                SendMessage(RichEdit&,1075,0,cRect#)
                EndPage(PrinterDC&)

            Wend

            EndDoc(PrinterDC&)
            SendMessage(RichEdit&, 1081, 1, 0)

        Endif

    Endif

EndWhile

Dispose FormatRange#
Dispose DocInfo#
Dispose PrintDLG#
DeleteDC(PrinterDC&)
End

startpaint DC&
DrawText 2250,6725,"Seite "+str$(x%)'..........bei A4 hoch
endpaint
inc x%
~StartPage(DC&)'------------Seite beginnen > Vorbereitung Drucken

' ab XProfan 8.0
Def SetEditNumeric(1) SetWindowLong(@&(1),-16, (GetWindowLong(@&(1),-16) | $2002))
Def SetWindowLong(3) !"USER32", "SetWindowLongA"
Def GetWindowLong(2) !"USER32", "GetWindowLongA"
Def GetSysColor(1) !"USER32","GetSysColor"
Declare text$,text1$,x%,h$
Declare ed1&,ed2&
Declare sed1&,sed2&,sed3&,sed4&,sed5&
Declare hed1&
Declare but&,sich&
Declare font&
SetTrueColor 1
Window 10,10 - 900,600
cls GetSysColor(15)
font&=CreateFont("Arial",16,0,0,0,0)
SetDialogFont  font&
ed1&=Create("RichEdit",%hwnd,"",11,10,700,500)
ed2&=Create("RichEdit",%hwnd,"",0,00,0,0)
CreateText(%hwnd,"Spaltenbreite",760,80,100,22)
sed1&=CreateEdit(%hwnd,"200",760,110,100,22)
sed2&=CreateEdit(%hwnd,"200",760,140,100,22)
sed3&=CreateEdit(%hwnd,"200",760,170,100,22)
sed4&=CreateEdit(%hwnd,"",760,200,100,22)
sed5&=CreateEdit(%hwnd,"",760,230,100,22)
SetEditNumeric(sed1&)
SetEditNumeric(sed2&)
SetEditNumeric(sed3&)
SetEditNumeric(sed4&)
SetEditNumeric(sed5&)
CreateText(%hwnd,"Zeilenhöhe",760,300,100,22)
hed1&=CreateEdit(%hwnd,"12",760,330,100,22)
SetEditNumeric(hed1&)
but&=CreateButton(%hwnd,"Einfügen",760,360,100,24)
sich&=CreateButton(%hwnd,"Speichern",760,460,100,24)
SetFocus(ed1&)
settext Ed1&,"Bitte eine Tabellenzeile einfügen\nund für weitere Zeilen"+ \
" den Curser ans Zeilenende setzen und die Taste ENTER drücken.\n"+ \
"Die Spaltenbreite ist nachträglich nicht mehr zu verändern."+Chr$(13)+Chr$(10)
SendMessage(Ed1&,$00B1,-1,-1)

While 1

    WaitInput
    case %key=2:BREAK
    case GetFocus(But&) AND (val(GetText$(sed1&))>0) : RTF_Zeile

    If GetFocus(sich&)

        Text$ = @SaveFile$("Speichern","Neu.rtf")
        case Len(trim$(Text$))>0 : call(&SaveRTF,Ed1&,addr(Text$))

    EndIf

wend

DeleteObject font&
End

Proc RTF_Zeile

    Assign #1,"Zeile.tmp"
    Rewrite #1
    Print #1,"{\"+chr$(114)+"tf1\"+chr$(097)+"nsi\"+chr$(097)+"nsicpg1252\deff0\deflang1049\deflangfe1049{\"+chr$(102)+"onttbl{\"+chr$(102)+"0\"+chr$(102)+"nil\"+chr$(102)+"charset0 Arial;}}"
    Print #1,"\viewkind4\uc1"
    text$="\"+chr$(116)+"rowd\"+chr$(116)+"rgaph30"
    x%= int(val(GetText$(sed1&))*10)
    text$=text$+"\cellx"+str$(x%)
    text1$="\cell"
    h$= str$(int(val(GetText$(hed1&))*2))

    If val(GetText$(sed2&))>0

        x%= x%+int(val(GetText$(sed2&))*10)
        text$=text$+"\cellx"+str$(x%)
        text1$=text1$+"\cell"

    EndIf

    If val(GetText$(sed3&))>0

        x%= x%+int(val(GetText$(sed3&))*10)
        text$=text$+"\cellx"+str$(x%)
        text1$=text1$+"\cell"

    EndIf

    If val(GetText$(sed4&))>0

        x%= x%+int(val(GetText$(sed4&))*10)
        text$=text$+"\cellx"+str$(x%)
        text1$=text1$+"\cell"

    EndIf

    If val(GetText$(sed5&))>0

        x%= x%+int(val(GetText$(sed5&))*10)
        text$=text$+"\cellx"+str$(x%)
        text1$=text1$+"\cell"

    EndIf

    Print #1,text$+"\pard\intbl\lang1031\"+chr$(102)+"s"+h$+text1$+"\"+chr$(114)+"ow"
    Print #1,"\par}"
    Close #1
    Rtf("LoadRTF",ed2&,"Zeile.tmp")
    SetFocus(ed2&)
    sendmessage(ed2&,$00B1,0,-1)
    Sendmessage(ed2&,$301,0,0)
    Sendmessage(ed1&,$302,0,0)
    SetFocus(ed1&)

EndProc

...
~StartDoc(DC&,DocInfo#)'-------Druckauftrag beginnen

whileloop 1,Seiten%'-----------Anzahl ermittelte Seiten

    mcls 500,100,255'--Farbe nur zu Testzwecken
    startpaint -1'-----%HDC nach StartPaint -1: DC der Speicherbitmap
    usefont "Balloon",50,0,0,0,0
    drawtext 0,0,"Seite "+str$(&loop)+" von "+str$(Seiten%)
    ~BitBlt(DC&,10,10,500,100,%hdc,0,0,~SRCCOPY)'--Parameter 2+3: Position in der Seite
    endpaint
    ~StartPage(DC&)'------------Seite beginnen > Vorbereitung Drucken
    ...