// 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 //+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 //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ PROCEDURE AppSys() #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 := "Alaska Crt" oCrt:FontName := "8.Arial" //#endif oCrt:Create() // Presentation Space initialisieren oCrt:PresSpace() // XbpCrt wird aktives Fenster und Ausgabeger§t SetAppWindow ( oCrt ) 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 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 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 NEXT i DbeSetDefault( "DELDBE" ) DbeInfo( COMPONENT_DATA, DELDBE_MODE, DELDBE_MULTIFIELD ) DbeInfo( COMPONENT_DATA, DELDBE_FIELD_TOKEN, "," ) 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 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** //+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 //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 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 PUBLIC cBFont := nFontR, 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 @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 use C:\HDBE\mwstdat exclusive //IF cLn == "L" IF cLn $ "LO" //24.08.2007 09:06 O bedeutet: Verbindung mit Oberhausen herstellen replace mwstdat->datver with "C:\HDBE\" cObver := Trim( mwstdat->obver ) // cNetver := TRIM(mwstdat->netver) IF SubStr( mwstdat->netver,1,1 ) == "T" // klappt auch im Local-Mode 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 cf08 := mwstdat->f08 cf09 := mwstdat->f09 cf10 := mwstdat->f10 cf11 := mwstdat->f11 cf12 := mwstdat->f12 cf13 := mwstdat->f13 cf14 := mwstdat->f14 xdmeu := mwstdat->dmeu 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 //////////////////////////////////////////////////////////////////////////// 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->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->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 .JPG-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 weitere Dateien.....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 weitere Dateien.....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 weitere Dateien.....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 weitere Dateien.....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile4 ) TO ( "C:\HDBE\" + cDFile4 ) ENDIF /* 03.07.2008 11:55 besser: Žnderung in ratenant.txt in der mwstdat.dbf ! Dann reicht obiges!*/ ////// /* 03.07.2008 11:50 nochmal fr neue ratenant.txt */ ////// cDFile := Stuff(cDFile4,Len(cDFile4)-3,4,".txt") ////// 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 weitere Dateien.....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 weitere Dateien.....bitte nicht unterbrechen!" COPY FILE ( "T:\HDBE\" + cDFile5 ) TO ( "C:\HDBE\" + cDFile5 ) ENDIF ENDIF ENDIF //** ENDIF ENDIF //+25.03.2012 11:44 wird wohl nicht mehr gebraucht: //ELSEIF cLn $ "T" //28.03.2008 21:27 zur Reparatur der TBest fr GE // RepTBest() ELSE // holt sich das Netzverzeichnis und die Systemnummer dieses Client: cNetver := TRIM(mwstdat->netver) cObver := Trim(mwstdat->obver) cSystem := mwstdat->system cPubAuf := mwstdat->pubauf cf08 := mwstdat->f08 cf09 := mwstdat->f09 cf10 := mwstdat->f10 cf11 := mwstdat->f11 cf12 := mwstdat->f12 cf13 := mwstdat->f13 cf14 := mwstdat->f14 xdmeu := mwstdat->dmeu USE 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 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->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->loc_or_net with cLn //07.03.2008 17:58 hierher von unten 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 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 // l„uft nur in den Satellitenstationen (weil es nur dort ein Laufwerk T: -cOBver- gibt): IF Upper(cNetver)[1] != "M" .AND. !"BEST"$Upper(cNetver) //+23.02.2010 09:41 weil Netzwerkabfrage lange dauert IF File( cOBver+"OB", "D" ) // wenn Verbindung besteht IF ALERT( "Verbindung nach OB steht!", ; {"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\" 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] ) USE ELSE COPY FILE (aTFiles[i]) TO ( cOBver + aTFiles[i] ) ENDIF NEXT lTDZap := .T. 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 Zentra”server 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 QUIT ELSE IF ALERT( "OB hat Daten fr UNS!", ; {"Daten von OB", "Abbruch"}, ; "W+/R,BG+/N,,,W/R" ) ==1 DO WHILE 1 == 1 // 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 QUIT ELSE 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 USE ( "C:\hdbe\ob\" + aTFiles[i] ) EXCLUSIVE APPEND FROM (cOBver+"OB\"+aTFiles[i] ) USE ELSE 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 @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 RunShell( "/C ERASE /Q C:\HDBE\OB\*.*" ) // unvollst„ndige Dateien alle l”schen Sleep(1) //+ vorsichtshalber LOOP // nochmal Copy der Dateien vom Zentralserver ELSE // wenn alle 7 Dateien in C:\HDBE\OB sind // dann werden die Dateien im Zentralserver gel”scht FOR i := 1 TO 7 FErase( cOBver + "OB\" + aTFiles[i] ) NEXT EXIT ENDIF ENDIF ENDDO 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 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 @5,5 SAY "Es sind nicht alle Dateien in c:\hdbe\ob\ zum Eingliedern!" WAIT ELSE @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 APPEND FROM ("C:\HDBE\"+aTFiles[i] ) // die 'Arbeits-T-Dateien' 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 ENDIF //** //**/////////////////////////////////////////////////////////////////////////////// ENDIF ENDIF @ 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. ) ENDIF IF !FILE( cOBver + "artneu", "D" ) RunShell( "/C MD "+cOBver + "artneu",, .T. ) 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." @ 12,10 SAY "Trennen Sie dann die Verbindung nach OB..." @ 13,10 SAY "mit der ïOberhausenï-Ikone." @ 15,10 SAY "Starten Sie danach das Programm erneut." WAIT CLEAR ALL QUIT ENDIF ENDIF ENDIF // IF File( "C:\hdbe\ob\tbest.dbf" ) CLEAR IF AllFilesExist( aTFiles, "C:\hdbe\ob\" ) //+02.10.2012 21:15 geREMt, weil: wird nur gebraucht, wenn die Struktur von best.dbf ge„ndert wurde: ////// USE best //+16.07.2008 20:30 hier Abfrage, ob die neue Struktur schon da ////// IF !IsFieldVar("abr_datum") ////// USE ////// @ 5,5 SAY "A C H T U N G !" ////// @ 7,5 SAY "Machen Sie unbedingt zun„chst einen Prflauf !" ////// @ 9,5 SAY "Nach einem Tastendruck startet das Prflauf-Programm !" ////// @ 11,5 SAY "Drcken Sie dort unbedingt die -Taste !" ////// WAIT ////// ineux() ////// ENDIF ////// USE @5,5 SAY "Eingliedern der Daten aus dem Haupt-Server in OB:" ineux(.F.) //+22.12.2013 15:07 vor dem Eingliedern TTSerSat( "C:\HDBE\OB\", "C:\HDBE\" ) ineux(.F.) //+22.12.2013 15:07 nach dem Eingliedern 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 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 //+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 do termine //clear all do hpar 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 " DO CASE 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) = "T:\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) = "T:\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) = "T:\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) = "T:\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) = "T:\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) = "T:\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 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() dbdelete() else dbdelete() endif RETURN upfehl FUNCTION Satzrecall upfehl:=0 If rlock() 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(), "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 "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 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 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() IF .NOT. NETERR() RETURN (.T.) ENDIF forever = (wait = 0) DO WHILE (forever .OR. wait > 0) DBAPPEND() 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ï)" 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") .OR. mp1 == Asc("T") cLn := Chr(mp1) lStart := .T. CASE mp1 == Asc("7") 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() RETURN .F. 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. 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