IdPOP3, IdMessage and attachment gmail - attachment

I need help, please. I can connect to Gmail and I can receive emails.
What I can't do is to save attachments. I think that it is a setting problem? I have IdAttachment and IdAttachmentFile in my uses clause. I tried all sorts of ContentType settings, but nothing seams to work.
if (IdMessage1.MessageParts.Items[i] is TIdAttachment) then
begin
with (IdMessage1.MessageParts.Items[i] as TIdAttachment) do
begin
SaveToFile('C:\test123.txt');
end;
end;
Here is my code:
procedure TForm1.Button1Click(Sender: TObject);
var
i, j: Integer;
IdSSLIOHandlerSocket: TIdSSLIOHandlerSocketOpenSSL;
bodytext: string;
s: string;
n: string;
mailcount : integer;
TMP: string;
begin
IdSSLIOHandlerSocket := TIdSSLIOHandlerSocketOpenSSL.Create(Self);
idpop31.IOHandler := IdSSLIOHandlerSocket;
idpop31.UseTLS := utUseImplicitTLS;
IdPOP31.Host := 'pop.gmail.com';
IdPOP31.Port := 995;
IdPOP31.UseTLS := utUseImplicitTLS;
IdPOP31.Username := 'name#gmail.com';
IdPOP31.Password := 'xxxxx';
IdPOP31.Connect;
Mailcount:= idpop31.checkmessages;
For i:= 1 to mailcount do
Begin
Idmessage1.clear;
Idpop31.retrieveheader (i,idmessage1);
TMP:= idmessage1.subject;
Mailzeug.lines. Add (TMP);
Idpop31.retrieve (i,idmessage1);
TMP:= idmessage1.body.Text;
Mailzeug.lines. Add (TMP);
if (IdMessage1.MessageParts.Items[i] is TIdAttachment) then
begin
TIdAttachment(IdMessage1.MessageParts.Items[i]).SaveToFile(TIdAttachment(IdMessage1.MessageParts.Items[I]).Filename);
end;
end;
Idpop31.disconnect;
end;

You are using the wrong index value with the IdMessage1.MessageParts.Items[] property, that is why you are getting an "out of range" error. You are using the email's (1-based) index within the mailbox as-if it were a (0-based) attachment index within the email.
You need a 2nd loop to iterate the MessageParts collection of each email that is downloaded, eg:
procedure TForm1.Button1Click(Sender: TObject);
var
i, j: Integer;
IdSSLIOHandlerSocket: TIdSSLIOHandlerSocketOpenSSL;
BodyText: string;
MailCount : integer;
part: TIdMessagePart;
begin
IdSSLIOHandlerSocket := TIdSSLIOHandlerSocketOpenSSL.Create(Self);
IdPOP31.IOHandler := IdSSLIOHandlerSocket;
IdPOP31.Host := 'pop.gmail.com';
IdPOP31.Port := 995;
IdPOP31.UseTLS := utUseImplicitTLS;
IdPOP31.Username := 'name#gmail.com';
IdPOP31.Password := 'xxxxx';
IdPOP31.Connect;
try
MailCount := IdPOP31.CheckMessages;
for i := 1 to MailCount do
begin
IdMessage1.Clear;
IdPOP31.Retrieve(i, IdMessage1);
Mailzeug.Lines.Add(IdMessage1.Subject);
BodyText := IdMessage1.Body.Text;
Mailzeug.Lines.Add(BodyText);
for j := 0 to IdMessage1.MessagePart.Count-1 do
begin
part := IdMessage1.MessageParts.Items[j];
if (part is TIdAttachment) then
begin
TIdAttachment(part).SaveToFile(TIdAttachment(part).Filename);
end;
end;
end;
finally
IdPOP31.Disconnect;
end;
end;

Related

Delphi 7 - Check if server is online

