PureBasic Forums - English

Code: Select all

XIncludeFile "CheetahInc.pb"

xdbUseDLL()

dBaseArtikel=xdbOpen("g:\auf\00001\fpos.dbf")
Debug dBaseArtikel
Records=xdbRecordCount(dbaseartikel)
Fields=xdbFieldCount(dbaseartikel)
Debug fields

FieldNumber=1
Debug xdbFieldName(dbaseartikel, FieldNumber)
Debug xdbFieldType(dbaseartikel, FieldNumber)
Debug xdbFieldLength(dbaseartikel, FieldNumber)
;Debug xdbFieldDecimals(dbaseartikel, FieldNumber)

MessageRequester("Achtung!","Durchsuche "+Str(records)+" Einträge...")

wg=xdbFieldnumber(dbaseartikel, "wg")
gp=xdbFieldnumber(dbaseartikel, "GP")
test.q=0
Debug wg
For i=1 To records
	xdbGetRecord(dbaseartikel,i)
	If xdbFieldValue(dbaseartikel,"",wg)="Battery"
	test+1
	EndIf
Next i
Debug "ok"
MessageRequester("Ergebnis:",StrQ(test))

Code: Select all

; Define

	EnableExplicit

	#dBaseMaxFiles=100
	#dBaseMaxFields=1000

	#dBaseIgnoreErrors=#False
	#dBaseEnableDebug=#True
	#dBaseDatabaseCode=3
	#dBaseFieldEndCode=$d
	#dBasePositionStart=4
	#dBasePositionFields=32

	Global dBaseFieldCounter=0

	Structure dBaseFileStructure
		;ID.l
		Name.s
		;Open.w
		Records.l
		Start.w
		Size.w
		FieldID.l
		Fields.l
	EndStructure

	Structure dBaseFieldStructure
		Name.s
		Type.c
		Offset.l
		Size.b
		Fix.b
	EndStructure

	Global Dim dBaseFile.dBaseFileStructure(#dBaseMaxFiles)
	Global Dim dBaseField.dBaseFieldStructure(#dBaseMaxFields)

	Global *MemBlock=AllocateMemory(256); die maximale Länge eines Feldes ist 255 Zeichen


	;	Aufbau eriner dBase-Datei (empirisch ermittelt):
	;
	;	Byte	Länge	Inhalt
	;	0		1			Kennung 3 (dBase-Datei-III ohne Memofelder)
	;	1		3			letzte Änderung Tag/Monat/Jahr
	;	4		4			Anzahl der Einträge
	;	6		2			Start der Datensätze
	;	8		2			Länge eines Datensatzes (inklusive Löschbyte)
	;	10	20		?
	;	32	11		1. Feld, Name ('_' anstelle ' ', Null-Byte schließt ab)
	;	43	1			1. Feld, Typ ('C' Character, 'N' Numeric, 'L' Logical, 'D' Date)
	;	44	4			1. Feld, Offset (kann auch leer bleiben)
	;	48	1			1. Feld, Länge
	;	49	1			1. Feld, Dezimalzeichen
	;	50	14		1. Feld, ?
	;	64	:			2. Feld, Name...
	;	 :
	;	 :		1			Endesymbol ($D)
	;	 :		1			1. Eintrag, Löschbyte (' ' oder '*') ?
	;	 :					1. Eintrag, Feld 1, 2, 3,...
	;	 :		1			2. Eintrag, Löschbyte (' ' oder '*') ?
	;	 :					2. Eintrag, Feld 1, 2, 3,...
	;	 :		1			Endesymbol ($1A)

; EndDefine

Macro MyDebug(zahl,text="Wert",format=Str)
	If #DBaseEnableDebug
		Debug text+": "+format#(zahl)
	EndIf
EndMacro
Procedure.s ReadStringLen(id,len)
	ReadData(id,*MemBlock,len)
	PokeB(*MemBlock+len,0)
	ProcedureReturn PeekS(*MemBlock)
EndProcedure
Procedure dBaseError(text.s,file=0,record=0,field=0)
	If #dBaseIgnoreErrors=#False
		If file+record+field
			text+#CR$+LSet("",Len(text)>>1,"—")+#CR$
			If file : text+"Datei: "+GetFilePart(dBaseFile(file)\Name)+#CR$ : EndIf
			If record: text+"Eintrag: "+Str(record)+#CR$ : EndIf
			If field : text+"Feld: "+dBaseField(field)\Name+#CR$ : EndIf
		EndIf
		MessageBox_(0,text,"dBase-Problem",#MB_ICONERROR|#MB_OK)
		End
	EndIf
EndProcedure
Procedure dBaseCheckFileID(id,name.s)
	If id<#dBaseMaxFiles
		;dBaseFileCounter+1
		;ReDim dBaseFile.dBaseFileStructure(dBaseFileCounter)

		With dBaseFile(id)
			;\ID=id
			If \Name=""
				\Name=name
				\Records=0
			Else
				dBaseError("Datenbank ID bereits in Verwendung!",id)
			EndIf
		EndWith
	Else
		dBaseError("Zuviele Datenbanken aktiv!")
	EndIf
EndProcedure
Procedure dBaseIncFieldCounter(n=1)
	If dBaseFieldCounter+n>#dBaseMaxFields
		dBaseError("Zuviele Datenfelder aktiv!")
	Else
		dBaseFieldCounter+n;	neue Array-Größe
		;ReDim dBaseField.dBaseFieldStructure(dBaseFieldCounter)
	EndIf
EndProcedure
Procedure.s dBaseReadField(id,record,field)
	record-1
	field+dBaseFile(id)\FieldID
	;Mydebug(dBaseFile(id)\Start,Str(dBaseFile(id)\Size*record+dBaseField(field)\Offset))
	;Mydebug(dBaseField(field)\offset,Str(dBaseField(field)\Offset))
	FileSeek(id,dBaseFile(id)\Start+dBaseFile(id)\Size*record+dBaseField(field)\Offset)
	ProcedureReturn ReadStringLen(id,dBaseField(field)\Size)
EndProcedure
Procedure.l dBaseGetFieldNr(id,name.s)
	Protected n=dBaseFile(id)\FieldID
	Protected i=dBaseFile(id)\Fields

	name=LCase(name)
	While i
		If name=LCase(dBaseField(n+i)\name)
			Break
		EndIf
		i-1
	Wend

	If i=0
		dBaseError("Feldname '"+name+"' nicht definiert!",id)
	EndIf

	ProcedureReturn i
EndProcedure
Procedure dBaseDefineFile(id,name.s,fields.s); Offset, Size etc. fehlt noch...
	Protected i,j,n,z

	; Array vergrößern...
	dBaseCheckFileID(id,name)

	; Felder überprüfen...
	n=CountString(fields,"|")
	If (n>1) And (n%3<>1)
		n=(n+1)/3

		; Array vergrößern...
		z=dBaseFieldCounter
		dBaseIncFieldCounter(n)

		With dBaseFile(id)
			\Fields=n
			\FieldID=z
		EndWith

		; Felddaten übernehmen...
		j=0
		For i=1 To n
			MyDebug(i,"Feld")
			z+1
			With dBaseField(z)
				j+1 :	\Name=StringField(fields,j,"|")
				j+1 : \Type=Asc(StringField(fields,j,"|"))&$DF
				j+1 : \Size=Val(StringField(fields,j,"|"))
				If FindString("NCDL",Chr(\Type),1)=0;
					dBaseError("Ungültiger Typ "+#DQUOTE$+Chr(\Type)+#DQUOTE$+"!",id,0,dBaseFieldCounter)
				EndIf
				MyDebug(\Name,"Name",Trim)
				MyDebug(\Type,"Typ",Chr)
				MyDebug(\Size,"Länge")
			EndWith

		Next i
	Else
		dBaseError("Falsche Felddefinition!",id)
	EndIf

EndProcedure
Procedure.l dBaseOpenFile(id,name.s)
	Protected i,n,z
	Protected dummy.s

	dBaseCheckFileID(id,name.s)
	If FileSize(name)>#dBasePositionFields
		If OpenFile(id,name)
			If ReadByte(id)=#dBaseDatabaseCode

				FileSeek(id,#dBasePositionStart)
				With dBaseFile(id)
					\Records=ReadLong(id)
					\Start=ReadWord(id)
					\Size=ReadWord(id)
					\Fields=0
					\FieldID=dBaseFieldCounter

					MyDebug(\Records,"Einträge")
					MyDebug(\Start,"Start")
					MyDebug(\Size,"Länge")
					MyDebug(\FieldID,"Felder")
					MyDebug(dBaseFieldCounter,"Zeiger")
				EndWith

				FileSeek(id,#dBasePositionFields)

				n=0
				Repeat
					;z=dBaseIncFieldCounter(\Records)
					dummy.s=ReadStringLen(id,11); 10 Zeichen + Null
					If Asc(dummy)=#dBaseFieldEndCode
						Break
					Else
						n+1
						dBaseIncFieldCounter()
						With dBaseField(dBaseFieldCounter)
							\Name=dummy
							\Type=ReadByte(id)
							\Offset=ReadLong(id); 	gefällt mir nicht, lieber 'händisch' ausrechnen...
							\Offset=1; 					Offset=0: Löschzeichen (' ': ok, '*': Datensatz gelöscht)
							If n>1 : \Offset=dBaseField(dBaseFieldCounter-1)\Offset+dBaseField(dBaseFieldCounter-1)\Size : EndIf
							\Size=ReadByte(id)
							\Fix=ReadByte(id)
							dummy.s=ReadStringLen(id,14)

							;MyDebug(\Name,Str(n),Trim)

						EndWith
					EndIf

				ForEver

				dBaseFile(id)\Fields=n

			Else
				dBaseError("Keine gültige Datenbank!",id)
			EndIf
			ProcedureReturn #True
		Else
			dBaseError("Datei kann nicht geöffnet werden!",id)
		EndIf
	Else
		dBaseError("Datei existiert nicht oder ist zu klein!",id)
	EndIf
	ProcedureReturn #False
EndProcedure


; Test-Beispiel

; dBase-Dateien öffnen...
dBaseOpenFile(2,"g:\auf\00001\fpos.dbf")

; Felder suchen...
Define f=dBaseGetFieldNr(2,"Wg")
Define g=dBaseGetFieldNr(2,"Gp")
Define i.l
Define test.q
Define dummy.s

MessageRequester("Achtung!","Durchsuche "+Str(dBaseFile(2)\Records)+" Einträge...")

; alle Einträge durchgehen...
For i=1 To dBaseFile(2)\records
	dummy=Trim(dBaseReadField(2,i,f));	Texteintrag lesen, Leerzeichen entfernen...
	;OemToChar_(@dummy,@dummy);	Umlaute anpassen...
	If dummy="Battery";							Daten ausfiltern...
		;dummy=dBaseReadField(2,i,g);		Zahlenwert lesen...
		test+1;MakeInteger(dummy);			und aufsummieren...
	EndIf
Next i

MessageRequester("Ergebnis:",Str(test))
FreeMemory(*MemBlock)