funções IsDBF e RootName.... PTOOLS

bencz · Mensagem por **bencz** » 24 Jul 2014 15:50

Boa tarde!

Alguem sabe dizer, quais são as funções do Harbour, compativeis com IsDBF e RootName, da ptools ?

Grato

Alexandre

bencz · Mensagem por **bencz** » 24 Jul 2014 16:12

A função rootname, consegui 'recriar' ela...

Código: Selecionar todos

FUNCTION ROOTNAME(cFilePath)
  LOCAL cPath, cFileName, cExtension
  HB_FNameSplit( cFilePath, @cPath, @cFileName, @cExtension )
RETURN cFileName

a função, IsDBF, fico com receio de apenas verificar se a estenção do arquivo é DBF...

Mensagem por **Kapiaba** » 24 Jul 2014 17:19

Olá, acgei isto na NET, não sei se é o que você quer.

Código: Selecionar todos

#include "FiveWin.ch"

FUNCTION Main()

  //parameters cFileName
  LOCAL cFileName := "SERVIDOR.DBF"

  ? isdbf(cFilename)

  aDBInfo:=isdbf(cFileName,1)

  ? aDBInfo[1] 
  ? aDBInfo[2] 
  ? aDBInfo[3]

  aDBStruct:=isdbf(cFileName,2)

  ? aDBInfo[1] 
  ? aDBInfo[2] 
  ? aDBInfo[3]

  quit

RETURN NIL

