Ist doch kein Problem, habe ja nichts zu verbergen. Verstehe nur die Aufregung nicht
Code
$L
$P+
'###############################################################################################################################################
'Unitinfo: Texte ausdrucken oder Druckvorschau erstellen
'
' Erstellt am: 15.03.2012
' 1.) Komplette Unit neu geschrieben.
'###############################################################################################################################################
'###############################################################################################################################################
'Standart Includes und Units einbinden
'###############################################################################################################################################
$H WINDOWS.PH
$H Messages.ph
$H Structs.ph
$H Richedit.ph
'###############################################################################################################################################
'Öffentliche Variablen
'XPrinterStandart$ = Standartdrucker nach dem Programmstart
'XPrinterOrientation% = Druckerausrichtung des Standartdruckers nach dem Programmstart
'XPrintDlgName$ = Ausgewählten Druckername nach Aufruf des Druckermenüs
'XPrintDlgOrientation% = Ausgewählte Druckerausrichtung nach Aufruf des Druckermenüs
'XPrintDlgCopies% = Anzahl der Kopieen nach Aufruf des Druckermenüs
'XSeitenpos&[500] = Enthält die Seitennummern für die Druckvorschau
'###############################################################################################################################################
Declare XPrinterStandart$,XPrinterOrientation%,XPrintDlgName$,XPrintDlgOrientation%,XPrintDlgCopies%,XSeitenpos&[500]
'###############################################################################################################################################
'Öffentliche Definitionen
'###############################################################################################################################################
Def XGetDefaultPrinter(2) !"WINSPOOL.DRV","GetDefaultPrinterA"
Def XSetDefaultPrinter(1) ! "WINSPOOL.DRV","SetDefaultPrinterA"
Def XPrintDialog(1) ! "COMDLG32.DLL","PrintDlgA","#","%"
Def XOpenPrinter(3) !"winspool.drv","OpenPrinterA"
Def XClosePrinter(1) !"winspool.drv","ClosePrinter"
Def XDocumentProperties(6) !"winspool.drv","DocumentPropertiesA"
Def XDocumentPropertiesW(6) !"winspool.drv","DocumentPropertiesW"
Def XRegCREATEKEY(3)!"ADVAPI32","RegCreateKeyA"
Def XRegSetValueEx(6) !"ADVAPI32","RegSetValueExA"
Def XRegCloseKey(1) !"ADVAPI32","RegCloseKey"
Def &XWin32_Windows 1
Def &XWin32_NT 2
'###############################################################################################################################################
'Öffentliche Structuren
'###############################################################################################################################################
Struct XOSVERSIONINFO = dwOSVersionInfoSize&,dwMajorVersion&,dwMinorVersion&,dwBuildNumber&,\
dwPlatformId&,szCSDVersion$(128)
Struct XDevMode = dmDeviceName#(32),dmSpecVersion%,dmDriverVersion%,dmSize%,\
dmDriverExtra%,dmFields&,dmOrientation%,dmPaperSize%,\
dmPaperLength%,dmPaperWidth%,dmScale%,dmCopies%,dmDefaultSource%,\
dmPrintQuality%,dmColor%,dmDuplex%,dmYResolution%,dmTTOption%,\
dmCollate%,dmFormName#(4),dmUnusedPadding%,dmBitsPerPel%,dmPelsWidth&,\
dmPelsHeight&,dmDisplayFlags&,dmDisplayFrequency&
'###############################################################################################################################################
'Standartdrucker ermitteln
'
'Der Name des Standartdrucker wird unter XPrinterStandart$ gespeichert
'und die Druckerausrichtung in XPrinterOrientation%
'###############################################################################################################################################
Proc ?_GetPrinterStandart
XPrinterStandart$ = ?_GetPrinter()
XPrinterOrientation% = ?_GetOrientation(XPrinterStandart$)
EndProc
'###############################################################################################################################################
'Der aktuelle Drucker wird ermittelt
'
'Rückgabewert: String, Name des Druckers
'###############################################################################################################################################
Proc ?_GetPrinter
Declare size&,Txt$
Txt$ = Space$(200)
Size& = SizeOf(Txt$)
XGetDefaultPrinter(Addr(Txt$),addr(size&))
Return Trim$(Txt$)
EndProc
'###############################################################################################################################################
'Drucker setzen
'Parameters Drucker$ = Druckername
'###############################################################################################################################################
Proc ?_SetPrinter
Parameters Drucker$
XSetDefaultPrinter(Addr(Drucker$))
EndProc
'###############################################################################################################################################
'Druckermenü aufrufen
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
' Orientation% = 1 > Hochformat
' 2 > Querformat
'
'Rückgabewert: Integer = 0 > Ok
' 1 > Abbruch
'###############################################################################################################################################
Proc ?_PrinterDialog
Parameters Printername$,Orientation%
Declare PrintDlg#,Devmode#,x&,y&,PDC&,DevMem&
Struct PrintDlg = ~printdlg
'Devmode setzen
Dim Devmode#,XDevMode
With Devmode#
.dmOrientation% = Orientation%
.dmSize% = SizeOf(Devmode#)
.dmDeviceName# = Printername$
.dmCopies% = 1
' .dmPaperSize% = ~dmPaper_A4
.dmFields& = ~dm_Orientation | ~DM_COPIES' | ~dm_PaperSize
EndWith
'Daten in PrintDlg schreiben
Dim PrintDlg#,PrintDlg
With PrintDlg#
.StructSize& = SizeOf(PrintDlg#)
.hWndOwner& = %HWnd
.Flags& = $100 | $100000 | $200000 | $8 | $4'PD_RETURNDC, PD_HIDEPRINTTOFILE, PD_NONETWORKBUTTON, PD_NOPAGENUMS, PD_NOSELECTION
.hDevMode& = ~GlobalAlloc(~GHND,SizeOf(Devmode#))
DevMem& = ~GlobalLock(.hDevMode&)
Char DevMem&, 0 = Char$(DevMode#, 0, SizeOf(DevMode#))
~GlobalUnlock(DevMem&)
EndWith
'PrinterDlg aufrufen
XPrintDialog(PrintDlg#)
'Wenn Abbruch dann zurück, sonst Daten übernehmen
PDC& = Long(PrintDLG#,16)
If PDC& = 0
~GlobalFree(DevMem&)
Dispose Devmode#
Dispose PrintDlg#
Return 1
EndIf
'Ausgewählter Drucker ermitteln
x& = ~GlobalLock(PrintDlg#.hDevNames&)
y& = Word(x&,2)
XPrintDlgName$ = String$(x&,y&)
~GlobalUnlock(PrintDlg#.hDevNames&)
'Druckerausrichtung ermittelen
x& = ~GlobalLock(PrintDlg#.hDevMode&)
XPrintDlgOrientation% = Word(x&,44)
~GlobalUnlock(PrintDlg#.hDevMode&)
'Kopieen ermitteln
XPrintDlgCopies% = PrintDlg#.nCopies%
'Speicher freigeben
~GlobalFree(DevMem&)
Dispose Devmode#
Dispose PrintDlg#
Return 0
EndProc
'###############################################################################################################################################
'Horizontale Auflösung des aktuellen Druckers in DPI
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_DpiX
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,88)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Vertikale Auflösung des aktuellen Druckers in DPI
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_DpiY
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,90)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Breite des druckbaren Bereichs in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperWidthPix
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,8)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Höhe des druckbaren Bereichs in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperHeightPix
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,10)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Linker Rand des aktuellen Druckers in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperLeftPix
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,112)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Rechter Rand des aktuellen Druckers in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperRightPix
Parameters Printername$
Declare p!,PB!,PDC&
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
PB! = ~GetDeviceCaps(PDC&,110)'Physikalische Breite
~DeleteDC(PDC&)
p! = (PB!-?_PaperWidthPix(Printername$))-?_PaperLeftPix(Printername$)
Return p!
EndProc
'###############################################################################################################################################
'Oberer Rand des aktuellen Druckers in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperTopPix
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,113)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Unterer Rand des aktuellen Druckers in Pixel
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperBottomPix
Parameters Printername$
Declare p!,PH!,PDC&
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
PH! = ~GetDeviceCaps(PDC&,111)'Physikalische Hoehe
~DeleteDC(PDC&)
p! = (PH!-?_PaperHeightPix(Printername$))-?_PaperTopPix(Printername$)
Return p!
EndProc
'###############################################################################################################################################
'Breite des druckbaren Bereichs in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperWidthMM
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,4)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Höhe des druckbaren Bereichs in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperHeightMM
Parameters Printername$
Declare PDC&,p!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
p! = ~GetDeviceCaps(PDC&,6)
~DeleteDC(PDC&)
Return p!
EndProc
'###############################################################################################################################################
'Linker Rand des aktuellen Druckers in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperLeftMM
Parameters Printername$
Declare p!
Set("Decimals",1)
p! = Round(((?_PaperWidthMM(Printername$)/?_PaperWidthPix(Printername$))*?_PaperLeftPix(Printername$)),1)
Set("Decimals",0)
Return p!
EndProc
'###############################################################################################################################################
'Rechter Rand des aktuellen Druckers in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperRightMM
Parameters Printername$
Declare PDC&,p!,PB!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
PB! = ~GetDeviceCaps(PDC&,110)'Physikalische Breite
~DeleteDC(PDC&)
Set("Decimals",1)
p! = Round((?_PaperWidthMM(Printername$)/?_PaperWidthPix(Printername$))*((PB!-?_PaperWidthPix(Printername$))-?_PaperLeftPix(Printername$)),1)
Set("Decimals",0)
Return p!
EndProc
'###############################################################################################################################################
'Oberer Rand des aktuellen Druckers in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperTopMM
Parameters Printername$
Declare p!
Set("Decimals",1)
p! = Round(((?_PaperHeightMM(Printername$)/?_PaperHeightPix(Printername$))*?_PaperTopPix(Printername$)),1)
Set("Decimals",0)
Return p!
EndProc
'###############################################################################################################################################
'Unterer Rand des aktuellen Druckers in mm
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Float
'###############################################################################################################################################
Proc ?_PaperBottomMM
Parameters Printername$
Declare PDC&,p!,PH!
PDC& = ~CreateDC("WINSPOOL.DRV",Printername$,0,0)
PH! = ~GetDeviceCaps(PDC&,111)'Physikalische Hoehe
~DeleteDC(PDC&)
Set("Decimals",1)
p! = Round(((?_PaperHeightMM(Printername$)/?_PaperHeightPix(Printername$))*((PH!-?_PaperHeightPix(Printername$))-?_PaperTopPix(Printername$))),1)
Set("Decimals",0)
Return p!
EndProc
'###############################################################################################################################################
'Ermittelt die Druckerorientation
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
'
'Rückgabewert: Integer: 1 = Hochformat
' 2 = Querformat
'###############################################################################################################################################
Proc ?_GetOrientation
Parameters Printername$
Declare PHANDLE#,Pdevice$,Fehler&,Länge&,DevMode#,Orientation%
DIM PHANDLE#,4
Pdevice$ = ""
Fehler& = XOpenPrinter(ADDR(Printername$),PHANDLE#,0)
Länge& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),0,0,0)
DIM DevMode#,Länge&
Fehler& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),DevMode#,0,2)
Orientation% = Word(DevMode#,44)
Dispose DevMode#
Dispose PHANDLE#
Return Orientation%
EndProc
'###############################################################################################################################################
'Druckerorientation umstellen
'Parameters: Printername$ = Ein Druckername wie er im Druckermenü steht
' Orientation% = 1 > Hochformat
' 2 > Querformat
'
'Rückgabewert: Integer = 0 > Ok
' 1 > Abbruch
'###############################################################################################################################################
Proc ?_SetOrientation
Parameters Printername$,Orientation%
Declare WINVER&,OS#
Declare Pdevice$,PHANDLE#,Fehler&,Länge&,DevMode#,DevMode2#,Handle#,SubKey$
'OS-Version ermitteln
Dim OS#,XOSVERSIONINFO
OS#.dwOSVersionInfoSize& = 148
External("Kernel32","GetVersionExA",OS#)
Winver& = 8
If OS#.dwPlatformId& = &XWin32_Windows
If OS#.dwMajorVersion& = 4
Case OS#.dwMinorVersion& = 0 : Winver& = 1
Case OS#.dwMinorVersion& = 10 : Winver& = 2
Case OS#.dwMinorVersion& = 90 : Winver& = 3
Endif
ElseIf OS#.dwPlatformId& = &XWin32_NT
Case OS#.dwMajorVersion& = 3 : Winver& = 4
Case OS#.dwMajorVersion& = 4 : Winver& = 5
Case OS#.dwMajorVersion& = 5 : Winver& = 6
Case OS#.dwMinorVersion& = 1 : Winver& = 7
Endif
Dispose OS#
'Variablen setzen
Pdevice$ = ""
IF WinVer&<6
DIM PHANDLE#,4
Fehler& = XOpenPrinter(ADDR(Printername$),PHANDLE#,0)
Case Fehler& <> 1 : Return 1
Länge& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),0,0,0)
DIM DevMode#,Länge&
DIM DevMode2#,Länge&
Fehler& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),DevMode#,0,2)
Fehler& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),DevMode2#,0,2)
Long DevMode#,40=1
Word DevMode#,44=Orientation%
Fehler& = XDocumentProperties(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),DevMode#,DevMode#,8 | 2 | 1)
Fehler& = XClosePrinter(Long(PHANDLE#,0))
Dispose DevMode#
Dispose PHANDLE#
Dispose DevMode2#
Return 0
Else
DIM PHANDLE#,4
Fehler& = XOpenPrinter(ADDR(Printername$),PHANDLE#,0)
Case Fehler& <> 1 : Return 1
Länge& = XDocumentPropertiesW(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),0,0,0)
DIM DevMode#,Länge&
Fehler& = XDocumentPropertiesW(%HWND,Long(PHANDLE#,0),ADDR(Pdevice$),DevMode#,0,2)
DIM DevMode2#,Länge&
Fehler& = XClosePrinter(Long(PHANDLE#,0))
WORD DEVMODE#,44+32=Orientation%
Dim Handle#,4
SubKey$ = "Printers\DevModePerUser"
XRegCREATEKEY($80000001,Addr(SubKey$),Handle#)
XRegSetValueEx(LONG(Handle#,0),ADDR(Printername$),0,3,DEVMODE#,Länge&)
XRegCloseKey(LONG(Handle#,0))
SubKey$ = "Printers\DevModes2"
XRegCREATEKEY($80000001,Addr(SubKey$),Handle#)
XRegSetValueEx(LONG(Handle#,0),ADDR(Printername$),0,3,DEVMODE#,Länge&)
XRegCloseKey(LONG(Handle#,0))
Dispose Handle#
Sendmessage($FFFF,$001A,0,0)
Sendmessage($FFFF,$001B,0,0)
Dispose PHANDLE#
Dispose DevMode2#
Dispose DevMode#
Return 0
EndIf
EndProc
'###############################################################################################################################################
'Schriftgröße eines Rtf ändern. Wird bei Druckvorschau verwendet
'Parameters: t% = Verkleinerungsfaktor
' Pfad$ = Pfad für Daten zum Zwischenspeichern, werden wieder gelöscht
'###############################################################################################################################################
Proc ?_SetRtfFont
Parameters t%,Pfad$
Declare Zeile$,g%,s$,p$,z%
Assign #99,Pfad$+"\PT2.dat"
Rewrite #99
Assign #98,Pfad$+"\PT1.dat"
Reset #98
WhileNot Eof(#98)
Input #98,Zeile$
'Nach Schriftgröße suchen und um Verkleinerungsfaktor t% verkleinern
g% = InStr("\\fs",Zeile$)
If g% > 0
p$ = ""
z% = 0
While g%
'Text bis \fs holen
p$ = p$+Mid$(Zeile$,1,g%+2)
'Schriftgröße holen und um t% verkleinern
s$ = Mid$(Zeile$,g%+3,3)
If (Right$(s$,1)=" ") | (Right$(s$,1)="\\")
s$ = Mid$(Zeile$,g%+3,2)
g% = g%+5
Else
g% = g%+6
EndIf
s$ = Str$(Val(s$)/t%)
'Neue Schriftgröße anhängen
p$ = p$+s$
'Zeile$ erneuern
Zeile$ = Mid$(Zeile$,g%,Len(Zeile$))
g% = InStr("\\fs",Zeile$)
inc z%
case z% > 20 : break
EndWhile
p$ = p$+Zeile$'+"#"+Str$(z%)
Print #99, p$
Else
Print #99, Zeile$
EndIf
EndWhile
Close #98
Close #99
EndProc
'###############################################################################################################################################
'Druckvorschau für Rtf erzeugen und anzeigen
'Parameters: wnd& = Handle des Rtfs das als Vorschau gezeigt werden soll
' Printername$ = Ein Druckername wie er im Druckermenü steht
' Orientation% = 1 > Hochformat
' 2 > Querformat
' BorderLeft% = Linker Rand
' BorderTop% = Oberer Rand
' Pfad$ = Pfad für Daten zum Zwischenspeichern, werden wieder gelöscht
'###############################################################################################################################################
Proc ?_VorschauRtf
Parameters wnd&,Printername$,Orientation%,BorderLeft%,BorderTop%,Pfad$
Declare AltFocus&,PrinterDC&,Teil%,Size&,Pos&,vs%,InfoHandle&,x%,y%,b%,h%
Declare HorzRes&,VertRes&,PixelsX&,PixelsY&,iWidthTwips&,iHeightTwips&
Declare cRect#,DocInfo#,FormatRange#
Declare DialogHandle&,Dialogende%,vx%,vy%,vb%,vh%,DialogStatic&,DialogB1&,DialogB2&,Seite%,Druckseiten%,Font_Infodialog&,Infotext&
'Wenn keine Daten in Rtf dann zurück
If Len(GetText$(wnd&)) = 0
MessageBox("Das Dokument enthält keine Daten,\ndeshalb Druckvorschau nicht möglich","Druckenvorschau",262192)
SetFocus(wnd&)
Return
EndIf
'Focus vom aktuellen Fenster sichern und Variablen setzen
AltFocus& = GetActiveWindow()
vs% = 2'Halbe Größe
Teil% = 14
'Infodialog zeigen
Font_Infodialog& = Create("Font","Consolas",14,0,1,0,0)
b% = 315
h% = 40
x% = (%WinLeft+((%WinRight-%WinLeft)/2))-(b%/2)
Case x% < 1 : x% = %WinLeft+5
y% = (%WinTop+((%WinBottom-%WinTop)/2))-(h%/2)
Case y% < 1 : y% = %WinTop+5
InfoHandle& = Create("Dialog",%hWnd,"",x%,y%,b%,h%)
SetStyle InfoHandle&,GetStyle(InfoHandle&)-$0C80000
Infotext& = Create("Text",InfoHandle&,"Bitte warten, übergebe Daten an Vorschau...",5,10,310,20)
SetFont Infotext&,Font_Infodialog&
'Rtf in angegebener vs% zwischenspeichern
Rtf("SaveRTF",wnd&,Pfad$+"\PT1.dat")
?_SetRtfFont(vs%,Pfad$)
'Ein leeres Rtf öffnen und Daten laden
wnd& = Create("RichEdit",%hWnd,"",0,0,0,0)
Rtf("LoadRTF",wnd&,Pfad$+"\PT2.dat")
'Übergebener Drucker kurzzeitig als Standart setzen
?_SetPrinter(Printername$)
Case ?_GetOrientation(Printername$) <> Orientation% : ?_SetOrientation(Printername$,Orientation%)
'Twips für die Umrechnung einlesen
HorzRes& = ?_PaperWidthPix(Printername$)
VertRes& = ?_PaperHeightPix(Printername$)
PixelsX& = ?_DpiX(Printername$)
PixelsY& = ?_DpiY(Printername$)
iWidthTwips& = ((Int((HorzRes&/PixelsX&))*1440)/vs%)+(PixelsX&-100)
iHeightTwips& = ((Int((VertRes&/PixelsY&))*1440)/vs%)+(PixelsY&-200)
vb% = iWidthTwips&/Teil%
vh% = iHeightTwips&/Teil%
'Dialog öffnen in Hochformat(1) oder Querformat(1) abfragen
DialogHandle& = Create("XDialog",%hWnd,"",0,0,vb%,vh%+20,0,0,1)
DialogB1& = Create("Button",DialogHandle&,"<<",((vb%+2)/2)-35,1,30,20)',"Seite zurück",WTheme%)
DialogB2& = Create("Button",DialogHandle&,">>",((vb%+2)/2)+5,1,30,20)',"Seite vor",WTheme%)
XDraw.ColorRect(DialogHandle&,0,25,vb%+(?_PaperLeftPix(Printername$)/Teil%),vh%+(?_PaperBottomPix(Printername$)/Teil%),Weiss&,0)
DialogStatic& = Create("XStatic",DialogHandle&,0+(?_PaperLeftPix(Printername$)/Teil%),25,vb%,vh%,0)
SetFocus(DialogHandle&)
PrinterDC& = ~GetWindowDC(DialogStatic&)
'Variablen Dimensonieren
Dim FormatRange#,48
Dim DocInfo#,12
Clear DocInfo#
Dim cRect#,16
'Anzahl der zu druckenden Seiten holen
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = 0
'Long FormatRange#,0 = PrinterDC& 'HDC
'Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% '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 )
SendMessage(wnd&,~EM_SETSEL,-1,-1)'----------Cursor ans Ende des Edits
SendMessage(wnd&,~EM_GETSEL,Addr(Size&),0)'--Position des Cursors = Anzahl Zeichen
Druckseiten% = 0
Pos& = 0
XSeitenpos&[1] = 0
WhileLoop 1,99
Inc Druckseiten%
Long FormatRange#,40 = Pos&,-1
Pos& = SendMessage(wnd&,~EM_FORMATRANGE,1,FormatRange#)
XSeitenpos&[Druckseiten%+1] = Pos&
Case Pos& >= Size& : break
Case Pos& <0 : break
EndWhile
SendMessage(wnd&,~EM_FORMATRANGE,1,0)
'Formatdate für Drucker neu setzen
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = 0
Long FormatRange#,0 = PrinterDC& 'HDC
Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% '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 )
'Variablen setzen
Seite% = 1
Pos& = 0
Dialogende% = 0
'Erste Seite zeigen
DestroyWindow(InfoHandle&)
DeleteObject Font_Infodialog&
SetFocus(AltFocus&)
SetFocus(DialogHandle&)
XDraw.ColorRect(DialogHandle&,0,25,vb%+(?_PaperLeftPix(Printername$)/Teil%),vh%+(?_PaperBottomPix(Printername$)/Teil%),Weiss&,0)
SendMessage(wnd&,~EM_FORMATRANGE,1,FormatRange#)'--Pos& = 1. Zeichen der nächsten Seite
'Tastaturabfrage starten
WhileNot Dialogende%
SetText DialogHandle&,"Seite "+Str$(Seite%)+" von "+Str$(Druckseiten%)+" Seiten"
Waitinput
Case MenuItem(-2) : Dialogende% = 1'----------------------------SystemX
If Clicked(DialogB1&)'-------------------------------------Seite zurück
Dec Seite%
If Seite% > 0
XDraw.ColorRect(DialogHandle&,0,25,vb%+(?_PaperLeftPix(Printername$)/Teil%),vh%+(?_PaperBottomPix(Printername$)/Teil%),Weiss&,0)
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = 0
Long FormatRange#,0 = PrinterDC& 'HDC
Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,32 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,36 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,40 = XSeitenpos&[Seite%]'--Ab diesem Zeichen drucken (1. Seite: 0)...
Long FormatRange#,44 = -1'----...soweit wie möglich
SendMessage(wnd&,~EM_FORMATRANGE,1,FormatRange#)'--Pos& = 1. Zeichen der nächsten Seite
Else
Seite% = 1
EndIf
ElseIf Clicked(DialogB2&)'------------------------------------Seite vor
Inc Seite%
If Seite% <= Druckseiten%
XDraw.ColorRect(DialogHandle&,0,25,vb%+(?_PaperLeftPix(Printername$)/Teil%),vh%+(?_PaperBottomPix(Printername$)/Teil%),Weiss&,0)
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = 0
Long FormatRange#,0 = PrinterDC& 'HDC
Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,32 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,36 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,40 = XSeitenpos&[Seite%]'--Ab diesem Zeichen drucken (1. Seite: 0)...
Long FormatRange#,44 = -1'----...soweit wie möglich
SendMessage(wnd&,~EM_FORMATRANGE,1,FormatRange#)'--Pos& = 1. Zeichen der nächsten Seite
Else
Seite% = Druckseiten%
EndIf
EndIf
EndWhile
SendMessage(wnd&,~EM_FORMATRANGE,1,0)
'Fenster schließen
DestroyWindow(DialogHandle&)
DestroyWindow(wnd&)
'Speicher freigeben
Dispose FormatRange#
Dispose DocInfo#
Dispose cRect#
~DeleteDC(PrinterDC&)
'Standartdrucker wieder setzen
?_SetPrinter(XPrinterStandart$)
Case ?_GetOrientation(XPrinterStandart$) <> XPrinterOrientation% : ?_SetOrientation(XPrinterStandart$,XPrinterOrientation%)
'Alte Dateien löschen wenn nötig
If vs% > 0
XFile.DeleteFile(Pfad$+"\PT1.dat")
XFile.DeleteFile(Pfad$+"\PT2.dat")
EndIf
'Alten Focus wieder setzen
SetFocus(AltFocus&)
EndProc
'###############################################################################################################################################
'RTf ausdrucken. Zuvor wird das Druckermenü aufgerufen.
'Parameters: wnd& = Handle des Rtfs das gedruckt werden soll
' Printername$ = Ein Druckername wie er im Druckermenü steht
' Orientation% = 1 > Hochformat
' 2 > Querformat
' BorderLeft% = Linker Rand
' BorderTop% = Oberer Rand
' Info$ = Textname für den Ausdruck
'
'Rückgabewert: Integer = 0 > Ok
' 1 > Abbruch
'###############################################################################################################################################
Proc ?_DruckenRtf
Parameters wnd&,Printername$,Orientation%,BorderLeft%,BorderTop%,Info$
Declare AltFocus&,PrinterDC&,DialogHandle&,x%,y%,b%,h%,Font_Infodialog&,Infotext&
Declare HorzRes&,VertRes&,PixelsX&,PixelsY&,iWidthTwips&,iHeightTwips&
Declare cRect#,DocInfo#,FormatRange#,iTextOut&,iTextLength&
'Focus vom aktuellen Fenster sichern
AltFocus& = GetActiveWindow()
'Wenn keine Daten in Rtf dann zurück
If Len(GetText$(wnd&)) = 0
MessageBox("Das Dokument enthält keine Daten,\ndeshalb drucken nicht möglich","Drucken",262192)
SetFocus(wnd&)
Return 1
EndIf
'Druckermenü aufrufen
Case ?_PrinterDialog(Printername$,Orientation%) = 1 : Return 1
'Infodialog zeigen
Font_Infodialog& = Create("Font","Consolas",14,0,1,0,0)
b% = 315
h% = 40
x% = (%WinLeft+((%WinRight-%WinLeft)/2))-(b%/2)
Case x% < 1 : x% = %WinLeft+5
y% = (%WinTop+((%WinBottom-%WinTop)/2))-(h%/2)
Case y% < 1 : y% = %WinTop+5
DialogHandle& = Create("Dialog",%hWnd,"",x%,y%,b%,h%)
SetStyle DialogHandle&,GetStyle(DialogHandle&)-$0C80000
Infotext& = Create("Text",DialogHandle&,"Bitte warten, übergebe Daten an Drucker...",5,10,310,20)
SetFont Infotext&,Font_Infodialog&
'Ausgewählter Drucker kurzzeitig als Standart setzen
?_SetPrinter(XPrintDlgName$)
?_SetOrientation(XPrintDlgName$,XPrintDlgOrientation%)
'Twips für die Umrechnung einlesen
HorzRes& = ?_PaperWidthPix(XPrintDlgName$)
VertRes& = ?_PaperHeightPix(XPrintDlgName$)
PixelsX& = ?_DpiX(XPrintDlgName$)
PixelsY& = ?_DpiY(XPrintDlgName$)
iWidthTwips& = Int((HorzRes&/PixelsX&))*1440
iHeightTwips& = Int((VertRes&/PixelsY&))*1440
'Drucker PDC holen
PrinterDC& = ~CreateDC("WINSPOOL.DRV",XPrintDlgName$,0,0)
'Formartierung für Drucker
Dim FormatRange#,48
Dim DocInfo#,12
Clear DocInfo#
Dim cRect#,16
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = ADDR(Info$)
Long FormatRange#,0 = PrinterDC& 'HDC
Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% '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(wnd&,14,0,0)- SendMessage(wnd&,186,0,0)
'Ausdrucken
~StartDoc(PrinterDC&,DocInfo#)
Whileloop XPrintDlgCopies%
Whilenot (iTextOut& >= iTextLength&) | (itextOut& = -1)
~StartPage(PrinterDC&)
Long FormatRange#,44 = -1
iTextOut& = SendMessage(wnd&,1081,1,FormatRange#)
Long FormatRange#,40 = iTextOut&
SendMessage(wnd&,1075,0,cRect#)
~EndPage(PrinterDC&)
EndWhile
Long cRect#,0 = 0
Long cRect#,4 = 0
Long cRect#,8 = iWidthTwips&
Long cRect#,12 = iHeightTwips&
Long DocInfo#,0 = 12
Long DocInfo#,4 = ADDR(Info$)
Long FormatRange#,0 = PrinterDC& 'HDC
Long FormatRange#,4 = PrinterDC& 'TargetHDC
Long FormatRange#,8 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,12 = BorderTop% 'oberer Rand in Twips
Long FormatRange#,16 = iWidthTwips& 'rechter Rand in Twips
Long FormatRange#,20 = iHeightTwips& 'unterer Rand in Twips
Long FormatRange#,24 = BorderLeft% 'linker Rand in Twips
Long FormatRange#,28 = BorderTop% '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(wnd&,14,0,0)- SendMessage(wnd&,186,0,0)
EndWhile
~EndDoc(PrinterDC&)
SendMessage(wnd&,1081,1,0)
'Speicher freigeben
Dispose FormatRange#
Dispose DocInfo#
Dispose cRect#
~DeleteDC(PrinterDC&)
'Standartdrucker wieder setzen
?_SetPrinter(XPrinterStandart$)
Case ?_GetOrientation(XPrinterStandart$) <> XPrinterOrientation% : ?_SetOrientation(XPrinterStandart$,XPrinterOrientation%)
'Alten Focus wieder setzen
DestroyWindow(DialogHandle&)
DeleteObject Font_Infodialog&
SetFocus(AltFocus&)
Return 0
EndProc
Alles anzeigen
Da gibts bestimmt noch viel zu verbessern, ist aber schon mal ein Anfang.