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
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}
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;
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
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 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.