* -------------------------------------------------------- 
function   isdbf(cFileName,nMode) 
  /* ------------------------------------------------------ 
    ISDBF() 
      Pr ft ob DBF in Ordnung ist 
    Syntax: 
      isdbf(<cDATEINAME>,[<nMODUS>])->lOK|aDBINFO 
    Parameter: 
      <cDateiname> ein g ltiger DOS Dateiname 
      <nModus> 0 oder NULL gibt logischen Wert zur ck ob Datei in Ordnung 
ist 
               1 gibt ein Array mit Dateiinformationen zur ck 
               2 gibt ein Array mit Dateiinformationen zur ck 
    R ckgabe: 
      Modus 0: .t. Datei ok, .f. Datei fehlerhaft 
      Modus 1: Ein Array mit folgendem Aufbau: 
               nError       : Fehlernummer; 0=ok 
               cDErrorText  : Fehlerbeschreibung deutsch 
               cGBErrorText : Fehlerbeschreibung englisch 
        zus?tzlich, wenn kein Fehler: 
               nDBType      : Versionsnummer der Datenbank 
               cLastUpdate  : Datum des letzten Schreibzugriffs 
               nRecNo       : Anzahl der Datens?tze laut Header 
               nHeadLen     : Headerl?nge 
               nRecLen      : Satzl?nge 
               nFieldCount  : Anzahl der Felder 
      Modus 2: Ein Array mit folgendem Aufbau: 
               nError       : Fehlernummer; 0=ok 
               cDErrorText  : Fehlerbeschreibung deutsch 
               cGBErrorText : Fehlerbeschreibung englisch 
        zus?tzlich, wenn kein Fehler: 
               aFieldName   : Array mit den Feldnamen 
               aFieldType   : Array mit den Feldtypen 
               aFieldLen    : Array mit den Feldl?ngen 
               aFieldDec    : Array mit den Dezimalstellen 
  -------------------------------------------------------- */ 
  * ---------------- Puffervariablen initialisieren ------ 
  cDBType:=space(1)      /* DBase Version 03=DB3 / 83=DB3-Memo */ 
  cLastUpdate:=space(3)  /* Datum letzter Schreibzugriff */ 
  cRecNo:=space(4)       /* Anzahl Datens?tze */ 
  cHeadLen:=space(2)     /* Headerl?nge */ 
  cRecLen:=space(2)      /* Datensatzl?nge */ 
  cFieldInfo:=space(32)  /* Feldbeschreibung */ 
  nFieldCount:=0         /* Anzahl der Felder */ 
  cHeadEnd:=space(1)     /* Header Ende (0D) */ 
  nDBType:=0 
  nRecNo:=0 
  nHeadLen:=0 
  nRecLen:=0 
  nFieldCount:=0 
  nCount:=0 
  * ------------------------------------------------------ 
  if valtype(nMode)="U" 
    nMode:=0 
  endif 
  nHandle:=fopen(cFileName,64)  /* read-only deny-none */ 
  nError:=ferror() 
  begin sequence 
    if nError!=0 
      break /* low level file error */ 
    endif 
    nFileLen:=fseek(nHandle,0,2)  /* EOF */ 
    fseek(nHandle,0,0) /* BOF */ 
    /* Datenbankversion */ 

    nDBType:=asc(cDBType) 
    if nDBType!=3 .and. nDBType!=131 
      nError:=200 
      break  /* Keine DB3 Datei */ 
    endif 
    /* Datum letzte ?nderung ins dtos Format */ 

    cLastUpdate:="19"+strzero(asc(substr(cLastupdate,1,1)),2)+; 
                 strzero(asc(substr(cLastupdate,2,1)),2)+; 
                 strzero(asc(substr(cLastupdate,3,1)),2) 
    /* Anzahl Records LSB=1, MSB=4 (interner Z?hler) */ 

    nRecNo:=asc(substr(cRecNo,1,1))+; 
            asc(substr(cRecNo,2,1))*256+; 
            asc(substr(cRecNo,3,1))*65536+; 
            asc(substr(cRecNo,4,1))*4294967296 
    /* Headerl?nge LSB=1, MSB=2 */ 

    nHeadLen:=asc(substr(cHeadLen,1,1))+; 
              asc(substr(cHeadLen,2,1))*256 
    /* Recordl?nge LSB=1, MSB=2 */ 

    nRecLen:=asc(substr(cRecLen,1,1))+; 
             asc(substr(cRecLen,2,1))*256 
    /* reservierter Bereich 20 Zeichen  berspringen */ 
    fseek(nHandle,20,1) 
    /* Feldinfos auslesen (Bis hier ist der Header immer 32 Byte lang) */ 
    do while fseek(nHandle,0,1)<nHeadLen-32 

      if nByteCount!=32 
        nError:=210 
        nCount:=nFieldCount 
        break  /* Something terrible has happened */ 
      endif 
      nFieldCount++ 
    enddo 
    /* Feldinfo analysieren */ 
    fseek(nHandle,32,0) 
    declare aFieldName[nFieldCount],aFieldType[nFieldCount],; 
            aFieldLen[nFieldCount],aFieldDec[nFieldCount] 
    for nCount=1 to nFieldCount 

      aFieldName[nCount]:=substr(cFieldInfo,1,at(chr(0),cFieldInfo)-1) 
      aFieldType[nCount]:=substr(cFieldInfo,12,1) 
      if !aFieldType[nCount]$"CNLDM" 
        nError:=220 
        break  /* unbekannter Feldtyp */ 
      endif 
      aFieldLen[nCount]:=asc(substr(cFieldInfo,17,1)) 
      aFieldDec[nCount]:=asc(substr(cFieldInfo,18,1)) 
      if aFieldDec[nCount]>0 .and. aFieldType[nCount]!="N" 
        nError:=230 
        break /* Dezimalstellen nur bei numerischen Feldern */ 
      endif 
      if aFieldDec[nCount]>aFieldLen[nCount]-2 .and.; 
         aFieldDec[nCount]!=0 .and. aFieldType[nCount]=="N" 
        nError:=240 
        break /* zu viele Dezimalstellen angegeben */ 
      endif 
    next 
    /* Header Ende lesen */ 

    if cHeadEnd!=chr(13) 
      nError:=250 
      break  /* Hier mu das Header Ende sein */ 
    endif 
  end sequence 
  fclose(nHandle) 
  aTmp=ErrTxt(nError,nCount) 
  cDErrorText:=aTmp[1] 
  cGBErrorText:=aTmp[2] 
  do case 
    case nMode==1 .and. nError==0 
      return({nError,cDErrorText,cGBErrorText,nDBType,cLastUpdate,; 
              nRecNo,nHeadLen,nRecLen,nFieldCount}) 
    case nMode==1 .and. nError!=0 
      return({nError,cDErrorText,cGBErrorText}) 
    case nMode==2 .and. nError==0 
      return({nError,cDErrorText,cGBErrorText,aFieldName,; 
              aFieldType,aFieldLen,aFieldDec}) 
    case nMode==2 .and. nError!=0 
      return({nError,cDErrorText,cGBErrorText}) 
    otherwise 
      return(iif(nError==0,.t.,.f.)) 
  endcase 