I have a program created in Delphi 7 that uses ftp downloading.
How can i insert into that program to check for a server status?
For example if server is online to produce a green image, if server is offline o produce a red image. Here is the code.
unit Download;
interface
uses
Classes, Wininet, Windows, SysUtils, Dialogs, Forms;
type
GFilesThread = class(TThread)
private
LTemp : Longword;
STemp : string;
FilesToGet : TStringList;
FilesSize : Longword;
CBackup : integer;
CRevision : integer;
CForceCheck : boolean;
CSwitch : integer;
UUrl : string;
USelfParam : string;
Dir: string;
FSource: TStream;
protected
procedure Execute; override;
procedure UpdateFileProgress;
procedure SetFileProgressMax;
procedure UpdateStatusLabel;
procedure UpdateFileDecompStat;
procedure UpdateFilesProgress;
procedure CheckFiles(FList : TStringList);
procedure BZProgress(Sender: TObject);
procedure LockFMain;
procedure UNLockFMain;
procedure GetFiles;
procedure SelfUpdate(SelfVal : string);
procedure UpdateRevision;
procedure ModHosts(Lines : TStringList);
procedure DoUncompressStream(ASource, ADest: TStream);
procedure DoUncompress(const ASource, ADest: TFileName);
function HTTPGetFile(const fileURL, FileName: string; sh_progress: boolean): boolean;
public
property CreateBackup : integer write CBackup;
property UpdatesUrl : string write UUrl;
property LocalRevision : integer write CRevision;
property ForceCheck : boolean write CForceCheck;
end;
implementation
uses Launcher, CheckFiles, BZip2, md5, FileList;
// -------- by 667
procedure GFilesThread.UpdateStatusLabel;
begin
FMain.Label3.Caption:=STemp;
end;
procedure GFilesThread.SetFileProgressMax;
begin
if(CSwitch=0) then
FMain.Gauge1.MaxValue:=LTemp;
if(CSwitch=1) then
FMain.Gauge2.MaxValue:=LTemp;
end;
procedure GFilesThread.UpdateFileProgress;
begin
FMain.Gauge1.Progress:=LTemp;
end;
procedure GFilesThread.UpdateFilesProgress;
begin
FMain.Gauge2.Progress:=LTemp;
end;
procedure GFilesThread.UpdateRevision;
begin
FMain.UpdateRevision(IntToStr(CRevision));
end;
procedure GFilesThread.UpdateFileDecompStat;
begin
FMain.Gauge1.Progress:=LTemp;
end;
procedure GFilesThread.BZProgress(Sender: TObject);
begin
LTemp:=FSource.Position;
Synchronize(UpdateFileDecompStat);
end;
procedure GFilesThread.LockFMain;
begin
Fmain.ImgBtn1.Visible:=False;
Fmain.ImgBtn2.Visible:=False;
Fmain.ImgBtn5.Enabled:=False;
end;
procedure GFilesThread.UNLockFMain;
begin
Fmain.ImgBtn1.Visible:=True;
Fmain.ImgBtn2.Visible:=True;
Fmain.ImgBtn5.Enabled:=True;
end;
// --------- by 667
function GFilesThread.HTTPGetFile(const fileURL, FileName: string; sh_progress: boolean): boolean;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: Longword;
f: file;
sAppName: string;
begin
Result := False;
sAppName := 'L2ClientUpdater';
LTemp:=0;
hSession := InternetOpen(PChar(sAppName),
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, 0, 0);
if (hURL <> nil) then begin
try
DeleteUrlCacheEntry(PChar(fileURL));
AssignFile(f, FileName);
Rewrite(f,1);
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen);
if (sh_progress) then
begin
LTemp:=LTemp+BufferLen;
Synchronize(UpdateFileProgress);
end;
until
BufferLen = 0;
CloseFile(f);
Result := True;
finally
InternetCloseHandle(hURL);
end;
end;
finally
InternetCloseHandle(hSession);
end;
LTemp:=0;
Synchronize(UpdateFileProgress);
end;
procedure GFilesThread.DoUncompress(const ASource, ADest: TFileName);
var
Source, Dest: TStream;
begin
Source := TFileStream.Create(ASource, fmOpenRead + fmShareDenyWrite);
try
Dest := TFileStream.Create(ADest, fmCreate);
try
DoUncompressStream(Source, Dest);
finally
Dest.Free;
end;
finally
Source.Free;
DeleteFile(ASource);
end;
end;
procedure GFilesThread.DoUncompressStream(ASource, ADest: TStream);
const
BufferSize = 65536;
var
Count: Integer;
Decomp: TBZDecompressionStream;
Buffer: array[0..BufferSize - 1] of Byte;
begin
FSource := ASource;
LTemp:=FSource.Size;
CSwitch:=0;
Synchronize(SetFileProgressMax);
Decomp := TBZDecompressionStream.Create(ASource);
try
Decomp.OnProgress := BZProgress;
while True do
begin
Count := Decomp.Read(Buffer, BufferSize);
if Count <> 0 then ADest.WriteBuffer(Buffer, Count) else Break;
end;
finally
Decomp.Free;
FSource := nil;
LTemp:=0;
Synchronize(UpdateFileDecompStat);
end;
end;
procedure GFilesThread.CheckFiles(FList : TStringList);
var
i: integer;
FParam: TStringList;
FNameLocal: string;
begin
if(FList.Count>0) and (FList[0]<>'FAIL') and (not terminated) then
begin
STemp:='Checking files';
Synchronize(UpdateStatusLabel);
CSwitch:=1;
LTemp:=FList.Count-1;
Synchronize(SetFileProgressMax);
FParam:=TStringList.Create;
for i:=0 to FList.Count-1 do
begin
LTemp:=i;
Synchronize(UpdateFilesProgress);
FParam:=Tokenize(FList[i],'|');
FNameLocal:=Dir+FParam[2];
STemp:='Checking '+FParam[2];
Synchronize(UpdateStatusLabel);
if (not FileExists(FNameLocal)) then
begin
FilesToGet.Add(FList[i]);
FilesSize:=FilesSize+StrToInt(FParam[0]);
end
else
begin
if (MD5Print(MD5File(FNameLocal))<>FParam[1]) then
begin
FilesToGet.Add(FList[i]);
FilesSize:=FilesSize+StrToInt(FParam[0]);
end;
end;
end;
FParam.Free;
LTemp:=0;
Synchronize(UpdateFilesProgress);
STemp:='';
Synchronize(UpdateStatusLabel);
end;
end;
procedure GFilesThread.SelfUpdate(SelfVal : string);
var
FParam: TStringList;
FNameLocal: string;
F:boolean;
begin
if(SelfVal<>'') then
begin
FParam:=TStringList.Create;
FParam:=Tokenize(SelfVal,'|');
FNameLocal:=Dir+FParam[2];
if (MD5Print(MD5File(FNameLocal))<>FParam[1]) then
begin
FilesSize:=FilesSize+StrToInt(FParam[0]);
F:=HTTPGetFile(UUrl+FParam[2]+'.bz2',FNameLocal+'.bz2',True);
if(F) then begin
try
DoUncompress(FNameLocal+'.bz2',Dir+FParam[2]+'.New');
GenKillerBat(FParam[2]);
RunApp(Dir+'Update.bat');
except
STemp:='Update Failed';
DeleteFile(FNameLocal);
end;
end;
end;
FParam.Free;
end;
end;
procedure GFilesThread.ModHosts(Lines : TStringList);
var
Hosts : textfile;
H, HostsStrings, HostLineParam : TStringList;
HostsPath, temp : string;
i, z, funnyFlag : integer;
WindirP : PChar;
Res : cardinal;
begin
WinDirP := StrAlloc(MAX_PATH);
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then
begin
if(FileExists(StrPas(WinDirP)+'\system32\drivers\etc\hosts.msn')) then
HostsPath := StrPas(WinDirP)+'\system32\drivers\etc\hosts.msn'
else
HostsPath := StrPas(WinDirP)+'\system32\drivers\etc\hosts';
AssignFile(Hosts,HostsPath);
Reset(Hosts);
HostsStrings:= TStringList.Create;
H:= TStringList.Create;
H.Add('#-------- Added by L2Updater --------');
while (not Eof(Hosts)) do
begin
ReadLn(Hosts, temp);
HostsStrings.Add(Trim(temp));
end ;
Reset(Hosts);
for i:=0 to Lines.Count-1 do
begin
funnyFlag:=0;
HostLineParam:=Tokenize(Lines[i],'|');
for z:=0 to HostsStrings.Count-1 do
begin
if (StrSearch(1,HostsStrings[z],HostLineParam[0])>0) and (HostsStrings[z][1]<>'#') then
begin
if (StrSearch(1,HostsStrings[z],HostLineParam[1]+#9)= 0) and (StrSearch(1,HostsStrings[z],HostLineParam[1]+' ')= 0 ) then
begin
HostsStrings[z]:= '#'+HostsStrings[z];
funnyFlag:=1;
end
else funnyFlag:=2;
end;
end;
if (funnyFlag=1) or (funnyFlag=0) then
H.Add(HostLineParam[1]+#9+HostLineParam[0]);
end;
H.Add('#-----------------');
if H.Count>2 then
begin
Rewrite(Hosts);
STemp:='Applying changes to Hosts';
Synchronize(UpdateStatusLabel);
for i:=0 to HostsStrings.Count-1 do
begin
WriteLn(Hosts,HostsStrings[i]);
end;
for i:=0 to H.Count-1 do
begin
WriteLn(Hosts,H[i]);
end;
STemp:='Hosts file chamged';
Synchronize(UpdateStatusLabel);
end;
H.Free; HostsStrings.Free; HostLineParam.Free;
CloseFile(Hosts);
end;
end;
procedure GFilesThread.GetFiles;
var
FParam : TStringList;
i : integer;
F, error : boolean;
LocalFile, BakFile: string;
begin
error := False;
if (FilesToGet.Count>0) then
begin
FParam:=TStringList.Create;
LTemp:=FilesToGet.Count-1;
CSwitch:=1;
Synchronize(SetFileProgressMax);
i:=0;
while (i < FilesToGet.Count) and (not terminated) do
begin
FParam:=Tokenize(FilesToGet[i],'|');
LocalFile:= Dir+FParam[2];
STemp:='Downloading '+ FParam[2];
Synchronize(UpdateStatusLabel);
CSwitch:=0;
LTemp:= StrToInt(FParam[0]);
Synchronize(SetFileProgressMax);
if (not DirectoryExists(ExtractFilePath(LocalFile))) then
ForceDirectories(ExtractFilePath(LocalFile));
F:=HTTPGetFile(UUrl+ReplaceStr(FParam[2],'\','/')+'.bz2',LocalFile+'.bz2',True);
if (F) then
begin
try
if (CBackup=1) then
begin
BakFile:=Dir+'backup\'+FParam[2];
if (not DirectoryExists(ExtractFilePath(BakFile))) then
ForceDirectories(ExtractFilePath(BakFile));
CopyFile(PChar(LocalFile),PChar(BakFile),false);
end;
STemp:='Extracting '+ FParam[2];
Synchronize(UpdateStatusLabel);
DoUncompress(LocalFile+'.bz2',Dir+FParam[2]);
except
STemp:='Update Failed';
error := True;
end;
end
else
begin
STemp:='Update Failed';
error := True;
Break;
end;
inc(i);
LTemp:=i;
CSwitch:=1;
Synchronize(UpdateFilesProgress);
end;
LTemp:=0;
Synchronize(UpdateFilesProgress);
FParam.Free;
if (not error) then
STemp:='All files have been updated.';
end
else STemp:='';
end;
procedure GFilesThread.Execute;
var
List: TListFile;
CFiles, NFiles, HostsLines : TStringList;
TRev, IsModHosts : integer;
F : boolean;
begin
Dir:=GetCurrentDir+'\';
FilesSize:=0;
Synchronize(LockFMain);
STemp:='Downloading updates list';
Synchronize(UpdateStatusLabel);
if(UUrl[length(UUrl)]<>'/') then UUrl:=UUrl+'/';
F:=HTTPGetFile(UUrl+'files.lst.bz2',Dir+'files.lst.bz2', True);
if (F) then
begin
STemp:='';
Synchronize(UpdateStatusLabel);
try
DoUncompress(Dir+'files.lst.bz2',Dir+'files.lst');
except
STemp:='Update Failed';
Synchronize(UpdateStatusLabel);
DeleteFile(Dir+'files.lst');
end;
if(FileExists(Dir+'files.lst')) then
begin
FilesToGet := TStringList.Create;
List := TListFile.Create(Dir+'files.lst');
CFiles:=TStringList.Create;
TRev:=StrToInt(List.GetKeyValue('settings','Rev'));
IsModHosts:=StrToInt(List.GetKeyValue('settings','ModHosts'));
if (IsModHosts = 1) then
begin
HostsLines:= TStringList.Create;
HostsLines:= List.GetFSection('hosts');
try
ModHosts(HostsLines);
finally
HostsLines.Free;
end;
end;
USelfParam:= List.GetFSection('self')[0];
if(USelfParam<>'FAIL') then SelfUpdate(USelfParam);
CFiles:=List.GetFSection('files_critical');
CheckFiles(CFiles);
CFiles.Free;
if (CForceCheck) or (TRev>CRevision) then
begin
if (CBackup=1) then
begin
DelDir(Dir+'backup');
MkDir(Dir+'backup');
end;
NFiles:=TStringList.Create;
NFiles:=List.GetFSection('files_normal');
CheckFiles(NFiles);
NFiles.Free;
end;
GetFiles;
List.Destroy;
FilesToGet.Free;
DeleteFile(Dir+'files.lst');
if TRev>CRevision then
begin
CRevision:=TRev;
Synchronize(UpdateRevision);
end;
end;
end
else
begin
STemp:='Update Failed';
DeleteFile(Dir+'files.lst');
end;
Synchronize(UpdateStatusLabel);
Synchronize(UNLockFMain);
end;
end.
function CanConnect(const aUserName, aPassword, aHost: String; out aErrm: string): boolean;
var
LocalIDFTP: TIdFTP;
begin
aErrm := '';
LocalIDFTP := TIdFTP.Create(nil);
try
LocalIDFTP.UserName := aUserName;
LocalIDFTP.Password := aPassword;
LocalIDFTP.Host := aHost;
LocalIDFTP.Passive := True;
try
LocalIDFTP.Connect;
LocalIDFTP.Quit;
result := true;
except
on E: Exception do
begin
aErrm := 'Unable to connect to FTP site: ' + E.Message;
Result := FALSE;
end;
end;
finally
if Assigned(LocalIDFTP) then
LocalIDFTP.Free
else
Result := FALSE;
end;
end; {CanConnect}

Posting Data with Indy and Receiving it to TWebBrowser

I am trying to post data to bing with this code
function PostExample: string;
var
lHTTP: TIdHTTP;
lParamList: TStringList;
begin
lParamList := TStringList.Create;
lParamList.Add('q=test');
lHTTP := TIdHTTP.Create(nil);
try
Result := lHTTP.Post('http://www.bing.com/', lParamList);
finally
FreeAndNil(lHTTP);
FreeAndNil(lParamList);
end;
end;
And then, how can I get the result to the TWebBrowser and display it?
Try LoadDocFromString:
procedure LoadBlankDoc(ABrowser: TWebBrowser);
begin
ABrowser.Navigate('about:blank');
while ABrowser.ReadyState <> READYSTATE_COMPLETE do
begin
Application.ProcessMessages;
Sleep(0);
end;
end;
procedure CheckDocReady(ABrowser: TWebBrowser);
begin
if not Assigned(ABrowser.Document) then
LoadBlankDoc(ABrowser);
end;
procedure LoadDocFromString(ABrowser: TWebBrowser; const HTMLString: wideString);
var
v: OleVariant;
HTMLDocument: IHTMLDocument2;
begin
CheckDocReady(ABrowser);
HTMLDocument := ABrowser.Document as IHTMLDocument2;
v := VarArrayCreate([0, 0], varVariant);
v[0] := HTMLString;
HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
HTMLDocument.Close;
end;
Or you can use the memory streams for loading
uses
OleCtrls, SHDocVw, IdHTTP, ActiveX;
function PostRequest(const AURL: string; const AParams: TStringList;
const AWebBrowser: TWebBrowser): Boolean;
var
IdHTTP: TIdHTTP;
Response: TMemoryStream;
begin
Result := True;
try
AWebBrowser.Navigate('about:blank');
while AWebBrowser.ReadyState < READYSTATE_COMPLETE do
Application.ProcessMessages;
Response := TMemoryStream.Create;
try
IdHTTP := TIdHTTP.Create(nil);
try
IdHTTP.Post(AURL, AParams, Response);
if Response.Size > 0 then
begin
Response.Position := 0;
(AWebBrowser.Document as IPersistStreamInit).Load(
TStreamAdapter.Create(Response, soReference));
end;
finally
IdHTTP.Free;
end;
finally
Response.Free;
end;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Params: TStringList;
begin
Params := TStringList.Create;
try
Params.Add('q=test');
if not PostRequest('http://www.bing.com/', Params, WebBrowser1) then
ShowMessage('An unexpected error occured!');
finally
Params.Free;
end;
end;

How to load and save StringGrid content?

First part of the code works OK while the second (commented) does not.
It overwrites my A1 file although it should write to A2.
procedure TForm1.AdvGlowButton12Click(Sender: TObject);
var
i,j: Integer;
Seznam: TStrings;
ApplicationPath: string;
begin
if (cxRadiogroup3.ItemIndex and cxRadiogroup2.ItemIndex) = 0 then begin
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
for i:=0 to advStringGrid2.ColCount-1 do
Seznam.AddStrings(advStringGrid2.Cols [i]);
for i:=0 to advStringGrid2.rowCount-1 do
Seznam.AddStrings(advStringGrid2.rows [j]);
Seznam.SaveToFile(ApplicationPath+'\A1.txt');
finally
seznam.free;
end;
end ;
//if cxRadiogroup3.ItemIndex = 1 and cxRadiogroup2.ItemIndex = 0 then begin
// ApplicationPath:= ExtractFileDir(Application.ExeName);
// Seznam:= TStringList.Create;
// try
// for i:=0 to advStringGrid2.ColCount-1 do
// Seznam.AddStrings(advStringGrid2.Cols [i]);
// for i:=0 to advStringGrid2.rowCount-1 do
// Seznam.AddStrings(advStringGrid2.rows [j]);
// Seznam.SaveToFile(ApplicationPath+'\A2.txt');
// finally
// seznam.free;
// end ;
//end
end;
What am I doing wrong ?
Also why is the stringgrid giving listindex out of bounds when I try to load into it contents from an empty text file? If I save empty stringgrid to that file,later ,though it has nothing in the file,it does not complain? Strange...
This is how I load A1 and A2 into the stringgrid.
procedure TForm1.cxRadioGroup2Click(Sender: TObject);
Var
I,j,k: Integer;
Seznam: TStrings;
ApplicationPath: string;
begin
case cxradioGroup2.ItemIndex of
0: begin
if cxradioGroup3.ItemIndex = 0 then begin
Seznam:= TStringList.Create;
AdvStringgrid2.ClearAll;
try
Seznam.LoadFromFile('A1.txt');
k:= 0;
for i:=0 to advStringGrid2.ColCount-1 do
for j:=0 to advStringGrid2.RowCount-1 do begin
advstringGrid2.Cells [i,j]:= Seznam.Strings [k];
Inc(k);
end;
finally
seznam.free;
end;
end;
if cxradioGroup3.ItemIndex = 1 then begin
Seznam:= TStringList.Create;
AdvStringgrid2.ClearAll;
try
Seznam.LoadFromFile('A2.txt');
k:=0;
for i:=0 to advStringGrid2.ColCount-1 do
for j:=0 to advStringGrid2.RowCount-1 do begin
advstringGrid2.Cells [i,j]:= Seznam.Strings [k];
Inc(k);
end;
finally
seznam.free;
end;
end;
end;
end;
end;
here is an old tipp from SwissDelphiCenter that could help you
// Save StringGrid1 to 'c:\temp.txt':
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Load StringGrid1 from 'c:\temp.txt':
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Save a TStringGrid to a file
procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
i, k: Integer;
begin
AssignFile(f, FileName);
Rewrite(f);
with StringGrid do
begin
// Write number of Columns/Rows
Writeln(f, ColCount);
Writeln(f, RowCount);
// loop through cells
for i := 0 to ColCount - 1 do
for k := 0 to RowCount - 1 do
Writeln(F, Cells[i, k]);
end;
CloseFile(F);
end;
// Load a TStringGrid from a file
procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
iTmp, i, k: Integer;
strTemp: String;
begin
AssignFile(f, FileName);
Reset(f);
with StringGrid do
begin
// Get number of columns
Readln(f, iTmp);
ColCount := iTmp;
// Get number of rows
Readln(f, iTmp);
RowCount := iTmp;
// loop through cells & fill in values
for i := 0 to ColCount - 1 do
for k := 0 to RowCount - 1 do
begin
Readln(f, strTemp);
Cells[i, k] := strTemp;
end;
end;
CloseFile(f);
end;
I'm trying to understand your code and tried him as good as it is possible for me to rewrite. (it's not tested)
procedure TForm1.AdvGlowButton12Click(Sender: TObject);
var
i, j: Integer;
Seznam: TStrings;
ApplicationPath: string;
fileName: string;
line: string;
begin
if (cxRadiogroup2.ItemIndex = 0) then begin
if (cxRadiogroup3.ItemIndex = 0) then
fileName:= 'A1.txt'
else
fileName:= 'A2.txt'
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
for k:=0 to advStringGrid2.RowCount-1 do begin
line:= '';
for i:=0 to advStringGrid2.ColCount-1 do
line = line + '|' + advStringGrid2.Cells[i, k];
Seznam.AddStrings(line);
end;
Seznam.SaveToFile(ApplicationPath + '\' + fileName);
finally
seznam.Free;
end;
end;
end;
procedure TForm1.cxRadioGroup2Click(Sender: TObject);
var
splitList: TStringList;
i, j: Integer;
Seznam: TStrings;
ApplicationPath: string;
fileName: string;
line: string;
sepIndex: integer;
begin
if (cxRadiogroup2.ItemIndex = 0) then begin
if (cxRadiogroup3.ItemIndex = 0) then
fileName:= 'A1.txt'
else
fileName:= 'A2.txt'
AdvStringgrid2.ClearAll; // don't know what this does
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
Seznam.LoadFromFile(fileName);
advstringGrid2.RowCount:= Seznam.Count;
splitList:= TStringList.Create;
for i:=0 to Seznam.Count-1 do begin
line:= Seznam.Strings [i];
Split('|', line, splitList);
advStringGrid2.ColCount:= Max(advStringGrid2.ColCount, splitList.Count);
for k:=0 to splitList.Count-1 do
advStringGrid2.Cells[i, k]:= splitList[k];
end;
finally
splitList.Free;
seznam.Free;
end;
end;
end;
procedure Split (const Delimiter: Char; Input: string; const Strings: TStrings);
begin
Assert(Assigned(Strings));
Strings.Clear;
Strings.Delimiter:= Delimiter;
Strings.DelimitedText:= Input;
end;
hope that helps
How do you know it is overwriting A1.txt? You are saving the exact same contents in both cases.
Founded and adapted to my needs. Then shared :-)
procedure LoadStringGrid(const AFileName: TFileName; AGrid: TStringGrid);
var
slRows: TStringList;
i: integer;
begin
slRows:= TStringList.Create;
try
slRows.LoadFromFile(AFileName);
for i:= 0 to slRows.Count -1 do
AGrid.Rows[i +1].CommaText:= slRows[i];
finally
slRows.Free;
end;
end;// LoadStringGrid
procedure SaveStringGrid(const AFileName: TFileName; AGrid: TStringGrid);
var
slRows: TStringList;
i: integer;
begin
slRows:= TStringList.Create;
try
for i:= 1 to AGrid.RowCount -1 do
slRows.Add(AGrid.Rows[i].CommaText);
slRows.SaveToFile(AFileName);
finally
slRows.Free;
end;
end;// SaveStringGrid

From TCheckListBox to TcxCheckListBox with an exception?

I use this code with TCheckListbox (lbServices) and it works fine. But with TcxCheckListBox from Devexpress it raise exception.
procedure TMaintenanceForm.AfterConstruction;
var
i: Integer;
ActionObj: TAction;
begin
inherited;
for i := 0 to ServiceActionList.ActionCount-1 do
begin
ActionObj := ServiceActionList.Actions[i] as TAction;
lbServices.Items.AddObject(ActionObj.Caption, ActionObj);
end;
end;
procedure TMaintenanceForm.btnStopClick(Sender: TObject);
begin
fContinue := False;
end;
procedure TMaintenanceForm.cmdExecuteSelectedClick(Sender: TObject);
var
i: Integer;
begin
Screen.Cursor := crHourGlass;
try
for i := 0 to lbServices.Count -1 do
if lbServices.Selected[i] then
(lbServices.Items.Objects[i] as TAction).Execute; // Exception here!!!!
finally
Screen.Cursor := crDefault;
end;
end;
If I debug the code lbServices.Count = 12.
lbServices.Items.Objects[i] is nil for all items in the list. What is wrong here ?
Use the following code instead:
var
AItem: TcxCheckListBoxItem;
begin
AItem := cxCheckListBox1.Items.Add;
AItem.ItemObject := Action1;
AItem.Text := Action1.Caption;
end;
...
var
I: Integer;
begin
for I := 0 to cxCheckListBox1.Items.Count - 1 do
if cxCheckListBox1.Items[I].Checked then
(cxCheckListBox1.Items[I].ItemObject as TACtion).Execute;
end;
There is no Objects property of TcxCheckListBox.Items

How can I get all installed components inside IDE? (Delphi)

How can I get all installed components in TStrings?
I think this code work only within packages:
uses TypInfo, ToolIntf, Exptintf;
procedure GetComponentNames(lst: TStrings);
var
i, k: Integer;
CRef: TClass;
strName: ShortString;
begin
lst.Clear;
for i := 0 to ToolServices.GetModuleCount-1 do
begin
for k := 0 to ToolServices.GetComponentCount(i)-1 do
begin
CRef := TClass(GetClass(ToolServices.GetComponentName(i, k)));
while CRef <> nil do
begin
strName := CRef.ClassName;
if lst.IndexOf(strName) = -1 then
lst.Add(strName);
if str <> 'TComponent' then
CRef := CRef.ClassParent
else
CRef := nil;
end;
end;
end;
end;
Or:
uses ToolsApi;
{....}
var
a, i: Integer;
begin
with (BorlandIDEServices as IOTAPackageServices) do
begin
for a := 0 to GetPackageCount - 1 do
begin
for i := 0 to GetComponentCount(a) - 1 do
begin
{get each component name with GetComponentName(a, i);}
// DoSomething
end;
end;
end;
end;
Thanks for help.
This example doesn't use the OpenAPI, it uses the Registry. It works but it also lists non-visual components amongst other hidden items.
procedure GetComponentNames(lst: TStrings);
var
i, j, iPos: Integer;
Reg: TRegistry;
sComponent: String;
slValues, slData: TStrings;
begin
Reg := TRegistry.Create;
slValues := TStringList.Create;
slData := TStringList.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('Software\Borland\Delphi\6.0\Palette', False); // Change reg key where appropriate
Reg.GetValueNames(slValues);
for i := 0 to Pred(slValues.Count) do
begin
lst.Append(slValues[i]);
lst.Append('----------');
slData.Delimiter := ';';
slData.DelimitedText := Reg.ReadString(slValues[i]);
for j := 0 to Pred(slData.Count) do
begin
sComponent := slData[j];
iPos := Pos('.', sComponent);
if (iPos > 0) then
Delete(sComponent, 1, iPos);
lst.Append(sComponent);
end;
end;
finally
slData.Free;
slValues.Free;
Reg.Free;
end; {try..finally}
end;
I'm not saying this is ideal but it does give you a list and a headstart.

Resources