You must have the component TNMSMTP from FastNet tools. This component is included in Delphi 4-5 Professional and Enterprise
procedure TForm1.Button1Click(Sender:Object);
Begin
NMSMTP1.Host := 'mail.host.com';
NMSMTP1.UserID:= 'username';
NMSMTP1.Connect;
NMSMTP1.PostMessage.FromAddress:='webmaster@swissdelphicenter.ch';
NMSMTP1.PostMessage.ToAddress.Text := 'user@host.com';
NMSMTP1.PostMessage.Body.Text := 'This is the message';
NMSMTP1.PostMessage.Subject:='Mailsubject;
NMSMTP1.SendMail;
showmessage('Mail sent !');
end;
To get a list of fonts available we have to use EnumFontFamilies or EnumFonts Win32 API functions. For a description of the differences between those two functions please refer to Win32 SDK documentation. I'll use the first one (EnumFontFalimiles) for this example.
Win32 API provides several enumeration functions for various tasks. There are functions capable of enumerating installed fonts, printers and so on. All those enumerating functions require you to pass a callback function, actually the function pointer, as one of its parameters.
A callback function is one function coded and provided to the system by the programmer. The system uses the function, the programmer passes as a parameter to an EnumXXXX function, to pass the requested information back.
Here is how you might code a call to EnumFontFamilies function:
var
DC: HDC;
begin
DC := GetDC(0); { get screen's device context }
try
EnumFontFamilies(DC, nil, @EnumFontsProc, LongInt(ComboBox1));
finally
ReleaseDC(0, DC); { release device context }
end;
end;
The first parameter, DC, is a device context. Check "Device Contexts" topic of the Win32 SDK for more info on device contexts. We are passing screen's device context here since we are interested for screen fonts.
The second parameter is a PChar specifying the family name of the desired fonts. Since we want all the available information we pass nil.
The third parameter is the pointer to the callback function we provide. We didn't actually code it yet. We'll do that in a minute. As you know the "@ operator returns the address of a variable, or of a function, procedure, or method; that is, @ constructs a pointer to its operand" as Delphi's online help states.
The last parameter is a Longint. Anything that could be typecasted as a LongInt could be passed here. It's up to us to decide what to pass.
Remember, an object could be typecasted to a LongInt as
Longint(MyObject)
and then pass it to the function.
Here is how the EnumFontsProc, the callback function provided by the programmer, might look like:
function EnumFontsProc(var EnumLogFont: TEnumLogFont; var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer; stdcall;
var
FontName: string;
CB : TComboBox;
begin
CB := TComboBox(Data);
FontName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
if (CB.Items.IndexOf(FontName) < 0) then
if (FontType = TRUETYPE_FONTTYPE) then
CB.Items.Add(FontName);
Result := 1;
end;
For a complete description of the TEnumLogFont and TNewTextMetric please refer to Win32 SDK. I think it's enough to say that they hold all the info the system could provide us regarding a font. They are declared in Windows.pas.
The FontType could be one of the following integer constants declared in Windows.pas too
RASTER_FONTTYPE = 1;
DEVICE_FONTTYPE = 2;
TRUETYPE_FONTTYPE = 4;
Here is how this mechanism works:
Windows randomly selects one font of each available type family, since we have passed nil as the second parameter to EnumFontFamilies, and passes the available information for that font to your callback function, EnumFontsProc in this case.
The enumeration will continue until either the callback return 0 (we constantly retrun 1) or there are no more fonts to enumerate.
Inside the EnumFontsProc we might examine each font passed and do what we want to do with the available information. In the above code I just add the FontNames to a ComboBox items.
Following is a class I've coded to make the task easier:
type
TFontType = (ftRaster, ftDevice, ftTrueType);
(*----------------------------------------------------------------------------------*)
TFontInfo = class
private
FShortName : string;
FFullName : string;
FStyle : string;
FLF : TLogFont;
FFontType : TFontType;
FTM : TNewTextMetric;
public
property FullName : string read FFullName ;
property ShortName : string read FShortName;
property Style : string read FStyle ;
property FontType : TFontType read FFontType ;
property TM : TNewTextMetric read FTM ;
property LF : TLogFont read FLF ;
end;
(*----------------------------------------------------------------------------------*)
TFontList = class
private
procedure ClearList;
procedure AddFont(EnumLogFont: TEnumLogFont; TextMetric: TNewTextMetric; FontType: Integer);
public
List : TStringList;
constructor Create;
destructor Destroy; override;
procedure RefreshFontInfo;
end;
{ TFontList }
(*----------------------------------------------------------------------------------*)
constructor TFontList.Create;
begin
inherited Create;
List := TStringList.Create;
List.Sorted := True;
end;
(*----------------------------------------------------------------------------------*)
destructor TFontList.Destroy;
begin
ClearList;
inherited Destroy;
end;
(*----------------------------------------------------------------------------------*)
procedure TFontList.ClearList;
begin
while List.Count > 0 do
begin
TFontInfo(List.Objects[0]).Free;
List.Delete(0);
end;
end;
(*----------------------------------------------------------------------------------*)
function EnumFontsProc(var EnumLogFont: TEnumLogFont; var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer; stdcall;
var
FontList : TFontList;
begin
FontList := TFontList(Data);
FontList.AddFont(EnumLogFont, TextMetric, FontType);
Result := 1;
end;
(*----------------------------------------------------------------------------------*)
procedure TFontList.AddFont(EnumLogFont: TEnumLogFont; TextMetric: TNewTextMetric; FontType: Integer);
var
FI : TFontInfo;
begin
FI := TFontInfo.Create;
FI.FShortName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
FI.FFullName := StrPas(EnumLogFont.elfFullName);
FI.FStyle := StrPas(EnumLogFont.elfStyle);
FI.FLF := EnumLogFont.elfLogFont;
case FontType of
RASTER_FONTTYPE : FI.FFontType := ftRaster;
DEVICE_FONTTYPE : FI.FFontType := ftDevice;
TRUETYPE_FONTTYPE : FI.FFontType := ftTrueType;
end;
FI.FTM := TextMetric;
List.AddObject(FI.FShortName, FI);
end;
(*----------------------------------------------------------------------------------*)
procedure TFontList.RefreshFontInfo;
var
DC: HDC;
begin
ClearList;
DC := GetDC(0);
try
EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
finally
ReleaseDC(0, DC);
end;
end;
And here is an example use:
procedure TForm1.Button1Click(Sender: TObject);
var
FontList : TFontList;
begin
ListBox1.Clear;
FontList := TFontList.Create;
try
FontList.RefreshFontInfo;
ListBox1.Items.AddStrings(FontList.List);
finally
FontList.Free;
end;
end;
You must interface with the Windows Shell API module to let
Windows know that your application accepts dropped files (this
can be done in your main form's create event), and then you must
respond to the drag events as they happen by creating an event
handler.
The following is an example of a Delphi form that accepts dropped
files and adds the names of the files to a memo component:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMDROPFILES(var Message: TWMDROPFILES);
message WM_DROPFILES;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellApi;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Let Windows know we accept dropped files}
DragAcceptFiles(Form1.Handle, True);
end;
procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES);
var
NumFiles : longint;
i : longint;
buffer : array[0..255] of char;
begin
{How many files are being dropped}
NumFiles := DragQueryFile(Message.Drop,
-1,
nil,
0);
{Accept the dropped files}
for i := 0 to (NumFiles - 1) do begin
DragQueryFile(Message.Drop,
i,
@buffer,
sizeof(buffer));
Form1.Memo1.Lines.Add(buffer);
end;
end;
end.
function SetPrivilege(aPrivilegeName : string;
aEnabled : boolean ): boolean;
var
TPPrev,
TP : TTokenPrivileges;
Token : THandle;
dwRetLen : DWord;
begin
Result := False;
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, @Token );
TP.PrivilegeCount := 1;
if( LookupPrivilegeValue(nil, PChar( aPrivilegeName ),
TP.Privileges[ 0 ].LUID ) ) then
begin
if( aEnabled )then
TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED;
else
TP.Privileges[0].Attributes:= 0;
dwRetLen := 0;
Result := AdjustTokenPrivileges(Token,False,TP,
SizeOf( TPPrev ),
TPPrev,dwRetLen );
end;
CloseHandle( Token );
end;
function WinExit( iFlags : integer ) : boolean;
// possible Flags:
// EWX_LOGOFF
// EWX_REBOOT
// EWX_SHUTDOWN
begin
Result := True;
if( SetPrivilege( 'SeShutdownPrivilege', true ) ) then
begin
if( not ExitWindowsEx( iFlags, 0 ) )then
begin
Result := False;
end;
SetPrivilege( 'SeShutdownPrivilege', False )
end
else
begin
Result := False;
end;
end;
{ define Global vars }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ put the Code in the OnCreate event of your form }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx
(FindWindow(
'Shell_TrayWnd', nil),
0,'Button', nil);
OldBitmap := SendMessage(StartButton,
BM_SetImage, 0,
NewImage.Bitmap.Handle);
end;
{ OnDestroy-Event }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;
This code demonstrates use of windows registery and function overloading to read from registery:
if key doesnt exist it's created and Default passed to key value ReadReg(KeyToRead,DefaultValue)
to write to registery:
writereg(KeyToWrite,ValueToKey)
Supports integer,string and boolean types, other type can be similary added.}
unit module1;
interface
uses Windows, registry;
function WriteReg(Key:string;value:integer) :boolean; overload;
function WriteReg(Key:string;value:boolean) :boolean; overload;
function WriteReg(Key:string;value:String) :boolean; overload;
function ReadReg(Key:string;default:String='') :string; overload;
function ReadReg(Key:string;default:integer=0) :integer; overload;
function ReadReg(Key:string;default:boolean=false):boolean;overload;
const
ApplicationName:string ='MyProgram'; //Your Programname
implementation
function ReadReg(Key:string;default:integer=0):integer;
var
Registry: TRegistry;
begin
Registry :=TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ ApplicationName,True);
if registry.ValueExists(key) =true then
result:=Registry.readinteger(key)
else
begin
Registry.Writeinteger(key,default);
result:=Registry.readinteger(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:string=''):string;
var
Registry : TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg := Registry.readstring(key)
else
begin
Registry.Writestring(key,default);
Readreg := Registry.readstring(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:boolean=false):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg:=Registry.readbool(key)
else
begin
Registry.Writebool(key,default);
readreg:=Registry.readbool(key);
end;
Registry.Free;
end;
function WriteReg(Key:string;value:boolean):boolean;
var Registry: TRegistry;
begin
Registry:=TRegistry.Create;
Registry.RootKey:=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.WriteBool(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:string):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writestring(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:integer):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writeinteger(key,value);
writereg:= registry.KeyExists(key);
Registry.Free;
end;
Compare dates
Uses SysUtils;
...
if(Date < EncodeDate( 2000, 1, 1 )) then
Showmessage(' The date is ' + DateToStr(Date));
…
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject); protected
procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TForm1.WMDROPFILES (var Msg: TMessage);
var i,anzahl, size : integer;
Dateiname : PChar;
begin
inherited;
anzahl := DragQueryFile(Msg.WParam, $FFFFFFFF,Dateiname,255);
for i := 0 to (anzahl - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
Dateiname:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Dateiname, size);
listbox1.items.add(StrPas(Dateiname)); StrDispose(Dateiname);
end;
DragFinish(Msg.WParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
end;
end.
Found in the Win32.hlp
type
PTokenUser = ^TTokenUser;
_TOKEN_USER = record
User: TSIDAndAttributes;
end;
TTokenUser = _TOKEN_USER;
procedure getCurrentUserAndDomain(var User, Domain: String);
var
hProcess, hAccessToken: THandle;
InfoBuffer: array[0..1000] of Char;
szAccountName, szDomainName: array [0..200] of Char;
dwInfoBufferSize, dwAccountSize, dwDomainSize: DWORD;
pUser: PTokenUser;
snu: SID_NAME_USE;
begin
dwAccountSize:=200;
dwDomainSize:=200;
hProcess:=GetCurrentProcess;
OpenProcessToken(hProcess,TOKEN_READ,hAccessToken);
GetTokenInformation(hAccessToken,TokenUser,@InfoBuffer[0],1000,
dwInfoBufferSize);
pUser:=PTokenUser(@InfoBuffer[0]);
LookupAccountSid(nil, pUser.User.Sid, szAccountName, dwAccountSize, szDomainName, dwDomainSize, snu);
User:=szAccountName;
Domain:=szDomainName;
CloseHandle(hAccessToken);
end;
computer For Win95, you can find it in the registry - but this is not portable to NT. A safer way (and one which is portable to NT) would be to use the Win32 calls GetComputerName and GetUserName, both of which are defined in the Windows unit. Each of these functions takes a buffer as its first parameter and the length of the buffer as its second.
The function definitions are shown below:
function GetComputerName(lpBuffer:PChar;
var nSize:DWORD): BOOL; stdcall;
function GetUserName(lpBuffer :PChar;
var nSize: DWORD): BOOL; stdcall;
Use them like this:
function GetWindowsUserName : string;
const
cnMaxLen = 254;
var
sUserName : string;
dwUserNameLen : DWord;
begin
dwUserNameLen:=cnMaxLen-1;
SetLength(sUserName,cnMaxLen);
GetUserName(Pchar(sUserName),dwUserNameLen);
SetLength(sUserName,dwUserNameLen);
result:=sUserName;
if dwUserNameLen=cnMaxLen-1 then result:='';
end;
You may have noticed that using SystemParametersInfo to change the wallpaper when ActiveDesktop is turned on doesn't work. The reason is because you need to use the IActiveDesktop COM interface. Using SystemParametersInfo still works, but it doesn't update the wallpaper.
Note that the IActiveDesktop interface requires a Shell32.dll version >= 4.71. The document titled "Get a File Version" demonstrates how to check the file version and uses the shell32.dll as an example.
Here is an example of using IActiveDesktop to work with
the wallpaper. It assumes that you have 3 labels on a form
and two buttons with the default names.
uses
ComObj, // For CreateComObject and Initialization/Finalization of COM
ShlObj; // For IActiveDesktop
{ The CLASS ID for ActiveDesktop is not defined in ShlObj, while the IID is so we define it here. }
const
CLSID_ActiveDesktop : TGUID = '{75048700-EF1F11D0-9888-06097DEACF9}';
{ Demonstrate getting the Wallpaper }
procedure TForm1.Button1Click(Sender: TObject);
var
ActiveDesktop : IActiveDesktop;
CurrentWallpaper : string;
CurrentPattern : string;
WallpaperOptions : TWallpaperOpt;
TmpBuffer : PWideChar;
begin
// Create the ActiveDesktop COM Object
ActiveDesktop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
// We now need to allocate some memory to get the current Wallpaper.
// However, tmpBuffer is a PWideChar which means 2 bytes make
// up one Char. In order to compenstate for the WideChar, we
// allocate enough memory for MAX_PATH*2
tmpBuffer := AllocMem(MAX_PATH*2);
try
ActiveDesktop.GetWallpaper(tmpBuffer, MAX_PATH*2, 0);
CurrentWallpaper := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentWallpaper <> '' then
Label1.Caption := 'Current Wallpaper: ' + CurrentWallpaper
else
Label1.Caption := 'No Wallpaper set';
// Now get the current Wallpaper options.
// The second parameter is reserved and must be 0.
WallpaperOptions.dwSize := SizeOf(WallpaperOptions);
ActiveDesktop.GetWallpaperOptions(WallpaperOptions, 0);
case WallpaperOptions.dwStyle of
WPSTYLE_CENTER : Label2.Caption := 'Centered';
WPSTYLE_TILE : Label2.Caption := 'Tiled';
WPSTYLE_STRETCH : Label2.Caption := 'Stretched';
WPSTYLE_MAX : Label2.Caption := 'Maxed';
end;
{Now get the desktop pattern. The pattern is a string of decimals whose bit pattern represents a picture. Each decimal represents the on/off state of the 8 pixels in that row. }
tmpBuffer := AllocMem(256);
try
ActiveDesktop.GetPattern(tmpBuffer, 256, 0);
CurrentPattern := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentPattern <> '' then
Label3.Caption := CurrentPattern
else
Label3.Caption := 'No Pattern set';
end;
{ Demonstrate setting the wallpaper }
procedure TForm1.Button2Click(Sender: TObject);
var
ActiveDesktop: IActiveDesktop;
begin
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
ActiveDesktop.SetWallpaper('c:\downloads\images\test.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
Responds:
Good programming. But I just calling
SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, @WallpaperBMPFileAndPath[1], 3);
Parameters:
EWX_SHUTDOWN : shut down windows(Power off)
EWX_REBOOT : reboot windows
EWX_POWEROFF : Standby mode
EWX_LOGOFF : Log Off
procedure TForm1.Button1Click(Sender: TObject);
begin
ExitWindowsEx(EWX_SHUTDOWN,0);
end;
or use rundll32.exe
uses ShellAPI;
function ExecuteFile(const FileName, Params,DefaultDir : string;
ShowCmd: Integer) : THandle;
var
zFileName, zParams, zDir : array[0..79] of Char;
begin
Result :=ShellExecute(Application.MainForm.Handle, nil,
StrPCopy(zFileName, FileName),StrPCopy(zParams,Params), StrPCopy(zDir, DefaultDir), ShowCmd);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteFile('Rundll.exe','user,exitwindows','',SW_SHOW);
end;
uses jpeg;
procedure TForm1.Button1Click(Sender: TObject);
var
bmp : TImage;
jpg : TJpegImage;
begin
bmp := TImage.Create(nil);
jpg := TJpegImage.Create;
bmp.picture.bitmap.LoadFromFile('c:\picture.bmp');
jpg.Assign( bmp.picture.bitmap );
//Here you can set the jpg object's
//properties as compression, size and more
jpg.SaveToFile('c:\picture.jpg');
jpg.Free;
bmp.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
var devmode : TDEVMODE;
d : INTEGER;
litem : TListItem;
p : ^TDevmode;
begin
devmode.dmSize := SizeOf(TDEVMODE);
devmode.dmDriverExtra := 0; d := 0;
listview1.Columns[0].Width := 400;
While EnumDisplaySettings(nil, d, devmode) do
with devmode do
begin
Inc(d);
litem := listview1.Items.Add;
litem.Caption:=Format('Modus %3d : %dx%d, %d Farben(%d Hz)', [d,dmPelsWidth,dmPelsHeight,1 shl(dmBitsPerPel),dmDisplayFrequency]);
new(p);
p^ := Devmode;
litem.Data := p;
end;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
ChangeDisplaySettings(TDevmode(listview1.Selected.data^),0);
end;
DiskFree(n) //where n = number.
0 = the current drive you are working in. 1 = A, 2 = B, 3 = C, 4 = D etc.
DiskFree(3);// C drive.
DiskFree returns the number of free bytes on the specified drive number.
Procedure Opendoor;
Begin
mciSendString('Set cdaudio door open', nil, 0, 0);
End;
Procedure CloseDoor;
Begin
mciSendString('Set cdaudio door closed', nil, 0, 0);
End;
note : Remember to include the unit MMSYSTEM
implementation
function RegisterServiceProcess(dwProcessID, dwType: DWord) : DWord; stdcall;
external 'KERNEL32.DLL';
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,0);
end;
procedure RecycleFile(s : string);
var
SHFileOpStruct : TSHFileOpStruct;
begin
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_DELETE; // we want to delete a file...
pFrom := PChar(s); //... this file ...
pTo := nil;
fFlags := FOF_ALLOWUNDO; //... able to "Undo" (recycle)
hNameMappings := nil;
lpszProgressTitle := nil;
end;
SHFileOperation(SHFileOpStruct); // to the Recycle Bin
end;
For Example we want to execute calc.exe. You may change with other executable application.
…
WinExec('C:\WINDOWS\CALC.EXE', SW_ShowNormal);
...
You can run the program Maximized - SW_ShowMaximized
You can run the program Minimized - SW_ShowMinimized
And you can run the program as Normal - SW_ShowNormal