* -------------------------------------------------------- 
function   ErrTxt(nError,nFieldNo) 
  do case 
    case nError==0 
      cDErrorText:="Keine Fehler gefunden" 
      cGBErrorText:="No errors found" 
    case nError==2 
      cDErrorText:="Datei nicht gefunden" 
      cGBErrorText:="File not found" 
    case nError==3 
      cDErrorText:="Pfad nicht gefunden" 
      cGBErrorText:="Path not found" 
    case nError==4 
      cDErrorText:="Zu viele Dateien geffnet" 
      cGBErrorText:="Too many open files" 
    case nError==5 
      cDErrorText:="Zugriff verweigert" 
      cGBErrorText:="Access denied" 
    case nError==6 
      cDErrorText:="Ung ltiges Datei-Handle" 
      cGBErrorText:="Invalid handle" 
    case nError==8 
      cDErrorText:="Nicht gen gend Speicher vorhanden" 
      cGBErrorText:="Insufficient memory" 
    case nError==15 
      cDErrorText:="Ung ltige Laufwerksangabe" 
      cGBErrorText:="Invalid drive specified" 
    case nError==19 
      cDErrorText:="Schreibversuch auf schreibgesch tzter Diskette" 
      cGBErrorText:="Attempt to write on a write protected diskette" 
    case nError==21 
      cDErrorText:="Laufwerk nicht bereit" 
      cGBErrorText:="Drive not ready" 
    case nError==23 
      cDErrorText:="CRC-Datenfehler (Pr fsummenfehler)" 
      cGBErrorText:="CRC error" 
    case nError==29 
      cDErrorText:="Schreibfehler" 
      cGBErrorText:="Write fault" 
    case nError==30 
      cDErrorText:="Lesefehler" 
      cGBErrorText:="Read fault" 
    case nError==32 
      cDErrorText:="Fehlerhafter Mehrfachzugriff" 
      cGBErrorText:="Sharing violation" 
    case nError==33 
      cDErrorText:="Mehrfachzugriff gesperrt" 
      cGBErrorText:="Lock violation" 
    case nError==200 
      cDErrorText:="Datei ist keine DB3 Datei" 
      cGBErrorText:="File is no DB3 database" 
    case nError==210
      cDErrorText:="Lesefehler in der Datenfeldbeschreibung Feld:"+strzero(nFieldNo,3)
      cGBErrorText:="Read fault in field definition field:"+strzero(nFieldNo,3)
    case nError==220 
      cDErrorText:="Feldtyp unbekannt; Feld:"+strzero(nFieldNo,3) 
      cGBErrorText:="Unknown field type; field:"+strzero(nFieldNo,3) 
    case nError==230 
      cDErrorText:="Felddezimalenfehler; Feld:"+strzero(nFieldNo,3) 
      cGBErrorText:="Error in field decimals; field:"+strzero(nFieldNo,3) 
    case nError==240 
      cDErrorText:="Feldl?ngenfehler; Feld:"+strzero(nFieldNo,3) 
      cGBErrorText:="Error in field length; field:"+strzero(nFieldNo,3) 
    case nError==250 
      cDErrorText:="Dateiheader Ende nicht gefunden" 
      cGBErrorText:="File header end not found" 
    otherwise 
      cDErrorText:="Unbekannter Fehler: "+str(nError,3) 
      cGBErrorText:="Unknown error: "+str(nError,3) 
  endcase 
 return({ cDErrorText,cGBErrorText })

