// 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( cAppName, cBildBreit, cBildHoch) //18.07.2026 13:33 nBildBreit, nBildHoch zur Gr”áen-Žnderung * 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 DEFAULT cBildBreit TO "1536", cBildHoch TO "864" //18.07.2026 13:36 1820/1.25 und 1080/1.25 (siehe Desktop:Bildschirmaufl”sung) PUBLIC nBSbreit := Int(cBildBreit) //18.07.2026 13:39 PUBLIC nBShoch := Int(cBildHoch) //18.07.2026 13:39 //+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 := "" //+15.12.2020 16:29 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. ) DO eurov // damit die Variablen schon mal deklariert sind //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" USE C:\HDBE\mwstdat EXCLUSIVE // IF !AllFilesExist(aFiles,"C:\HDBE\") .OR. ; //26.10.2025 10:19 vorsichtshalber, falls mwstdat Fehler enth„lt // !"T:\"$Upper(mwstdat->obver) //20.12.2024 13:48 wenn es kein Haupt-PC ist IF (!"C:\"$Upper(mwstdat->netver) .OR. "BESTATT"$Upper(mwstdat->netver)) //28.10.2025 18:12 'BESTATT' fr meinen LT // !AllFilesExist(aFiles,"C:\HDBE\") //28.10.2025 18:13 fr alle F„lle: sind alle da? CLEAR @ 10,10 SAY "Dieser PC hat keine lokalen Daten!" @ 11,10 SAY "Dieses ist ein Neben-PC - nicht der Haupt-PC." @ 12,10 SAY "Starten Sie das Programm neu..." @ 14,10 SAY " ...und geben Sie N statt L ein!" WAIT "Drcken Sie " QUIT ENDIF replace mwstdat->datver with "C:\HDBE\" USE ELSEIF cLn == "O" use C:\HDBE\mwstdat EXCLUSIVE //vvvvvvvvvvvvvvvvvvvv //26.10.2025 10:25 von hier oben ("L") kopiert, weil auch hier ("O") wichtig: IF !AllFilesExist(aFiles,"C:\HDBE\") .OR. ; //26.10.2025 10:19 vorsichtshalber, falls mwstdat Fehler enth„lt !"T:\HDBE\"$Upper(mwstdat->obver) .OR. !"C:\HDBE\"$Upper(mwstdat->netver) //28.10.2025 19:07 wenn es kein Haupt-PC ist CLEAR @ 10,10 SAY "Dieser PC hat keine lokalen Daten!" @ 11,10 SAY "šbertragung von hier nicht m”glich!" @ 12,10 SAY "Wechseln Sie zum Haupt-PC ..." @ 14,10 SAY " ...und geben Sie dort O ein!" WAIT "Drcken Sie " QUIT ENDIF //^^^^^^^^^^^^^^^^^^ replace mwstdat->datver with "C:\HDBE\" cObver := Trim( mwstdat->obver ) // cNetver := TRIM(mwstdat->netver) IF SubStr( mwstdat->obver,1,1 ) == "T" //19.03.2017 15:37 frher ->netver //////19.03.2017 15:09 geREMt: ////// IF cLN == "O" //24.08.2007 09:21 ////// RunShell( "/C NET USE T: \\dcschumacher\Platte_M oberhausen /USER:\\dcschumacher\aussenstelle /PERSISTENT:YES" ) ////// Sleep( 500 ) // 5 Sekunden schlafen/warten ////// ENDIF IF FILE( "T:\HDBE\MWSTDAT.DBF" ) // wenn also die Verbindung zustandekommt // holt sich das Netzverzeichnis und die Systemnummer dieses Client: cNetver := TRIM(mwstdat->netver) cObver := Trim(mwstdat->obver) cSystem := mwstdat->system cPubAuf := mwstdat->pubauf nBGFarbe := Val(mwstdat->zcodewort9) //+22.11.2019 10:56 nFeldBGFarbe := Val(mwstdat->zcodewort8) //+22.11.2019 10:56 cBFont := mwstdat->zcodewort7 //+25.11.2019 13:17 cf08 := mwstdat->f08 cf09 := mwstdat->f09 cf10 := mwstdat->f10 cf11 := mwstdat->f11 cf12 := mwstdat->f12 cf13 := mwstdat->f13 cf14 := mwstdat->f14 xdmeu := mwstdat->dmeu cTextprog := mwstdat->textprog //+01.04.2017 21:11 USE //////////////////////////////////////////////////////////////////////////// //+11.02.2013 15:56 lokale mwstdat.dbf sichern: // (cDatver ist C:\HDBE\ - aus EUROV) IF FRename( "C:\HDBE\mwstdat.dbf", "C:\HDBE\mwstdat_orig.dbf" ) = -1 FErase( "C:\HDBE\mwstdat_orig.dbf") FRename( "C:\HDBE\mwstdat.dbf", "C:\HDBE\mwstdat_orig.dbf" ) ENDIF //////////////////////////////////////////////////////////////////////////// // REM 09.11.2025 10:45 die vorhergehenden Zeilen sichern mwstdat in mwstdat_orig, // damit die nachfolgenden Zeilen sie aus dem neuesten Stand des Zentralservers // wieder neu generieren kann: RunShell( "/C COPY T:\HDBE\MWSTDAT.DBF C:\HDBE\MWSTDAT.DBF" ) // schreibt das Netzverzeichnis, die Systemnummer etc. in die neue Mwstdat: USE C:\HDBE\mwstdat EXCLUSIVE REPLACE mwstdat->datver with "C:\HDBE\" // weil im LOCAL-Mode! REPLACE mwstdat->netver with cNetver REPLACE mwstdat->obver with cOBver REPLACE mwstdat->system with cSystem REPLACE mwstdat->pubauf with cPubAuf REPLACE mwstdat->zcodewort9 WITH Str(nBGFarbe) //+22.11.2019 10:57 REPLACE mwstdat->zcodewort8 WITH Str(nFeldBGFarbe) //+22.11.2019 10:57 REPLACE mwstdat->zcodewort7 WITH cBFont //+25.11.2019 13:18 REPLACE mwstdat->f08 with cF08 REPLACE mwstdat->f09 with cF09 REPLACE mwstdat->f10 with cF10 REPLACE mwstdat->f11 with cF11 REPLACE mwstdat->f12 with cF12 REPLACE mwstdat->f13 with cF13 REPLACE mwstdat->f14 with cF14 REPLACE mwstdat->dmeu with xdmeu REPLACE mwstdat->textprog WITH cTextprog //+01.04.2017 21:14 replace mwstdat->loc_or_net with cLn //07.03.2008 17:58 hierher von unten cDFile1 := IIf(IsFieldVar("dfile1"),Trim(mwstdat->dfile1),"") cDFile2 := IIf(IsFieldVar("dfile2"),Trim(mwstdat->dfile2),"") cDFile3 := IIf(IsFieldVar("dfile3"),Trim(mwstdat->dfile3),"") cDFile4 := IIf(IsFieldVar("dfile4"),Trim(mwstdat->dfile4),"") cDFile5 := IIf(IsFieldVar("dfile5"),Trim(mwstdat->dfile5),"") USE // gibt es eine neue Programmversion? Dann KSOX.NEU vom Server kopieren // (vor allem anderen, damit die neue Programmversion schon mal da ist...) cKSOX_NEU := "T:\HDBE\KSOX.NEU" aNeuFiles := Directory( cKSOX_NEU ) aExeFiles := Directory( "C:\HDBE\KSOX.EXE" ) IF Len( aNeuFiles ) > 0 // gibt es eine neue Programmversion auf dem Server? : IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 6,10 SAY "Auf dem Server befindet sich eine neuere Version des Programms." @ 7,10 SAY "Die neue Version wird jetzt vom Server geholt." @ 8,10 SAY "Bitte nicht unterbrechen!" @ 10,10 SAY "Ich bertrage ....." COPY FILE ( "C:\HDBE\KSOX.NEU" ) TO ( "C:\HDBE\KSOX.NBK" ) // Backup fr alle F„lle COPY FILE ( "T:\HDBE\KSOX.NEU" ) TO ( "C:\HDBE\KSOX.NEU" ) // neues Programm kopieren COPY FILE ( "T:\HDBE\KSOTEXTE.DBF" ) TO ( "C:\HDBE\KSOTEXTE.DBF" ) // neue Zahltexte kopieren COPY FILE ( "T:\HDBE\F1.DBF" ) TO ( "C:\HDBE\F1.DBF" ) // Hilfedateien holen COPY FILE ( "T:\HDBE\F1_MA.DBF" ) TO ( "C:\HDBE\F1_MA.DBF" ) // Hilfedateien holen COPY FILE ( "T:\HDBE\F1_trans.DBF" ) TO ( "C:\HDBE\F1_trans.DBF" ) // Hilfedateien holen @ 10,10 SAY "F E R T I G " @ 13,10 SAY "Das Programm wurde erneuert." @ 15,10 SAY "Die neue Version k”nnen Sie wie folgt aktivieren:" @ 17,10 SAY "Beenden Sie bitte das Programm ganz und starten Sie es neu." @ 19,10 SAY "(Wenn Sie weitermachen, arbeiten Sie mit der alten Version.)" wait "Drcken Sie " ENDIF ENDIF //**07.03.2008 18:48 Kopie der neuen DFile*-Dateien: IF "."$cDFile1 IF !FExists("C:\HDBE\" + cDFile1) //12.03.2008 09:21 COPY FILE ( "T:\HDBE\" + cDFile1 ) TO ( "C:\HDBE\" + cDFile1 ) ELSE aNeuFiles := Directory( "T:\HDBE\" + cDFile1 ) aExeFiles := Directory( "C:\HDBE\" + cDFile1 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile1+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile1 ) TO ( "C:\HDBE\" + cDFile1 ) ENDIF ENDIF ENDIF IF "."$cDFile2 IF !FExists("C:\HDBE\" + cDFile2) //12.03.2008 09:21 COPY FILE ( "T:\HDBE\" + cDFile2 ) TO ( "C:\HDBE\" + cDFile2 ) ELSE aNeuFiles := Directory( "T:\HDBE\" + cDFile2 ) aExeFiles := Directory( "C:\HDBE\" + cDFile2 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile2+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile2 ) TO ( "C:\HDBE\" + cDFile2 ) ENDIF ENDIF ENDIF IF "."$cDFile3 IF !FExists("C:\HDBE\" + cDFile3) //12.03.2008 09:21 COPY FILE ( "T:\HDBE\" + cDFile3 ) TO ( "C:\HDBE\" + cDFile3 ) ELSE aNeuFiles := Directory( "T:\HDBE\" + cDFile3 ) aExeFiles := Directory( "C:\HDBE\" + cDFile3 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile3+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile3 ) TO ( "C:\HDBE\" + cDFile3 ) ENDIF ENDIF ENDIF IF "."$cDFile4 IF !FExists("C:\HDBE\" + cDFile4) //12.03.2008 09:21 COPY FILE ( "T:\HDBE\" + cDFile4 ) TO ( "C:\HDBE\" + cDFile4 ) ELSE aNeuFiles := Directory( "T:\HDBE\" + cDFile4 ) aExeFiles := Directory( "C:\HDBE\" + cDFile4 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile4+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile4 ) TO ( "C:\HDBE\" + cDFile4 ) ENDIF ENDIF ENDIF IF "."$cDFile5 IF !FExists("C:\HDBE\" + cDFile5) //12.03.2008 09:21 COPY FILE ( "T:\HDBE\" + cDFile5 ) TO ( "C:\HDBE\" + cDFile5 ) ELSE aNeuFiles := Directory( "T:\HDBE\" + cDFile5 ) aExeFiles := Directory( "C:\HDBE\" + cDFile5 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile5+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile5 ) TO ( "C:\HDBE\" + cDFile5 ) ENDIF ENDIF ENDIF //** //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv //+23.09.2018 12:32 Dateien fr die Korrespondenz via OpenOfficeWriter: aDFile := {"KSO_GhAusz.png","Guthaben.txt","ErinnA-Kto.txt","ErinnTF.txt", ; "WriterBrief.html","Html_Brief.html", ; "dummy.abr","dHTML.abr","dHTML.mahn"} // 06.06.2019 12:24 falsches dummy.abd -> .abr FOR f=1 TO Len(aDFile) IF !FExists("C:\HDBE\" + aDFile[f]) //12.03.2008 09:21 CLEAR @ 10,10 SAY "Ich bertrage die Datei "+aDFile[f]+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + aDFile[f] ) TO ( "C:\HDBE\" + aDFile[f] ) ELSE aNeuFiles := Directory( "T:\HDBE\" + aDFile[f] ) aExeFiles := Directory( "C:\HDBE\" + aDFile[f] ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+aDFile[f]+".....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + aDFile[f] ) TO ( "C:\HDBE\" + aDFile[f] ) ENDIF ENDIF NEXT //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ENDIF ELSE USE //+19.03.2017 15:11 weil L/O-Auswahl und use mwstdat oben verschoben wurde ENDIF ELSEIF cLn == "N" //+19.03.2017 17:48 damit nicht bei cLn=="L" use C:\HDBE\mwstdat exclusive //vvvvvvvvvvvvvvvvvvvv //26.10.2025 10:25 von hier oben ("L", "O") kopiert, weil auch hier ("N") wichtig: // IF (!AllFilesExist(aFiles,"M:\HDBE\") .OR. ; //26.10.2025 10:19 vorsichtshalber, falls mwstdat Fehler enth„lt // !"M:\"$Upper(mwstdat->netver)) ; //20.12.2024 13:48 wenn es DER Haupt-PC ist // .OR. !AllFilesExist(aFiles,mwstdat->netver) //26.10.2025 11:44 fr meinen LT IF ("M:\"$Upper(mwstdat->netver) .OR. "BESTATT"$Upper(mwstdat->netver)) .AND. ; //28.10.2025 18:12 'BESTATT' fr meinen LT AllFilesExist(aFiles,Trim(mwstdat->netver)) //28.10.2025 18:13 fr alle F„lle: sind alle da? ELSE CLEAR @ 10,10 SAY "Dieser PC hat keine Verbindung zum Daten-Laufwerk M:!" @ 11,10 SAY "Wenn es der Haupt-PC ist:" @ 12,10 SAY "Starten Sie das Programm neu..." @ 14,10 SAY " ...und geben Sie L statt N ein!" WAIT "Drcken Sie " QUIT ENDIF //^^^^^^^^^^^^^^^^^^ // holt sich das Netzverzeichnis und die Systemnummer dieses Client: cNetver := Trim(mwstdat->netver) cObver := Trim(mwstdat->obver) cSystem := mwstdat->system cPubAuf := mwstdat->pubauf nBGFarbe := Val(mwstdat->zcodewort9) //+22.11.2019 10:57 nFeldBGFarbe := Val(mwstdat->zcodewort8) //+22.11.2019 10:57 cBFont := mwstdat->zcodewort7 //+25.11.2019 13:17 cf05 := mwstdat->f05 cf06 := mwstdat->f06 cf08 := mwstdat->f08 cf09 := mwstdat->f09 cf10 := mwstdat->f10 cf11 := mwstdat->f11 cf12 := mwstdat->f12 cf13 := mwstdat->f13 cf14 := mwstdat->f14 xdmeu := mwstdat->dmeu cTextprog := mwstdat->textprog //+01.04.2017 21:12 USE //////19.03.2017 15:09 geREMt: ////// IF SubStr( cNetver,1,1 ) == "T" ////// RunShell( "/C NET USE T: \\dcschumacher\Platte_M oberhausen /USER:\\dcschumacher\aussenstelle /PERSISTENT:yes" ) ////// ENDIF cMwstdatNet := cNetver+"MWSTDAT.DBF" // Mwstdat.dbf aktualisieren: vom Server kopieren IF File( cMwstdatNet ) //////////////////////////////////////////////////////////////////////////// //+11.02.2013 15:56 lokale mwstdat.dbf sichern: // (cDatver ist C:\HDBE\ - aus EUROV) IF FRename( "C:\HDBE\mwstdat.dbf", "C:\HDBE\mwstdat_orig.dbf" ) = -1 FErase( "C:\HDBE\mwstdat_orig.dbf") FRename( "C:\HDBE\mwstdat.dbf", "C:\HDBE\mwstdat_orig.dbf" ) ENDIF //////////////////////////////////////////////////////////////////////////// RunShell( "/C COPY &cMwstdatNet C:\HDBE\MWSTDAT.DBF" ) ELSE IF !FILE( cMwstdatNet ) CLEAR @ 10,10 SAY "Das Laufwerk auf dem Netzwerk-Server ist nicht verfgbar!" @ 12,10 SAY "Haben Sie den Computer ordentlich im Netzwerk angemeldet?" @ 13,10 SAY "Starten Sie den PC neu... " @ 14,10 SAY " ...und geben Sie Ihr richtiges Passwort ein!" WAIT "Drcken Sie " QUIT ENDIF ENDIF // schreibt das Netzverzeichnis, die Systemnummer etc. in die neue Mwstdat: USE C:\HDBE\mwstdat EXCLUSIVE REPLACE mwstdat->datver with cNetver REPLACE mwstdat->netver with cNetver REPLACE mwstdat->obver with cOBver REPLACE mwstdat->system with cSystem REPLACE mwstdat->pubauf with cPubAuf REPLACE mwstdat->zcodewort9 WITH Str(nBGFarbe) //+22.11.2019 10:57 REPLACE mwstdat->zcodewort8 WITH Str(nFeldBGFarbe) //+22.11.2019 10:57 REPLACE mwstdat->zcodewort7 WITH cBFont //+25.11.2019 13:18 REPLACE mwstdat->f05 with cF05 REPLACE mwstdat->f06 with cF06 REPLACE mwstdat->f08 with cF08 REPLACE mwstdat->f09 with cF09 REPLACE mwstdat->f10 with cF10 REPLACE mwstdat->f11 with cF11 REPLACE mwstdat->f12 with cF12 REPLACE mwstdat->f13 with cF13 REPLACE mwstdat->f14 with cF14 REPLACE mwstdat->dmeu with xdmeu REPLACE mwstdat->textprog with cTextprog //+01.04.2017 21:13 replace mwstdat->loc_or_net with cLn //07.03.2008 17:58 hierher von unten cDFile1 := IIf(IsFieldVar("dfile1"),Trim(mwstdat->dfile1),"") cDFile2 := IIf(IsFieldVar("dfile2"),Trim(mwstdat->dfile2),"") cDFile3 := IIf(IsFieldVar("dfile3"),Trim(mwstdat->dfile3),"") cDFile4 := IIf(IsFieldVar("dfile4"),Trim(mwstdat->dfile4),"") cDFile5 := IIf(IsFieldVar("dfile5"),Trim(mwstdat->dfile5),"") USE cKSOX_NEU := cNetver + "KSOX.NEU" aNeuFiles := Directory( cKSOX_NEU ) aExeFiles := Directory( "C:\HDBE\KSOX.EXE" ) IF Len( aNeuFiles ) > 0 // gibt es eine neue Programmversion auf dem Server? : IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] // .AND. Upper( Substr( cNetver,1,1 ) ) != "T" CLEAR @ 6,10 SAY "Auf dem Server befindet sich eine neuere Version des Programms." @ 7,10 SAY "Die neue Version wird jetzt vom Server geholt." @ 8,10 SAY "Bitte nicht unterbrechen!" COPY FILE ( cNetver+"KSOX.NEU" ) TO ( "C:\HDBE\KSOX.NEU" ) @ 10,10 SAY "F E R T I G" @ 13,10 SAY "Das Programm wurde erneuert." @ 15,10 SAY "Die neue Version k”nnen Sie wie folgt aktivieren:" @ 17,10 SAY "Beenden Sie bitte das Programm ganz und starten Sie es neu." @ 19,10 SAY "(Wenn Sie weitermachen, arbeiten Sie mit der alten Version.)" wait "Drcken Sie " ENDIF ENDIF //**02.04.2017 14:11 Kopie der neuen DFile*-Dateien: IF "."$cDFile1 IF !FExists("C:\HDBE\" + cDFile1) //12.03.2008 09:21 COPY FILE ( cNetver + cDFile1 ) TO ( "C:\HDBE\" + cDFile1 ) ELSE aNeuFiles := Directory( cNetver + cDFile1 ) aExeFiles := Directory( "C:\HDBE\" + cDFile1 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile1+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + cDFile1 ) TO ( "C:\HDBE\" + cDFile1 ) ENDIF ENDIF ENDIF IF "."$cDFile2 IF !FExists("C:\HDBE\" + cDFile2) //12.03.2008 09:21 COPY FILE ( cNetver + cDFile2 ) TO ( "C:\HDBE\" + cDFile2 ) ELSE aNeuFiles := Directory( cNetver + cDFile2 ) aExeFiles := Directory( "C:\HDBE\" + cDFile2 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile2+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + cDFile2 ) TO ( "C:\HDBE\" + cDFile2 ) ENDIF ENDIF ENDIF IF "."$cDFile3 IF !FExists("C:\HDBE\" + cDFile3) //12.03.2008 09:21 COPY FILE ( cNetver + cDFile3 ) TO ( "C:\HDBE\" + cDFile3 ) ELSE aNeuFiles := Directory( cNetver + cDFile3 ) aExeFiles := Directory( "C:\HDBE\" + cDFile3 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile3+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + cDFile3 ) TO ( "C:\HDBE\" + cDFile3 ) ENDIF ENDIF ENDIF IF "."$cDFile4 IF !FExists("C:\HDBE\" + cDFile4) //12.03.2008 09:21 COPY FILE ( cNetver + cDFile4 ) TO ( "C:\HDBE\" + cDFile4 ) ELSE aNeuFiles := Directory( cNetver + cDFile4 ) aExeFiles := Directory( "C:\HDBE\" + cDFile4 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile4+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + cDFile4 ) TO ( "C:\HDBE\" + cDFile4 ) ENDIF ENDIF ENDIF IF "."$cDFile5 IF !FExists("C:\HDBE\" + cDFile5) //12.03.2008 09:21 COPY FILE ( cNetver + cDFile5 ) TO ( "C:\HDBE\" + cDFile5 ) ELSE aNeuFiles := Directory( cNetver + cDFile5 ) aExeFiles := Directory( "C:\HDBE\" + cDFile5 ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+cDFile5+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + cDFile5 ) TO ( "C:\HDBE\" + cDFile5 ) ENDIF ENDIF ENDIF //** //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv //+23.09.2018 12:32 Dateien fr die Korrespondenz via OpenOfficeWriter: aDFile := {"KSO_GhAusz.png","Guthaben.txt","ErinnA-Kto.txt","ErinnTF.txt", ; "WriterBrief.html","Html_Brief.html", ; "dummy.abr","dHTML.abr","dHTML.mahn"} FOR f=1 TO Len(aDFile) IF !FExists("C:\HDBE\" + aDFile[f]) //12.03.2008 09:21 CLEAR @ 10,10 SAY "Ich bertrage die Datei "+aDFile[f]+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + aDFile[f] ) TO ( "C:\HDBE\" + aDFile[f] ) ELSE aNeuFiles := Directory( cNetver + aDFile[f] ) aExeFiles := Directory( "C:\HDBE\" + aDFile[f] ) IF aNeuFiles[ 1, F_WRITE_DATE ] > aExeFiles[ 1, F_WRITE_DATE ] CLEAR @ 10,10 SAY "Ich bertrage die Datei "+aDFile[f]+".....bitte nicht unterbrechen!" COPY FILE ( cNetver + aDFile[f] ) TO ( "C:\HDBE\" + aDFile[f] ) ENDIF ENDIF NEXT //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 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 IF cLn == "O" IF ValType(bc := TStickDrive(cOBver)) == "A" IF Alert("Wohin m”chten Sie die Daten bertragen", ; {"auf den Stick "+Chr(bc[1]),"ber VPN auf den Zentralserver"}) == 1 cOBver := bc[2] ENDIF ENDIF ENDIF // l„uft nur in den Satellitenstationen (weil es nur dort ein Laufwerk T: -cOBver- gibt): // 19.03.2017 18:40 cLn=="O" erg„nzt IF cLn == "O" .AND. Upper(cNetver)[1] != "M" .AND. !(Upper(cOBver)[1]=="T" .AND. "BEST"$Upper(cNetver)) //+23.02.2010 09:41 weil Netzwerkabfrage lange dauert IF File( cOBver+"OB", "D" ) // wenn Verbindung besteht //09.11.2025 11:57: cOBStick := IIf("T:\"$cOBver,"nach OB", "zum Stick") IF ALERT( "Verbindung "+cOBStick+" steht! In das Verzeichnis "+cOBver, ; {"Daten bertragen", "nicht bertragen"}, ; "W+/R,BG+/N,,,W/R" ) ==1 lTDZap := .F. //**28.03.2008 09:07** IF !File( cOBver + "tbest.dbf" ) // cOBver ist z.B. "T:\HDBE\E\" // das kann schon lange nicht mehr passieren, weil die kso_satser.exe hier beim Eingliedern leere Dateien vorinstalliert! SELECT 1 USE tbest // wenn also noch nichts auf dem Hauptserver ist SELECT 2 USE tvv // ...und wir hier schon etwas Neues haben... SELECT 3 USE tauftr SELECT 4 USE tvers SELECT 5 USE tvbest // ist an diesem Tag schon etwas bearbeitet worden? : IF 1->(LastRec()) > 1 .OR. 2->(LastRec()) > 1 .OR. 3->(LastRec()) > 1 ; .OR. 4->(LastRec()) > 1 .OR. 5->(LastRec()) > 1 CLOSE ALL IF ALERT( "WIR haben Daten fr OB!", ; {"Daten nach OB", "Abbruch"}, ; "W+/R,BG+/N,,,W/R" ) ==1 // wenn bertragen werden soll, dann erstmal eine Datensicherung: IF Len( Directory("c:\hdbe\server") ) == 0 RunShell( "/C MD C:\HDBE\SERVER" ) ENDIF //**//21.02.2008 10:24 damit die unwichtigen Files nicht den Ablauf verlangsamen: aZuSichFiles := {"best","vv","auftr","vers","art","vbest","vvv","vauftr","term","t*"} FOR i := 1 TO Len(aZuSichFiles) cDings1 := "C:\HDBE\" + aZuSichFiles[i]+".DB?" cDings2 := "C:\HDBE\SERVER\" + aZuSichFiles[i]+".DB?" RunShell( "/C COPY &cDings1 &cDings2" ) NEXT //**// CLEAR @5,5 SAY "Kopieren der T-Dateien auf den Hauptserver in OB:" FOR i := 1 TO 7 @ 6+i,10 SAY aTFiles[i] IF File( cOBver + aTFiles[i] ) IF i>5 ; LOOP ; ENDIF USE ( cOBver + aTFiles[i] ) EXCLUSIVE APPEND FROM (aTFiles[i] ) USE ELSE COPY FILE (aTFiles[i]) TO ( cOBver + aTFiles[i] ) ENDIF NEXT lTDZap := .T. ENDIF @ 5,5 SAY "fertig! " ELSE CLOSE ALL ENDIF ELSE @5,5 SAY "Appenden der T-Dateien in den Hauptserver in OB:" FOR i := 1 TO 7 @ 6+i,10 SAY aTFiles[i] IF File( cOBver + aTFiles[i] ) // wenn noch Dateien auf dem Hauptserver IF i>5 ; LOOP ; ENDIF USE ( cOBver + aTFiles[i] ) EXCLUSIVE APPEND FROM (aTFiles[i] ) // direkt aus den T-Dateien in C:\HDBE USE ELSE COPY FILE (aTFiles[i]) TO ( cOBver + aTFiles[i] ) ENDIF NEXT lTDZap := .T. // Damit die aktuellen T-Dateien ganz zum Schluss gezapt werden ENDIF // hat der Hauptserver etwas im Abhol-Verzeichnis? dann : CLEAR @5,5 SAY "kopieren vom Abhol-Verzeichnis in OB nach c:\hdbe\ob\" IF !File( cOBver + "OB\" + "tbest.dbf" ) //+ keine Daten zum šbertragen auf dem Zentral-Server @7,5 SAY "Es sind keine Daten im Abhol-Verzeichnis in OB!" ELSE IF !AllFilesExist( aTFiles, cOBver + "OB\" ) // wenn im Zentralserver nicht alle 7 Dateien @5,5 SAY "Es sind auf dem Zentralserver nur unvollst„ndige Daten!" @6,5 SAY "Verst„ndigen Sie umgehend den Programmierer," @7,5 SAY "damit er den Zentralserver berprft!" @9,5 SAY "Trennen Sie die Verbindung," @10,5 SAY "und starten Sie das Programm ohne šbertragung!" WAIT "Drcken Sie " QUIT ELSE IF ALERT( "OB hat Daten fr UNS!", ; {"Daten von OB", "Abbruch"}, ; "W+/R,BG+/N,,,W/R" ) ==1 //23.07.2023 17:19 damit die While-Schleife nicht unendlich wird: w = 0 DO WHILE ++w < 10 // einfach nur eine Endlosschleife IF !AllFilesExist( aTFiles, cOBver + "OB\" ) // unlogisch (s.o.), daher: inzwischen Leitung gest”rt @5,5 SAY "Die Verbindung zum Zentralserver scheint gest”rt!" @6,5 SAY "Trennen Sie die Verbindung zun„chst und" @7,5 SAY "stellen Sie sie dann wieder neu her." @8,5 SAY "Dann starten Sie das Programm" @9,5 SAY "zu einem neuen šbertragungsversuch." WAIT "Drcken Sie " QUIT ELSE // wenn also im Server-Abholverzeichnis alle Dateien vollst„ndig sind == NORMALFALL //23.07.2023 17:13 totaler Umbau: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv //23.07.2023 17:13 check ob in c:\hdbe\ob ein unvollst„ndiger Dateiensatz ist: IF !AllFilesExist(aTFiles,"C:\HDBE\OB\") .AND. FExists("C:\HDBE\OB\*.*") IF ALERT( "Verzeichnis C:\HDBE\OB ist nicht leer", ; {"leeren+weiter", "Abbruch"}, ; "W+/R,BG+/N,,,W/R" ) ==1 RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) // unvollst„ndige Dateien alle l”schen Sleep(1) //+ vorsichtshalber ELSE @ 15,10 SAY "Programm bitte neu starten!" WAIT "Drcken Sie " QUIT ENDIF ENDIF //23.07.2023 17:12 sind denn also alle aTFiles im lokalen Verzeichnis c:\hdbe\ob enthalten? IF AllFilesExist(aTFiles,"C:\HDBE\OB\") // also wenn ALLE aTFiles vorhanden sind, auch die *.dbt !!! // sehr unwahrscheinlich nach den vorigen Checks und L”schungen FOR i := 1 TO 7 @ 6+i,10 SAY aTFiles[i] IF i>5 ; LOOP ; ENDIF USE ( "C:\hdbe\ob\" + aTFiles[i] ) EXCLUSIVE APPEND FROM (cOBver+"OB\"+aTFiles[i] ) USE NEXT ELSE // egal ob und wieviele Dateien noch im lokalen Verzeichnis c:\hdbe\ob drin sind: // der NORMALFALL ist, dass die Dateien vom Server rberkopiert werden: (nicht appended!) FOR i := 1 TO 7 cDings1 := cOBver+"OB\"+aTFiles[i] //+08.07.2021 10:50 ersetzt die COPY FILE-Zeile danach cDings2 := "C:\hdbe\ob\"+aTFiles[i] // ... weil es Fehler bei der šbertragung aus Essen gab RunShell( "/C COPY &cDings1 &cDings2" ) // ... erst mal so als Experiment ! NEXT Sleep(1) //+ vorsichtshalber ENDIF //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ // 23.07.2023 17:08 vorige Version mit m”glichem Fehler:^vvvvvvvvvvvvvvv // FOR i := 1 TO 7 // @ 6+i,10 SAY aTFiles[i] // IF File( "C:\hdbe\ob\" + aTFiles[i] ) // wenn schon diese Datei lokal vorhanden // IF i>5 ; LOOP ; ENDIF //23.07.2023 17:15 was ist, wenn aber die *.dbt nicht vorhanden ist?? // USE ( "C:\hdbe\ob\" + aTFiles[i] ) EXCLUSIVE // APPEND FROM (cOBver+"OB\"+aTFiles[i] ) // USE // ELSE // cDings1 := cOBver+"OB\"+aTFiles[i] //+08.07.2021 10:50 ersetzt die COPY FILE-Zeile danach // cDings2 := "C:\hdbe\ob\"+aTFiles[i] // ... weil es Fahler bei der šbertragung aus Essen gab // RunShell( "/C COPY &cDings1 &cDings2" ) // ... erst mal so als Experiment ! //// COPY FILE (cOBver+"OB\"+aTFiles[i]) TO ("C:\hdbe\ob\" + aTFiles[i]) // ENDIF // NEXT //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ // Leeren des Abholverzeichnisses im Server //+02.10.2012 21:59 IF FILE( "C:\hdbe\ob\tvbest.dbt" ) // wenn šbertragung erfolgt ist IF !AllFilesExist( aTFiles, "C:\hdbe\ob\" ) //+02.10.2012 22:00 wenn unvollst„ndige šbertragung vom Server @5,5 SAY "Es sind nicht alle Daten aus dem Zentralserver in OB bertragen worden!" @6,5 SAY "Drcken Sie ," @7,5 SAY "um die šbertragung zu wiederholen!" //+ in diesem Falle sind die Dateien oben sicher durch Copy und nicht durch Append entstanden //+ k”nnen daher alle gel”scht werden: WAIT "Drcken Sie " RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) // unvollst„ndige Dateien lokal alle l”schen Sleep(1) //+ vorsichtshalber LOOP // nochmal Copy der Dateien vom Zentralserver ELSE // wenn alle 7 Dateien in C:\HDBE\OB sind // == der NORMALFALL // dann werden die Dateien im Zentralserver gel”scht FOR i := 1 TO 7 FErase( cOBver + "OB\" + aTFiles[i] ) NEXT EXIT ENDIF ENDIF ENDDO // WHILE-Schleife zu Ende ENDIF ENDIF ENDIF // Achtung: // Das Folgende passiert nur, wenn die Verbindung nach OB steht und man bertragen angeklickt hat!: // ... und wenn bertragen wurde, dann die šbertragung geklappt hat! //**/////////////////////////////////////////////////////////////////////////////// // 28.03.2008 09:17 Hiermit werden neue Žnderungen (von heute in dieser Filiale) // an die neue šbertragung aus Oberhausen angeh„ngt. // D.h. es gilt der neue Stand, z.B. bei der Rechnung. //**28.03.2008 09:11 internes Kopieren: Daten FšR OB hinter Daten AUS OB kopieren: CLEAR // l”scht nur den Bildschirm?? //23.07.2023 18:04 gel”scht, weil berflssig: (AllFilesExist ist besser!) // IF !File( "C:\hdbe\ob\" + "tbest.dbf" ) // //+ keine lokalen Daten zum Eingliedern // @5,5 SAY "Es sind keine Dateien in c:\hdbe\ob\ zum Eingliedern!" // WAIT // ELSE IF !AllFilesExist( aTFiles, "C:\hdbe\ob\" ) //+02.10.2012 22:00 wenn šbertragung unvollst„ndig // sollte hier praktisch nie landen, weil schon vorher aussortiert //23.07.2023 18:18: IF ALERT( "!Verzeichnis C:\HDBE\OB hat nicht alle Dateien zum Eingliedern!", ; {"leeren", "Abbruch"}, ; "W+/R,BG+/N,,,W/R" ) ==1 RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) // unvollst„ndige Dateien alle l”schen Sleep(1) //+ vorsichtshalber ELSE RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) // unvollst„ndige Dateien alle l”schen Sleep(1) //+ vorsichtshalber @ 15,10 SAY "Programm bitte neu starten!" WAIT "Drcken Sie " QUIT ENDIF ELSE // der NORMALFALL: @5,5 SAY "appenden der eigenen T-Dateien im PC nach c:\hdbe\ob\" FOR i := 1 TO 7 @ 6+i,10 SAY aTFiles[i] IF File( "C:\hdbe\ob\" + aTFiles[i] ) IF i>5 ; LOOP ; ENDIF USE ( "C:\hdbe\ob\" + aTFiles[i] ) EXCLUSIVE // die T-Dateien zum Eingliedern (vom Server) APPEND FROM ("C:\HDBE\"+aTFiles[i] ) // die 'Arbeits-T-Dateien' (vom Client, aktueller Stand) USE ELSE COPY FILE ("C:\HDBE\"+aTFiles[i]) TO ("C:\hdbe\ob\" + aTFiles[i]) ENDIF NEXT //** //**28.03.2008 09:10** Zappen hierher verschoben, weil vorher noch internes Kopieren // T-Dateien zappen IF lTDZap // wird jeweils oben gesetzt, wenn gezappt wrde FOR i := 1 TO 7 IF i>5 ; LOOP ; ENDIF //21.02.2008 10:51 //+ da der šbertragungs-PC die Daten immer in c:\hdbe hat: cDatei := ("C:\HDBE\"+aTFiles[i]) //**27.03.2008 15:00** USE &cDatei EXCLUSIVE //21.02.2008 10:51 ZAP //21.02.2008 10:51 USE NEXT ENDIF ENDIF //s.o. ENDIF //** //**/////////////////////////////////////////////////////////////////////////////// ENDIF ENDIF CLEAR @ 5,5 SAY "fertig! " IF File( cOBver+"OB", "D" ) // wenn Verbindung besteht //+03.06.2013 15:37 vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv /* Verzeichnis erzeugen, wenn noch nicht existent */ IF !FILE( cOBver + "art", "D" ) RunShell( "/C MD "+cOBver + "art",, .T. ) sleep(10) ENDIF IF !FILE( cOBver + "artneu", "D" ) RunShell( "/C MD "+cOBver + "artneu",, .T. ) sleep(10) ENDIF IF !FExists( cOBver + "art\artfil.dbf" ) // Artikeldatei der Filiale in den Zentral-Server kopieren: COPY FILE (cDatver + "art.dbf") TO ( cOBver + "\art\artfil.dbf" ) ENDIF IF FExists( cOBver + "artneu\artneu.dbf" ) COPY FILE (cDatver + "art.dbf") TO ( cDatver + "artalt.dbf" ) // neue Artikeldatei aus der Zentrale in die Filiale kopieren: COPY FILE (cOBver + "artneu\artneu.dbf") TO ( cDatver + "art.dbf" ) COPY FILE (cOBver + "artneu\artneu.dbf") TO ( cOBver + "artneu\artzen.dbf" ) FErase(cOBver + "artneu\artneu.dbf") ENDIF /**/ //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ IF ALERT( "Verbindung nach OB...", ; {"beibehalten", "abbrechen"}, ; "W+/R,BG+/N,,,W/R" ) ==2 CLEAR ////// IF cLN == "O" //24.08.2007 09:21 ////// RunShell( "/C NET USE T: \\dcschumacher\Platte_M /DELETE" ) ////// Sleep( 500 ) // 5 Sekunden schlafen/warten ////// ELSE ////// // RunShell( "/C NET USE T: /delete /yes" ) @ 10,10 SAY "Das Bestattungsprogramm schlieát hier." IF cObver[1] != "T" @ 12,10 SAY "Entnehmen Sie danach den Stick ..." @ 13,10 SAY "... nachdem Sie rechts unten auf 'USB-Hardware entfernen' geklickt haben." ENDIF @ 15,10 SAY "Starten Sie danach das Programm erneut." WAIT "Drcken Sie " CLEAR ALL QUIT ////// ENDIF ENDIF ENDIF ENDIF // Falls man versehentlich auf weitermachen geklickt hat: cLn := IIf(cLn=="O","L",cLn) //+02.04.2017 17:10 IF cLn == "L" .AND. Upper(cNetver)[1] != "M" .AND. !(Upper(cOBver)[1]=="T" .AND. "BEST"$Upper(cNetver)) //+23.02.2010 09:41 weil Netzwerkabfrage lange dauert IF File( "C:\hdbe\ob\tbest.dbf" ) CLEAR IF AllFilesExist( aTFiles, "C:\hdbe\ob\" ) @5,5 SAY "Eingliedern der Daten aus dem Haupt-Server in OB:" @6,5 SAY "(vorher Prflauf und nachher Prflauf)" ineux(.F.) //+22.12.2013 15:07 vor dem Eingliedern eurov() TTSerSat( "C:\HDBE\OB\", "C:\HDBE\" ) ineux(.F.) //+22.12.2013 15:07 nach dem Eingliedern eurov() RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) ELSE @5,5 SAY "Es sind nicht alle Daten aus dem Haupt-Server in OB bertragen worden!" @6,5 SAY "Stellen Sie erneut eine Verbindung nach Oberhausen her," @7,5 SAY "starten Sie das Programm neu und" @8,5 SAY "machen Sie noch mal eine šbertragung!" WAIT "Drcken Sie !" CLEAR ALL QUIT ENDIF ENDIF ENDIF IF !FILE( cDatver + "AUFTR_B.DBF" ) USE auftr COPY stru TO AUFTR_B USE ENDIF 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 ////// 20.03.2017 18:47 geREMt, weil nicht hier in KSOX.exe sondern nur in KSOX_R.exe gebraucht ////// //+02.07.2013 12:01: vorsichtshalber indizieren ////// IF FExists(cDatver+"s_.tak") ////// DbUseArea( ,"SDFNTX", "s_.tak", "sv" ) // 9.2.2005 ////// OrdCreate( "xFldPos",, "Upper(fname)+StrZero(field_pos+1000,4,0)" ) ////// ENDIF /*02.05.2025 18:37 ist vielleicht bei SSDs nicht mehr n”tig??: //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv //+22.09.2018 17:52 damit der Puffer aufgebaut wird fr die Feldsuche //+25.08.2021 16:12 GEDULD: @ 10,10 SAY "der Such-Index wird initialisiert" @ 12,10 SAY "bitte eine Minute Geduld" oThread_BI := Thread():new() oThread_BI:setPriority( PRIORITY_IDLE ) oThread_BI:setInterval(NIL) //14.03.2025 15:49 oThread_BI:start("BestIndex") //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */ 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="1111110" do datei select 1 best4p( "Bestattungs-Aufnahme/Pflege-Maske -- Karl Schumacher Oberhausen" ) CLOSE ALL ENDIF do while .t. // prog=" " do eurov *** *melinks za00=" " za01=" BESTATTUNGSVERWALTUNG - SCHUMACHER " za02=" " za03=" Vestische Straáe 146 " za04=" 46117 Oberhausen " zb00=" " zb01=" " zb02=" " zb03=" " zb04=" Version vom " + cVersionsDatum + " " IF cLon ="L" zb05=" Sie arbeiten LOKAL " ELSE zb05=" Sie arbeiten im Netzwerk " ENDIF ***************************************************************** * ausgabe links ***************************************************************** //do hpar ***use mwstdat k1="N" k2="BG" k3="W" k4="N" k5="W" k6="N" xxx = "&k1/&k2,&k3/&k4,,,&k5/&k6" set color to &xxx @ 0,0 say za00 @ 1,0 say za01 @ 2,0 say za02 @ 3,0 say za03 @ 4,0 say za04 @ 5,0 say za05 ****** k1="N" k2="BG" k3="W" k4="N" k5="W" k6="N" xxx = "&k1/&k2,&k3/&k4,,,&k5/&k6" set color to &xxx @ 0,40 say zb00 datum=dtoc(date()) zeile1=" "+cdow(date()) *zeile3=" "+substr(datum,1,2)+". "+cmonth(date())+" 19"+substr(datum,7,2)+" "+time() zeile3=" "+dtoc(date())+" "+time() @ 1,40 say zeile1+substr(zb01,1,36-len(zeile1)) + xdmeu + "/" + clon + " " @ 2,40 say zb02 @ 3,40 say zeile3+substr(zb03,1,40-len(zeile3)) @ 4,40 say zb04 @ 5,40 say zb05 *** //----------------------------------------------------------------------- do while .T. prog=" " do eurov && ****EURO set color to "N+/W" @ 6,0 clear set color to &cFarbe aMenuItems := { "1 Verwalten der Daten ", ; "2 šbersichten / Statistiken", ; "3 Korrespondenz ", ; "4 Formulardruck ", ; "5 Terminkalender ", ; "6 Kassenbuch ", ; "7 Programm/Datenpflege ", ; "8 Jahresabschluá ", ; "9 Vorvertr„ge ", ; "S Sonstige Programme ", ; "P Prflauf ", ; "!, F10 oder ESC = Ende "} nTop := 6 ; nLeft := 2 ; nBottom := 22 ; nRight := 36 cMenuTitle := " H A U P T A U S W A H L " cBoxChars := " " ; cMenuColor := "GR+/B" // "W+/B,W+/R,R/GR+,,W+/W" SET WRAP ON nChoice := BoxMenu( aMenuItems, nTop, nLeft, nBottom, nRight, cMenuTitle, ; , cBoxChars, cMenuColor ) prog = IIF(nChoice<12, ltrim(str(nChoice,2,0)), "!" ) if prog<>" " exit endif enddo //----------------------------------------------------------------------- do hpar // do eurov do case case prog="I" do ineux case prog="10" .or. prog="s".or.prog="S" schf=1 cCodewort=cCodeworts do codewor2 if schf=0 do somenuf endif case prog="11" .or. prog="p".or.prog="P" schf=1 cCodewort=cCodewortp do codewor2 if schf=0 do ineux endif /* 03.07.2008 11:24 DM geht nicht mehr! Und wenn, dann nur noch ber FORM-PARAM! case prog="12" .or. prog="x".or.prog="X" prog="x" do eurox */ case prog="1" schf=1 cCodewort=cCodewort1 do codewor2 if schf=0 do menuf endif case prog="2" //schf=1 //cCodewort=cCodewort2 // Schutz erst innerhalb von drmenuf //do codewor2 //if schf=0 do drmenuf //endif case prog="3" schf=1 cCodewort=cCodewort3 do codewor2 if schf=0 do brmenuf endif case prog="4" schf=1 cCodewort=cCodewort4 do codewor2 if schf=0 do fomenuf endif case prog="5" schf=1 cCodewort=cCodewort5 do codewor2 if schf=0 do temenuf endif case prog="6" schf=1 cCodewort=cCodewort6 do codewor2 if schf=0 do kassef endif case prog="7" //schf=1 //cCodewort=cCodewort7 //do codewor2 //if schf=0 do bemenuf //endif case prog="8" schf=1 cCodewort=cCodewort8 do codewor2 if schf=0 do jamenuf endif case prog="9" schf=1 cCodewort=cCodewort9 do codewor2 if schf=0 do vmenuf endif case prog="!" .or. prog="0" // clear all clear antw=" " do while antw=" " @6,15 say "+-------------------------------------------+" @7,15 say "| Wollen Sie Ihre Arbeit beenden ? |" @7,53 get antw @8,15 say "+-------------------------------------------+" @9,15 say "| E N D E = j |" @10,15 say "+----------------------------------------ak-+" read if antw="j" .or. antw="J" clear return endif if antw="n" .or. antw="N" clear loop endif antw=" " enddo endcase CLEAR TYPEAHEAD enddo 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 //