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.
Related
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;
I made a directory TreeView in Delphi FMX, but when I expand 'C:\Windows\WinSxS' it contains 15000 folders. It took a lot of time, but it doesn't expand. On the other hand, when I tried to do it with a VCL TreeView, it worked fine, as it should. Is there any way to make it fast?
Here is my code:
function SlashSep(const Path, S: String): String;
begin
{$IF DEFINED(CLR)}
if Path[Length(Path)] <> '\' then
{$ELSE}
if AnsiLastChar(Path)^ <> '\' then
{$ENDIF}
Result := Path + '\' + S
else
Result := Path + S;
end;
procedure GetDir(const ParentDirectory: string; ParentItem: TTreeViewItem);
var
Status: Integer;
SearchRec: TSearchRec;
Node: TTreeViewItem;
begin
Status := FindFirst(SlashSep(ParentDirectory, '*.*'), faDirectory, SearchRec);
try
while Status = 0 do
begin
if (SearchRec.Attr and faDirectory = faDirectory) then
begin
if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
begin
Node := AddChild(ParentItem,ExtractFileName(SearchRec.Name));
Node.HasChildren := True;
end;
end;
Status := FindNext(SearchRec);
end;
finally
FindClose(SearchRec);
end;
end;
procedure TForm1.ItemOnExpanding(Sender: TObject; Node: TTreeViewItem);
var
i: Integer;
begin
for i := Node.Count - 1 downto 0 do
TreeView1.RemoveObject(Node.Items[i]);
Node.BeginUpdate;
GetDir(GetPathItem(node),node);
Node.EndUpdate;
end;
It's expanding from here:
procedure TCustomTreeView.ItemExpanded(const Item: TTreeViewItem);
var
I: Integer;
Child: TTreeViewItem;
AllowExpansion: Boolean;
begin
InvalidateGlobalList;
if Item.IsExpanded then
for I := 0 to Item.Count - 1 do
begin
Child := Item.Items[I];
if not Child.IsInflated then
Child.Inflate;
end;
RealignContent;
//end;
if Assigned(FOnExpanding) then
if Item.IsExpanded then
FOnExpanding(Self, Item, AllowExpansion)
else
if Assigned(FOnCollapsing) then
if not Item.IsExpanded then
FOnCollapsing(Self, Item, AllowExpansion)
end;
I want to get and show the name and extension of selected file in explorer by delphi7.
I use below code for show caption of active window but i need selected file name in active window.
function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := ActiveCaption;
end;
The only way I know of is to use the Active-X IShellWindows and IWebBrowser Interfaces to to that.
First, you have to import the "Microsoft Internet Controls" Active-X (via the Component Menu). By that you will get a unit called "SHDocVW_TLB". Put this unit and the ActiveX unit in your uses clause.
Than you can use the following two functions to retrieve the selected file from the window handle provided:
The first function does a rough test if the given handle belongs to an explorer window
function isexplorerwindow(exwnd: hwnd): boolean;
var
p: array[0..max_path] of Char;
begin
GetClassName(exwnd, p, SizeOf(p));
result := ((strcomp(p, 'CabinetWClass') = 0) or (strcomp(p, 'ExploreWClass') = 0));
end;
And the second function retrieves the name of the nth selected file:
function getexplorerselectedfile(exwnd: hwnd; nr: integer): string;
var
pvShell: IShellWindows;
pvWeb2: IWebBrowser2;
ovIE: OleVariant;
psp: IServiceProvider;
psb: IShellBrowser;
isw: IShellView;
ido: IDataObject;
FmtEtc: TFormatEtc;
Medium: TStgMedium;
dwcount: integer;
n: integer;
p: array[0..max_path] of Char;
s: string;
found: boolean;
begin
found := false;
result := '';
s :='';
try
pvShell := CoShellWindows.Create;
for dwcount := 0 to Pred(pvShell.count) do
begin
ovIE := pvShell.Item(dwcount);
if (ovIE.hwnd = exwnd) or ((exwnd = 0) and isexplorerwindow(ovIE.hwnd)) then
begin
found := true;
if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then
begin
psp := (pvWeb2 as IServiceProvider);
psp.QueryService(IID_IShellBrowser, IID_IShellBrowser, psb);
psb.QueryActiveShellView(isw);
if isw.GetItemObject(SVGIO_SELECTION, IDataObject, pointer(ido)) = S_OK then
begin
try
FmtEtc.cfFormat := CF_HDROP;
FmtEtc.ptd := nil;
FmtEtc.dwAspect := DVASPECT_CONTENT;
FmtEtc.lindex := -1;
FmtEtc.tymed := TYMED_HGLOBAL;
ido.GetData(FmtEtc, Medium);
GlobalLock(Medium.hGlobal);
try
n := DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0);
if nr < n then
begin
DragQueryFile(Medium.hGlobal, nr, p, max_path);
s := strpas(p);
end;
finally
DragFinish(Medium.hGlobal);
GlobalUnLock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end;
end;
pvWeb2 := nil;
end;
end;
ovIE := Unassigned;
if found then
break;
end;
pvShell := nil;
finally
result := s;
end;
end;
To test this code create a new project and place a button and a memo on the form.
Add the following units to the uses clause:
USES SHDocVW_TLB, ShlObj, activex, shellapi;
And add this code to the button event handler:
PROCEDURE TForm2.Button1Click(Sender: TObject);
VAR
wnd, exwnd: hwnd;
n: integer;
s: STRING;
BEGIN
exwnd := 0;
wnd := getwindow(getdesktopwindow, gw_child);
REPEAT
IF isexplorerwindow(wnd) THEN
BEGIN
exwnd := wnd;
break;
END;
wnd := getwindow(wnd, gw_hwndnext);
UNTIL (wnd = 0) OR (exwnd <> 0);
IF exwnd <> 0 THEN
BEGIN
n := 0;
REPEAT
s := getexplorerselectedfile(exwnd, n);
memo1.Lines.Add(s);
inc(n);
UNTIL s = '';
END;
END;
If you press the button, the memo will contain the selected files of the first open explorer window it finds. Of course you should have an explorer window open with at least one file selected.
Anyone can help how can I transform this to work with tcxchecklistbox?
My Save procedure looks like...
procedure Tfrm_A.SaveCheckListBoxData(S: TMemoryStream;
CheckListBox: TCheckListBox);
var
i: longint;
b: boolean;
buf : string;
begin
S.Clear;
buf := CheckListBox.Items.Text;
i := Length(buf);
S.Write(i, SizeOf(i));
if i > 0 then begin
S.Write(buf[1], i);
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
b:= CheckListBox.Checked[i];
s.Write(b,1);
end;
end;
end;
My load procedure looks like...
procedure Tfrm_A.LoadCheckListBoxData(S: TMemoryStream;
CheckListBox: TChecklistBox);
var
i: longint;
b: Boolean;
buf : string;
begin
S.Position := 0;
S.Read(i, SizeOf(i));
if i > 0 then begin
SetLength(buf, i);
S.Read(buf[1], i);
CheckListBox.Items.Text := buf;
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
s.Read(b,1);
CheckListBox.Checked[i] := b;
end;
end;
end;
My problem is
buf := CheckListBox.Items.Text;
TcxChecklistbox has checklistbox.items[Index].textproperty
Thanks for the help!
You can use a TStringStream to do this. Basically, it's just a question of iterating the cxCheckBoxList Items and writing a character to the StringStream indicating whether the checkbox is checked, and then reading the stream back a character at a time.
function StateToString(Checked : Boolean) : String;
begin
if Checked then
Result := '+'
else
Result := '-';
end;
procedure TForm1.SaveStatesToStream(SS : TStringStream);
var
i : integer;
begin
SS.Clear;
SS.Position := 0;
for i := 0 to cxCheckListBox1.Items.Count - 1 do begin
SS.WriteString(StateToString(cxCheckListBox1.Items[i].Checked));
end;
Memo1.Lines.Add('>' + SS.DataString + '<');
end;
procedure TForm1.LoadStatesFromStream(SS : TStringStream);
var
i : integer;
S : String;
begin
CheckBoxList.ClearCheckmarks;
SS.Position := 0;
i := 0;
while (i <= cxCheckListBox1.Items.Count - 1) and (SS.Position < SS.Size) do begin
S := SS.ReadString(1);
cxCheckListBox1.Items[i].Checked := S = '+';
Inc(i);
end;
end;
Tested in Delphi Seattle
I know the only way to do that is to remap keys with regedit.
Have someone has done that with delphi ? (disable it and enable it again)
http://www.northcode.com/blog.php/2007/07/25/Securing-Windows-For-Use-As-A-Kiosk
The information in the article would translate to Delphi as follows:
uses
Registry;
const
DisableScancodes: packed array[0..11] of DWORD = (
$00000000, // version = 0
$00000000, // flags = 0
$00000009, // # of mappings = 9
$E05B0000, // disable Windows key
$E05C0000, // disable Windows key
$E05D0000, // disable Windows menu key
$00440000, // disable F10 key
$001D0000, // disable Left Ctrl key
$00380000, // disable Left Alt key
$E01D0000, // disable Right Ctrl key
$E0380000, // disable Right Alt key
$00000000 // end of list
);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
// to enable the mapping
Reg.WriteBinaryData('Scancode Map', DisableScancodes, SizeOf(DisableScancodes));
// to disable the mapping
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
If you need to be more dynamic about which scancodes you enable/disable, you will have to use TRegistry.ReadBinaryData() to read the current Scancode Map value (if it exists), modify it as needed, and then save the changes using TRegistry.WriteBinaryData(). Try something like this:
unit ScanCodeMap;
interface
type
TMappedScancode = record
Scancode: WORD;
MappedTo: WORD;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
procedure AddScancodeMapping(const Value: TMappedScancode);
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
procedure RemoveScancodeMapping(Scancode: WORD);
procedure DisableScancodes(Scancodes: array of WORD);
procedure DisableScancode(Scancode: WORD);
implementation
uses
Windows, Registry;
type
PScancodeMapHdr = ^TScancodeMapHdr;
TScancodeMapHdr = packed record
Version: DWORD;
Flags: DWORD;
NumMappings: DWORD;
end;
TScancodeMap = record
Version: DWORD;
Flags: DWORD;
Mappings: array of TMappedScancode;
end;
procedure AddScancodesToMap(var Map: TScancodeMap; const Values: array of TMappedScancode);
var
I, J, Idx: Integer;
begin
for I := 0 to High(Values) do
begin
Idx := -1;
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Values[I].Scancode then
begin
Idx := J;
Break;
end;
end;
if Idx = -1 then
begin
SetLength(Map.Mappings, Length(Map.Mappings)+1);
Idx := High(Map.Mappings);
end;
Map.Mappings[Idx].MappedTo := Values[I].MappedTo;
end;
end;
procedure RemoveScancodesFromMap(var Map: TScancodeMap; const Scancodes: array of WORD);
var
I, J: Integer;
begin
for I := 0 to High(Scancodes) do
begin
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Scancodes[I] then
begin
if J < High(Map.Mappings) then
Move(Map.Mappings[J+1], Map.Mappings[J], (High(Mappings)-J) * SizeOf(TMappedScancode));
SetLength(Map.Mappings, Length(Map.Mappings)-1);
Break;
end;
end;
end;
end;
procedure WriteScanCodeMap(const Map: TScancodeMap);
var
Reg: TRegistry;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
if Length(Map.Mappings) > 0 then
begin
SetLength(Data, sizeof(TScancodeMapHdr) + (Length(Map.Mappings) + 1) * SizeOf(DWORD));
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Hdr.Version := Map.Version;
Hdr.Flags := Map.Flags;
Hdr.NumMappings := Length(Map.Mappings) + 1;
Inc(Tmp, SizeOf(TScancodeMapHdr));
for I := 0 to High(Map.Mappings) do
begin
PDWORD(Tmp)^ := (DWORD(Map.Mappings[0].Scancode) shr 16) or DWORD(Map.Mappings[0].MappedTo);
Inc(Tmp, SizeOf(DWORD));
end;
PDWORD(Tmp)^ := 0;
end;
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
if Length(Data) > 0 then
Reg.WriteBinaryData('Scancode Map', Data[0], Length(Data))
else
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure ReadScanCodeMap(var Map: TScancodeMap);
var
Reg: TRegistry;
Size: Integer;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
Map.Version := 0;
Map.Flags := 0;
SetLength(Map.Mappings, 0);
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Control\Keyboard Layout') then
begin
try
Size := Reg.GetDataSize('Scancode Map');
if Size > SizeOf(TScancodeMapHdr) then
begin
SetLength(Data, Size);
Reg.ReadBinaryData('Scancode Map', Data[0], Size);
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Map.Version := Hdr.Version;
Map.Flags := Hdr.Flags;
Inc(Tmp, SizeOf(TScancodeMapHdr));
if Hdr.NumMappings > 1 then
begin
SetLength(Map.Mappings, Hdr.NumMappings-1);
for I := 0 to High(Map.Mappings) do
begin
Map.Mappings[I].Scancode := HIWORD(PDWORD(Tmp)^);
Map.Mappings[I].MappedTo := LOWORD(PDWORD(Tmp)^);
end;
end;
end;
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
AddScancodesToMap(Map, Values);
WriteScanCodeMap(Map);
end;
procedure AddScancodeMapping(const Value: TMappedScancode);
begin
AddScancodeMappings([Value]);
end;
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
var
Value: array[0..0] of TMappedScancode;
begin
Value[0].Scancode := Scancode;
Value[0].MappedTo := MappedTo;
AddScancodeMappings([Value]);
end;
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
RemoveScancodesFromMap(Map, Scancodes);
WriteScanCodeMap(Map);
end;
procedure RemoveScancodeMapping(Scancode: WORD);
begin
RemoveScancodeMappings([Scancode]);
end;
procedure DisableScancodes(Scancodes: array of WORD);
var
Values: array of TMappedScancode;
I: Integer;
begin
SetLength(Values, Length(Scancodes));
for I := 0 to High(Mappings) do
begin
Values[I].Scancode := Scancodes[I];
Values[I].MappedTo := $0000;
end;
AddScancodeMappings(Values);
end;
procedure DisableScancode(Scancode: WORD);
begin
AddScancodeMapping(Scancode, $0000);
end;
end.
Then you can do this:
uses
ScanCodeMap;
const
Scancodes: packed array[0..7] of WORD = (
$E05B, // Windows key
$E05C, // Windows key
$E05D, // Windows menu key
$0044, // F10 key
$001D, // Left Ctrl key
$0038, // Left Alt key
$E01D, // Right Ctrl key
$E038 // Right Alt key
);
procedure DisableCtrlAltDel;
begin
DisableScancodes(Scancodes);
end;
procedure EnableCtrlAltDel;
begin
RemoveScancodeMappings(Scancodes);
end;