yugi386 · Mensagem por **yugi386** » 25 Jul 2014 01:03

Uma solução alternativa seria o seguinte código:

Código: Selecionar todos

function main()

    cls
    ? verificaDBF("a.dbf")
    ? verificaDBF("facil.dbf")

return NIL

// ============================================================
function verificaDBF(nomeArquivo)
    local ret := .T.

    BEGIN SEQUENCE WITH {| oErr | Break( oErr ) }
        use &nomearquivo
        close
    RECOVER
        ret:= .F.
    END SEQUENCE

return ret
// ============================================================

[]s

Yugi

bencz · Mensagem por **bencz** » 25 Jul 2014 08:14

Nossa!!!
Kapiaba, onde você encontrou esta função ?

Mensagem por **Kapiaba** » 25 Jul 2014 10:27

Olá, não certeza, talvez aqui:

http://www.ousob.com/ngfind.php

abs,

yugi386 · Mensagem por **yugi386** » 25 Jul 2014 13:14

Saudações!

Prezado Kapiaba,

Não consegui compilar a sua função:

Harbour 3.4.0dev () (2014-07-17 07:46)
Copyright (c) 1999-2014, https://github.com/vszakats/harbour-core/
Compiling 'isdbf.prg'...
isdbf.prg(161) Error E0030 Syntax error "syntax error at '0'"
isdbf.prg(164) Error E0010 ENDIF does not match IF
isdbf.prg(170) Error E0013 NEXT does not match FOR
isdbf.prg(197) Error E0017 Unclosed control structure 'WHILE'
4 errors

Mensagem por **Kapiaba** » 25 Jul 2014 16:16

Olá, compilei com Fiviwin e xHarbour e compila normal.

mas eu acho que esta função é para .dbf do foxpró e não para harbour/xharbour.

Não tenho certeza.

abs.

Mensagem por **Kapiaba** » 25 Jul 2014 16:55

Tente esta com [x]Habour e Harbour

Código: Selecionar todos

#include "FiveWin.ch"  // retire isto

STATIC lOk := .F.

FUNCTION Main()

   IF ISDBF( "SERVIDOR.dbf" )

      IF lOk

         ? "Valid .DBF File"

      ELSE

         ? "Not a valid .DBF file."

      ENDIF

   ENDIF

RETURN NIL

function IsDBF(cFile)

   local hFile,buffer,cText:=""

   hFile:=fopen(cFile)

   buffer:=SPACE(512)

   fread(hFile,@buffer ,512)

   cText:=str2hex(substr(buffer,1,1))

   fclose(cFile)

   if alltrim(cText)="03"

      lOk:=.t.

   else

      lOk:=.f.

   end if

return lOk

Mensagem por **Kapiaba** » 25 Jul 2014 17:00

Achei o original em clipper:

http://computer-programming-forum.com/1 ... 57c1fb.htm

http://computer-programming-forum.com/1 ... 29e936.htm

http://computer-programming-forum.com/1 ... 4de1bf.htm

http://computer-programming-forum.com/v ... er/615.htm

abs,

Mensagem por **Kapiaba** » 25 Jul 2014 17:08

http://computer-programming-forum.com/1 ... 81aa2a.htm

bencz · Mensagem por **bencz** » 26 Jul 2014 19:13

Exatamente o que eu havia pensado..., a função IsDBF da para ser criada lendo o header do arquivo....

http://ulisse.elettra.trieste.it/servic ... struct.htm

Essa documentação é mais legal aidna:
http://www.idea2ic.com/File_Formats/DBF ... UCTURE.pdf

Veja só:

Código: Selecionar todos

function main()
  LOCAL nHandle := FOpen( "teste.dbf" )
  LOCAL cDbfMod := SPACE(1)
  
  IF FError() == 0
    FRead( nHandle, @cDbfMod, 1 )
    FClose( nHandle )
    
    IF cDbfMod == 0x03 .OR. cDbfMod == 0x83
      ? "EH UM DBF EM!!!"
    ENDIF 
  ENDIF  

return nil