// KSO.PRG #include "Gra.ch" #include "Xbp.ch" #include "Appevent.ch" #include "Font.ch" #include "Directry.ch" #include "Dmlb.ch" #include "Common.ch" #include "xbpdev.ch" #include "Dll.ch" #include "DelDbe.ch" //+25.06.2013 12:38 #include "Thread.ch" //+22.09.2018 20:48 //+02.06.2013 12:35 fr kso/Benutzer: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv // #defines fr Registry-Datenbank mssen mit // dem Windows SDK bereinstimmen #define HKEY_CLASSES_ROOT 2147483648 #define HKEY_CURRENT_USER 2147483649 #define HKEY_LOCAL_MACHINE 2147483650 #define HKEY_USERS 2147483651 #define KEY_QUERY_VALUE 1 #define KEY_SET_VALUE 2 #define KEY_CREATE_SUB_KEY 4 #define KEY_ENUMERATE_SUB_KEYS 8 #define KEY_NOTIFY 16 #define KEY_CREATE_LINK 32 //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ // war nur zum Experiment! 06.12.2020 11:09 geREMt //INIT PROCEDURE BeimStart() //msgbox("Beim Start") //RETURN // //EXIT PROCEDURE AllOverNow() //msgbox("Beim Ende") //RETURN // /* PROCEDURE AppSys_ALT() #define DEF_ROWS 25 #define DEF_COLS 80 // #define DEF_FONTHEIGHT 20 // ...bei 800X600 // #define DEF_FONTWIDTH 10 // -"- // #define DEF_FONTHEIGHT 16 // ...bei 640x480 // #define DEF_FONTWIDTH 8 // -"- LOCAL oCrt, nAppType := AppType() LOCAL aSizeDesktop, aPos aSizeDesktop := AppDesktop():currentSize() //DO CASE // CASE aSizeDesktop[1] == 640 //#define DEF_FONTHEIGHT aSizeDesktop[2]/30 //#define DEF_FONTWIDTH aSizeDesktop[1]/80 // CASE aSizeDesktop[1] >= 800 #define DEF_FONTHEIGHT aSizeDesktop[2]/28 #define DEF_FONTWIDTH aSizeDesktop[1]/80 // CASE aSizeDesktop[1] == 1024 //#define DEF_FONTHEIGHT aSizeDesktop[2]/28 //#define DEF_FONTWIDTH aSizeDesktop[1]/84 //ENDCASE // DO CASE // Anwendung wurde im PM Modus gelinkt, eine XbpCrt Instanz // ist zu erzeugen. // CASE nAppType == APPTYPE_PM // Bestimmen der Fensterposition (Anordnen in der Mitte // des Desktop-Fensters) // aSizeDesktop := AppDesktop():currentSize() aPos := { (aSizeDesktop[1]-(DEF_COLS * DEF_FONTWIDTH)) /2, ; (aSizeDesktop[2]-(DEF_ROWS * DEF_FONTHEIGHT)) /2 } // XbpCRT-Fenster erzeugen oCrt := XbpCrt():New ( NIL, NIL, aPos, DEF_ROWS, DEF_COLS ) oCrt:FontWidth := DEF_FONTWIDTH oCrt:FontHeight := DEF_FONTHEIGHT oCrt:title := AppName()+" - Bestattungs-Institut Karl Schumacher Oberhausen" //#ifdef __WIN32__ oCrt:FontName := "8.Arial" sleep(5) //+19.11.2019 21:27 test, ob 'Ausstieg direkt beim Start' dann noch auftritt //#endif oCrt:Create() sleep(5) //+19.11.2019 21:27 // Presentation Space initialisieren oCrt:PresSpace() sleep(5) //+19.11.2019 21:27 // XbpCrt wird aktives Fenster und Ausgabeger§t SetAppWindow ( oCrt ) oCrt:icon = 1 //+14.12.2020 09:28 RETURN */ PROCEDURE AppSys() #define DEF_ROWS 25 #define DEF_COLS 80 LOCAL oCrt, nAppType := AppType() LOCAL aSizeDesktop, aPos aSizeDesktop := AppDesktop():currentSize() #define DEF_FONTHEIGHT Int(aSizeDesktop[2]/30) #define DEF_FONTWIDTH Int(aSizeDesktop[1]/85) // Bestimmen der Fensterposition (Anordnen in der Mitte // des Desktop-Fensters) aPos := { (aSizeDesktop[1]-(DEF_COLS * DEF_FONTWIDTH)) /2, ; (aSizeDesktop[2]-(DEF_ROWS * DEF_FONTHEIGHT)) /2 } // XbpCRT-Fenster erzeugen oCrt := XbpCrt():New ( NIL, NIL, aPos, DEF_ROWS, DEF_COLS ) oCrt:FontWidth := DEF_FONTWIDTH oCrt:FontHeight := DEF_FONTHEIGHT oCrt:title := AppName()+" - Bestattungs-Institut Karl Schumacher Oberhausen" //#ifdef __WIN32__ oCrt:FontName := "8.Arial" sleep(5) //+19.11.2019 21:27 test, ob 'Ausstieg direkt beim Start' dann noch auftritt //#endif oCrt:Create() sleep(5) //+19.11.2019 21:27 // Presentation Space initialisieren oCrt:PresSpace() sleep(5) //+19.11.2019 21:27 // XbpCrt wird aktives Fenster und Ausgabeger§t SetAppWindow ( oCrt ) oCrt:icon = 1 //+14.12.2020 09:28 RETURN //+25.06.2013 12:38: ******************************************************************************* * DbeSys() wird bei jedem Programmstart ausgefhrt ******************************************************************************* PROCEDURE dbeSys() /* * Der Parameter lHidden wird fr alle Database-Engines, die zu * einer abstrakten Database-Engine kombiniert werden, auf .T. gesetzt. */ //LOCAL aDbes := { { "DBFDBE", .T.},; // { "NTXDBE", .T.},; // { "DELDBE", .F.},; // { "SDFDBE", .F.},; // { "FOXDBE", .F.},; // { "CDXDBE", .F.} } //LOCAL aBuild :={ { "DBFNTX", 1, 2 },{ "SDFNTX", 4, 2 },{ "FOXCDX", 5, 6 } } LOCAL aDbes := { { "DBFDBE", .T.},; { "NTXDBE", .T.},; { "DELDBE", .F.},; { "SDFDBE", .F.} } LOCAL aBuild :={ { "DBFNTX", 1, 2 },{ "SDFNTX", 4, 2 } } LOCAL i /* * Setzen der Sortierfolge und des Datumformates */ SET COLLATION TO GERMAN SET DATE TO GERMAN /* * Laden aller Database-Engines */ FOR i:= 1 TO len(aDbes) IF ! DbeLoad( aDbes[i][1], aDbes[i][2]) Alert( aDbes[i][1] + MSG_DBE_NOT_LOADED , {"OK"} ) ENDIF sleep(5) //+19.11.2019 21:27 test, ob 'Ausstieg direkt beim Start' dann noch auftritt NEXT i /* * Erzeugen von Database-Engines */ FOR i:= 1 TO len(aBuild) IF ! DbeBuild( aBuild[i][1], aDbes[aBuild[i][2]][1], aDbes[aBuild[i][3]][1]) Alert( aBuild[i][1] + MSG_DBE_NOT_CREATED , {"OK"} ) ENDIF sleep(5) //+19.11.2019 21:27 test, ob 'Ausstieg direkt beim Start' dann noch auftritt NEXT i DbeSetDefault( "DELDBE" ) DbeInfo( COMPONENT_DATA, DELDBE_MODE, DELDBE_MULTIFIELD ) DbeInfo( COMPONENT_DATA, DELDBE_FIELD_TOKEN, "," ) DbeInfo( COMPONENT_DATA, DELDBE_RECORD_TOKEN, Chr(13)+Chr(10) ) //13.08.2024 18:38 DbeSetDefault( "SDFNTX" ) DbeInfo( COMPONENT_DATA , DBE_EXTENSION, "TAK" ) DbeInfo( COMPONENT_ORDER, DBE_EXTENSION, "XAK" ) DbeSetDefault( "DBFNTX" ) // ohne das geht es nicht! DbeInfo( COMPONENT_DATA , DBE_EXTENSION, "DBF" ) DbeInfo( COMPONENT_ORDER, DBE_EXTENSION, "NTX" ) RETURN PROCEDURE MAIN * schumach: hauptmenu-bestattungen LOCAL aNeuFiles, aExeFiles, cLn LOCAL aFiles := { "best.dbf", "vv.dbf", "auftr.dbf", "vers.dbf", "vbest.dbf", "best.dbt", "vbest.dbt" } //26.10.2025 10:16 LOCAL aTFiles := { "tbest.dbf", "tvv.dbf", "tauftr.dbf", "tvers.dbf", "tvbest.dbf", "tbest.dbt", "tvbest.dbt" } //21.02.2008 10:53 LOCAL aT0Files := { "tbest0.dbf", "tvv0.dbf", "tauftr0.dbf", "tvers0.dbf", "tvbest0.dbf", ; // "tbest0.dbt", "tvbest0.dbt" } LOCAL cDFile1 := cDFile2 := cDFile3 := cDFile4 := cDFile5 := "" //17.03.2008 19:04 LOCAL lTDZap //**28.03.2008 09:08** //+28.10.2019 19:01 Error-Handling addiert: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv LOCAL bSaveError := ErrorBlock( {|e| FehlerBehandlung(e) } ) // schon hierher vorgezogen - wie in bestp4.prg //+02.06.2013 22:38 vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv PUBLIC cPCName := NetName(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\ComputerName\ComputerName", "ComputerName") //+02.06.2013 18:15 PUBLIC cUserName := NetName(HKEY_CURRENT_USER, "Volatile Environment", "USERNAME") //+02.06.2013 18:15 PUBLIC cPCNr := "1" //+25.04.2026 20:27 Aufm LapTop!! // im Bro: wird in Datei() gefllt anhand der TextXX-Felder in der arb.dbf<><><><><><><><><><><><><> //+16.11.2022 09:25 fr die html-Briefe: PUBLIC cBU1 := "Beerdigungsinstitut" PUBLIC cBU2 := "Karl Schumacher e.K." PUBLIC cBU3 := "Zentrale" PUBLIC cBU4 := "Vestische Straáe 146" PUBLIC cBU5 := "46117 Oberhausen" PUBLIC cBU6 := "0208 690480" //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ //+20.07.2019 09:36 #ifndef DEBUG SetCancel( .F.) // Alt-C wirkt nicht, auáer bei Debug-Version #endif SET EXCLUSIVE off //SET EXCLUSIVE ON // nur zum Testen !! SET EPOCH TO (Year(date())-99) set date format to "dd.mm.yyyy" SetMouse(.T.) SetCursor(1) //SetCancel( .F. ) msgbox("vor EuroV") DO eurov // damit die Variablen schon mal deklariert sind msgbox("nach EuroV") //k PRIVATE nFontR := IIf( nV<=1, FONT_DEFFIXED_SMALL, FONT_DEFFIXED_MEDIUM ) //+25.06.2013 12:55 PRIVATE nFontR := IIf( nV<=1, "8.Arial", "10.Arial" ) //k 07.07.2013 21:01 PRIVATE cAc := "WERNER.EXE" //+25.06.2013 17:50 PUBLIC cPreisZ := cPreisGr := "1" // Preis in 1. Zeile / Preisgruppen wie bei Raguse **Z: 20.04.2005** PUBLIC cVersBM := cAdrBM := cTermBM := cSerieBM := cLeistBM := " ", cFarbeBG := "1", nBezZeil := 1 //+25.06.2013 12:12, nBrowH, lVor, lVorH, lVorG //+26.11.2019 09:09 cBFont in EUROV PUBLIC cBFont := nFontR, oBest := NIL //+25.06.2013 12:26 PUBLIC oBest := NIL //+25.06.2013 12:26 PUBLIC cPicture := "@ 99,999.99", cColor := "W", cKomma := ".", cPreisGr, cPreisZ, nKomma := 0 PUBLIC cBrNe1:="B", cBrNe2:="B", cBrNe3:="B", cBrNe4:="B", cBrNe5:="B" //+25.06.2013 14:36 PUBLIC oFocSle, oVideo := NIL //+25.06.2013 14:39 cTime := Time() //+31.03.2012 18:33 IF AppKeyState(65553)==1 .OR. (cTime < "08:30:00") //+31.03.2012 18:28 nur mit Ctrl-Taste Ineux(.T.) // damit Text ausgegeben werden muss ENDIF @24,18 say " <¸> Copyright 1993 - CS Jrgen Schmitt " cLn := DisplayLogo( cLn ) lDirekt := (cLn="L" .OR. cLn="N") cLn = UPPER( cLn ) cNetver := "C:\HDBE\" // Voreinstellung auf lokalen Betrieb //cDatver := "C:\HDBE\" // darf nicht, weil sonst die Clients nicht laufen! 20.03.2017 18:50 siehe 11 Zeilen weiter // zum Testen: IF "bestatt"$cDatver za05x := PadR(" PC: Testrechner fr Essen",40) ELSE za05x := " " ENDIF //09.11.2025 09:28 mwstdat fehlt in c:\hdbe, rekonstruieren aus mwstdat_orig: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv IF !FExists("C:\HDBE\mwstdat.dbf") CLEAR @ 10,10 SAY "Die Parameterdatei MWSTDAT.DBF ist verloren gegangen!" IF !FExists("C:\HDBE\mwstdat_orig.dbf") @ 12,10 SAY "Die Backup-Datei MWSTDAT_ORIG.DBF existiert nicht!" @ 14,10 SAY "Rufen Sie den Administrator an: 0171 466 4967 !" WAIT "Drcken Sie " QUIT ELSE @ 12,10 SAY "Kopiere die Backup-Datei MWSTDAT_ORIG.DBF auf MWSTDAT.DBF ..." COPY FILE ( "C:\HDBE\MWSTDAT_ORIG.DBF" ) TO ( "C:\HDBE\MWSTDAT.DBF" ) // Rekonstruktion Sleep(200) IF !FExists("C:\HDBE\MWSTDAT_ORIG.DBF") .OR. !FExists("C:\HDBE\MWSTDAT.DBF") @ 14,10 SAY "... misslungen !" @ 16,10 SAY "Rufen Sie den Administrator an: 0171 466 4967 !" WAIT "Drcken Sie " QUIT ELSE @ 14,10 SAY "... geschafft !" @ 16,10 SAY "Beobachten Sie, ob das Programm jetzt einwandfrei funktioniert !" @ 17,10 SAY "Wenn nicht, dann rufen Sie den Administrator an: 0171 466 4967 !" WAIT "Drcken Sie " ENDIF ENDIF ENDIF //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ //19.03.2017 15:07 IF cLn $ "LO" //24.08.2007 09:06 O bedeutet: Verbindung mit Oberhausen herstellen IF cLn == "L" // hierzwischen war die šbertragungs-Routine cLN := "N" // weil nur "N" existiert ENDIF ////replace mwstdat->loc_or_net with cLn //07.03.2008 17:58 nach oben verschoben ////use //SET DEFAULT TO &cNetver SET DEFAULT TO &cDatver // äöüÄÖÜß „”Ž™šá CLEAR //17.03.2008 19:06 do hpar do eurov set color to &cFarbe *SCHF=1 *do codewort *if schf=1 * clear * @ 5,5 say "CODEWORT FALSCH !!!" * clear all * return *endif antw=" " set bell off set confirm off set delete on set safety off set talk off set function 2 to "h " set function 3 to "h10 " set function 9 to space(6) set function 10 to "! " set century on clear do hpar do eurov // 29.06.2026 11:14 DO termine //clear all do hpar DO CASE //09.11.2025 10:34 netver ge„ndert: aus T:\HDBE -> C:\HDBE CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "OB" za05 := PadR(" PC: Arbeitsplatz in Oberhausen",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "MS" za05 := PadR(" PC: Arbeitsplatz in Oberhausen-MS",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\MS\" za05 := PadR(" PC: Hauptrechner in Oberhausen-MS",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "DU" za05 := PadR(" PC: Nebenrechner in Duisburg",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\DU\" za05 := PadR(" PC: Hauptrechner in Duisburg",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "E" za05 := PadR(" PC: Nebenrechner in Essen",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\E\" za05 := PadR(" PC: Hauptrechner in Essen",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "GE" za05 := PadR(" PC: Nebenrechner in Gelsenkirchen",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\GE\" za05 := PadR(" PC: Hauptrechner in Gelsenkirchen",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "HE" za05 := PadR(" PC: Nebenrechner in Herne",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\HE\" za05 := PadR(" PC: Hauptrechner in Herne",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "DO" za05 := PadR(" PC: Nebenrechner in Dortmund",40) CASE Upper(cNetVer) = "C:\HDBE\" .AND. Upper(cOBVer) = "T:\HDBE\DO\" za05 := PadR(" PC: Hauptrechner in Dortmund",40) CASE Upper(cNetVer) = "M:\HDBE\" .AND. Upper(cOBVer) = "LT" za05 := PadR(" PC: LapTop",40) OTHERWISE za05 := PadR("ACHTUNG: Konfig mit <7-1>!",40) ENDCASE IF lDirekt = .T. // schdat="1000000" //25.04.2026 18:56 "1111110" // do datei select 1 //28.06.2026 19:49vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv use best //25.04.2026 20:08 statt do datei index on str(auftrnr,6,0) to xauftrnr index on Upper(name) to xname DESCENDING //+20.12.2018 15:26 Indexzeile erg„nzt, damit gleiche Namen nach Nummer liegen index on Upper(name+vorname) to xnamevor //+26.10.2018 18:54 +vorname erg„nzt 20.12.2018 15:26 inxnamevor umbenannt index on Upper(ansp_name) to xanspnam DESCENDING //+18.09.2018 12:49 Zeile erg„nzt index on Upper(ansp_name+ansp_vname) to xanspvor //+06.07.2019 18:34 Zeile erg„nzt index on Upper(strasse+plz_ort) to xstrasse //+18.09.2018 12:49 Zeile erg„nzt SET INDEX TO xauftrnr,xname,xnamevor,xanspnam,xanspvor,xstrasse //14.03.2025 16:04 //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ best4p( "Bestattungs-Aufnahme/Pflege-Maske -- Karl Schumacher Oberhausen" ) CLOSE ALL ENDIF //----------------------------------------------------------------------- RETURN *** *** *** //+02.06.2013 12:34 Test fr kso/Benutzer: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv // Name der Workstation feststellen FUNCTION NetName(nHKey,cKey,cEntry) // cKey := "System\CurrentControlSet\Control\ComputerName\ComputerName" // cKey := "Volatile Environment" // cEntry := "ComputerName" // cEntry := "USERNAME" RETURN QueryRegistry( nHKey, cKey, cEntry ) // Xbase++ Wrapper-Funktionen fr jeden API-Aufruf deklarieren DLLFUNCTION RegOpenKeyExA( nHkeyClass, cKeyName, nReserved , nAccess , @nKeyHandle ) ; USING STDCALL ; FROM ADVAPI32.DLL DLLFUNCTION RegQueryValueExA( nKeyHandle, cEntry, nReserved, @nType , @cName , @nSize ) ; USING STDCALL ; FROM ADVAPI32.DLL DLLFUNCTION RegCloseKey( nKeyHandle ) ; USING STDCALL ; FROM ADVAPI32.DLL // Werte aus der Windows Registry-Datenbank auslesen: FUNCTION QueryRegistry( nHKEY, cKey, cEntry ) LOCAL cName := "" // Alle Parameter, die an LOCAL nSize := 0 // API Funktionen bergeben LOCAL nHandle:= 0 // werden, mssen einen Wert LOCAL nType := 0 // ungleich NIL haben LOCAL nRet // Registry ”ffnen nRet := RegOpenKeyExA( nHKEY, cKey, 0, KEY_QUERY_VALUE, @nHandle ) IF nRet <> 0 // Fehler beim ”ffnen RETURN cName // ** RETURN ** ENDIF // L„nge und Typ des // Eintrags feststellen RegQueryValueExA( nHandle, cEntry, 0, @nType , @cName, @nSize ) IF nSize > 0 // Leeren String vorbereiten. cName := Space( nSize-1 ) // Er wird per Referenz an die // API bergeben und enth„lt // dann das Ergebnis. RegQueryValueExA( nHandle, cEntry, 0, nType , @cName, @nSize ) ENDIF RegCloseKey( nHandle ) // Registry schlieáen RETURN cName //================================================================================== *** *** *** *dbupges *GESamtes UnterProgramm fr DatenBanken im Netz *zum Ausfhren von USE, Recordlock, Recorddelete, Append ***hpar.prg - erkl§rt die Netzwerk-Variablen procedure hpar *********** public clipper public upfehl public vnetz public schalt public vara upfehl=0 if clipper vnetz="J" else vnetz="N" endif schalt=" " vara=".F." return *********** FUNCTION Satzdelete upfehl:=0 // If rlock() IF DbRlock( Recno() ) //+17.11.2018 17:59 dbdelete() else dbdelete() endif RETURN upfehl FUNCTION Satzrecall upfehl:=0 // If rlock() IF DbRlock( Recno() ) //+17.11.2018 18:00 dbrecall() else dbrecall() endif RETURN upfehl * dbupro Unterprog Datenbanken lesen und Verarbeiten *set procedure to dbupro //procedure dbupro //parameters dat,ind,upfehl,schalt,upfunk //if vnetz = 'J' && netz j,n ************************************************************************ //*FUNCTION DBaufmachen(cDat, cInd, cSchalt) //*dat:=cDat ; ind:=cInd ; schalt:=cSchalt FUNCTION DBaufmachen parameters dat,ind,schalt //* IF upper(dat) == "MWSTDAT" dat := "C:\HDBE\MWSTDAT" ELSEIF Substr(dat,2,1) ==":" ELSE dat := cDatver+dat // erg§nzen um das Datenverzeichnis ENDIF *// if ind # NIL IIf( SUBSTR( ind,2,1 ) == ":", ind, ind := cDatver+ind ) endif // if upfunk = 1 && 1 = use,2=Satzsperren,3=append if Schalt = 'E' && E= exclusive (z.B. bei reorg wenn upfunk=1) stor .T. to vara else stor .F. to vara endif stor 0 to upfehl stor '1' to schleife do while schleife = '1' // if net_use("&dat",vara,.5) if net_use("&dat",vara,5) // 14.09.2006 if ind # NIL set index to &ind endif stor '2' to schleife else IF ConfirmBox( SetAppWindow(), "Nochmal versuchen=JA - Programmabbruch=NEIN", ; //+09.05.2018 17:21 "Datei "+dat+" kann nicht ge”ffnet werden!", ; //+09.05.2018 17:20 XBPMB_YESNO, ; XBPMB_QUESTION ) == XBPMB_RET_YES LOOP ELSE QUIT ENDIF save screen clear @ 3,8 to 13,65 double @ 5,10 say "Die Datenbank wird zur Zeit von einem anderen Benutzer" @ 6,10 say "des Netzwerkes ge„ndert." @ 7,10 say "Die Benutzung ist daher zur Zeit nicht m”glich." @ 9,10 say "Drcken Sie bitte auf die '1'-Taste," @10,10 say "wenn der Zugriff erneut versucht werden soll." @11,10 say "Die '#'-Taste bricht das Programm ab !!" @15,10 say "Datenbankname = " + dat SET CONS OFF WAIT "Drcken Sie " to schleife SET CONS ON if schleife <> "#" schleife = "1" // "1" in der Netzwerkversion ///////// endif if schleife # '1' stor 1 to upfehl @ 20,10 say "Das Programm wurde durch Sie abgebrochen." @ 21,10 say "Sie k”nnen es sofort wieder starten." exit endif **--> clear stor 0 to upfehl restore screen endif enddo // endif if upfehl <>0 // einmal fr alle // quit endif RETURN upfehl ********************************************************************* FUNCTION Satzsperren // if upfunk = 2 && 2 = Satzsperren stor 0 to upfehl stor '1' to schleife do while schleife = '1' // if REC_LOCK(.5) if REC_LOCK(5) // 14.09.2006 stor 0 to upfehl stor '2' to schleife else IF ConfirmBox( SetAppWindow(), "Weitermachen?", ; "Datensatz ist schon gesperrt", ; XBPMB_YESNO, ; XBPMB_QUESTION ) == XBPMB_RET_YES LOOP ELSE QUIT ENDIF save screen clear @ 3,8 to 13,65 double @ 5,10 say "Der angeforderte Datensatz wird zur Zeit " @ 6,10 say "von einem anderen Benutzer des Netzwerkes ge„ndert." @ 7,10 say "Die Benutzung ist daher z. Zt. fr Sie nicht m”glich." @ 9,10 say "Drcken Sie bitte auf die '1'-Taste," @10,10 say "wenn der Zugriff erneut versucht werden soll." @11,10 say "Die '#'-Taste bricht das Programm ab !!" @15,10 say "Datensatz = " + str(recno()) SET CONS OFF WAIT to schleife SET CONS ON if schleife <> "#" schleife = "1" // "1" in der Netzwerkversion ///////// endif if schleife # '1' stor 1 to upfehl @ 20,10 say "Das Programm wurde durch Sie abgebrochen." @ 21,10 say "Sie k”nnen es sofort wieder starten." exit endif *--> clear stor 0 to upfehl restore screen endif enddo // endif if upfehl <>0 // einmal fr alle // quit endif RETURN upfehl ************************************************************************ FUNCTION Satzentsperren Dbunlock() RETURN (.T.) ************************************************************************ FUNCTION Satzappend // if upfunk = 3 && 3 = einfgen stor 0 to upfehl stor '1' to schleife do while schleife = '1' // if ADD_REC(.5) if ADD_REC(5) // 14.09.2006 stor 0 to upfehl stor '2' to schleife else IF ConfirmBox( SetAppWindow(), "Weitermachen?", ; "Datensatz ist schon gesperrt", ; XBPMB_YESNO, ; XBPMB_QUESTION ) == XBPMB_RET_YES LOOP ELSE QUIT ENDIF save screen clear @ 3,8 to 13,65 double @ 5,10 say "Der angeforderte Datensatz wird zur Zeit " @ 6,10 say "von einem anderen Benutzer des Netzwerkes eingefgt." @ 7,10 say "Eine Einfgung ist daher z. Zt. fr Sie nicht m”glich." @ 9,10 say "Drcken Sie bitte auf die '1'-Taste," @10,10 say "wenn der Zugriff erneut versucht werden soll." @11,10 say "Die '#'-Taste bricht das Programm ab !!" @15,10 say "Datensatz = " + str(recno()) SET CONS OFF WAIT to schleife SET CONS ON if schleife <> "#" schleife = "1" // "1" in der Netzwerkversion ///////// endif if schleife # '1' stor 1 to upfehl @ 20,10 say "Das Programm wurde durch Sie abgebrochen." @ 21,10 say "Sie k”nnen es sofort wieder starten." exit endif *--> clear stor 0 to upfehl restore screen endif enddo // endif //endif if upfehl <>0 // einmal fr alle // quit endif RETURN upfehl ****--------------------------------- FUNCTION Net_use PARAMETERS file, ex_use, wait PRIVATE forever forever = (wait = 0) DO WHILE (forever .OR. wait > 0) IF ex_use && exclusive dbUseArea(,, file,,.F.) ELSE dbUseArea(,, file ) && shared ENDIF IF .NOT. NETERR() && USE succeeds RETURN (.T.) ENDIF INKEY(1) && wait 1 second wait = wait - 1 ENDDO RETURN (.F.) && USE fails //////FUNCTION Net_use( file, ex_use, WAIT) ////// LOCAL bError := ErrorBlock( {|e| Break(e) } ) //+09.05.2018 14:12 ////// LOCAL lReturn := .F. ////// PRIVATE forever ////// ////// forever = (wait = 0) ////// DO WHILE (forever .OR. wait > 0) ////// ////// BEGIN SEQUENCE ////// dbUseArea(,, file,,!ex_use) ////// WAIT := 0 ////// lReturn := .T. ////// RECOVER ////// Sleep(100) ////// WAIT = WAIT - 1 ////// IF wait==0 .AND. ConfirmBox( SetAppWindow(), "Nochmal probieren?", ; ////// "Datei "+FILE+" kann nicht ge”ffnet werden.", ; ////// XBPMB_YESNO, ; ////// XBPMB_QUESTION ) == XBPMB_RET_YES ////// WAIT := 5 ////// LOOP ////// ELSEIF WAIT == 0 ////// EXIT ////// ENDIF ////// LOOP ////// END SEQUENCE ////// ENDDO ////// ErrorBlock( bError ) //+09.05.2018 14:13 Fehler-Codeblock zurcksetzen //////RETURN lReturn *****------------------ FUNCTION REC_LOCK PARAMETERS wait PRIVATE forever IF RLOCK() RETURN (.T.) && locked ENDIF forever = (wait = 0) DO WHILE (forever .OR. wait > 0) IF RLOCK() RETURN (.T.) && locked ENDIF INKEY(.5) && wait 1/2 second wait = wait - .5 ENDDO RETURN (.F.) && not locked * End - REC_LOCK ******--------------------------------- * ADD_REC function * * Returns true if record appended. The new record is current * and locked. * Pass the following parameter * 1. Numeric - seconds to wait (0 = wait forever) * FUNCTION ADD_REC PARAMETERS wait PRIVATE forever DbAppend(1) //+17.11.2018 20:53 1, damit alle anderen Satzsperren so bleiben IF .NOT. NETERR() RETURN (.T.) ENDIF forever = (wait = 0) DO WHILE (forever .OR. wait > 0) DBAPPEND(1) //+17.11.2018 20:53 1, damit alle anderen Satzsperren so bleiben IF .NOT. NETERR() RETURN .T. ENDIF INKEY(.5) && wait 1/2 second wait = wait - .5 ENDDO RETURN (.F.) && not locked //------------------------------------------------------------------------- FUNCTION __SETFUNCTION( nFKey, cString ) nFKey := IIf( nFKey==1, 28, 1-nFKey ) RETURN SetKey( nFKey, { || _Keyboard( cString ) } ) //------------------------------------------------------------------------- FUNCTION BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; nChoice, cBoxChars, cMenuColor ) LOCAL i LOCAL nMenuRow LOCAL nMenuCol LOCAL cOldColor LOCAL nLength := 0 LOCAL lArrNotChar := .F. // Wird kein Array bergeben, oder ist Array zu groá fr Bildschirm , // dann NIL zurckgeben. IF aMenuItems == NIL .OR. LEN( aMenuItems ) > ( MAXROW() - 3 ) RETURN ( NIL ) // *NOTE* ENDIF // šberprfung eines optionalen Startelementes (nChoice) nChoice := IF( nChoice == NIL, 1, nChoice ) // Suchen des l„ngsten Arrayelementes fr das Menuprompt // und šberprfung des Datentypes des Arrays ASCAN( aMenuItems, { |str| nLength := MAX( nLength, LEN( str ) ), ; lArrNotChar := ( VALTYPE( str ) <> "C" ) } ) // Rckgabe von NIL, wenn ein Element nicht vom Datentyp Character ist IF lArrNotChar RETURN ( NIL ) ENDIF // Initialisierung der 4 Eck-Koordinaten nTop := IF( nTop == NIL, 0, nTop ) nLeft := IF( nLeft == NIL, 0, nLeft ) nBottom := MIN( MAX( nTop + LEN( aMenuItems ) + 2,; IF( nBottom == NIL, MAXROW(), nBottom ) ), MAXROW() ) nRight := MIN( MAX( nLeft + nLength + 3, ; IF( nRight == NIL, MAXCOL(), nRight ) ), MAXCOL() ) // šberprfen ob Rahmen-Zeichen und Farbeinstellungen bergeben wurden cBoxChars := IF( cBoxChars == NIL, "+-+|+-+|", cBoxChars ) cMenuColor := IF( cMenuColor == NIL, SETCOLOR(), cMenuColor ) // Sichern der alten Farbeinstellung und setzen der neuen Farbe cOldColor := SETCOLOR( cMenuColor ) // Zeichnen der Box @ nTop, nLeft CLEAR TO nBottom, nRight @ nTop, nLeft, nBottom, nRight BOX cBoxChars //** MenuTitel zentriert (ak): IF cMenuTitle != NIL @ nTop, nLeft + int((nRight-nLeft-len(cMenuTitle))/2) SAY "[" + cMenuTitle + "]" ENDIF // Zeichnen des Schattens BoxShadow( nTop, nLeft, nBottom, nRight ) // Ermitteln der Zeile und Spalte fr das erste Menuprompt // damit das Menu zentriert wird nMenuRow := nTop + INT( (( nBottom - nTop ) - LEN( aMenuItems )) / 2 ) + 1 nMenuCol := nLeft + INT( (( nRight - nLeft ) - nLength ) / 2 ) + 1 // Aktivieren des Menus FOR i := 1 TO LEN( aMenuItems ) @ nMenuRow++, nMenuCol ; PROMPT LEFT( aMenuItems[i] + SPACE(nLength), nLength ) NEXT // @22,30 say nChoice MENU TO nChoice // @22,10 say nChoice // Alte Farbeinstellung wiederherstellen SETCOLOR( cOldColor ) if nChoice=0 nChoice=19 endif RETURN nChoice /*** * * BoxShadow( , , , ) --> NIL * * Zeichnet eine Schattenbox * */ FUNCTION BoxShadow( nTop, nLeft, nBottom, nRight ) LOCAL nShadTop LOCAL nShadLeft LOCAL nShadBottom LOCAL nShadRight nShadTop := nShadBottom := MIN( nBottom + 1, MAXROW() ) nShadLeft := nLeft + 1 nShadRight := MIN( nRight + 1, MAXCOL() ) // Der Eindruck eines Schattens wird durch das Ersetzen des aktuellen // Farbattributs durch "" ( CHR(7), Grau auf Schwarz ) entlang dem // rechten und unterem Rand der Box erzeugt. RESTSCREEN( nShadTop, nShadLeft, nShadBottom, nShadRight, ; TRANSFORM( SAVESCREEN(nShadTop, nShadLeft, nShadBottom, nShadRight), ; REPLICATE("X", nShadRight - nShadLeft + 1 ) ) ) nShadTop := nTop + 1 nShadLeft := nShadRight := MIN( nRight + 1, MAXCOL() ) nShadBottom := nBottom RESTSCREEN( nShadTop, nShadLeft, nShadBottom, nShadRight, ; TRANSFORM( SAVESCREEN(nShadTop, nShadLeft, nShadBottom, nShadRight), ; REPLICATE("X", nShadBottom - nShadTop + 1 ) ) ) RETURN ( NIL ) ///=======================================================********//// //----------------------------------------------------------------------- FUNCTION AdMenu() aMenuItems := { "1 Ansehen ", ; "2 Drucken ", ; "- ", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 20 ; nBottom := 15 ; nRight := 60 cMenuTitle := " Bitte Funktion eingeben : " cBoxChars := " " ; cMenuColor := "N/W" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) cFunk := IIF(nChoice<4, str(nChoice,1,0), "!" ) RETURN (cFunk) //----------------------------------------------------------------------- FUNCTION AalMenu() aMenuItems := { "1 Anlegen ", ; "2 Ansehen / Žndern ", ; "L L”schen ", ; "- ", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 20 ; nBottom := 15 ; nRight := 60 cMenuTitle := " Bitte Funktion eingeben : " cBoxChars := " " ; cMenuColor := "N/W" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) cFunk := IIF(nChoice<5, str(nChoice,1,0), "!" ) RETURN (cFunk) //----------------------------------------------------------------------- FUNCTION AalnMenu() aMenuItems := { "1 Anlegen (alt) ", ; "2 Ansehen / Žndern (alt)", ; "L L”schen (alt) ", ; "N Neue Maske ", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 20 ; nBottom := 15 ; nRight := 60 cMenuTitle := " Bitte Funktion eingeben : " cBoxChars := " " ; cMenuColor := "N/W" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) cFunk := IIF(nChoice<5, str(nChoice,1,0), "!" ) RETURN (cFunk) //----------------------------------------------------------------------- FUNCTION AaluMenu() aMenuItems := { "1 Anlegen ", ; "2 Ansehen / Žndern ", ; "L L”schen ", ; "4 šbersicht ", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 20 ; nBottom := 15 ; nRight := 60 cMenuTitle := " Bitte Funktion eingeben : " cBoxChars := " " ; cMenuColor := "N/W" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) cFunk := IIF(nChoice<5, str(nChoice,1,0), "!" ) RETURN (cFunk) //----------------------------------------------------------------------- FUNCTION AaludMenu() aMenuItems := { "1 Anlegen ", ; "2 Ansehen / Žndern ", ; "L L”schen ", ; "4 šbersicht und Drucken", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 20 ; nBottom := 15 ; nRight := 60 cMenuTitle := " Bitte Funktion eingeben : " cBoxChars := " " ; cMenuColor := "N/W" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) cFunk := IIF(nChoice<5, str(nChoice,1,0), "!" ) RETURN (cFunk) //----------------------------------------------------------------------- //----------------------------------------------------------------------- //////FUNCTION Drucker_aus() ////// set printer to dummy.txt ////// set printer to ////// Set( _SET_DEVICE, "SCREEN" ) //////RETURN .T. ////////----------------------------------------------------------------------- //////FUNCTION Drucker_an(nP) //////Do while .not. IsPrinter() ////// IF ALERT( "Drucker ist nicht bereit", ; ////// {"Wiederholen", "Abbrechen"}, ; ////// "W+/R,BG+/N,,,W/R" ) ==2 ////// Set( _SET_PRINTFILE, "LPT1" ) ////// funk="!" ////// RETURN (.F.) ////// ENDIF //////ENDDO //////SetPrc(0,0) //////if nP=1 ////// Set(_SET_PRINTER, .T. ) //////else ////// Set( _SET_DEVICE, "PRINTER" ) //////// cDruckerName := DruckerName() + "." ////// Set( _SET_PRINTFILE, "LPT1" ) //////endif //////RETURN (.T.) ////////----------------------------------------------------------------------- //////FUNCTION Drucker_anW(nP) //////Do while .not. IsPrinter() ////// IF ConfirmBox( oCB, "Noch einmal versuchen?", ; ////// "Drucker nicht bereit", ; ////// XBPMB_YESNO, ; ////// XBPMB_QUESTION ) == XBPMB_RET_NO ////// Set( _SET_PRINTFILE, "LPT1" ) ////// funk="!" ////// RETURN (.F.) ////// ENDIF //////ENDDO //////SetPrc(0,0) //////if nP=1 ////// Set(_SET_PRINTER, .T. ) //////else ////// Set( _SET_DEVICE, "PRINTER" ) //////// cDruckerName := DruckerName() //////// Set( _SET_PRINTFILE, cDruckerName + "." ) ////// Set( _SET_PRINTFILE, "LPT1" ) //////endif //////RETURN (.T.) ////////----------------------------------------------------------------------- ////// FUNCTION DruckerName() ////// LOCAL aDrucker, cDruckerName, oDC := XbpPrinter():New() ////// oDC:Create( ) ////// aDrucker := oDC:list() // wird nur fr Debugging-Zwecke gebraucht ////// IF oDC <> NIL ////// cDruckerName := oDC:devName ////// oDC:destroy() ////// ENDIF ////// RETURN cDruckerName ////////----------------------------------------------------------------------- //----------------------------------------------------------------------- //----------------------------------------------------------------------- //----------------------------------------------------------------------- //----------------------------------------------------------------------- //----------------------------------------------------------------------- FUNCTION Drucker_aus() IF cLPT = "LPTA" .and. !Empty( oPrinterPS ) oPrinterPS:device():endDoc() DestroyDevice( oPrinterPS ) Set( _SET_DEVICE, "SCREEN" ) cLPTSCR := "S" oPrinterPS := NIL ELSE IF lSeiteLeer == .F. // 04.08.2005: wenn schon was auf der Seite steht NeueSeite() // weil sonst die Seite nicht heraus kommt. ENDIF set printer to SET PRINTER OFF SET CONSOLE ON Set( _SET_DEVICE, "SCREEN" ) ENDIF cBriefKopf := "n" lSeiteLeer := .T. // 04.08.2005: jetzt ist die Seite per Definition leer RETURN .T. FUNCTION Drucker_an(nP) IF cLPT = "LPTA" IF nP=1 Set(_SET_PRINTER, .T. ) SET CONSOLE OFF ELSE cLPTSCR := "P" oPrinterPS := PrinterPS() oFont := XbpFont():new( oPrinterPS ) oPrinterPS:device():startdoc() ENDIF ELSE DO WHILE .not. IsPrinter() IF ALERT( "Drucker ist nicht bereit", ; {"Wiederholen", "Abbrechen"}, ; "W+/R,BG+/N,,,W/R" ) ==2 funk="!" RETURN (.F.) ENDIF ENDDO SetPrc(0,0) IF nP=1 Set(_SET_PRINTER, .T. ) SET CONSOLE OFF ELSE Set( _SET_DEVICE, "PRINTER" ) Set( _SET_PRINTFILE, "LPT1" ) ENDIF ENDIF lSeiteLeer := .T. // 04.08.2005 zun„chst ist die Seite noch leer RETURN .T. FUNCTION Drucker_anW(nP) LOCAL oBitmap, aBitSize, aBitRect // "nOrientierung := 1" (oder := 2) muss vor "set device to printw" stehen nOrientierung := IIf( IsMemVar("nOrientierung"), nOrientierung, NIL ) // 27.10.2005 IF cLPT = "LPTA" IF nP=1 Set(_SET_PRINTER, .T. ) SET CONSOLE OFF ELSE cLPTSCR := "P" oPrinterPS := PrinterPS( , nOrientierung) // 27.10.2005 Umschaltung direkt "vor Ort" oFont := XbpFont():new( oPrinterPS ) IF cBriefKopf != "n" cBriefkopf := IIf("."$cBriefKopf,cBriefKopf,cBriefKopf+".BMP") oBitmap := XbpBitmap():new():create( oPrinterPS ) aBitSize := oPrinterPS:DEVICE():paperSize() aBitRect := { 0, 0, aBitSize[1], aBitSize[2] } oBitmap:loadFile( cDatver+cBriefKopf ) // Bitmap laden ENDIF oPrinterPS:device():startdoc() IF cBriefKopf != "n" oBitmap:draw( oPrinterPS, aBitRect ) ENDIF ENDIF ELSE SetPrc(0,0) IF nP=1 Set(_SET_PRINTER, .T. ) SET CONSOLE OFF ELSE Set( _SET_DEVICE, "PRINTER" ) Set( _SET_PRINTFILE, "LPT1" ) ENDIF ENDIF lSeiteLeer := .T. // 04.08.2005 zun„chst ist die Seite noch leer RETURN .T. FUNCTION Sage( nRow, nCol, cSay ) LOCAL aPenPos IF cLPTSCR = "S" .OR. cLPT != "LPTA" DevPos( nRow, nCol ) DevOut( cSay ) ELSE nZei := nRow nSpa := nCol cText := IIf( ValType(cSay)="C", cSay, IIf(ValType(cSay)="N",Str(cSay), IIf(ValType(cSay)="D",DtoC(cSay),))) // nPOffX := nPOffY := 0 aPenPos := FdrG( oPrinterPS, oFont, cText, 1, aFonts ) lSeiteLeer := .F. // 04.08.200 es steht was auf der Seite ENDIF RETURN aPenPos //FUNCTION NeueSeite() // IF cLPT = "LPTA" // oPrinterPS:device():newPage() // ELSE // _Eject() // ENDIF //RETURN .T. FUNCTION NeueSeite() IF lSeiteLeer == .F. // 23.10.2003: damit eject keine leeren Seiten bef”rdert IF cLPT = "LPTA" .AND. !Empty(oPrinterPS) oPrinterPS:device():newPage() ELSEIF cLPT = "LPT1" _Eject() ENDIF ENDIF lSeiteLeer := .T. // 21.10.2003 Seite ist leer RETURN .T. FUNCTION PrinterPS( cPrinterObjectName, nOrientierung ) LOCAL oPS, oDC := XbpPrinter():New() // stellt auf Portrait-Mode, wenn nicht anders bestimmt: nOrientierung := IIf( Empty(nOrientierung), XBPPRN_ORIENT_PORTRAIT, nOrientierung ) // 27.10.2005 oDC:create( cPrinterObjectName ) oDC:setOrientation( nOrientierung ) // 27.10.2005 oPS := XbpPresSpace():New() oPS:create( oDC, oDC:papersize(), GRA_PU_LOMETRIC ) RETURN oPS PROCEDURE DestroyDevice( oPS ) LOCAL oDC := oPS:device() IF oDC <> NIL oPS:configure() oDC:destroy() ENDIF RETURN //----------------------------------------------------------------------- /* aus dem Programm login_g * Firmenlogo anzeigen * * - XbpStatic wird verwendet um eine Bitmap mit einem Firmenlogo anzuzeigen * * - Die Bitmap ist 600 x200 Pixel groá und hat die numerische ID 2001 * Die ID ist in einer RC datei definiert * * - aSize = Gr”áe der "drawingArea" eines XbpCrt Fensters * */ FUNCTION DisplayLogo( cLn ) // LOCAL oLogo, aPos, aSize, drawingArea := SetAppWindow():drawingArea LOCAL oDlg, oLogo, aPos, aSize, drawingArea , nEvent, bkeyboard LOCAL oXbp, mp1, mp2, lStart LOCAL aSizeDesktop := AppDesktop():currentSize() LOCAL nBSb := aSizeDesktop[1] , nV := nBSb/800 LOCAL nBSh := aSizeDesktop[2] oDlg := XbpDialog():new( AppDesktop(), SetAppWindow(), {50,50}, {nBSb-100,nBSh-100}, , .F.) // oDlg := XbpDialog():new( AppDesktop(), , {50,50}, {550,380}, , .F.) oDlg:taskList := .T. oDlg:title := "Das fhrende Bestattungs-Institut im Ruhrgebiet :" oDlg:create() SetAppWindow():clipChildren := .F. SetAppWindow():configure() drawingArea := oDlg:drawingArea bkeyboard := {|nKey,x,obj| Qout(str(nKey,6,0)), cLn := chr(nKey), ; IIF( nKey==108 .or. nkey==110, lExit := .T., ; lExit := .F. ) } aSize := drawingArea:currentSize() aPos := { 0, 50*nV } // aPos := { 30,30 } oLogo := XbpStatic():new( drawingArea,,aPos,{aSize[1],aSize[2]-aPos[2]}) ////// oLogo:type := XBPSTATIC_TYPE_BITMAP ////// oLogo:caption := 2001 oLogo:create() ////// oLogo:show() oLogo:cargo := BitView():new( oLogo ):CREATE() oLogo:cargo:load( cDatver+"KSO.BMP" ) drawingArea:paint := {|x,y,obj| x:=obj:currentSize(), ; oLogo:cargo:DISPLAY( {0,0,x[1],x[2]} ) } oXbp := XbpPushButton():new( drawingArea, , {10*nV,10*nV}, {aSize[1]/2-20*nV,30*nV} ) oXbp:caption := "~Lokaler Betrieb (direkt mit groáem ïLï / šbertragung mit groáem 'O')" oXbp:keyboard := bKeyboard oXbp:preSelect := .T. oXbP:group := XBP_BEGIN_GROUP oXbp:create() oXbp:activate := {|| cLn := "l", lStart := .T. } oXbp := XbpPushButton():new( drawingArea, , {aSize[1]/2+10*nV,10*nV}, {aSize[1]/2-20*nV,30*nV} ) oXbp:caption := "~Netzwerk-Betrieb (direkt mit groáem ïNï)" oXbp:keyboard := bKeyboard oXbP:group := XBP_END_GROUP oXbp:create() oXbp:activate := {|| cLn := "n", lStart := .T. } oDlg:show() oDlg:setModalState( XBP_DISP_APPMODAL ) // SetAppWindow():disable() // SetAppFocus( oID ) lStart := .F. DO WHILE ! lStart nEvent := AppEvent( @mp1, @mp2, @oXbp ) IF nEvent == xbeP_Keyboard DO CASE CASE mp1 == Asc("L") .OR. mp1 == Asc("N") .OR. mp1 == Asc("l") .OR. mp1 == Asc("n") .OR. mp1 == Asc("O") //12.01.2025 12:01 geREMt: .OR. mp1 == Asc("T") cLn := Chr(mp1) lStart := .T. //12.01.2025 12:26 folgende Zeilen geREMt (Schriftgr”áe l„sst sich ja eh mit Strg-G/K einstellen) CASE mp1 == Asc("7") //+26.11.2019 09:09 cBFont in EUROV - wirkt hier also nicht mehr cBFont := "7.Arial" CASE mp1 == Asc("8") cBFont := "8.Arial" CASE mp1 == Asc("9") cBFont := "9.Arial" CASE mp1 == Asc("a") cBFont := "10.Arial" CASE mp1 == Asc("b") cBFont := "11.Arial" CASE mp1 == Asc("c") cBFont := "12.Arial" CASE mp1 == Asc("0") cBFont := NIL ENDCASE ENDIF oXbp:handleEvent( nEvent, mp1, mp2 ) ENDDO oDlg:setModalState( XBP_DISP_MODELESS ) oDlg:destroy() RETURN cLn //================================================================ /* * Klasse zum Anzeigen von Bitmaps oder Metadateien */ CLASS BitView FROM XbpStatic PROTECTED: VAR oFrame VAR oCanvas VAR oPS VAR oBitmap VAR oMetafile VAR nMode EXPORTED: VAR autoScale VAR file METHOD init, create, load, display ENDCLASS /* * Objekt initialisieren. Self ist Parent fr zwei XbpStatic Objekte */ METHOD BitView:init( oParent, oOwner, aPos, aSize, aPresParam, lVisible ) ////// ::xbpStatic:init( oParent, oOwner, aPos, aSize, aPresParam, lVisible ) ////// ::xbpStatic:type := XBPSTATIC_TYPE_RAISEDRECT ////// ////// ::oFrame := XbpStatic():new( self ) ////// ::oFrame:type := XBPSTATIC_TYPE_RECESSEDRECT ////// ::oCanvas := XbpStatic():new( self ) ::oCanvas := oParent ::autoScale := .T. ::nMode := 0 ::oPS := XbpPresSpace():new() RETURN self /* * Systemresourcen anfordern. Self ist der „uáere Rahmen, ::oFrame ist der * innere Rahmen und in ::oCanvas wird das Bild gezeichnet */ METHOD BitView:create( oParent, oOwner, aPos, aSize, aPresParam, lVisible ) LOCAL aAttr[ GRA_AA_COUNT ] ////// ::xbpStatic:create( oParent, oOwner, aPos, aSize, aPresParam, lVisible ) ////// aSize := ::currentSize() ////// aSize[1] -= 8 ////// aSize[2] -= 8 ////// ////// ::oFrame:create(self,, {4,4}, aSize ) ////// ////// aSize[1] -= 2 ////// aSize[2] -= 2 ////// ////// ::oCanvas:create(::oFrame,, {1,1}, aSize ) /* * Presentation Space mit dem Device Kontext von XbpStatic verbinden */ ::oPS:create( ::oCanvas:winDevice() ) aAttr[ GRA_AA_COLOR ] := GRA_CLR_BACKGROUND ::oPS:setAttrArea( aAttr ) ::oCanvas:paint := {| aClip | ::display( aClip ) } RETURN self /* * Bilddatei laden */ METHOD BitView:load( cFile ) LOCAL lSuccess := .F. IF Valtype( cFile ) <> "C" .OR. ! File( cFile ) RETURN lSuccess ENDIF ::nMode := 0 ::file := "" IF ".BMP" $ Upper( cFile ) .OR. ; ".GIF" $ Upper( cFile ) .OR. ; ".JPG" $ Upper( cFile ) .OR. ; ".PNG" $ Upper( cFile ) IF ::oBitmap == NIL ::oBitmap := XbpBitmap():New():create( ::oPS ) ENDIF IF ( lSuccess := ::oBitmap:loadFile( cFile ) ) ::nMode := 1 ::file := cFile ENDIF ELSEIF ".EMF" $ Upper( cFile ) .OR. ".MET" $ Upper( cFile ) IF ::oMetafile == NIL ::oMetafile := XbpMetafile():New():create() ENDIF IF ( lSuccess := ::oMetafile:load( cFile ) ) ::nMode := 2 ::file := cFile ENDIF ENDIF RETURN lSuccess /* * Bilddatei anzeigen */ METHOD BitView:display( aClip ) LOCAL lSuccess := .F. LOCAL aSize := ::oCanvas:currentSize() LOCAL aTarget, aSource, nAspect /* * Clip Bereich vorbereiten */ DEFAULT aClip TO { 1, 1, aSize[1]-1, aSize[2]-1 } GraPathBegin( ::oPS ) GraBox( ::oPS, { aClip[1]-1, aClip[2]-1 }, { aClip[3]+1, aClip[4]+1 }, GRA_OUTLINE ) GraPathEnd( ::oPS ) GraPathClip( ::oPS, .T. ) GraBox( ::oPS, {0,0}, aSize, GRA_FILL ) DO CASE CASE ::nMode == 1 /* * Eine Bitmap Datei ist geladen */ aSource := {0,0,::oBitmap:xSize,::oBitmap:ySize} aTarget := {1,1,aSize[1]-2,aSize[2]-2} IF ::autoScale /* * Bitmap wird auf die Gr”áe von ::oCanvas skaliert */ nAspect := aSource[3] / aSource[4] IF nAspect > 1 aTarget[4] := aTarget[3] / nAspect ELSE aTarget[3] := aTarget[4] * nAspect ENDIF ELSE aTarget[3] := aSource[3] aTarget[4] := aSource[4] ENDIF /* * Bitmap in ::oCanvas horizontal oder vertikal zentrieren */ IF aTarget[3] < aSize[1]-2 nAspect := ( aSize[1]-2-aTarget[3] ) / 2 aTarget[1] += nAspect aTarget[3] += nAspect ENDIF IF aTarget[4] < aSize[2]-2 nAspect := ( aSize[2]-2-aTarget[4] ) / 2 aTarget[2] += nAspect aTarget[4] += nAspect ENDIF ::oBitmap:draw( ::oPS, aTarget, aSource, , GRA_BLT_BBO_IGNORE ) Sleep(1) CASE ::nMode == 2 /* * Eine Metadatei ist geladen */ IF ::autoScale ::oMetafile:draw( ::oPS, XBPMETA_DRAW_SCALE ) ELSE ::oMetafile:draw( ::oPS, XBPMETA_DRAW_DEFAULT ) ENDIF ENDCASE GraPathClip( ::oPS, .F. ) RETURN lSuccess PROCEDURE RepTBest() LOCAL aData1, aData2, aDataD IF File( "C:\HDBE\REP\" + "tbest.dbf" ) SELECT 1 USE c:\hdbe\rep\tbest COPY STRUCTURE TO c:\hdbe\rep\tbrep SELECT 2 USE c:\hdbe\rep\tbrep EXCLUSIVE SELECT 1 DO WHILE !Eof() aData1 := Satzget( 1, RecNo() ) DbSkip() aData2 := Satzget( 1, RecNo() ) DbSkip() aDataD := Satzget( 1, RecNo() ) SELECT 2 APPEND BLANK 2->auftrnr := aData2[1] APPEND BLANK Satzput( 2, RecNo(), aData2, "" ) APPEND BLANK Satzput( 2, RecNo(), aData2, "" ) SELECT 1 DbSkip() ENDDO USE SELECT 2 USE WAIT " Es ist vollbracht " QUIT ENDIF RETURN #define DRIVE_NOT_READY 21 // Fehlercode ******************************* FUNCTION IsDriveReady( cDrive ) // Ist Laufwerk bereit ? LOCAL nReturn := 0 LOCAL cOldDrive := CurDrive() // Aktuelles Laufwerk merken LOCAL bError := ErrorBlock( {|e| Break(e) } ) LOCAL oError BEGIN SEQUENCE CurDrive( cDrive ) // Laufwerk „ndern CurDir( cDrive ) // Verzeichnis abfragen RECOVER USING oError // Fehler ist aufgetreten IF oError:osCode == DRIVE_NOT_READY nReturn := -1 // Laufwerk nicht bereit ELSE nReturn := -2 // Laufwerk nicht vorhanden ENDIF ENDSEQUENCE ErrorBlock( bError ) // Fehler-Codeblock und CurDrive( cOldDrive ) // Laufwerk zurcksetzen RETURN nReturn /* * Feststellen, ob alle Dateien im Array 'aFiles' vorhanden sind */ FUNCTION AllFilesExist( aFiles, cDir ) LOCAL lExist := .T., i:=0, imax := Len(aFiles) DEFAULT cDir TO "" DO WHILE ++i <= imax .AND. lExist lExist := File( cDir + aFiles[i] ) ENDDO RETURN lExist ///////////////////////////////////////////////////////////////////////////////////// FUNCTION MagicHelpLabel() RETURN .F. FUNCTION ClickCalc() RETURN .F. FUNCTION ClickDate() RETURN .F. FUNCTION Komplement() RETURN .F. FUNCTION BMPManip() RETURN .F. FUNCTION ConvToAnsiCPAK() RETURN .F. FUNCTION ConvToOEMCPAK() RETURN .F. FUNCTION BDVideo() RETURN .F. FUNCTION ORTohnePLZ( cPlzOrt ) //18.03.2025 15:19 aus DbDruSysw.prg RETURN IIf( Val( cPlzOrt ) == 0, AllTrim(cPlzOrt), AllTrim( SubStr(cPlzOrt,6))) //+13.10.2008 14:02 FUNCTION DruckerWahl() RETURN .F. FUNCTION XBPPreview() RETURN .F. FUNCTION Vorschau_Ausgabe() RETURN .F. FUNCTION DirWahl() RETURN .F. FUNCTION FileWahl() RETURN .F. FUNCTION ImageView() RETURN .F. FUNCTION Manipulate() RETURN .F. //02.01.2024 12:51 FUNCTION ProgressBar() // RETURN .F. FUNCTION MComboBox() RETURN .F. FUNCTION WIN_CLIP_FILE() RETURN .F. //+14.06.2009 15:34 speziell fr Array-Browser: FUNCTION KWert(cW) cW := IIf(ValType(cW)=="C", ; //+04.05.2010 12:51 IIf( "."$cW, Stuff(cW,At(".",cW),1,""), cW ), ; IIf(ValType(cW)=="N",Str(cW),"0")) //+ 1000er-Punkt wird gel”scht RETURN Val( IIf( ","$cW, Stuff(cW,RAt(",",cW),1,"."), cW) ) //+ Komma wird Punkt FUNCTION StrL(nAuf,nL,nD) // 13.04.2007 22:11 mit Picture, aber linksbndig DEFAULT nD TO 2 RETURN LTrim(IIf(cKomma=",".AND.nD!=0, Transform(nAuf,cPicture), Str(nAuf,nL,nD) )) //13.04.2007 22:22; FUNCTION StrP(nAuf,nL,nD) // 13.04.2007 21:59 mit Picture und fhrenden Leerzeichen RETURN IIf(cKomma=",",Transform(nAuf,cPicture), Str(nAuf,nL,nD)) //13.04.2007 22:23; // nachgestelltes EUR: FUNCTION StrPE(nAuf,nL,nD) // 13.04.2007 21:59 mit Picture und fhrenden Leerzeichen RETURN IIf(cKomma=",",Transform(nAuf,cPicture)+" "+w_g, Str(nAuf,nL,nD)+" "+w_g) //13.04.2007 22:23; // vorangestelltes EUR: FUNCTION StrEP(nAuf,nL,nD) // 13.04.2007 21:59 mit Picture und fhrenden Leerzeichen RETURN IIf(cKomma=",",w_g+" "+Transform(nAuf,cPicture), w_g+" "+Str(nAuf,nL,nD)) //13.04.2007 22:23; FUNCTION StrS(nAuf,nL,nD) // 26.08.2005 MengX: alle mit neuer Rechnung: StrZero RETURN IIf(nL=6 .OR. Upper(AppName())!="MENGX.EXE", StrZERO(nAuf,nL,nD), ; Trim(1->ver_ort)+SubStr(StrZero(nAuf,nL,nD),2,6) ) // VO +6 Stellen! FUNCTION StrU(nAuf,nL,nD) // 03.06.2007 14:10 fr Uhrzeit-Format: "10.30 Uhr" DEFAULT nL TO 5, nD TO 2 RETURN IIf(nAuf == 0.00,"",Str(nAuf,nL,nD)+" Uhr") FUNCTION StrV(nAuf,nL,nD) // 26.08.2005 MengX: alle mit neuer Rechnung: StrZero RETURN IIf(nL=6 .OR. Upper(AppName())!="MENGX.EXE", StrZERO(nAuf,nL,nD), ; Trim(1->ver_ort)+" "+StrZero(nAuf,nL,nD) ) // VO +6 Stellen! FUNCTION StrX(nAuf,nL,nD) // 26.08.2005 alle mit neuer Rechnung: StrZero RETURN StrZERO(nAuf,nL,nD) //+08.01.2009 16:14 absolute Position eines Xbparts auf dem DeskTop FUNCTION AbsolutePos(oXbp) LOCAL aPos := oXbp:currentPos() DO WHILE oXbp:setParent() != AppDeskTop() oXbp := oXbp:setParent() aPos[1] += oXbp:currentPos()[1] aPos[2] += oXbp:currentPos()[2] ENDDO RETURN aPos // ermittelt den Lw-Buchstaben und/oder das komplette Verzeichnis cTDrive eines angeschlossenen Sticks FUNCTION TStickDrive(cTDrive) //REM 09.11.2025 11:07 cTDrive ist z.B. T:\HDBE\E\ LOCAL nDrive, n:=0 //23.07.2023 18:38 FOR nDrive := 83 TO 68 STEP -1 // Chr(nDrive) = "S" ... "D" FOR nDrive := 76 TO 68 STEP -1 // Chr(nDrive) = "L" ... "D" IF IsDriveReady(Chr(nDrive)) = 0 // REM 09.11.2025 11:20 '0' heiát: Laufwerk ist bereit // wenn das Laufwerk existiert: IF FExists( Chr(nDrive)+SubStr(cTDrive,2)+"\OB", "D" ) // wenn das Verzeichnis existiert: cTDrive := Chr(nDrive)+SubStr(cTDrive,2) EXIT ELSE IF Alert("Neuer Stick? Ist der Laufwerk-Buchstabe "+Chr(nDrive)+" richtig?;"+; "Soll hier das šbertragungsverzeichnis erstellt werden:"+SubStr(cTdrive,8)+"?", ; {"ja","nein -> abbrechen"}) == 1 // Verzeichnis neu erstellen: RunShell( "/C MD "+Chr(nDrive)+SubStr(cTDrive,2)+"\OB",, .T. ) sleep(100) IF ++n <= 1 // mit demselben Laufwerk noch einmal versuchen nDrive++ ELSE // beim zweiten Mal ein Laufwerk weiter gehen n := 0 ENDIF LOOP ENDIF ENDIF ENDIF NEXT // Abfrage, wenn kein USB-Stick gefunden wurde: IF nDrive < 68 //nur fr KSOXTF.exe msgBox("Kein USB-Stick angeschlossen!?") ELSEIF ValType(cTDrive) == "C" RETURN {nDrive,cTDrive} ELSE RETURN nDrive ENDIF RETURN .F. PROCEDURE BestIndex() Sleep(1000) SELECT 31 USE best INDEX ON BERATER TO C:\HDBE\btemp_bi USE //+31.10.2018 18:30 geREMt BREAK() RETURN // // //02.05.2017 14:12 // LapTops mit Win10pro: // RX8XK-N4Y8X-QFXQF-JG3KV-MBH82 / LAPTOP-ICT5P7D // HDPNP-GJ9KJ-4Y3H2-7DQHJ-VH7CP // FUNCTION RADIO() RETURN .F. FUNCTION STAPELVEINGABE() RETURN .F. FUNCTION ADRESSBRIEF() RETURN .F. FUNCTION TERMINEINGABE() RETURN .F. FUNCTION SERIENEINGABE() RETURN .F. Function ARTIKELEINGABE() RETURN .F. Function FORMULARVERWALTUNG() RETURN .F. Function VERSEINGABE() RETURN .F. Function RECH3EINGABE() RETURN .F. Function RECH5EINGABE() RETURN .F. FUNCTION STAPELEINGABE() RETURN .F. Function ADRESSEINGABE() RETURN .F. Function AUFTRKONTROLLE() RETURN .F. Function AUFTRKONTROLLE_2() RETURN .F. FUNCTION KKRECH() RETURN .F. Function BSEINGABE() RETURN .F. FUNCTION BILD() RETURN .F. Function INEUX() RETURN .F. Function TERMINE() RETURN .F. // diese Funktion ist in KSOX in rechdr1x.prg //25.04.2026 19:31 FUNCTION Wandeln_in_UTF8(cString) LOCAL aUml := {"„","”","","á","Ž","™","š"} LOCAL aUTF8 := {Chr(0xC3)+Chr(0xA4),Chr(0xC3)+Chr(0xB6),Chr(0xC3)+Chr(0xBC),Chr(0xC3)+Chr(0x9F),Chr(0xC3)+Chr(0x84),Chr(0xC3)+Chr(0x96),Chr(0xC3)+Chr(0x9C)} FOR i:=1 TO Len(cString) IF (n := AScan(aUml, cString[i])) > 0 cString := Stuff( cString, i, 1, aUTF8[n]) ++i ENDIF NEXT RETURN cString // diese Funktion ist in KSOX in BRegieMA.prg //25.04.2026 19:33 FUNCTION Anrede(cAnr,lAkG,lArt) LOCAL cString := "" DEFAULT cAnr TO 1->ansp_anr, lAkG TO .T., lArt TO .T. //* lArt = .T. heiát 'HerrN' lAkG := IIf(ValType(lAkG)=="N",IIf(lAkG==0,.F.,.T.),lAkG) //20.03.2024 12:55 lArt := IIf(ValType(lArt)=="N",IIf(lArt==0,.F.,.T.),lArt) //20.03.2024 12:55 IF cAnr = "Herr" .AND. lArt cString := "Herrn " + IIf( lAkG, SubStr(cAnr,At(" ",cAnr)+1), "" ) ELSEIF cAnr = "Herr" .AND. !lArt cString := "Herr " + IIf( lAkG, SubStr(cAnr,At(" ",cAnr)+1), "" ) ELSE cString := SubStr(cAnr,1,At(" ",cAnr)) + IIf( lAkG, SubStr(cAnr,At(" ",cAnr)+1), "" ) ENDIF RETURN cString //25.04.2026 20:39 stammt auch aus BRegieMA.prg //20.03.2024 19:23 total berarbeitet fr cVerskz und das Suchen von Herr/Frau in name1+name2 // damit man NICHT in cName eingeben muss: 5->name1 + 5->name2 FUNCTION SehrGeehrte(cAnrede,cName) //31.05.2007 17:19 LOCAL cString := "Sehr geehrte Damen und Herren," LOCAL cVerskz, nA := 5 DEFAULT cAnrede TO 1->ansp_anr, cName TO 1->ansp_name IF Len(cAnrede)>0 .AND. !"Herr"$cAnrede .AND. !"Frau"$cAnrede // vermutlich verskz in der cAnrede cVerskz := cAnrede IF Len(cVerskz) < 6 .AND. Len(AllTrim(cVerskz)) > 0 IF !(nA)->(DbSeek(cVerskz,.F.)) // die Adresse mit DbSeek(cVerskz) suchen RETURN cVerskz ENDIF ELSE (nA)->(DbGotop()) // die Adresse mit DbLocate(cVerskz) suchen IF Len(AllTrim(cVerskz)) == 0 .OR. !(nA)->(DBLocate( {|| cVerskz $ ((nA)->name1 + (nA)->name2) .OR. cVerskz $ (AllTrim((nA)->name1) +" "+ AllTrim((nA)->plz_ort)) } )) RETURN cVerskz ENDIF ENDIF cName := IIf(cName==1->ansp_name, 5->name1 + 5->name2, cName) ENDIF DO CASE CASE cAnrede = "Herr" cString := "Sehr geehrter Herr "+Trim(cName)+"," CASE cAnrede = "Frau" cString := "Sehr geehrte Frau "+Trim(cName)+"," CASE "Herr "$SubStr(cName,1,7) .OR. "Herrn "$SubStr(cName,1,8) cString := "Sehr geehrter Herr "+Trim(SubStr(cName,At(" ",cName,At("Herr",cName))+1))+"," CASE "Frau "$SubStr(cName,1,7) cString := "Sehr geehrte "+Trim(SubStr(cName,At("Frau",cName)))+"," CASE "Herr "$cName .OR. "Herrn "$cName //20.03.2024 19:13 sucht in name1+name2 nach "Herr" nAnf := At(" ",cName,At("Herr",cName))+1 nEnd := At(" ",cName,nAnf+7) cString := "Sehr geehrter Herr "+Trim(SubStr(cName,nAnf,nEnd-nAnf))+"," // cString := "Sehr geehrter Herr "+Trim(SubStr(cName,At(" ",cName,At("Herr",cName))+1))+"," CASE "Frau "$cName //20.03.2024 19:13 sucht in name1+name2 nach "Frau" nAnf := At(" ",cName,At("Frau",cName))+1 nEnd := At(" ",cName,nAnf+7) cString := "Sehr geehrte Frau "+Trim(SubStr(cName,nAnf,nEnd-nAnf))+"," // cString := "Sehr geehrte "+Trim(SubStr(cName,At("Frau",cName)))+"," CASE cAnrede = "Eheleute" cString := "Sehr geehrte Frau "+Trim(cName)+", "+"sehr geehrter Herr "+Trim(cName)+"," ENDCASE RETURN cString