Kod: Tümünü seç
function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
Inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GridSelectAll(DBGrid1);
end;Kod: Tümünü seç
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.First;
Table1.MoveBy(Random(Table1.RecordCount));
end; Kod: Tümünü seç
function DirectoryIsEmpty(Directory: string): Boolean;
var
SR: TSearchRec;
i: Integer;
begin
Result := False;
FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);
for i := 1 to 2 do
if (SR.Name = '.') or (SR.Name = '..') then
Result := FindNext(SR) <> 0;
FindClose(SR);
end;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
if DirectoryIsEmpty('C:\test') then
Label1.Caption := 'empty'
else
Label1.Caption := 'not empty';
end;
Kod: Tümünü seç
{
This code is useful if you are creating a webserver program.
It's very simple, just input the extension of a file and the
function returns the MIME type of that file.
mimetypes.RES is the compiled resource file that contains a string
table with 641 different MIME types.
http://modelingman.freeprohost.com/Downloads/Delphi/MIME/mimetypes.RES
mimetypes.rc is the source file of mimetypes.RES, you can add more
types to this and compile it using brcc32
http://modelingman.freeprohost.com/Downloads/Delphi/MIME/mimetypes.rc
}
{$R mimetypes.RES}
function GetMIMEType(FileExt: string): string;
var
I: Integer;
S: array[0..255] of Char;
const
MIMEStart = 101;
// ID of first MIME Type string (IDs are set in the .rc file
// before compiling with brcc32)
MIMEEnd = 742; //ID of last MIME Type string
begin
Result := 'text/plain';
// If the file extenstion is not found then the result is plain text
for I := MIMEStart to MIMEEnd do
begin
LoadString(hInstance, I, @S, 255);
// Loads a string from mimetypes.res which is embedded into the
// compiled exe
if Copy(S, 1, Length(FileExt)) = FileExt then
// "If the string that was loaded contains FileExt then"
begin
Result := Copy(S, Length(FileExt) + 2, 255);
// Copies the MIME Type from the string that was loaded
Break;
// Breaks the for loop so that it won't go through every
// MIME Type after it found the correct one.
end;
end;
end;Kod: Tümünü seç
{This code shows how to use TXMLDocument to save and restore configuration
settings in a XML document. The public methods works the same as a TIniFile.
There is not mutch comment in the code because it is self explaining
and small. Hope this benefit other persons. It is only tested in D7 pro.}
unit uCiaXml;
interface
uses
Forms, SysUtils, Windows, XmlIntf, XMLDoc;
type
TXMLConfig = class
private
FModified: Boolean;
FFileName: string;
FXMLDoc: TXMLDocument;
FBackup: Boolean;
function GetVersion: string;
public
constructor Create(const FileName: string); overload;
constructor Create; overload;
destructor Destroy; override;
procedure Save;
function ReadString(const Section, Key, default: string): string;
procedure WriteString(const Section, Key, Value: string);
function ReadInteger(const Section, Key: string; default: Integer): Integer;
procedure WriteInteger(const Section, Key: string; Value: Integer);
function ReadBoolean(const Section, Key: string; default: Boolean): Boolean;
procedure WriteBoolean(const Section, Key: string; Value: Boolean);
property Backup: Boolean read FBackup write FBackup;
property Version: string read GetVersion;
end;
implementation
{ TXMLConfig }
constructor TXMLConfig.Create(const FileName: string);
begin
inherited Create;
FBackup := True;
FFileName := FileName;
FXMLDoc := TXMLDocument.Create(Application);
FXMLDoc.Options := [doNodeAutoIndent];
if FileExists(FFileName) then
FXMLDoc.LoadFromFile(FFileName)
else
begin
FXMLDoc.Active := True;
FXMLDoc.AddChild('Configuration');
end;
end;
constructor TXMLConfig.Create;
begin
Create(ChangeFileExt(Application.Exename, '_cfg.xml'));
end;
destructor TXMLConfig.Destroy;
begin
Save;
FXMLDoc.Destroy;
inherited;
end;
function TXMLConfig.GetVersion: string;
begin
Result := '1.00';
end;
function TXMLConfig.ReadBoolean(const Section, Key: string; default: Boolean): Boolean;
begin
Result := Boolean(ReadInteger(Section, Key, Integer(default)));
end;
function TXMLConfig.ReadInteger(const Section, Key: string; default: Integer): Integer;
begin
Result := StrToInt(ReadString(Section, Key, IntToStr(default)));
end;
function TXMLConfig.ReadString(const Section, Key, default: string): string;
var
Node: IXMLNode;
begin
Node := FXMLDoc.DocumentElement.ChildNodes.FindNode(Section);
if Assigned(Node) and Node.HasAttribute(Key) then
Result := Node.Attributes[Key]
else
Result := default;
end;
procedure TXMLConfig.Save;
begin
if not FModified then
Exit;
if FBackup then
CopyFile(PChar(FFileName), PChar(FFileName + '.bak'), False);
FXMLDoc.SaveToFile(FFileName);
FModified := False;
end;
procedure TXMLConfig.WriteBoolean(const Section, Key: string; Value: Boolean);
begin
WriteInteger(Section, Key, Integer(Value));
end;
procedure TXMLConfig.WriteInteger(const Section, Key: string; Value: Integer);
begin
WriteString(Section, Key, IntToStr(Value));
end;
procedure TXMLConfig.WriteString(const Section, Key, Value: string);
var
Node: IXMLNode;
begin
if ReadString(Section, Key, '') = Value then
Exit;
Node := FXMLDoc.DocumentElement.ChildNodes.FindNode(Section);
if not Assigned(Node) then
Node := FXMLDoc.DocumentElement.AddChild(Section);
Node.Attributes[Key] := Value;
FModified := True;
end;
end.Kod: Tümünü seç
procedure ShredderFile(FileName: string);
const
Buffer = 1024;
Counttowrite = 34;
FillBuffer: array[0..5] of Integer = ($00, $FF, $00, $F0, $0F, $00);
var
arr: array[1..Buffer] of Byte;
f: file;
i, j, n: Integer;
begin
AssignFile(f, FileName);
Reset(f, 1);
n := FileSize(f);
for j := 0 to Counttowrite do
begin
for i := 1 to n div Buffer do
begin
BlockWrite(f, FillBuffer[j], Buffer);
end;
end;
CloseFile(f);
RenameFile(FileName, ExtractFilepath(FileName) + '$000000.tmp');
DeleteFile(ExtractFilepath(FileName) + '$000000.tmp');
end;
procedure ShredderAndDeleteFile(const FileName: string);
var
newname: string;
begin
// zuerst umbennen, dann später keine Rückschlüsse auf den Dateinamen möglich sind
// first rename the file
newname := ExtractFilepath(FileName) + '$000000.tmp';
if not RenameFile(FileName, newname) then
raise
Exception.CreateFmt('Fehlercode 2: Kann %s nicht umbenennen!', [FileName]);
ShredderFile(newname);
DeleteFile(newname);
end;
Kod: Tümünü seç
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
So jetzt hab ich endlich eine Lösung gefunden wie man
den gesamten Text aus einer PDF Datei (auch mit mehreren Seiten möglich)
auslesen kann.
Ich muss mich schon gleich mal im vorherein für meine unsaubere
Programmierung entschuldigen, aber ich hoffe ihr könnt trotzdem was
damit anfangen! Das Formular beinhaltet ein TMemo, 5 TLabel, 1 TButton
und einen OpenDialog
ach ja, ihr müsst vorher noch eine Typbibliothek einfügen,
öffnet dazu den Typbibliothek Importieren Dialog (unter Projekt zu
finden) und Wählt beim Hinzufügen den Ordner von Adobe Acrobat aus.
Dort solltet ihr eine Datei namens Acrobat.tbl finden, wenn nicht dann
einfach mal suchen.
Jetzt noch die Unit Anlegen dann Installieren und fertig.
viel spass
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
This tip show the way to cath the whole text of a PDF document.
You will need:
- 1 TMemo, 5 TLabel, 1 TButton and 1 OpenDialog
- to import the typelibrary from Adobe Acrobat (look fo Acrobat.tbl)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, acrobat_tlb;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
GroupBox1: TGroupBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses ComObj;
{$R *.dfm}
{$TYPEDADDRESS OFF} //muss so sein (this have to be)
var
PDDoc: Acrobat_TLB.CAcroPDDoc;
PDPage: Variant;
PDHili: Variant;
PDTextS: Variant;
acrobat: Variant;
Result: Boolean;
NTL, i, j, Pagecount: Integer;
zeilen: string;
stichwortcounter: Integer;
Size: Integer;
gesamtstring: AnsiString;
zwreal: Real;
procedure TForm1.Button1Click(Sender: TObject);
function removecrlf(workstring: string): string;
var
i: Integer;
begin
removecrlf := '';
for i := 0 to Length(workstring) do
begin
if workstring[i] = #13 then
workstring[i] := ' ';
if workstring[i] = #10 then
workstring[i] := ' ';
end;
removecrlf := workstring;
end;
begin
if not opendialog1.Execute then Exit;
memo1.Clear;
gesamtstring := '';
stichwortcounter := 0;
Size := 0;
try
//Object erstellen
acrobat := CreateOleObject('AcroExch.pdDoc');
//PDF Datei in Object öffnen
Result := acrobat.Open(opendialog1.FileName);
if Result = False then
begin
messagedlg('Kann Datei nicht öffnen', mtWarning, [mbOK], 0);
Exit;
end;
for j := 0 to acrobat.GetNumPages - 1 do
begin
memo1.Lines.Add('----------------------------------------------');
//Erste Seite des Dokuments aktiv setzen (first page)
PDPage := acrobat.acquirePage(j);
//Ein Highlight Object mit 2000 Elementen erzeugen
PDHili := CreateOleObject('AcroExch.HiliteList');
Result := PDHili.Add(0, 4096);
//Erzeuge eine Markierung über den ganzen Text
PDTextS := PDPage.CreatePageHilite(PDHili);
ntl := PDTextS.GetNumText;
for i := 0 to ntl - 1 do
begin
zeilen := PDTextS.GetText(i);
if (Length(zeilen) > 0) and (zeilen <> '') then
memo1.Lines.Add(removecrlf(zeilen));
gesamtstring := gesamtstring + removecrlf(zeilen);
//nur für statistik
Size := Size + SizeOf(zeilen);
Inc(stichwortcounter);
Application.ProcessMessages;
end;
//Wieder freigeben
pdhili := Unassigned;
pdtextS := Unassigned;
pdpage := Unassigned;
label2.Caption := IntToStr(stichwortcounter);
label4.Caption := IntToStr(Size);
label2.Refresh;
label4.Refresh;
end; //for i to pagecount
except
on e: Exception do
begin
messagedlg('Fehler: ' + e.Message, mtError, [mbOK], 0);
Exit;
end;
end;
if Size > 1024 then
begin
zwreal := Size / 1024;
str(zwreal: 2: 1,zeilen);
label4.Caption := zeilen;
label5.Caption := 'KB';
end;
memo1.Lines.SaveToFile(Extractfilepath(Application.exename) + '\debug.txt');
end;
end.Kod: Tümünü seç
We want to get an output like this in a *.res format:
BMP1 BITMAP "bmp1ueli.bmp"
BMP2 BITMAP "bmp2uml.bmp"
BMP3 BITMAP "bmp3.bmp"
.....
1. We put all the files in a directory
2. We start the scriptResourceFile() procedure
gets all the files like *.bmp or *.wav in a *.rc format
3. Activate the resource-compiler
}
procedure TStatForm.scriptresourceFile2(restype: string);
var
f: textfile;
ResFile: ShortString;
resstr: string;
s: array[0..2048] of Char;
i, filecount: Byte;
myResList: TStringList;
begin
myresList := TStringList.Create;
filecount := getfilelist(myResList);
if filecount > totalPictures then
filecount := totalPictures;
for i := 0 to filecount - 1 do
begin
resstr := Format('%s%d %s %s%s%s',
['bmp', i, restype, '"', myReslist.Strings[i], '"']);
StrCat(s, PChar(resstr));
StrCat(s, #13#10);
end;
ResFile := 'membmp.rc';
AssignFile(f, ResFile);
Rewrite(f);
Write(f, s);
closefile(f);
myResList.Free;
compileResfile(ResFile);
end;
procedure TStatForm.btnGenClick(Sender: TObject);
begin
scriptResourceFile2('Bitmap');
end;
function TStatForm.getFileList(aList: TStringList): Integer;
var
DOSerr: Integer;
fsrch: TsearchRec;
begin
Result := 0;
doserr := FindFirst('*.bmp', faAnyFile, fsrch);
if (DOSerr = 0) then
begin
while (DOSerr = 0) do
begin
aList.Add(fsrch.Name);
if (fsrch.attr and faDirectory) = 0 then Inc(Result);
DOSerr := findnext(fsrch);
end;
findClose(fsrch);
end;
end;
procedure TStatForm.compileResfile(vfile: string);
var
i, iCE: Integer;
begin
{$IFDEF MSWINDOWS}
iCE := shellapi.shellExecute(0, nil, PChar('BRCC32.exe'),
PChar(vfile), nil, 0);
i := 0;
repeat
Inc(i);
sleep(600);
Application.ProcessMessages;
until i >= 10;
if iCE <= 32 then ShowMessage('compError Nr. ' + IntToStr(iCE));
{$ENDIF}
end;
Kod: Tümünü seç
{This example will show you how your application
will be able to copy files from your application to
Windows Explorer using Drag'n Drop.
Exactly the way it is done by the OS itself!
Create a new application containing just one unit,
called 'Unit1'. Drop a FileListBox and a DirectoryListBox on to the form,
leave their names the way they are.
Connect FileListBox1 with DirectoryListBox1 by setting the FileList-property of
DirectoryListBox1. Make sure that the MultiSelect-property of FileListBox1 is set to 'True'!
The best thing you can do now is to replace all text with the code below:}
//---------------------------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls, FileCtrl, ActiveX, ShlObj, ComObj;
type
TForm1 = class(TForm, IDropSource)
FileListBox1: TFileListBox;
DirectoryListBox1: TDirectoryListBox;
procedure FileListBox1MouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FileListBox1MouseMove(Sender: TObject; Shift: TShiftState;
X,
Y: Integer);
private
FDragStartPos: TPoint;
function QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint): HResult; stdcall;
function GiveFeedback(dwEffect: Longint): HResult; stdcall;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetFileListDataObject(const Directory: string; Files:
TStrings):
IDataObject;
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
Malloc: IMalloc;
Root: IShellFolder;
FolderPidl: PItemIDList;
Folder: IShellFolder;
p: PArrayOfPItemIDList;
chEaten: ULONG;
dwAttributes: ULONG;
FileCount: Integer;
i: Integer;
begin
Result := nil;
if Files.Count = 0 then
Exit;
OleCheck(SHGetMalloc(Malloc));
OleCheck(SHGetDesktopFolder(Root));
OleCheck(Root.ParseDisplayName(0, nil,
PWideChar(WideString(Directory)),
chEaten, FolderPidl, dwAttributes));
try
OleCheck(Root.BindToObject(FolderPidl, nil, IShellFolder,
Pointer(Folder)));
FileCount := Files.Count;
p := AllocMem(SizeOf(PItemIDList) * FileCount);
try
for i := 0 to FileCount - 1 do
begin
OleCheck(Folder.ParseDisplayName(0, nil,
PWideChar(WideString(Files[i])), chEaten, p^[i],
dwAttributes));
end;
OleCheck(Folder.GetUIObjectOf(0, FileCount, p^[0], IDataObject,
nil,
Pointer(Result)));
finally
for i := 0 to FileCount - 1 do begin
if p^[i] <> nil then Malloc.Free(p^[i]);
end;
FreeMem(p);
end;
finally
Malloc.Free(FolderPidl);
end;
end;
function TForm1.QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: Longint): HResult; stdcall;
begin
if fEscapePressed or (grfKeyState and MK_RBUTTON = MK_RBUTTON) then
begin
Result := DRAGDROP_S_CANCEL
end else if grfKeyState and MK_LBUTTON = 0 then
begin
Result := DRAGDROP_S_DROP
end else
begin
Result := S_OK;
end;
end;
function TForm1.GiveFeedback(dwEffect: Longint): HResult; stdcall;
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
procedure TForm1.FileListBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
FDragStartPos.x := X;
FDragStartPos.y := Y;
end;
end;
procedure TForm1.FileListBox1MouseMove(Sender: TObject; Shift:
TShiftState;
X, Y: Integer);
const
Threshold = 5;
var
SelFileList: TStrings;
i: Integer;
DataObject: IDataObject;
Effect: DWORD;
begin
with Sender as TFileListBox do
begin
if (SelCount > 0) and (csLButtonDown in ControlState)
and ((Abs(X - FDragStartPos.x) >= Threshold)
or (Abs(Y - FDragStartPos.y) >= Threshold)) then
begin
Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
SelFileList := TStringList.Create;
try
SelFileList.Capacity := SelCount;
for i := 0 to Items.Count - 1 do
if Selected[i] then SelFileList.Add(Items[i]);
DataObject := GetFileListDataObject(Directory, SelFileList);
finally
SelFileList.Free;
end;
Effect := DROPEFFECT_NONE;
DoDragDrop(DataObject, Self, DROPEFFECT_COPY, Effect);
end;
end;
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
{
As you might have seen, TForm1 is not only a member of class TForm,
but also of class IDropSource!
Now make sure that the two FileListBox events
'OnMouseMove' and 'OnMouseDown' are set correctly.
Run your application and try out the Drag and Drop feature!
You can select multiple items to drag and press escape to cancel.
The cursor will show you what action will take place.
}Kod: Tümünü seç
function IsTextFile(const sFile: TFileName): boolean;
//Created By Marcelo Castro - from Brazil
var
oIn: TFileStream;
iRead: Integer;
iMaxRead: Integer;
iData: Byte;
dummy:string;
begin
result:=true;
dummy :='';
oIn := TFileStream.Create(sFile, fmOpenRead or fmShareDenyNone);
try
iMaxRead := 1000; //only text the first 1000 bytes
if iMaxRead > oIn.Size then
iMaxRead := oIn.Size;
for iRead := 1 to iMaxRead do
begin
oIn.Read(iData, 1);
if (idata) > 127 then result:=false;
end;
finally
FreeAndNil(oIn);
end;
end;
(* ----- Sample call ----- *)
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
if IsTextFile(OpenDialog1.FileName) then
showmessage('is ascii')
else showmessage('is BinaryFile')
end;
end;
Kod: Tümünü seç
Kod: Tümünü seç
function TForm1.SaveToCSV:Boolean;
var
SD : TSaveDialog;
I : Integer;
CSV : TStrings;
FileName : String;
begin
Try
// Filedialog erzeugen
SD := TSaveDialog.Create(Self);
SD.Filter := 'CSV-Trennzeichen getrennt (*.csv)|*.CSV';
//Filedialog ausführen
If SD.Execute = True Then
Begin
//Filename zuweisen
FileName := SD.FileName;
If Copy(FileName,Pos('.',FileName),Length(FileName)-Pos('.',FileName)+1) <> '.csv' Then FileName := FileName + '.csv';
Screen.Cursor := crHourGlass;
//Stringliste erzeugen
CSV := TStringList.Create;
Try
//Stringliste füllen
For I := 0 To Grid.RowCount - 1 Do CSV.Add(Grid.Rows[I].CommaText);
//CSV speichern
CSV.SaveToFile(FileName);
Result := True;
Finally
CSV.Free;
End;
End;
Finally
SD.Free;
Screen.Cursor := crDefault;
End;
end;
//SaveToCSV ausführen (sample call)
procedure TForm1.BtnSaveClick(Sender: TObject);
begin
SaveToCSV;
end;
Kod: Tümünü seç
function IsMaskedFileName(aFileName: string): Boolean;
begin
// First method
Result := (StrScan(PChar(aFileName), '*') <> nil) or
(StrScan(PChar(aFileName), '?') <> nil);
// Second way
Result := ((LastDelimiter('*?', aFileName) <> 0);
end;Kod: Tümünü seç
> I am trying to write an application that converts a CSV(or similar)it to
> an XML one.The application looks for a character(the comma - - or anything
> else specified in an Edit box - -), adds a starting and ending tag to the
> line, and writes the line to the new XML file. in the end I should get an
> XML file with the various elements.
{Your task has a number of subtasks.
The first is parsing the input file into lines. You can leave that to a
Tstringlist, if the files you need to handle are not in the
multimegabyte size range. If they are you would be best served by using
the good old Pascal Textfile routines, where a simple ReadLn( filevar, S
) gets you a line.
The second is parsing a line into its elements, based on a separator
character between the elements. This is also not so difficult to do,
especially if you don't need to deal with quoted elements that may
contain the separator. Search the newsgroup archives for "SplitString"
for an example. Tstringlist.Delimitedtext may be of use here, but be
warned that it considers any character <= #32 as a separator *in
addition* to what you define as Delimiter. It can deal with quoted
elements, though.
The second subtask would end with a TStringlist instance containing the
elements to store into the XML file for one line of the input file. This
is the input for the third task: to create a first-level XML element
containing the data. To write valid XML you need not only deal with
proper nesting of XML tags, you also have to properly represent some
characters that have special meaning in XML ('<' and '&' for instance).
I can recommend Berend de Boers xml_generator class
http://www.pobox.com/~berend/delphi for this task, it deals with all the
nastiness behind the scenes and produces syntactically correct XML
without the overhead of a DOM model implementation.
There is something else you need: a list of column names, one name for
each "column" in your XML file. These names will become the node names
for the subnodes of the produced XML. Depending on your input files you
may be able to get these names from the first line (which often is a
header line giving the column names).
Here is sketch (untested!) of the conversion routine: }
type
{: Callback for CSVToXML. If given the callback will be called
after each processed line.
@Param currentline is the 0-based number of the processed line
@Param totallines is the total number of lines. This may be a
raw estimate if the file is not completly loaded in memory.
@Returns true to continue processing, false to stop it. }
TProgressNotification =
function(currentline, totallines: Integer): Boolean of object;
{-- CSVToXML ----------------------------------------------------------}
{: Convert a delimiter-separated file of data to XML
@Param csvfilename is the file to convert
@Param xmlfilename is the xml file to create
@Param aSeparator is the separator for the data
@Param aRootNodeName is the name to use for the root node of the XML
file.
@Param columnnames is an optional list of column names to use as subnode
names. If this parameter is nil the first line of the data file must
contain a header line with the names to use.
@Param onProgress is an optional callback to call afte each processed
line.
@Precondition csvfilename exists
}{ Created 17.3.2003 by P. Below
-----------------------------------------------------------------------}
procedure CSVToXML(const csvfilename, xmlfilename: string;
const aSeparator: Char;
const aRootNodeName: string;
const columnnames: TStrings = nil;
const onProgress: TProgressNotification = nil);
function DoProgress(currentline, totallines: Integer): Boolean;
begin
if Assigned(onProgress) then
Result := onProgress(currentline, totallines)
else
Result := true;
end;
procedure WriteDataline(const line: string; header: TStringlist; xml: TXMLGenerator);
var
elements: TStringlist;
i, max: Integer;
begin
elements := TStringlist.Create;
try
elements.Delimiter := aSeparator;
elements.Delimitedtext := line;
if elements.count > header.count then
max := header.count
else
max := elements.count;
for i := 0 to max - 1 do begin
xml.StartTag(header[i]);
xml.AddData(elements[i]);
xml.StopTag;
end; { For }
finally
elements.Free;
end;
end;
procedure WriteData(data: TStringlist; xml: TXMLGenerator);
var
header: TStringlist;
firstline: Integer;
i: Integer;
begin
header := Tstringlist.Create;
try
firstline := 0;
if assigned(columnnames) then
header.Assign(columnnames)
else begin
header.Delimiter := aSeparator;
header.DelimitedText := data[0];
firstline := 1;
end; { Else }
for i := firstline to data.count - 1 do begin
WriteDataline(data[i], header, xml);
if not DoProgress(i, data.count) then
Break;
end; { For }
finally
header.Free;
end;
end;
procedure SaveStringToFile(const S, filename: string);
var
fs: TFilestream;
begin
fs := TFileStream.Create(filename, fmCreate);
try
if Length(S) > 0 then
fs.WriteBuffer(S[1], Length(S));
finally
fs.free
end;
end; { SaveStringToFile }
var
xml: TXMLGenerator; // from xml_generator unit by Berend de Boers
datafile: Tstringlist;
begin { CSVToXML }
if not FileExists(csvfilename) then
raise Exception.CreateFmt('Input file %s not found', [csvfilename]);
datafile := Tstringlist.Create;
try
datafile.LoadfromFile(csvfilename);
xml := TXMLGenerator.CreateWithEncoding(16 * 1024, encISO_8859_1);
try
xml.StartTag(aRootNodeName);
if datafile.count > 0 then
WriteData(datafile, xml);
xml.StopTag;
SaveStringToFile(xml.AsLatin1, xmlfilename);
finally
xml.Free;
end;
finally
datafile.free;
end;
end; { CSVToXML }
Kod: Tümünü seç
procedure ListFileDir(Path: string; FileList: TStrings);
var
SR: TSearchRec;
begin
if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
begin
repeat
if (SR.Attr <> faDirectory) then
begin
FileList.Add(SR.Name);
end;
until FindNext(SR) <> 0;
FindClose(SR);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListFileDir('C:\WINDOWS\', ListBox1.Items);
end;