neoturk: ...Delete the files in the document folder ?...
uses
ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(0, nil);
end;
Delphi - .....................................
neoturk: ...Retrieve the filenames in the clipboard ?...
{
"If I use the windows Explorer to copy a file,
how can I use a paste function in my app?
This code retrieves the filenames in the clipboard.
Now you may want to display a file in a memo or
do something else with it.
"Wenn ich im Windows Explorer eine Datei kopiere,
wie kann ich dann eine Einfüge Funktion implementieren ?
Der folgende Code listet alle Dateinamen in der Zwischenablage auf.
Dann kann man eine Datei z.B in ein Memo laden oder
etwas anderes damit anstellen.
}
uses
clipbrd, shellapi;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
f: THandle;
buffer: array [0..MAX_PATH] of Char;
i, numFiles: Integer;
begin
if not Clipboard.HasFormat(CF_HDROP) then Exit;
Clipboard.Open;
try
f := Clipboard.GetAsHandle(CF_HDROP);
if f <> 0 then
begin
numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);
memo1.Clear;
for i := 0 to numfiles - 1 do
begin
buffer[0] := #0;
DragQueryFile(f, i, buffer, SizeOf(buffer));
memo1.Lines.Add(buffer);
end;
end;
finally
Clipboard.Close;
end;
end;
Delphi - .....................................
neoturk: ...Retrieve the filenames in the clipboard ?...
{
"If I use the windows Explorer to copy a file,
how can I use a paste function in my app?
This code retrieves the filenames in the clipboard.
Now you may want to display a file in a memo or
do something else with it.
"Wenn ich im Windows Explorer eine Datei kopiere,
wie kann ich dann eine Einfüge Funktion implementieren ?
Der folgende Code listet alle Dateinamen in der Zwischenablage auf.
Dann kann man eine Datei z.B in ein Memo laden oder
etwas anderes damit anstellen.
}
uses
clipbrd, shellapi;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
f: THandle;
buffer: array [0..MAX_PATH] of Char;
i, numFiles: Integer;
begin
if not Clipboard.HasFormat(CF_HDROP) then Exit;
Clipboard.Open;
try
f := Clipboard.GetAsHandle(CF_HDROP);
if f <> 0 then
begin
numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);
memo1.Clear;
for i := 0 to numfiles - 1 do
begin
buffer[0] := #0;
DragQueryFile(f, i, buffer, SizeOf(buffer));
memo1.Lines.Add(buffer);
end;
end;
finally
Clipboard.Close;
end;
end;
Delphi - .....................................
neoturk: ...Change the color of a tpagecontrols ?...
{...}
type
TTabSheet = class(ComCtrls.TTabSheet)
private
FColor: TColor;
procedure SetColor(Value: TColor);
procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
public
constructor Create(aOwner: TComponent); override;
property Color: TColor read FColor write SetColor;
end;
type
TForm1 = class(TForm)
Button1: TButton;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
procedure PageControl1DrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TTabSheet.Create(aOwner: TComponent);
begin
inherited;
FColor := clBtnFace;
end;
procedure TTabSheet.SetColor(Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Invalidate;
end;
end;
procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
begin
if FColor = clBtnFace then
inherited
else
begin
Brush.Color := FColor;
Windows.FillRect(Msg.dc, ClientRect, Brush.Handle);
Msg.Result := 1;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Tabsheet1.Color := clWhite;
TabSheet2.Color := clLime;
end;
// PageControl1.OwnerDraw := True !
procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
AText: string;
APoint: TPoint;
begin
with (Control as TPageControl).Canvas do
begin
Brush.Color := ClGreen;
FillRect(Rect);
AText := TPageControl(Control).Pages[TabIndex].Caption;
with Control.Canvas do
begin
APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2;
APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2;
TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText);
end;
end;
end;
end.
Delphi - .....................................
neoturk: ...Change the color of a tpagecontrols ?...
{...}
type
TTabSheet = class(ComCtrls.TTabSheet)
private
FColor: TColor;
procedure SetColor(Value: TColor);
procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
public
constructor Create(aOwner: TComponent); override;
property Color: TColor read FColor write SetColor;
end;
type
TForm1 = class(TForm)
Button1: TButton;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
procedure PageControl1DrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TTabSheet.Create(aOwner: TComponent);
begin
inherited;
FColor := clBtnFace;
end;
procedure TTabSheet.SetColor(Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Invalidate;
end;
end;
procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
begin
if FColor = clBtnFace then
inherited
else
begin
Brush.Color := FColor;
Windows.FillRect(Msg.dc, ClientRect, Brush.Handle);
Msg.Result := 1;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Tabsheet1.Color := clWhite;
TabSheet2.Color := clLime;
end;
// PageControl1.OwnerDraw := True !
procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
AText: string;
APoint: TPoint;
begin
with (Control as TPageControl).Canvas do
begin
Brush.Color := ClGreen;
FillRect(Rect);
AText := TPageControl(Control).Pages[TabIndex].Caption;
with Control.Canvas do
begin
APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2;
APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2;
TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText);
end;
end;
end;
end.
Delphi - .....................................
neoturk: ...Save - load tfont information to an ini file ?...
uses
Inifiles;
procedure SaveFont(FName: string; Section: string; smFont: TFont);
var
FStream: TIniFile;
begin
FStream := TIniFile.Create(FName);
try
FStream.WriteString(Section, 'Name', smFont.Name);
FStream.WriteInteger(Section, 'CharSet', smFont.CharSet);
FStream.WriteInteger(Section, 'Color', smFont.Color);
FStream.WriteInteger(Section, 'Size', smFont.Size);
FStream.WriteInteger(Section, 'Style', Byte(smFont.Style));
finally
FStream.Free;
end;
end;
procedure LoadFont(FName: string; Section: string; smFont: TFont);
var
FStream: TIniFile;
begin
FStream := TIniFile.Create(Fname);
try
smFont.Name := FStream.ReadString(Section, 'Name', smFont.Name);
smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, 'CharSet', smFont.CharSet));
smFont.Color := TColor(FStream.ReadInteger(Section, 'Color', smFont.Color));
smFont.Size := FStream.ReadInteger(Section, 'Size', smFont.Size);
smFont.Style := TFontStyles(Byte(FStream.ReadInteger(Section, 'Style', Byte(smFont.Style))));
finally
FStream.Free;
end;
end;
//Example:
//Beispiel:
//Save Font
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveFont('font.ini', 'label', label1.Font);
end;
procedure TForm1.Label1DblClick(Sender: TObject);
begin
if FontDialog1.Execute then
label1.Font := FontDialog1.Font
end;
//Load Font
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadFont('font.ini', 'label', label1.Font);
end;
Delphi - .....................................
neoturk: ...Save - load tfont information to an ini file ?...
uses
Inifiles;
procedure SaveFont(FName: string; Section: string; smFont: TFont);
var
FStream: TIniFile;
begin
FStream := TIniFile.Create(FName);
try
FStream.WriteString(Section, 'Name', smFont.Name);
FStream.WriteInteger(Section, 'CharSet', smFont.CharSet);
FStream.WriteInteger(Section, 'Color', smFont.Color);
FStream.WriteInteger(Section, 'Size', smFont.Size);
FStream.WriteInteger(Section, 'Style', Byte(smFont.Style));
finally
FStream.Free;
end;
end;
procedure LoadFont(FName: string; Section: string; smFont: TFont);
var
FStream: TIniFile;
begin
FStream := TIniFile.Create(Fname);
try
smFont.Name := FStream.ReadString(Section, 'Name', smFont.Name);
smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, 'CharSet', smFont.CharSet));
smFont.Color := TColor(FStream.ReadInteger(Section, 'Color', smFont.Color));
smFont.Size := FStream.ReadInteger(Section, 'Size', smFont.Size);
smFont.Style := TFontStyles(Byte(FStream.ReadInteger(Section, 'Style', Byte(smFont.Style))));
finally
FStream.Free;
end;
end;
//Example:
//Beispiel:
//Save Font
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveFont('font.ini', 'label', label1.Font);
end;
procedure TForm1.Label1DblClick(Sender: TObject);
begin
if FontDialog1.Execute then
label1.Font := FontDialog1.Font
end;
//Load Font
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadFont('font.ini', 'label', label1.Font);
end;
Delphi - .....................................
neoturk: ...Insert a file in a tmemo at the cursor position ?...
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile('c:afile.txt');
Memo1.SetSelTextBuf(PChar(sl.Text));
finally
sl.Free;
end;
end;
Delphi - .....................................
neoturk: ...Insert a file in a tmemo at the cursor position ?...
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile('c:afile.txt');
Memo1.SetSelTextBuf(PChar(sl.Text));
finally
sl.Free;
end;
end;
Delphi - .....................................
neoturk: ...Use some tstream utility functions ?...
{
These are three utility functions to write strings to a TStream.
Nothing fancy, but I just ended up coding this repeatedly so
I made these functions. }
{
Hier sind einige TStreaam Hilfsfunktionen um strings
in einen TStream zu schreiben.
}
unit ClassUtils;
interface
uses
SysUtils,
Classes;
{: Write a string to the stream
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function Writestring(_Stream: TStream; const _s: string): Integer;
{: Write a string to the stream appending CRLF
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function WritestringLn(_Stream: TStream; const _s: string): Integer;
{: Write formatted data to the stream appending CRLF
@param Stream is the TStream to write to.
@param Format is a format string as used in sysutils.format
@param Args is an array of const as used in sysutils.format
@returns the number of bytes written. }
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
implementation
function Writestring(_Stream: TStream; const _s: string): Integer;
begin
Result := _Stream.Write(PChar(_s)^, Length(_s));
end;
function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
Result := Writestring(_Stream, _s);
Result := Result + Writestring(_Stream, #13#10);
end;
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
begin
Result := WritestringLn(_Stream, Format(_Format, _Args));
end;
Delphi - .....................................
neoturk: ...Use some tstream utility functions ?...
{
These are three utility functions to write strings to a TStream.
Nothing fancy, but I just ended up coding this repeatedly so
I made these functions. }
{
Hier sind einige TStreaam Hilfsfunktionen um strings
in einen TStream zu schreiben.
}
unit ClassUtils;
interface
uses
SysUtils,
Classes;
{: Write a string to the stream
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function Writestring(_Stream: TStream; const _s: string): Integer;
{: Write a string to the stream appending CRLF
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function WritestringLn(_Stream: TStream; const _s: string): Integer;
{: Write formatted data to the stream appending CRLF
@param Stream is the TStream to write to.
@param Format is a format string as used in sysutils.format
@param Args is an array of const as used in sysutils.format
@returns the number of bytes written. }
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
implementation
function Writestring(_Stream: TStream; const _s: string): Integer;
begin
Result := _Stream.Write(PChar(_s)^, Length(_s));
end;
function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
Result := Writestring(_Stream, _s);
Result := Result + Writestring(_Stream, #13#10);
end;
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
begin
Result := WritestringLn(_Stream, Format(_Format, _Args));
end;
Delphi - .....................................
neoturk: ...Write- append text to a file ?...
function AppendOrWriteTextToFile(FileName : TFilename; WriteText : string): boolean;
var
f : Textfile;
begin
Result := False;
AssignFile(f, FileName);
try
if FileExists(FileName) = False then
Rewrite(f)
else
begin
Append(f);
end;
Writeln(f, WriteText);
Result := True;
finally
CloseFile(f);
end;
end;
// Sample Source...
procedure TForm1.Close1Click(Sender : TObject);
var
dir, log : string;
begin
dir := ExtractFilePath(Application.Exename);
log := 'Last Programm Termination: ' + DateTimeToStr(now);
AppendOrWriteTextToFile(dir + 'logfile.txt', log)
end;
Delphi - .....................................
neoturk: ...Write- append text to a file ?...
function AppendOrWriteTextToFile(FileName : TFilename; WriteText : string): boolean;
var
f : Textfile;
begin
Result := False;
AssignFile(f, FileName);
try
if FileExists(FileName) = False then
Rewrite(f)
else
begin
Append(f);
end;
Writeln(f, WriteText);
Result := True;
finally
CloseFile(f);
end;
end;
// Sample Source...
procedure TForm1.Close1Click(Sender : TObject);
var
dir, log : string;
begin
dir := ExtractFilePath(Application.Exename);
log := 'Last Programm Termination: ' + DateTimeToStr(now);
AppendOrWriteTextToFile(dir + 'logfile.txt', log)
end;
Delphi - .....................................
neoturk: ...Stream multiple components to clipboard ?...
{
Clipboard has methods GetComponent and SetComponent but we need
to stream multiple components to the clipboard to include copy paste type
of feature.
Die Zwischenablage hat die Methoden GetComponent and SetComponent
aber wir wollen mehrere Komponenten in die
Zwischenablage speichern und wieder auslesen.
}
procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var
hMem: THandle;
pMem: Pointer;
begin
S.Position := 0;
hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
if hMem <> 0 then
begin
pMem := GlobalLock(hMem);
if pMem <> nil then
begin
S.Read(pMem^, S.Size);
S.Position := 0;
GlobalUnlock(hMem);
Clipboard.Open;
try
Clipboard.SetAsHandle(fmt, hMem);
finally
Clipboard.Close;
end;
end { If }
else
begin
GlobalFree(hMem);
OutOfMemoryError;
end;
end { If }
else
OutOfMemoryError;
end; { CopyStreamToClipboard }
procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream);
var
hMem: THandle;
pMem: Pointer;
begin
hMem := Clipboard.GetAsHandle(fmt);
if hMem <> 0 then
begin
pMem := GlobalLock(hMem);
if pMem <> nil then
begin
S.Write(pMem^, GlobalSize(hMem));
S.Position := 0;
GlobalUnlock(hMem);
end { If }
else
raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' +
'obtained from clipboard!');
end; { If }
end; { CopyStreamFromClipboard }
Delphi - .....................................
neoturk: ...Stream multiple components to clipboard ?...
{
Clipboard has methods GetComponent and SetComponent but we need
to stream multiple components to the clipboard to include copy paste type
of feature.
Die Zwischenablage hat die Methoden GetComponent and SetComponent
aber wir wollen mehrere Komponenten in die
Zwischenablage speichern und wieder auslesen.
}
procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var
hMem: THandle;
pMem: Pointer;
begin
S.Position := 0;
hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
if hMem <> 0 then
begin
pMem := GlobalLock(hMem);
if pMem <> nil then
begin
S.Read(pMem^, S.Size);
S.Position := 0;
GlobalUnlock(hMem);
Clipboard.Open;
try
Clipboard.SetAsHandle(fmt, hMem);
finally
Clipboard.Close;
end;
end { If }
else
begin
GlobalFree(hMem);
OutOfMemoryError;
end;
end { If }
else
OutOfMemoryError;
end; { CopyStreamToClipboard }
procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream);
var
hMem: THandle;
pMem: Pointer;
begin
hMem := Clipboard.GetAsHandle(fmt);
if hMem <> 0 then
begin
pMem := GlobalLock(hMem);
if pMem <> nil then
begin
S.Write(pMem^, GlobalSize(hMem));
S.Position := 0;
GlobalUnlock(hMem);
end { If }
else
raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' +
'obtained from clipboard!');
end; { If }
end; { CopyStreamFromClipboard }
Delphi - .....................................
neoturk: ...Convert oem to ansi ?...
procedure ConvertFile(const FileName: string; fromCodepage: Integer);
var
ms: TMemoryStream;
begin
if getOEMCP <> fromCodepage then
raise Exception.Create('ConvertFile: Codepage doesn't match!');
ms := TMemoryStream.Create;
try
ms.LoadFromFile(FileName);
// make backup
ms.Position := 0;
ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));
// convert text
OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);
// save back to original file
ms.Position := 0;
ms.SaveToFile(FileName);
finally
ms.Free;
end;
end;
Delphi - .....................................
neoturk: ...Convert oem to ansi ?...
procedure ConvertFile(const FileName: string; fromCodepage: Integer);
var
ms: TMemoryStream;
begin
if getOEMCP <> fromCodepage then
raise Exception.Create('ConvertFile: Codepage doesn't match!');
ms := TMemoryStream.Create;
try
ms.LoadFromFile(FileName);
// make backup
ms.Position := 0;
ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));
// convert text
OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);
// save back to original file
ms.Position := 0;
ms.SaveToFile(FileName);
finally
ms.Free;
end;
end;
Delphi - .....................................
neoturk: ...Create an excel file without ole ?...
const
CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
CXlsBof[4] := BuildNumber;
XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;
procedure XlsEndStream(XlsStream: TStream);
begin
XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;
procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := ARow;
CXlsRk[3] := ACol;
XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
XlsStream.WriteBuffer(V, 4);
end;
procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Double);
begin
CXlsNumber[2] := ARow;
CXlsNumber[3] := ACol;
XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
XlsStream.WriteBuffer(AValue, 8);
end;
procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := ARow;
CXlsLabel[3] := ACol;
CXlsLabel[5] := L;
XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FStream: TFileStream;
I, J: Integer;
begin
FStream := TFileStream.Create('c:e.xls', fmCreate);
try
XlsBeginStream(FStream, 0);
for I := 0 to 99 do
for J := 0 to 99 do
begin
XlsWriteCellNumber(FStream, I, J, 34.34);
// XlsWriteCellRk(FStream, I, J, 3434);
// XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
end;
XlsEndStream(FStream);
finally
FStream.Free;
end;
end;
Delphi - .....................................
neoturk: ...Create an excel file without ole ?...
const
CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
CXlsBof[4] := BuildNumber;
XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;
procedure XlsEndStream(XlsStream: TStream);
begin
XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;
procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := ARow;
CXlsRk[3] := ACol;
XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
XlsStream.WriteBuffer(V, 4);
end;
procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
const AValue: Double);
begin
CXlsNumber[2] := ARow;
CXlsNumber[3] := ACol;
XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
XlsStream.WriteBuffer(AValue, 8);
end;
procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := ARow;
CXlsLabel[3] := ACol;
CXlsLabel[5] := L;
XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FStream: TFileStream;
I, J: Integer;
begin
FStream := TFileStream.Create('c:e.xls', fmCreate);
try
XlsBeginStream(FStream, 0);
for I := 0 to 99 do
for J := 0 to 99 do
begin
XlsWriteCellNumber(FStream, I, J, 34.34);
// XlsWriteCellRk(FStream, I, J, 3434);
// XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
end;
XlsEndStream(FStream);
finally
FStream.Free;
end;
end;
Delphi - .....................................
neoturk: ...Capture the output from a dos application ?...
{----------------------------CreateDOSProcessRedirected---------------------------
Description : executes a (DOS!) app defined in the CommandLine parameter redirected
to take input from InputFile and give output to OutputFile
Result : True on success
Parameters :
CommandLine : the command line for the app, including its full path
InputFile : the ascii file where from the app takes input
OutputFile : the ascii file to which the app's output is redirected
ErrMsg : additional error message string. Can be empty
Error checking : YES
Target : Delphi 2, 3, 4
Author : Theodoros Bebekis, email bebekis@otenet.gr
Notes :
Example call : CreateDOSProcessRedirected('C:MyDOSApp.exe',
'C:InputPut.txt',
'C:OutPut.txt',
'Please, record this message')
-----------------------------------------------------------------------------------}
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
ErrMsg: string): Boolean;
const
ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
OldCursor: TCursor;
pCommandLine: array[0..MAX_PATH] of Char;
pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
SecAtrrs: TSecurityAttributes;
hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
begin
Result := False;
{ check for InputFile existence }
if not FileExists(InputFile) then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'Input file * %s *' + #10 +
'does not exist' + #10 + #10 +
ErrMsg, [InputFile]);
{ save the cursor }
OldCursor := Screen.Cursor;
Screen.Cursor := crHourglass;
{ copy the parameter Pascal strings to null terminated strings }
StrPCopy(pCommandLine, CommandLine);
StrPCopy(pInputFile, InputFile);
StrPCopy(pOutPutFile, OutputFile);
try
{ prepare SecAtrrs structure for the CreateFile calls
This SecAttrs structure is needed in this case because
we want the returned handle can be inherited by child process
This is true when running under WinNT.
As for Win95 the documentation is quite ambiguous }
FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
SecAtrrs.nLength := SizeOf(SecAtrrs);
SecAtrrs.lpSecurityDescriptor := nil;
SecAtrrs.bInheritHandle := True;
{ create the appropriate handle for the input file }
hInputFile := CreateFile(pInputFile,
{ pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{ access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{ share mode } @SecAtrrs, { pointer to security attributes }
OPEN_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0); { handle to file with attributes to copy }
{ is hInputFile a valid handle? }
if hInputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the input file * %s *' + #10 + #10 +
ErrMsg, [InputFile]);
{ create the appropriate handle for the output file }
hOutputFile := CreateFile(pOutPutFile,
{ pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{ access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{ share mode } @SecAtrrs, { pointer to security attributes }
CREATE_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0); { handle to file with attributes to copy }
{ is hOutputFile a valid handle? }
if hOutputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the output file * %s *' + #10 + #10 +
ErrMsg, [OutputFile]);
{ prepare StartupInfo structure }
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hOutputFile;
StartupInfo.hStdInput := hInputFile;
{ create the app }
Result := CreateProcess(nil, { pointer to name of executable module }
pCommandLine,
{ pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
True, { handle inheritance flag }
CREATE_NEW_CONSOLE or
REALTIME_PRIORITY_CLASS, { creation flags }
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo); { pointer to PROCESS_INF }
{ wait for the app to finish its job and take the handles to free them later }
if Result then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
hAppProcess := ProcessInfo.hProcess;
hAppThread := ProcessInfo.hThread;
end
else
raise Exception.Create(ROUTINE_ID + #10 + #10 +
'Function failure' + #10 + #10 +
ErrMsg);
finally
{ close the handles
Kernel objects, like the process and the files we created in this case,
are maintained by a usage count.
So, for cleaning up purposes we have to close the handles
to inform the system that we don't need the objects anymore }
if hOutputFile <> 0 then CloseHandle(hOutputFile);
if hInputFile <> 0 then CloseHandle(hInputFile);
if hAppThread <> 0 then CloseHandle(hAppThread);
if hAppProcess <> 0 then CloseHandle(hAppProcess);
{ restore the old cursor }
Screen.Cursor := OldCursor;
end;
end;
Delphi - .....................................
neoturk: ...Capture the output from a dos application ?...
{----------------------------CreateDOSProcessRedirected---------------------------
Description : executes a (DOS!) app defined in the CommandLine parameter redirected
to take input from InputFile and give output to OutputFile
Result : True on success
Parameters :
CommandLine : the command line for the app, including its full path
InputFile : the ascii file where from the app takes input
OutputFile : the ascii file to which the app's output is redirected
ErrMsg : additional error message string. Can be empty
Error checking : YES
Target : Delphi 2, 3, 4
Author : Theodoros Bebekis, email bebekis@otenet.gr
Notes :
Example call : CreateDOSProcessRedirected('C:MyDOSApp.exe',
'C:InputPut.txt',
'C:OutPut.txt',
'Please, record this message')
-----------------------------------------------------------------------------------}
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
ErrMsg: string): Boolean;
const
ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
OldCursor: TCursor;
pCommandLine: array[0..MAX_PATH] of Char;
pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
SecAtrrs: TSecurityAttributes;
hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
begin
Result := False;
{ check for InputFile existence }
if not FileExists(InputFile) then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'Input file * %s *' + #10 +
'does not exist' + #10 + #10 +
ErrMsg, [InputFile]);
{ save the cursor }
OldCursor := Screen.Cursor;
Screen.Cursor := crHourglass;
{ copy the parameter Pascal strings to null terminated strings }
StrPCopy(pCommandLine, CommandLine);
StrPCopy(pInputFile, InputFile);
StrPCopy(pOutPutFile, OutputFile);
try
{ prepare SecAtrrs structure for the CreateFile calls
This SecAttrs structure is needed in this case because
we want the returned handle can be inherited by child process
This is true when running under WinNT.
As for Win95 the documentation is quite ambiguous }
FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
SecAtrrs.nLength := SizeOf(SecAtrrs);
SecAtrrs.lpSecurityDescriptor := nil;
SecAtrrs.bInheritHandle := True;
{ create the appropriate handle for the input file }
hInputFile := CreateFile(pInputFile,
{ pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{ access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{ share mode } @SecAtrrs, { pointer to security attributes }
OPEN_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0); { handle to file with attributes to copy }
{ is hInputFile a valid handle? }
if hInputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the input file * %s *' + #10 + #10 +
ErrMsg, [InputFile]);
{ create the appropriate handle for the output file }
hOutputFile := CreateFile(pOutPutFile,
{ pointer to name of the file }
GENERIC_READ or GENERIC_WRITE,
{ access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE,
{ share mode } @SecAtrrs, { pointer to security attributes }
CREATE_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0); { handle to file with attributes to copy }
{ is hOutputFile a valid handle? }
if hOutputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the output file * %s *' + #10 + #10 +
ErrMsg, [OutputFile]);
{ prepare StartupInfo structure }
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hOutputFile;
StartupInfo.hStdInput := hInputFile;
{ create the app }
Result := CreateProcess(nil, { pointer to name of executable module }
pCommandLine,
{ pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
True, { handle inheritance flag }
CREATE_NEW_CONSOLE or
REALTIME_PRIORITY_CLASS, { creation flags }
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo); { pointer to PROCESS_INF }
{ wait for the app to finish its job and take the handles to free them later }
if Result then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
hAppProcess := ProcessInfo.hProcess;
hAppThread := ProcessInfo.hThread;
end
else
raise Exception.Create(ROUTINE_ID + #10 + #10 +
'Function failure' + #10 + #10 +
ErrMsg);
finally
{ close the handles
Kernel objects, like the process and the files we created in this case,
are maintained by a usage count.
So, for cleaning up purposes we have to close the handles
to inform the system that we don't need the objects anymore }
if hOutputFile <> 0 then CloseHandle(hOutputFile);
if hInputFile <> 0 then CloseHandle(hInputFile);
if hAppThread <> 0 then CloseHandle(hAppThread);
if hAppProcess <> 0 then CloseHandle(hAppProcess);
{ restore the old cursor }
Screen.Cursor := OldCursor;
end;
end;
