mssql tarih type convert
Style ID
Style Type
0 or 100 mon dd yyyy hh : miAM ( or PM )
101 mm / dd / yy
102 yy . mm . dd
103 dd / mm / yy
104 dd . mm . yy
105 dd - mm - yy
106 dd mon yy
107 Mon dd , yy
108 hh : mm : ss
9 or 109 mon dd yyyy hh : mi : ss : mmmAM ( or PM )
110 mm - dd - yy
111 yy / mm / dd
112 yymmdd
13 or 113 dd mon yyyy hh : mm : ss : mmm ( 24 h )
114 hh : mi : ss : mmm ( 24 h )
20 or 120 yyyy - mm - dd hh : mi : ss ( 24 h )
21 or 121 yyyy - mm - dd hh : mi : ss . mmm ( 24 h )
126 yyyy - mm - dd Thh : mm : ss . mmm ( no spaces )
130 dd mon yyyy hh : mi : ss : mmmAM
131 dd / mm / yy hh : mi : ss : mmmAM
select convert ( varchar , DateColumn , 108 ) from MyDateTest99
Delphi - .....................................
mssql tarih type convert
Style ID
Style Type
0 or 100 mon dd yyyy hh : miAM ( or PM )
101 mm / dd / yy
102 yy . mm . dd
103 dd / mm / yy
104 dd . mm . yy
105 dd - mm - yy
106 dd mon yy
107 Mon dd , yy
108 hh : mm : ss
9 or 109 mon dd yyyy hh : mi : ss : mmmAM ( or PM )
110 mm - dd - yy
111 yy / mm / dd
112 yymmdd
13 or 113 dd mon yyyy hh : mm : ss : mmm ( 24 h )
114 hh : mi : ss : mmm ( 24 h )
20 or 120 yyyy - mm - dd hh : mi : ss ( 24 h )
21 or 121 yyyy - mm - dd hh : mi : ss . mmm ( 24 h )
126 yyyy - mm - dd Thh : mm : ss . mmm ( no spaces )
130 dd mon yyyy hh : mi : ss : mmmAM
131 dd / mm / yy hh : mi : ss : mmmAM
select convert ( varchar , DateColumn , 108 ) from MyDateTest99
Delphi - .....................................
USB nin takılıp çıkarıldığını anlamak...
abi herseyi de ole component palete yuklemek ii degil. manul create edipte
olsuturabilirsiniz .
ustelik baska bir delphide derlerken componenti tekrar yukleme gibi bir
derdiniz de olmaz .
U_Usb . pas dosyasini projeyle ayni dizine kopyalayin ....
program Project1 ;
uses
Forms ,
Unit1 in 'Unit1.pas' {Form1} ,
U_Usb in 'U_Usb.pas' ;
{$R *.res}
begin
Application . Initialize ;
Application . CreateForm ( TForm1 , Form1 );
Application . Run ;
end .
////////////////////////////////////////////////////////////////////////////////////////////////
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , U_Usb , StdCtrls ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
procedure FormCreate ( Sender : TObject );
procedure FormDestroy ( Sender : TObject );
private
{ Private declarations }
public
usb : TComponentUSB ;
procedure BellekCikti ( Sender : TObject );
procedure BellekTakildi ( Sender : TObject );
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.dfm}
procedure TForm1 . BellekCikti ( Sender : TObject );
begin
ShowMessage ( 'bellek çıktı' );
end ;
procedure TForm1 . BellekTakildi ( Sender : TObject );
begin
ShowMessage ( 'bellek takıldı' );
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
usb := TComponentUSB . Create ( self );
usb . OnUSBArrival := BellekTakildi ;
usb . OnUSBRemove := BellekCikti ;
end ;
procedure TForm1 . FormDestroy ( Sender : TObject );
begin
FreeAndNil ( usb );
end ;
end .
> **************************************************
> unit U_Usb ;
>
> interface
>
> uses
> Windows , Messages , SysUtils , Classes , Forms ;
>
> type
>
> PDevBroadcastHdr = ^ DEV_BROADCAST_HDR ;
> DEV_BROADCAST_HDR = packed record
> dbch_size : DWORD ;
> dbch_devicetype : DWORD ;
> dbch_reserved : DWORD ;
> end ;
>
> PDevBroadcastDeviceInterface = ^ DEV_BROADCAST_DEVICEINTERFACE ;
> DEV_BROADCAST_DEVICEINTERFACE = record
> dbcc_size : DWORD ;
> dbcc_devicetype : DWORD ;
> dbcc_reserved : DWORD ;
> dbcc_classguid : TGUID ;
> dbcc_name : short ;
> end ;
>
> const
> GUID_DEVINTERFACE_USB_DEVICE : TGUID =
> '{A5DCBF10-6530-11D2-901F-00C04FB951ED}' ;
> DBT_DEVICEARRIVAL = $8000 ; // system detected a new
> device
> DBT_DEVICEREMOVECOMPLETE = $8004 ; // device is gone
> DBT_DEVTYP_DEVICEINTERFACE = $00000005 ; // device interface class
>
> type
>
> TComponentUSB = class ( TComponent )
> private
> FWindowHandle : HWND ;
> FOnUSBArrival : TNotifyEvent ;
> FOnUSBRemove : TNotifyEvent ;
> procedure WndProc ( var Msg : TMessage );
> function USBRegister : Boolean ;
>
> protected
> procedure WMDeviceChange ( var Msg : TMessage ); dynamic ;
> public
> constructor Create ( AOwner : TComponent ); override ;
> destructor Destroy ; override ;
> published
> property OnUSBArrival : TNotifyEvent read FOnUSBArrival write
> FOnUSBArrival ;
> property OnUSBRemove : TNotifyEvent read FOnUSBRemove write
> FOnUSBRemove ;
> end ;
> procedure Register ;
> implementation
>
> procedure Register ; { add this in the implementation section }
> begin
> RegisterComponents ( 'Samples' , [ TComponentUSB ]);
> end ;
>
>
> constructor TComponentUSB . Create ( AOwner : TComponent );
> begin
> inherited Create ( AOwner );
> FWindowHandle := AllocateHWnd ( WndProc );
> USBRegister ;
> end ;
>
> destructor TComponentUSB . Destroy ;
> begin
> DeallocateHWnd ( FWindowHandle );
> inherited Destroy ;
> end ;
>
> procedure TComponentUSB . WndProc ( var Msg : TMessage );
> begin
> if ( Msg . Msg = WM_DEVICECHANGE ) then
> begin
> try
> WMDeviceChange ( Msg );
> except
> Application . HandleException ( Self );
> end ;
> end
> else
> Msg . Result := DefWindowProc ( FWindowHandle , Msg . Msg , Msg . wParam ,
> Msg . lParam );
> end ;
>
> procedure TComponentUSB . WMDeviceChange ( var Msg : TMessage );
> var
> devType : Integer ;
> Datos : PDevBroadcastHdr ;
> begin
> if ( Msg . wParam = DBT_DEVICEARRIVAL ) or ( Msg . wParam =
> DBT_DEVICEREMOVECOMPLETE ) then
> begin
> Datos := PDevBroadcastHdr ( Msg . lParam );
> devType := Datos ^. dbch_devicetype ;
> if devType = DBT_DEVTYP_DEVICEINTERFACE then
> begin // USB Device
> if Msg . wParam = DBT_DEVICEARRIVAL then
> begin
> if Assigned ( FOnUSBArrival ) then
> FOnUSBArrival ( Self );
> end
> else
> begin
> if Assigned ( FOnUSBRemove ) then
> FOnUSBRemove ( Self );
> end ;
> end ;
> end ;
> end ;
>
> function TComponentUSB . USBRegister : Boolean ;
> var
> dbi : DEV_BROADCAST_DEVICEINTERFACE ;
> Size : Integer ;
> r : Pointer ;
> begin
> Result := False ;
> Size := SizeOf ( DEV_BROADCAST_DEVICEINTERFACE );
> ZeroMemory (@ dbi , Size );
> dbi . dbcc_size := Size ;
> dbi . dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE ;
> dbi . dbcc_reserved := 0 ;
> dbi . dbcc_classguid := GUID_DEVINTERFACE_USB_DEVICE ;
> dbi . dbcc_name := 0 ;
>
> r := RegisterDeviceNotification ( FWindowHandle , @ dbi ,
> DEVICE_NOTIFY_WINDOW_HANDLE
> );
> if Assigned ( r ) then Result := True ;
> end ;
>
> end .
ilgili sorular i ç in canertemp @ gmail . com
--
http : //sadettinpolat.zaxaz.com 'a teşekkürler...
Delphi - .....................................
USB nin takılıp çıkarıldığını anlamak...
abi herseyi de ole component palete yuklemek ii degil. manul create edipte
olsuturabilirsiniz .
ustelik baska bir delphide derlerken componenti tekrar yukleme gibi bir
derdiniz de olmaz .
U_Usb . pas dosyasini projeyle ayni dizine kopyalayin ....
program Project1 ;
uses
Forms ,
Unit1 in 'Unit1.pas' {Form1} ,
U_Usb in 'U_Usb.pas' ;
{$R *.res}
begin
Application . Initialize ;
Application . CreateForm ( TForm1 , Form1 );
Application . Run ;
end .
////////////////////////////////////////////////////////////////////////////////////////////////
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , U_Usb , StdCtrls ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
procedure FormCreate ( Sender : TObject );
procedure FormDestroy ( Sender : TObject );
private
{ Private declarations }
public
usb : TComponentUSB ;
procedure BellekCikti ( Sender : TObject );
procedure BellekTakildi ( Sender : TObject );
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.dfm}
procedure TForm1 . BellekCikti ( Sender : TObject );
begin
ShowMessage ( 'bellek çıktı' );
end ;
procedure TForm1 . BellekTakildi ( Sender : TObject );
begin
ShowMessage ( 'bellek takıldı' );
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
usb := TComponentUSB . Create ( self );
usb . OnUSBArrival := BellekTakildi ;
usb . OnUSBRemove := BellekCikti ;
end ;
procedure TForm1 . FormDestroy ( Sender : TObject );
begin
FreeAndNil ( usb );
end ;
end .
> **************************************************
> unit U_Usb ;
>
> interface
>
> uses
> Windows , Messages , SysUtils , Classes , Forms ;
>
> type
>
> PDevBroadcastHdr = ^ DEV_BROADCAST_HDR ;
> DEV_BROADCAST_HDR = packed record
> dbch_size : DWORD ;
> dbch_devicetype : DWORD ;
> dbch_reserved : DWORD ;
> end ;
>
> PDevBroadcastDeviceInterface = ^ DEV_BROADCAST_DEVICEINTERFACE ;
> DEV_BROADCAST_DEVICEINTERFACE = record
> dbcc_size : DWORD ;
> dbcc_devicetype : DWORD ;
> dbcc_reserved : DWORD ;
> dbcc_classguid : TGUID ;
> dbcc_name : short ;
> end ;
>
> const
> GUID_DEVINTERFACE_USB_DEVICE : TGUID =
> '{A5DCBF10-6530-11D2-901F-00C04FB951ED}' ;
> DBT_DEVICEARRIVAL = $8000 ; // system detected a new
> device
> DBT_DEVICEREMOVECOMPLETE = $8004 ; // device is gone
> DBT_DEVTYP_DEVICEINTERFACE = $00000005 ; // device interface class
>
> type
>
> TComponentUSB = class ( TComponent )
> private
> FWindowHandle : HWND ;
> FOnUSBArrival : TNotifyEvent ;
> FOnUSBRemove : TNotifyEvent ;
> procedure WndProc ( var Msg : TMessage );
> function USBRegister : Boolean ;
>
> protected
> procedure WMDeviceChange ( var Msg : TMessage ); dynamic ;
> public
> constructor Create ( AOwner : TComponent ); override ;
> destructor Destroy ; override ;
> published
> property OnUSBArrival : TNotifyEvent read FOnUSBArrival write
> FOnUSBArrival ;
> property OnUSBRemove : TNotifyEvent read FOnUSBRemove write
> FOnUSBRemove ;
> end ;
> procedure Register ;
> implementation
>
> procedure Register ; { add this in the implementation section }
> begin
> RegisterComponents ( 'Samples' , [ TComponentUSB ]);
> end ;
>
>
> constructor TComponentUSB . Create ( AOwner : TComponent );
> begin
> inherited Create ( AOwner );
> FWindowHandle := AllocateHWnd ( WndProc );
> USBRegister ;
> end ;
>
> destructor TComponentUSB . Destroy ;
> begin
> DeallocateHWnd ( FWindowHandle );
> inherited Destroy ;
> end ;
>
> procedure TComponentUSB . WndProc ( var Msg : TMessage );
> begin
> if ( Msg . Msg = WM_DEVICECHANGE ) then
> begin
> try
> WMDeviceChange ( Msg );
> except
> Application . HandleException ( Self );
> end ;
> end
> else
> Msg . Result := DefWindowProc ( FWindowHandle , Msg . Msg , Msg . wParam ,
> Msg . lParam );
> end ;
>
> procedure TComponentUSB . WMDeviceChange ( var Msg : TMessage );
> var
> devType : Integer ;
> Datos : PDevBroadcastHdr ;
> begin
> if ( Msg . wParam = DBT_DEVICEARRIVAL ) or ( Msg . wParam =
> DBT_DEVICEREMOVECOMPLETE ) then
> begin
> Datos := PDevBroadcastHdr ( Msg . lParam );
> devType := Datos ^. dbch_devicetype ;
> if devType = DBT_DEVTYP_DEVICEINTERFACE then
> begin // USB Device
> if Msg . wParam = DBT_DEVICEARRIVAL then
> begin
> if Assigned ( FOnUSBArrival ) then
> FOnUSBArrival ( Self );
> end
> else
> begin
> if Assigned ( FOnUSBRemove ) then
> FOnUSBRemove ( Self );
> end ;
> end ;
> end ;
> end ;
>
> function TComponentUSB . USBRegister : Boolean ;
> var
> dbi : DEV_BROADCAST_DEVICEINTERFACE ;
> Size : Integer ;
> r : Pointer ;
> begin
> Result := False ;
> Size := SizeOf ( DEV_BROADCAST_DEVICEINTERFACE );
> ZeroMemory (@ dbi , Size );
> dbi . dbcc_size := Size ;
> dbi . dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE ;
> dbi . dbcc_reserved := 0 ;
> dbi . dbcc_classguid := GUID_DEVINTERFACE_USB_DEVICE ;
> dbi . dbcc_name := 0 ;
>
> r := RegisterDeviceNotification ( FWindowHandle , @ dbi ,
> DEVICE_NOTIFY_WINDOW_HANDLE
> );
> if Assigned ( r ) then Result := True ;
> end ;
>
> end .
ilgili sorular i ç in canertemp @ gmail . com
--
http : //sadettinpolat.zaxaz.com 'a teşekkürler...
Delphi - .....................................
API (ve sesleniş)
{
Kimi insan vardır, sadece egolarıyla yaşar ve inanın sadece
egolarıyla da ölecektir. Bir insan bir çok konuda çok iyi olabilir.
Üstünlük burada başlamaz, üstünlük bildiklerini paylaşırken,
ben veriyorum demeden paylaşabilmektir. Çünkü en büyük bilgi sahibi
Allah'tır. Biz kimiz ki onun bize verdiği küçücük bilgileri bilgi sayıp
gurura kapılırız.
Bence en büyük erdem insanlara hükmetmek değildir, insanlara hükmetme
gücün varken onlarla aynı sofrayı paylaşabilmektir. En ileri seviye kodları
yazıpta ölümden kurtulabilen varmıdır. Toprakla yüzleştiğin gün
acaba yazdığın ve uğruna insanları incittiğin o kodlar
gururunu tekrar okşayabilecekmidir. Lütfen gençler, sizlerde gönül
taşıyorsunuz, içinizdeki o güzelliğe ses verin verin ve birbirinizi incitmeyin
Ben şimdi sahip olduğum nitelikleri yazmayacağım, çünkü sahip olduğuna inanmak
en büyük basitliktir benim için. Ama 88 den beri bu dünyada hizmet veriyorum
ve yapabileceğim bir şey olursa bana yazabilirsiniz. Özelden.
Sitem:
www.aktifcozumonline.com
www.argecity.com (Daha tamamlanmadı)
Mail Adreslerim:
mkaderoglu@aktifcozumonline.com
mkaderoglu@turksat.com.tr
mkaderoglu@microsoft.com
maholight@msn.com (msn adresim)
maholight@hotmail.com
maholight@gmail.com
maholight@yahoo.com
Gelelim Kodlara Arkadaşlar bu kodlar derlemedir. Bir kaç siteden topladım.
Yeni başlayan arkadaşlara iyi gelecektir. Ben hala kullanıyorum bir çoğunu
Allah işlerinizde kolaylık, gönüllerinizde rahatlık versin.
}
--------------------------------------------------------------------------------
//Belgeler menüsüne bir dosya ekleme
uses k ı sm ı na ShlOBJ unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
s : string ;
begin
s := 'C:DownLoaddeneme.html' ;
SHAddToRecentDocs ( SHARD_PATH , pChar ( s ));
end ;
--------------------------------------------------------------------------------
//Belgeler menüsünü temizleme
uses k ı sm ı na ShlOBJ unitini ekleyin ;
SHAddToRecentDocs ( SHARD_PATH , nil );
--------------------------------------------------------------------------------
//Duvar kağıdını değiştirmek
var
s : string ;
begin
s := 'c:windowscars.bmp' ;
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , PChar ( s ), 0 );
--------------------------------------------------------------------------------
//Başlat butonunu gizlemek veya kullanılmaz hale getirmek
procedure TForm1 . Button1Click ( Sender : TObject );
var
Rgn : hRgn ;
begin
// Başlat butonunu gizle
Rgn := CreateRectRgn ( 0 , 0 , 0 , 0 );
SetWindowRgn ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
Rgn ,
true );
end ;
Procedure TForm1 . Button2Click ( Sender : TObject );
begin
//Gizlenen Başlat butonunu eski haline döndürmek için
SetWindowRgn ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
0 ,
true );
end ;
procedure TForm1 . Button3Click ( Sender : TObject );
begin
//Başlat butonunu kullanılmaz yap
EnableWindow ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
false );
end ;
procedure TForm1 . Button4Click ( Sender : TObject );
begin
//Kullanılmaz yapılan Başlat butonunu eski haline getirmek için
EnableWindow ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
true );
end ;
--------------------------------------------------------------------------------
//Bir programın çalıştırılması
WinExec ( 'c:windowscalc.exe' , sw_show );
WinExec ( 'C:WINDOWSNOTEPAD.EXE C:WINDOWSWIN.INI' , SW_SHOWNORMAL );
WinExec ( 'COMMAND.COM' , SW_SHOWNORMAL );
WinExec ( 'COMMAND.COM /C DIR *.*' , SW_SHOWNORMAL );
--------------------------------------------------------------------------------
//Harddiskin seri numarasının bulunması
procedure TForm1 . Button1Click ( Sender : TObject );
var
VolumeSerialNumber : DWORD ;
MaximumComponentLength : DWORD ;
FileSystemFlags : DWORD ;
SerialNumber : string ;
begin
GetVolumeInformation ( 'C:' ,
nil ,
0 ,
@VolumeSerialNumber ,
MaximumComponentLength ,
FileSystemFlags ,
nil ,
0 );
SerialNumber := IntToHex ( HiWord ( VolumeSerialNumber ), 4 ) + '-' +
IntToHex ( LoWord ( VolumeSerialNumber ), 4 );
Memo1 . Lines . Add ( SerialNumber );
end ;
--------------------------------------------------------------------------------
//Windows ve System klasörlerinin bulunması
procedure TForm1 . Button1Click ( Sender : TObject );
var
a : Array [ 0 .. 144 ] of char ;
begin
GetWindowsDirectory ( a , sizeof ( a ));
ShowMessage ( StrPas ( a ));
GetSystemDirectory ( a , sizeof ( a ));
ShowMessage ( StrPas ( a ));
end ;
--------------------------------------------------------------------------------
//Windows lisans bilgilerinin (isim ve şirket) bulunması
uses k ı sm ı na Registry unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
reg : TRegIniFile ;
begin
reg := TRegIniFile . create ( 'SOFTWAREMICROSOFTMS SETUP (ACME)' );
Memo1 . Lines . Add ( reg . ReadString ( 'USER INFO' , 'DefName' , 'Mustafa ŞİMŞEK' ));
Memo1 . Lines . Add ( reg . ReadString ( 'USER INFO' , 'DefCompany' , '' ));
reg . free ;
end ;
--------------------------------------------------------------------------------
//Speakerdan Beep sesi çıkartma
MessageBeep ( word (- 1 ));
--------------------------------------------------------------------------------
//Bir Denetim Masası uygulamasını çalıştırmak
Control Panel uygulamalar ı Windows System klas ö r ü alt ı nda bulunur . *. CPL uzant ı l ı dosyalard ı r . Bu uygulamalar ı Control . Exe program ı ile ç al ış t ı rabilirsiniz . Baz ı Control Panel uygulamalar ı Windows System klas ö r ü nde bulunmaz . Bunlar ı n ismini vererek ç al ış t ı rabilirsiniz .
WinExec ( 'C:WINDOWSCONTROL.EXE TIMEDATE.CPL' , sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE MOUSE' , sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE PRINTERS' , sw_ShowNormal );
Windows 9 x ve NT 'de ortak olarak kullanılan bazı denetim masası uygulamaları
access . cpl :
Eri ş ilebilirlik
appwiz . cpl :
Program ekle / kald ı r
desk . cpl :
G ö r ü nt ü
intl . cpl :
B ö lgesel ayarlar
joy . cpl :
Oyun ç ubu ğ u
main . cpl :
Fare
mmsys . cpl :
Çoklu ortam
modem . cpl :
Modem
sysdm . cpl :
Sistem
timedate . cpl :
Tarih / Saat
--------------------------------------------------------------------------------
//Windows'u kapatmak veya yeniden başlatmak(reboot)
Win9x 'te bilgisayarı kapatmak veya yeninden başlatmak için :
ExitWindowsEx ( EWX_SHUTDOWN , 0 ); //yeniden başlatmak için EWX_REBOOT
--------------------------------------------------------------------------------
//Ekran koruyucusunu kapatmak ve açmak
//kapatmak için
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE ,
0 ,
nil ,
0 );
//açmak için
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE ,
1 ,
nil ,
0 );
--------------------------------------------------------------------------------
//Ekran kartım kaç rengi destekliyor
Ekran kart ı n ı z ı n ka ç rengi destekledi ğ ini a ş a ğı daki kodla bulabilirsiniz .
( 1 shl ( GetDeviceCaps ( Form1 . Canvas . Handle , BITSPIXEL ) *
GetDeviceCaps ( Form1 . Canvas . Handle , PLANES )));
--------------------------------------------------------------------------------
//Windows Gezginini istediğiniz bir klasörle açma
uses k ı sm ı na ShellApi unitini ekleyin .
ShellExecute ( 0 ,
'explore' ,
'C:WINDOWS' , //buraya açmak istediğiniz klasörü yazın.
nil ,
nil ,
SW_SHOWNORMAL );
--------------------------------------------------------------------------------
//Windows'un Bul (Find File) diyalog penceresini istediğiniz bir klasörle açma
//Windows'ta Başlat->Bul->Dosyalar ve Klasörler ile açtığınız Bul diyalog penceresini Delphi içerisinden hem de istediğiniz yolu vererek çalıştırabilirsiniz.
uses k ı sm ı na ddeman unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
begin
with TDDEClientConv . Create ( Self ) do begin
ConnectMode := ddeManual ;
ServiceApplication := 'explorer.exe' ;
SetLink ( 'Folders' , 'AppProperties' );
OpenLink ;
ExecuteMacro ( '[FindFolder(, C:DOWNLOAD)]' , False ); //diyalog açıldığında konum kısmında
CloseLink ; //olmasını istediğiniz klasör.
Free ;
end ;
end ;
--------------------------------------------------------------------------------
//Pencerenin kapatma düğmesini etkisiz hale getirme
//Pencerenin başlık çubuğunda bulunan kapatma düğmesini (X) etkisiz hale getirebilirsiniz. Aynı zamanda sistem menüsündeki Kapat(Close) seçeneğide kaybolur. Bunun için aşağıdaki gibi bir kod yazmalısınız.
procedure TForm1 . Button1Click ( Sender : TObject );
var
hwndHandle : THANDLE ;
hMenuHandle : HMENU ;
begin
hwndHandle := FindWindow ( nil , 'Form1' ); //Form1 pencerenin başlığını göstermektedir.
if ( hwndHandle <> 0 ) then begin //Burayı uygulamanıza göre değiştirin
hMenuHandle := GetSystemMenu ( hwndHandle , FALSE );
if ( hMenuHandle <> 0 ) then
DeleteMenu ( hMenuHandle , SC_CLOSE , MF_BYCOMMAND );
end ;
end ;
--------------------------------------------------------------------------------
//Uygulamam Windows her açıldığında otomatik çalışsın
uses k ı sm ı na Registry unitini ekleyin .
{$IFNDEF WIN32}
const MAX_PATH = 144 ;
{$ENDIF}
procedure TForm1 . Button1Click ( Sender : TObject );
var
reg : TRegistry ;
begin
reg := TRegistry . Create ;
reg . RootKey := HKEY_LOCAL_MACHINE ;
reg . LazyWrite := false ;
reg . OpenKey ( 'SoftwareMicrosoftWindowsCurrentVersionRun' , false );
reg . WriteString ( 'Uygulamam' , uygulaman ı z ı n_yolu_ve_ad ı);
reg . CloseKey ;
reg . free ;
end ;
--------------------------------------------------------------------------------
//Klasöre Gözat diyalogunu kullanarak bir klasörü seçme
uses k ı sm ı na ShellAPI ve ShlObj unitlerini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
TitleName : string ;
lpItemID : PItemIDList ;
BrowseInfo : TBrowseInfo ;
DisplayName : array [ 0 .. MAX_PATH ] of char ;
TempPath : array [ 0 .. MAX_PATH ] of char ;
begin
FillChar ( BrowseInfo , sizeof ( TBrowseInfo ), #0 );
BrowseInfo . hwndOwner := Form1 . Handle ;
BrowseInfo . pszDisplayName := @ DisplayName ;
TitleName := 'Lütfen bir klasör seçin' ;
BrowseInfo . lpszTitle := PChar ( TitleName );
BrowseInfo . ulFlags := BIF_RETURNONLYFSDIRS ;
lpItemID := SHBrowseForFolder ( BrowseInfo );
if lpItemId <> nil then begin
SHGetPathFromIDList ( lpItemID , TempPath );
ShowMessage ( TempPath );
GlobalFreePtr ( lpItemID );
end ;
end ;
--------------------------------------------------------------------------------
//Bir web adresini açma
//uses kısmına Shellapi unitini ekleyin;
ShellExecute ( Handle ,
'open' ,
'http://www.geocities.com/siliconvalley/campus/4958/' ,
nil ,
nil ,
sw_ShowMaximized );
--------------------------------------------------------------------------------
//Bir DOS programını çalıştırma ve çalışması bitince penceresini kapatma
WinExec ( 'command.com /c progdos.exe' , sw_ShowNormal ); //progdos.exe çalıştırılıyor.
(* eğer
--------------------------------------------------------------------------------
//Alt + Tab ve Ctrl + Esc tuşlarının kullanılmaz hale getirilmesi
var
OldVal : LongInt ;
begin
SystemParametersInfo ( 97 , Word ( True ), @ OldVal , 0 )
(* Word(False) ile kullanırsanız tuşları tekrar kullanabilirsiniz. *)
--------------------------------------------------------------------------------
//Bir menü öğesine resim ekleme
procedure TForm1 . FormCreate ( Sender : TObject );
var
Bmp1 : TPicture ;
begin
Bmp1 := TPicture . Create ;
Bmp1 . LoadFromFile ( 'c:denemeturkey.bmp' );
SetMenuItemBitmaps ( deneme1 . Handle ,
0 ,
MF_BYPOSITION ,
Bmp1 . Bitmap . Handle ,
Bmp1 . Bitmap . Handle );
end ;
--------------------------------------------------------------------------------
//Ağ ortamında makinenin ismini bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
Makine_ismi : array [ 0 .. 255 ] of char ;
BufferSize : DWORD ;
begin
BufferSize := SizeOf ( Makine_ismi );
GetComputerName (@ Makine_ismi , BufferSize );
Showmessage ( Makine_ismi );
end ;
--------------------------------------------------------------------------------
//Ağ ortamında login olmuş kullanıcı ismini bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
Kullanici_ismi : array [ 0 .. 255 ] of char ;
BufferSize : DWORD ;
begin
BufferSize := SizeOf ( Kullanici_ismi );
GetUserName (@ Kullanici_ismi , BufferSize );
Showmessage ( Kullanici_ismi );
end ;
--------------------------------------------------------------------------------
//Ekran çözünürlüğünü nasıl öğrenirim
Screen . Width //yatay çözünürlük
Screen . Height //dikey çözünürlük
MessageDlg ( 'Şu anda ' + IntToStr ( Screen . Width ) + ' x ' +
IntToStr ( Screen . Height )+ ' çözünürlükte çalışıyorsunuz' ,
mtInformation , [ mbOk ], 0 );
--------------------------------------------------------------------------------
//Taskbar'ın (Görev çubuğu) AutoHide özelliği açık mı, kapalı mı?
uses k ı sm ı na ShellAPI unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
ABData : TAppBarData ;
begin
ABData . cbSize := sizeof ( ABData );
if ( SHAppBarMessage ( ABM_GETSTATE , ABData ) and ABS_AUTOHIDE ) > 0 then
Showmessage ( 'Autohide özelliği açık' );
end ;
--------------------------------------------------------------------------------
//Programım biraz beklesin
Baz ı i ş lemlerden sonra di ğ er bir i ş lemi ç al ış t ı rmadan ö nce bir s ü re beklemek istersiniz . Bu gibi durumlarda Sleep komutunu kullanabilirsiniz . Burada verilen de ğ er milisaniye cinsindendir . ( 1 saniye = 1000 milisaniye )
Sleep ( 10000 ) //10 saniye bekler
--------------------------------------------------------------------------------
//Caps lock tuşu açık mı, kapalı mı?
if ( GetKeyState ( VK_CAPITAL ) and $01 )<> 0 then
Showmessage ( 'caps lock açık' );
--------------------------------------------------------------------------------
//İmleci (cursor) gizleyip, tekrar gösterme
ShowCursor ( False ) //imleci gizler
ShowCursor ( True ) //imleci tekrardan gösterir.
--------------------------------------------------------------------------------
//Ekran görüntüsünü alın
procedure TForm1 . Button1Click ( Sender : TObject );
var
DCDesk : HDC ;
begin
DCDesk := GetWindowDC ( GetDesktopWindow );
BitBlt ( Form1 . Canvas . Handle , 0 , 0 , Screen . Width , Screen . Height , DCDesk , 0 , 0 , SRCCOPY );
ReleaseDC ( GetDesktopWindow , DCDesk );
end ;
//Not: Yukarıdaki kod ekran görünütüsünü form üstüne alır. Image bileşeni içine ekran görüntüsünü almak için form üzerine bir image bileşeni yerleştirin ve Form1.Canvas.Handle yerine Image1.Canvas.Handle yazın.
--------------------------------------------------------------------------------
//Map Network Drive diyalogunu açma
WNetConnectionDialog ( 0 , RESOURCETYPE_DISK );
--------------------------------------------------------------------------------
//Bir dosyayı bağlantılı olduğu uygulama ile açma
uses k ı sm ı na shellapi unitini ekleyin .
shellexecute ( 0 , 'open' , 'c:test2.avi' , '' , '' , SW_NORMAL );
--------------------------------------------------------------------------------
//Temp klasörünü bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
temp_klasor : array [ 0 .. MAX_PATH ] of char ;
begin
GetTempPath ( SizeOf ( temp_klasor ), @ temp_klasor );
ShowMessage ( temp_klasor );
end ;
--------------------------------------------------------------------------------
//Ekran koruyucuyu çalıştırmak
PostMessage ( GetDesktopWindow , WM_SYSCOMMAND , SC_SCREENSAVE , 0 );
--------------------------------------------------------------------------------
//Güç koruma modunda (Power Safe Mode) çalışan monitörü kapatıp açma
//Monitörü kapatmak için :
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , 0 );
//Monitörü açmak için :
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , - 1 );
--------------------------------------------------------------------------------
//Windows Tarih/Saat Özellikleri (Date/Time Properties) iletişim kutusunu açma
Winexec ( 'Control.exe Date/Time' , sw_shownormal );
--------------------------------------------------------------------------------
//Windows'ta yüklü bulunan yazıcıları listeleme
uses k ı sm ı na printers unitini ekleyin
procedure TForm1 . Button1Click ( Sender : TObject );
var
Printer : TPrinter ;
begin
Printer := TPrinter . Create ;
Listbox1 . Items . Assign ( Printer . Printers )
end ;
{Bu ipucu Abdurrahman Sinanoğlu tarafından gönderilmiştir}
--------------------------------------------------------------------------------
//Programımın Windows NT'de çalıştığını nasıl tespit ederim
if Win32Platform = VER_PLATFORM_WIN32_NT then
ShowMessage ( 'NT''de çalışıyorsunuz!' );
--------------------------------------------------------------------------------
//Windows oturumunu kapatma (log off)
ExitWindows ( 0 , 0 );
--------------------------------------------------------------------------------
//CPU tipini nasıl tespit ederim
uses k ı sm ı na Registry unitini ekleyin . A ş a ğı daki fonksiyon ile CPU tipini bulabilirsiniz .
function CPUType : string ;
var
Reg : TRegistry ;
begin
CPUType := '' ;
Reg := TRegistry . Create ;
try
Reg . RootKey := HKEY_LOCAL_MACHINE ;
if Reg . OpenKey ( 'HardwareDescriptionSystemCentralProcessor ' , False ) then
CPUType := Reg . ReadString ( 'Identifier' );
finally
Reg . Free ;
end ;
end ;
--------------------------------------------------------------------------------
//Bir klasördeki tüm dosyaları silme
uses k ı m ı na ShellApi komutunu ekleyin . A ş a ğı daki kod bir klas ö rdeki t ü m dosyalar ı çö p tenekesine atar . Daha fazla se ç enek i ç in Delphi yard ı ma ba ş vurun .
procedure TumDosyalariSil ;
var
T : TSHFileOpStruct ;
begin
fillchar ( T , sizeof ( T ), 0 );
with T do begin
Wnd := 0 ;
wFunc := FO_DELETE ;
pFrom := 'E:TempTestDel*.*' #0 ;
fFlags := FOF_ALLOWUNDO or FOF_FILESONLY or
FOF_SILENT or FOF_NOCONFIRMATION ;
end ;
SHFileOperation ( T );
end ;
--------------------------------------------------------------------------------
//Windows NT/2000/XP'yi Kapatmak
//2000 ve XP'de bilgisayarı kapatmak için gerekli yetkiye sahip olmanız lazım. Aşağıda kodla bilgisayarı kapatabilirsiniz.
var
tkHandle : THandle ;
BufferLun , ret : DWORD ;
tk , tkPrevious : TTokenPrivileges ;
LID : TLargeInteger ;
LUID : TLuIDAndAttributes ;
versione : TOSVersionInfo ;
begin
BufferLun := 1024 ;
ret := 0 ;
versione . dwOSVersionInfoSize := sizeof ( versione );
GetVersionEx ( versione );
if versione . dwPlatformId = VER_PLATFORM_WIN32_NT then
begin
tkHandle := GetCurrentProcess ;
OpenProcessToken ( tkHandle , TOKEN_ALL_ACCESS , tkHandle );
LookupPrivilegeValue ( PChar ( '' ), PChar ( 'SeShutDownPrivilege' ), LID );
LUID . Luid := LID ;
LUID . Attributes := SE_PRIVILEGE_ENABLED ;
tk . PrivilegeCount := 1 ;
tk . Privileges [ 0 ] := LUID ;
AdjustTokenPrivileges ( tkHandle , False , tk , BufferLun , tkPrevious , ret );
end ;
ExitWindowsEx ( EWX_SHUTDOWN or EWX_PowerOff , 0 );
end ;
--------------------------------------------------------------------------------
//*.wav (ses) dosyalarını çaldırmak
//Bu iş için PlaySound isimli api'yi kullanabilirsiniz. Api geniş bir parametre aralığına sahip, detaylar için Delphi ile gelen Win32 yardım dosyasına bakabilirsiniz.
PlaySound ( 'C:WINDOWSMEDIAWindows Start.wav' , 0 , Snd_FileName or Snd_Async );
--------------------------------------------------------------------------------
//Programımın simgesi Tray'de (saatin yanında) gözüksün
Bu i ş i yapan bir ç ok bile ş en var . Bunlardan en iyisi art ı k bedava olarak da ğı t ı lan TurboPower ShellShock paketi i ç indeki tray bile ş eni . Bu paketi indirip kurun . İ ndirme detaylar ı i ç in sitedeki 3. Parti bile ş enler k ı sm ı ndaki TurboPower yaz ı s ı na bakabilirsiniz .
--------------------------------------------------------------------------------
//Programım Windows 2000/Xp'de düzgün çalışıyor, Win9x'te TComboBox bileşeninde xxx.Items.String EReadError veriyor
//Bu hata genellikle sistem kaynakları yetersiz olduğu zaman alınmakta. Win 9x'te sistem kaynakları biraz sınırlı.
//Diğer programlarda bu tip hatalar almıyorsanız, programınızda aldığınız kaynakları ve bunları işi bittiği anda serbest bırakıp bırakmadığınızı kontrol edin.
//Win9x'te user ve gdi kaynakları hala sınırlı. TWinControl sınıfından türeyen componentlerin hepsi handle'a sahiptir. Win9x'te handle sayısı 16K ile sınırlı. Ayrıca glyph, image, imagelist ve font gibi componentler de gdi kaynaklarını kullanırlar. Bu da sınırlı Win9x'te. Aşağıdaki noktalara dikkat edin.
//1. Kesin çözüm 2000 veya XP'ye terfi. Eğer
//2. Formları otomatik create etmeyin. Gerektiği zaman oluşturup işi bitince yok edin.
//3. TWinControl'den türeyen bileşenler yerine grafik componentler kullanın. Mesela Panel yerine Bevel kullanın. Grafik componentlerin handle'ları olmadığı için Windows kaynaklarını kullanmazlar.
//4. Kendi oluşturduğuz nesneleri yok edin. Mesela bir stringlist oluşturup, daha sonra yok etmezseniz program kapatılsa bile hafızada kalmaya devam eder. Aynı kodu programda bir çok kez çağırıyorsanız gerisini siz düşünün.
//5. Windows'ta resource monitör isimli bir program var. Yüklü değilse Program ekle/Kaldır windows kısmından kurabilirsiniz. Burdan user ve gdi resource kısmını takip ederek nerelerde kaynakların kritik noktalara indiğini takip edip önlem alabilirsiniz.
//6. Herşey yolunda olsa bile eğer bir formda çok fazla bileşen veya resim vs. varsa buda etkileyebilir. Geçenlerde birisi 1600 tane buton olan bir formdan bahsediyordu.
--------------------------------------------------------------------------------
//Başka bir uygulamayı kapatmak
//Programatik olarak başka bir uygulamayı kapatmak için, uygulamay WM_QUIT mesajı göndermeniz lazım.
function KillApp ( const sCapt : PChar ) : boolean ;
var AppHandle : THandle ;
begin
AppHandle := FindWindow ( Nil , sCapt );
Result := PostMessage ( AppHandle , WM_QUIT , 0 , 0 );
end ;
//Kullanılışı :
if not KillApp ( 'Pencere başlığı' ) then
ShowMessage ( 'Uygulama kapatılamadı!' );
--------------------------------------------------------------------------------
//CD'nin takılıp çıkarıldığından haberdar olma
//Bunun için WM_DEVICECHANGE mesajlarını yakalamamız lazım.
private k ı sm ı na a ş a ğı daki sat ı r ı ekleyin :
procedure WMDeviceChange ( var Msg : TMessage ); message WM_DEVICECHANGE ;
//bu da yakalama kısmı :
procedure TForm1 . WMDeviceChange ( var Msg : TMessage );
const
CD_IN = $8000 ;
CD_OUT = $8004 ;
var
Mesaj : String ;
begin
inherited;
case Msg . wParam of
CD_IN : Mesaj := 'CD takıldı' ;
CD_OUT : Mesaj := 'CD çıkarıldı' ;
end ;
ShowMessage ( Mesaj );
end ;
--------------------------------------------------------------------------------
//Sürücü (drive) tipini belirlemek
//Formun üzerine bir memo ve bir buton koyun ve aşağıdaki kodu yazın.
procedure TForm1 . Button1Click ( Sender : TObject );
var
Drive : Char ;
DriveLetter : String [ 4 ];
begin
for Drive := 'A' to 'Z' do
begin
DriveLetter := Drive + ':' ;
case GetDriveType ( PChar ( Drive + ':' )) of
DRIVE_REMOVABLE : Memo1 . Lines . Add ( DriveLetter + ' Disket Sürücü(Floppy Drive)' );
DRIVE_FIXED : Memo1 . Lines . Add ( DriveLetter + ' Sabit disk(Fixed Drive)' );
DRIVE_REMOTE : Memo1 . Lines . Add ( DriveLetter + ' Ağ sürücüsü(Network Drive)' );
DRIVE_CDROM : Memo1 . Lines . Add ( DriveLetter + ' CD-Rom(CD-ROM Drive)' );
DRIVE_RAMDISK : Memo1 . Lines . Add ( DriveLetter + ' RAM Disk' );
end ;
end ;
end ;
--------------------------------------------------------------------------------
//Bir fontu (.ttf) Windows'a kurmadan uygulamanızda kullanma
//Formun OnCreate ve OnClose olaylarına aşağıdaki kodları yazın.
procedure TForm1 . FormCreate ( Sender : TObject );
begin
AddFontResource ( 'c:FONTSMyFont.TTF' );
SendMessage ( HWND_BROADCAST , WM_FONTCHANGE , 0 , 0 );
end ;
procedure TForm1 . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
RemoveFontResource ( 'C:FONTSMyFont.TTF' );
SendMessage ( HWND_BROADCAST , WM_FONTCHANGE , 0 , 0 );
end ;
--------------------------------------------------------------------------------
//Bir Klasördeki Dosyaları Başka Bir Klasöre Kopyalama
uses k ı sm ı na ShellApi unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
OpStruc : TSHFileOpStruct ;
frombuf , tobuf : Array [ 0 .. 128 ] of Char ;
Begin
{The fillchars make sure the parameters are terminated by at least
two #0 characters, this is required since each parameter can hold
a list of zero-terminated strings, the extra #0 terminates the
list. }
fillChar ( OpStruc , Sizeof ( OpStruc ), 0 );
FillChar ( frombuf , Sizeof ( frombuf ), 0 );
FillChar ( tobuf , Sizeof ( tobuf ), 0 );
StrPCopy ( frombuf , 'c:deneme*.*' );
StrPCopy ( tobuf , 'd:deneme' );
With OpStruc DO Begin
Wnd := Handle ;
wFunc := FO_COPY ;
pFrom := @ frombuf ;
pTo :=@ tobuf ;
fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION ;
end ;
ShFileOperation ( OpStruc );
end ;
--------------------------------------------------------------------------------
//Windows'un Özel Klasörlerini Açma
//Aşağıdaki kodla Bilgisayarım, Masaüstü, Yazıcılar, Fontlar gibi özel Windows klasörlerini açabilirsiniz.
uses shellapi , ShlObj , ActiveX ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
exInfo : TShellExecuteInfo ;
Procedure FreePidl ( pidl : PItemIDList );
Var
allocator : IMalloc ;
Begin
If Succeeded ( SHGetMalloc ( allocator )) Then Begin
allocator . Free ( pidl );
{$IFDEF VER90}
allocator . Release ;
{$ENDIF}
End ;
End ;
Begin
FillChar ( exInfo , Sizeof ( exInfo ), 0 );
// initialize all fields to 0
With exInfo Do Begin
cbSize := Sizeof ( exInfo ); // required!
fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST ;
Wnd := Handle ;
nShow := SW_SHOWNORMAL ;
lpVerb := 'open' ;
ShGetSpecialFolderLocation ( handle , CSIDL_DESKTOP , PItemIDLIst ( lpIDList ));
End ;
ShellExecuteEx ( @ exInfo );
FreePIDL ( exinfo . lpIDList );
end ;
//Diğer özel klasörler : CSIDL_DESKTOP, CSIDL_PROGRAMS, CSIDL_CONTROLS, CSIDL_PRINTERS, CSIDL_PERSONAL, CSIDL_STARTUP, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET, CSIDL_STARTMENU, CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES (My Computer), CSIDL_NETWORK, CSIDL_NETHOOD, CSIDL_FONTS, CSIDL_TEMPLATES.
Delphi - .....................................
API (ve sesleniş)
{
Kimi insan vardır, sadece egolarıyla yaşar ve inanın sadece
egolarıyla da ölecektir. Bir insan bir çok konuda çok iyi olabilir.
Üstünlük burada başlamaz, üstünlük bildiklerini paylaşırken,
ben veriyorum demeden paylaşabilmektir. Çünkü en büyük bilgi sahibi
Allah'tır. Biz kimiz ki onun bize verdiği küçücük bilgileri bilgi sayıp
gurura kapılırız.
Bence en büyük erdem insanlara hükmetmek değildir, insanlara hükmetme
gücün varken onlarla aynı sofrayı paylaşabilmektir. En ileri seviye kodları
yazıpta ölümden kurtulabilen varmıdır. Toprakla yüzleştiğin gün
acaba yazdığın ve uğruna insanları incittiğin o kodlar
gururunu tekrar okşayabilecekmidir. Lütfen gençler, sizlerde gönül
taşıyorsunuz, içinizdeki o güzelliğe ses verin verin ve birbirinizi incitmeyin
Ben şimdi sahip olduğum nitelikleri yazmayacağım, çünkü sahip olduğuna inanmak
en büyük basitliktir benim için. Ama 88 den beri bu dünyada hizmet veriyorum
ve yapabileceğim bir şey olursa bana yazabilirsiniz. Özelden.
Sitem:
www.aktifcozumonline.com
www.argecity.com (Daha tamamlanmadı)
Mail Adreslerim:
mkaderoglu@aktifcozumonline.com
mkaderoglu@turksat.com.tr
mkaderoglu@microsoft.com
maholight@msn.com (msn adresim)
maholight@hotmail.com
maholight@gmail.com
maholight@yahoo.com
Gelelim Kodlara Arkadaşlar bu kodlar derlemedir. Bir kaç siteden topladım.
Yeni başlayan arkadaşlara iyi gelecektir. Ben hala kullanıyorum bir çoğunu
Allah işlerinizde kolaylık, gönüllerinizde rahatlık versin.
}
--------------------------------------------------------------------------------
//Belgeler menüsüne bir dosya ekleme
uses k ı sm ı na ShlOBJ unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
s : string ;
begin
s := 'C:DownLoaddeneme.html' ;
SHAddToRecentDocs ( SHARD_PATH , pChar ( s ));
end ;
--------------------------------------------------------------------------------
//Belgeler menüsünü temizleme
uses k ı sm ı na ShlOBJ unitini ekleyin ;
SHAddToRecentDocs ( SHARD_PATH , nil );
--------------------------------------------------------------------------------
//Duvar kağıdını değiştirmek
var
s : string ;
begin
s := 'c:windowscars.bmp' ;
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , PChar ( s ), 0 );
--------------------------------------------------------------------------------
//Başlat butonunu gizlemek veya kullanılmaz hale getirmek
procedure TForm1 . Button1Click ( Sender : TObject );
var
Rgn : hRgn ;
begin
// Başlat butonunu gizle
Rgn := CreateRectRgn ( 0 , 0 , 0 , 0 );
SetWindowRgn ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
Rgn ,
true );
end ;
Procedure TForm1 . Button2Click ( Sender : TObject );
begin
//Gizlenen Başlat butonunu eski haline döndürmek için
SetWindowRgn ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
0 ,
true );
end ;
procedure TForm1 . Button3Click ( Sender : TObject );
begin
//Başlat butonunu kullanılmaz yap
EnableWindow ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
false );
end ;
procedure TForm1 . Button4Click ( Sender : TObject );
begin
//Kullanılmaz yapılan Başlat butonunu eski haline getirmek için
EnableWindow ( FindWindowEx ( FindWindow ( 'Shell_TrayWnd' , nil ),
0 ,
'Button' ,
nil ),
true );
end ;
--------------------------------------------------------------------------------
//Bir programın çalıştırılması
WinExec ( 'c:windowscalc.exe' , sw_show );
WinExec ( 'C:WINDOWSNOTEPAD.EXE C:WINDOWSWIN.INI' , SW_SHOWNORMAL );
WinExec ( 'COMMAND.COM' , SW_SHOWNORMAL );
WinExec ( 'COMMAND.COM /C DIR *.*' , SW_SHOWNORMAL );
--------------------------------------------------------------------------------
//Harddiskin seri numarasının bulunması
procedure TForm1 . Button1Click ( Sender : TObject );
var
VolumeSerialNumber : DWORD ;
MaximumComponentLength : DWORD ;
FileSystemFlags : DWORD ;
SerialNumber : string ;
begin
GetVolumeInformation ( 'C:' ,
nil ,
0 ,
@VolumeSerialNumber ,
MaximumComponentLength ,
FileSystemFlags ,
nil ,
0 );
SerialNumber := IntToHex ( HiWord ( VolumeSerialNumber ), 4 ) + '-' +
IntToHex ( LoWord ( VolumeSerialNumber ), 4 );
Memo1 . Lines . Add ( SerialNumber );
end ;
--------------------------------------------------------------------------------
//Windows ve System klasörlerinin bulunması
procedure TForm1 . Button1Click ( Sender : TObject );
var
a : Array [ 0 .. 144 ] of char ;
begin
GetWindowsDirectory ( a , sizeof ( a ));
ShowMessage ( StrPas ( a ));
GetSystemDirectory ( a , sizeof ( a ));
ShowMessage ( StrPas ( a ));
end ;
--------------------------------------------------------------------------------
//Windows lisans bilgilerinin (isim ve şirket) bulunması
uses k ı sm ı na Registry unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
reg : TRegIniFile ;
begin
reg := TRegIniFile . create ( 'SOFTWAREMICROSOFTMS SETUP (ACME)' );
Memo1 . Lines . Add ( reg . ReadString ( 'USER INFO' , 'DefName' , 'Mustafa ŞİMŞEK' ));
Memo1 . Lines . Add ( reg . ReadString ( 'USER INFO' , 'DefCompany' , '' ));
reg . free ;
end ;
--------------------------------------------------------------------------------
//Speakerdan Beep sesi çıkartma
MessageBeep ( word (- 1 ));
--------------------------------------------------------------------------------
//Bir Denetim Masası uygulamasını çalıştırmak
Control Panel uygulamalar ı Windows System klas ö r ü alt ı nda bulunur . *. CPL uzant ı l ı dosyalard ı r . Bu uygulamalar ı Control . Exe program ı ile ç al ış t ı rabilirsiniz . Baz ı Control Panel uygulamalar ı Windows System klas ö r ü nde bulunmaz . Bunlar ı n ismini vererek ç al ış t ı rabilirsiniz .
WinExec ( 'C:WINDOWSCONTROL.EXE TIMEDATE.CPL' , sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE MOUSE' , sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE PRINTERS' , sw_ShowNormal );
Windows 9 x ve NT 'de ortak olarak kullanılan bazı denetim masası uygulamaları
access . cpl :
Eri ş ilebilirlik
appwiz . cpl :
Program ekle / kald ı r
desk . cpl :
G ö r ü nt ü
intl . cpl :
B ö lgesel ayarlar
joy . cpl :
Oyun ç ubu ğ u
main . cpl :
Fare
mmsys . cpl :
Çoklu ortam
modem . cpl :
Modem
sysdm . cpl :
Sistem
timedate . cpl :
Tarih / Saat
--------------------------------------------------------------------------------
//Windows'u kapatmak veya yeniden başlatmak(reboot)
Win9x 'te bilgisayarı kapatmak veya yeninden başlatmak için :
ExitWindowsEx ( EWX_SHUTDOWN , 0 ); //yeniden başlatmak için EWX_REBOOT
--------------------------------------------------------------------------------
//Ekran koruyucusunu kapatmak ve açmak
//kapatmak için
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE ,
0 ,
nil ,
0 );
//açmak için
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE ,
1 ,
nil ,
0 );
--------------------------------------------------------------------------------
//Ekran kartım kaç rengi destekliyor
Ekran kart ı n ı z ı n ka ç rengi destekledi ğ ini a ş a ğı daki kodla bulabilirsiniz .
( 1 shl ( GetDeviceCaps ( Form1 . Canvas . Handle , BITSPIXEL ) *
GetDeviceCaps ( Form1 . Canvas . Handle , PLANES )));
--------------------------------------------------------------------------------
//Windows Gezginini istediğiniz bir klasörle açma
uses k ı sm ı na ShellApi unitini ekleyin .
ShellExecute ( 0 ,
'explore' ,
'C:WINDOWS' , //buraya açmak istediğiniz klasörü yazın.
nil ,
nil ,
SW_SHOWNORMAL );
--------------------------------------------------------------------------------
//Windows'un Bul (Find File) diyalog penceresini istediğiniz bir klasörle açma
//Windows'ta Başlat->Bul->Dosyalar ve Klasörler ile açtığınız Bul diyalog penceresini Delphi içerisinden hem de istediğiniz yolu vererek çalıştırabilirsiniz.
uses k ı sm ı na ddeman unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
begin
with TDDEClientConv . Create ( Self ) do begin
ConnectMode := ddeManual ;
ServiceApplication := 'explorer.exe' ;
SetLink ( 'Folders' , 'AppProperties' );
OpenLink ;
ExecuteMacro ( '[FindFolder(, C:DOWNLOAD)]' , False ); //diyalog açıldığında konum kısmında
CloseLink ; //olmasını istediğiniz klasör.
Free ;
end ;
end ;
--------------------------------------------------------------------------------
//Pencerenin kapatma düğmesini etkisiz hale getirme
//Pencerenin başlık çubuğunda bulunan kapatma düğmesini (X) etkisiz hale getirebilirsiniz. Aynı zamanda sistem menüsündeki Kapat(Close) seçeneğide kaybolur. Bunun için aşağıdaki gibi bir kod yazmalısınız.
procedure TForm1 . Button1Click ( Sender : TObject );
var
hwndHandle : THANDLE ;
hMenuHandle : HMENU ;
begin
hwndHandle := FindWindow ( nil , 'Form1' ); //Form1 pencerenin başlığını göstermektedir.
if ( hwndHandle <> 0 ) then begin //Burayı uygulamanıza göre değiştirin
hMenuHandle := GetSystemMenu ( hwndHandle , FALSE );
if ( hMenuHandle <> 0 ) then
DeleteMenu ( hMenuHandle , SC_CLOSE , MF_BYCOMMAND );
end ;
end ;
--------------------------------------------------------------------------------
//Uygulamam Windows her açıldığında otomatik çalışsın
uses k ı sm ı na Registry unitini ekleyin .
{$IFNDEF WIN32}
const MAX_PATH = 144 ;
{$ENDIF}
procedure TForm1 . Button1Click ( Sender : TObject );
var
reg : TRegistry ;
begin
reg := TRegistry . Create ;
reg . RootKey := HKEY_LOCAL_MACHINE ;
reg . LazyWrite := false ;
reg . OpenKey ( 'SoftwareMicrosoftWindowsCurrentVersionRun' , false );
reg . WriteString ( 'Uygulamam' , uygulaman ı z ı n_yolu_ve_ad ı);
reg . CloseKey ;
reg . free ;
end ;
--------------------------------------------------------------------------------
//Klasöre Gözat diyalogunu kullanarak bir klasörü seçme
uses k ı sm ı na ShellAPI ve ShlObj unitlerini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
TitleName : string ;
lpItemID : PItemIDList ;
BrowseInfo : TBrowseInfo ;
DisplayName : array [ 0 .. MAX_PATH ] of char ;
TempPath : array [ 0 .. MAX_PATH ] of char ;
begin
FillChar ( BrowseInfo , sizeof ( TBrowseInfo ), #0 );
BrowseInfo . hwndOwner := Form1 . Handle ;
BrowseInfo . pszDisplayName := @ DisplayName ;
TitleName := 'Lütfen bir klasör seçin' ;
BrowseInfo . lpszTitle := PChar ( TitleName );
BrowseInfo . ulFlags := BIF_RETURNONLYFSDIRS ;
lpItemID := SHBrowseForFolder ( BrowseInfo );
if lpItemId <> nil then begin
SHGetPathFromIDList ( lpItemID , TempPath );
ShowMessage ( TempPath );
GlobalFreePtr ( lpItemID );
end ;
end ;
--------------------------------------------------------------------------------
//Bir web adresini açma
//uses kısmına Shellapi unitini ekleyin;
ShellExecute ( Handle ,
'open' ,
'http://www.geocities.com/siliconvalley/campus/4958/' ,
nil ,
nil ,
sw_ShowMaximized );
--------------------------------------------------------------------------------
//Bir DOS programını çalıştırma ve çalışması bitince penceresini kapatma
WinExec ( 'command.com /c progdos.exe' , sw_ShowNormal ); //progdos.exe çalıştırılıyor.
(* eğer ikinci paremetreyi sw_Hide yaparsanız kullanıcı programın çalıştığını görmez. *)
--------------------------------------------------------------------------------
//Alt + Tab ve Ctrl + Esc tuşlarının kullanılmaz hale getirilmesi
var
OldVal : LongInt ;
begin
SystemParametersInfo ( 97 , Word ( True ), @ OldVal , 0 )
(* Word(False) ile kullanırsanız tuşları tekrar kullanabilirsiniz. *)
--------------------------------------------------------------------------------
//Bir menü öğesine resim ekleme
procedure TForm1 . FormCreate ( Sender : TObject );
var
Bmp1 : TPicture ;
begin
Bmp1 := TPicture . Create ;
Bmp1 . LoadFromFile ( 'c:denemeturkey.bmp' );
SetMenuItemBitmaps ( deneme1 . Handle ,
0 ,
MF_BYPOSITION ,
Bmp1 . Bitmap . Handle ,
Bmp1 . Bitmap . Handle );
end ;
--------------------------------------------------------------------------------
//Ağ ortamında makinenin ismini bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
Makine_ismi : array [ 0 .. 255 ] of char ;
BufferSize : DWORD ;
begin
BufferSize := SizeOf ( Makine_ismi );
GetComputerName (@ Makine_ismi , BufferSize );
Showmessage ( Makine_ismi );
end ;
--------------------------------------------------------------------------------
//Ağ ortamında login olmuş kullanıcı ismini bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
Kullanici_ismi : array [ 0 .. 255 ] of char ;
BufferSize : DWORD ;
begin
BufferSize := SizeOf ( Kullanici_ismi );
GetUserName (@ Kullanici_ismi , BufferSize );
Showmessage ( Kullanici_ismi );
end ;
--------------------------------------------------------------------------------
//Ekran çözünürlüğünü nasıl öğrenirim
Screen . Width //yatay çözünürlük
Screen . Height //dikey çözünürlük
MessageDlg ( 'Şu anda ' + IntToStr ( Screen . Width ) + ' x ' +
IntToStr ( Screen . Height )+ ' çözünürlükte çalışıyorsunuz' ,
mtInformation , [ mbOk ], 0 );
--------------------------------------------------------------------------------
//Taskbar'ın (Görev çubuğu) AutoHide özelliği açık mı, kapalı mı?
uses k ı sm ı na ShellAPI unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
ABData : TAppBarData ;
begin
ABData . cbSize := sizeof ( ABData );
if ( SHAppBarMessage ( ABM_GETSTATE , ABData ) and ABS_AUTOHIDE ) > 0 then
Showmessage ( 'Autohide özelliği açık' );
end ;
--------------------------------------------------------------------------------
//Programım biraz beklesin
Baz ı i ş lemlerden sonra di ğ er bir i ş lemi ç al ış t ı rmadan ö nce bir s ü re beklemek istersiniz . Bu gibi durumlarda Sleep komutunu kullanabilirsiniz . Burada verilen de ğ er milisaniye cinsindendir . ( 1 saniye = 1000 milisaniye )
Sleep ( 10000 ) //10 saniye bekler
--------------------------------------------------------------------------------
//Caps lock tuşu açık mı, kapalı mı?
if ( GetKeyState ( VK_CAPITAL ) and $01 )<> 0 then
Showmessage ( 'caps lock açık' );
--------------------------------------------------------------------------------
//İmleci (cursor) gizleyip, tekrar gösterme
ShowCursor ( False ) //imleci gizler
ShowCursor ( True ) //imleci tekrardan gösterir.
--------------------------------------------------------------------------------
//Ekran görüntüsünü alın
procedure TForm1 . Button1Click ( Sender : TObject );
var
DCDesk : HDC ;
begin
DCDesk := GetWindowDC ( GetDesktopWindow );
BitBlt ( Form1 . Canvas . Handle , 0 , 0 , Screen . Width , Screen . Height , DCDesk , 0 , 0 , SRCCOPY );
ReleaseDC ( GetDesktopWindow , DCDesk );
end ;
//Not: Yukarıdaki kod ekran görünütüsünü form üstüne alır. Image bileşeni içine ekran görüntüsünü almak için form üzerine bir image bileşeni yerleştirin ve Form1.Canvas.Handle yerine Image1.Canvas.Handle yazın.
--------------------------------------------------------------------------------
//Map Network Drive diyalogunu açma
WNetConnectionDialog ( 0 , RESOURCETYPE_DISK );
--------------------------------------------------------------------------------
//Bir dosyayı bağlantılı olduğu uygulama ile açma
uses k ı sm ı na shellapi unitini ekleyin .
shellexecute ( 0 , 'open' , 'c:test2.avi' , '' , '' , SW_NORMAL );
--------------------------------------------------------------------------------
//Temp klasörünü bulma
procedure TForm1 . Button1Click ( Sender : TObject );
var
temp_klasor : array [ 0 .. MAX_PATH ] of char ;
begin
GetTempPath ( SizeOf ( temp_klasor ), @ temp_klasor );
ShowMessage ( temp_klasor );
end ;
--------------------------------------------------------------------------------
//Ekran koruyucuyu çalıştırmak
PostMessage ( GetDesktopWindow , WM_SYSCOMMAND , SC_SCREENSAVE , 0 );
--------------------------------------------------------------------------------
//Güç koruma modunda (Power Safe Mode) çalışan monitörü kapatıp açma
//Monitörü kapatmak için :
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , 0 );
//Monitörü açmak için :
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , - 1 );
--------------------------------------------------------------------------------
//Windows Tarih/Saat Özellikleri (Date/Time Properties) iletişim kutusunu açma
Winexec ( 'Control.exe Date/Time' , sw_shownormal );
--------------------------------------------------------------------------------
//Windows'ta yüklü bulunan yazıcıları listeleme
uses k ı sm ı na printers unitini ekleyin
procedure TForm1 . Button1Click ( Sender : TObject );
var
Printer : TPrinter ;
begin
Printer := TPrinter . Create ;
Listbox1 . Items . Assign ( Printer . Printers )
end ;
{Bu ipucu Abdurrahman Sinanoğlu tarafından gönderilmiştir}
--------------------------------------------------------------------------------
//Programımın Windows NT'de çalıştığını nasıl tespit ederim
if Win32Platform = VER_PLATFORM_WIN32_NT then
ShowMessage ( 'NT''de çalışıyorsunuz!' );
--------------------------------------------------------------------------------
//Windows oturumunu kapatma (log off)
ExitWindows ( 0 , 0 );
--------------------------------------------------------------------------------
//CPU tipini nasıl tespit ederim
uses k ı sm ı na Registry unitini ekleyin . A ş a ğı daki fonksiyon ile CPU tipini bulabilirsiniz .
function CPUType : string ;
var
Reg : TRegistry ;
begin
CPUType := '' ;
Reg := TRegistry . Create ;
try
Reg . RootKey := HKEY_LOCAL_MACHINE ;
if Reg . OpenKey ( 'HardwareDescriptionSystemCentralProcessor ' , False ) then
CPUType := Reg . ReadString ( 'Identifier' );
finally
Reg . Free ;
end ;
end ;
--------------------------------------------------------------------------------
//Bir klasördeki tüm dosyaları silme
uses k ı m ı na ShellApi komutunu ekleyin . A ş a ğı daki kod bir klas ö rdeki t ü m dosyalar ı çö p tenekesine atar . Daha fazla se ç enek i ç in Delphi yard ı ma ba ş vurun .
procedure TumDosyalariSil ;
var
T : TSHFileOpStruct ;
begin
fillchar ( T , sizeof ( T ), 0 );
with T do begin
Wnd := 0 ;
wFunc := FO_DELETE ;
pFrom := 'E:TempTestDel*.*' #0 ;
fFlags := FOF_ALLOWUNDO or FOF_FILESONLY or
FOF_SILENT or FOF_NOCONFIRMATION ;
end ;
SHFileOperation ( T );
end ;
--------------------------------------------------------------------------------
//Windows NT/2000/XP'yi Kapatmak
//2000 ve XP'de bilgisayarı kapatmak için gerekli yetkiye sahip olmanız lazım. Aşağıda kodla bilgisayarı kapatabilirsiniz.
var
tkHandle : THandle ;
BufferLun , ret : DWORD ;
tk , tkPrevious : TTokenPrivileges ;
LID : TLargeInteger ;
LUID : TLuIDAndAttributes ;
versione : TOSVersionInfo ;
begin
BufferLun := 1024 ;
ret := 0 ;
versione . dwOSVersionInfoSize := sizeof ( versione );
GetVersionEx ( versione );
if versione . dwPlatformId = VER_PLATFORM_WIN32_NT then
begin
tkHandle := GetCurrentProcess ;
OpenProcessToken ( tkHandle , TOKEN_ALL_ACCESS , tkHandle );
LookupPrivilegeValue ( PChar ( '' ), PChar ( 'SeShutDownPrivilege' ), LID );
LUID . Luid := LID ;
LUID . Attributes := SE_PRIVILEGE_ENABLED ;
tk . PrivilegeCount := 1 ;
tk . Privileges [ 0 ] := LUID ;
AdjustTokenPrivileges ( tkHandle , False , tk , BufferLun , tkPrevious , ret );
end ;
ExitWindowsEx ( EWX_SHUTDOWN or EWX_PowerOff , 0 );
end ;
--------------------------------------------------------------------------------
//*.wav (ses) dosyalarını çaldırmak
//Bu iş için PlaySound isimli api'yi kullanabilirsiniz. Api geniş bir parametre aralığına sahip, detaylar için Delphi ile gelen Win32 yardım dosyasına bakabilirsiniz.
PlaySound ( 'C:WINDOWSMEDIAWindows Start.wav' , 0 , Snd_FileName or Snd_Async );
--------------------------------------------------------------------------------
//Programımın simgesi Tray'de (saatin yanında) gözüksün
Bu i ş i yapan bir ç ok bile ş en var . Bunlardan en iyisi art ı k bedava olarak da ğı t ı lan TurboPower ShellShock paketi i ç indeki tray bile ş eni . Bu paketi indirip kurun . İ ndirme detaylar ı i ç in sitedeki 3. Parti bile ş enler k ı sm ı ndaki TurboPower yaz ı s ı na bakabilirsiniz .
--------------------------------------------------------------------------------
//Programım Windows 2000/Xp'de düzgün çalışıyor, Win9x'te TComboBox bileşeninde xxx.Items.String EReadError veriyor
//Bu hata genellikle sistem kaynakları yetersiz olduğu zaman alınmakta. Win 9x'te sistem kaynakları biraz sınırlı.
//Diğer programlarda bu tip hatalar almıyorsanız, programınızda aldığınız kaynakları ve bunları işi bittiği anda serbest bırakıp bırakmadığınızı kontrol edin.
//Win9x'te user ve gdi kaynakları hala sınırlı. TWinControl sınıfından türeyen componentlerin hepsi handle'a sahiptir. Win9x'te handle sayısı 16K ile sınırlı. Ayrıca glyph, image, imagelist ve font gibi componentler de gdi kaynaklarını kullanırlar. Bu da sınırlı Win9x'te. Aşağıdaki noktalara dikkat edin.
//1. Kesin çözüm 2000 veya XP'ye terfi. Eğer işyeri ise güvenlik gibi başka nedenlerle bu en iyi çözüm olacaktır. Biliyorsunuz Win9x'in hedef kitlesi ev kullanıcıları.
//2. Formları otomatik create etmeyin. Gerektiği zaman oluşturup işi bitince yok edin.
//3. TWinControl'den türeyen bileşenler yerine grafik componentler kullanın. Mesela Panel yerine Bevel kullanın. Grafik componentlerin handle'ları olmadığı için Windows kaynaklarını kullanmazlar.
//4. Kendi oluşturduğuz nesneleri yok edin. Mesela bir stringlist oluşturup, daha sonra yok etmezseniz program kapatılsa bile hafızada kalmaya devam eder. Aynı kodu programda bir çok kez çağırıyorsanız gerisini siz düşünün.
//5. Windows'ta resource monitör isimli bir program var. Yüklü değilse Program ekle/Kaldır windows kısmından kurabilirsiniz. Burdan user ve gdi resource kısmını takip ederek nerelerde kaynakların kritik noktalara indiğini takip edip önlem alabilirsiniz.
//6. Herşey yolunda olsa bile eğer bir formda çok fazla bileşen veya resim vs. varsa buda etkileyebilir. Geçenlerde birisi 1600 tane buton olan bir formdan bahsediyordu.
--------------------------------------------------------------------------------
//Başka bir uygulamayı kapatmak
//Programatik olarak başka bir uygulamayı kapatmak için, uygulamay WM_QUIT mesajı göndermeniz lazım.
function KillApp ( const sCapt : PChar ) : boolean ;
var AppHandle : THandle ;
begin
AppHandle := FindWindow ( Nil , sCapt );
Result := PostMessage ( AppHandle , WM_QUIT , 0 , 0 );
end ;
//Kullanılışı :
if not KillApp ( 'Pencere başlığı' ) then
ShowMessage ( 'Uygulama kapatılamadı!' );
--------------------------------------------------------------------------------
//CD'nin takılıp çıkarıldığından haberdar olma
//Bunun için WM_DEVICECHANGE mesajlarını yakalamamız lazım.
private k ı sm ı na a ş a ğı daki sat ı r ı ekleyin :
procedure WMDeviceChange ( var Msg : TMessage ); message WM_DEVICECHANGE ;
//bu da yakalama kısmı :
procedure TForm1 . WMDeviceChange ( var Msg : TMessage );
const
CD_IN = $8000 ;
CD_OUT = $8004 ;
var
Mesaj : String ;
begin
inherited;
case Msg . wParam of
CD_IN : Mesaj := 'CD takıldı' ;
CD_OUT : Mesaj := 'CD çıkarıldı' ;
end ;
ShowMessage ( Mesaj );
end ;
--------------------------------------------------------------------------------
//Sürücü (drive) tipini belirlemek
//Formun üzerine bir memo ve bir buton koyun ve aşağıdaki kodu yazın.
procedure TForm1 . Button1Click ( Sender : TObject );
var
Drive : Char ;
DriveLetter : String [ 4 ];
begin
for Drive := 'A' to 'Z' do
begin
DriveLetter := Drive + ':' ;
case GetDriveType ( PChar ( Drive + ':' )) of
DRIVE_REMOVABLE : Memo1 . Lines . Add ( DriveLetter + ' Disket Sürücü(Floppy Drive)' );
DRIVE_FIXED : Memo1 . Lines . Add ( DriveLetter + ' Sabit disk(Fixed Drive)' );
DRIVE_REMOTE : Memo1 . Lines . Add ( DriveLetter + ' Ağ sürücüsü(Network Drive)' );
DRIVE_CDROM : Memo1 . Lines . Add ( DriveLetter + ' CD-Rom(CD-ROM Drive)' );
DRIVE_RAMDISK : Memo1 . Lines . Add ( DriveLetter + ' RAM Disk' );
end ;
end ;
end ;
--------------------------------------------------------------------------------
//Bir fontu (.ttf) Windows'a kurmadan uygulamanızda kullanma
//Formun OnCreate ve OnClose olaylarına aşağıdaki kodları yazın.
procedure TForm1 . FormCreate ( Sender : TObject );
begin
AddFontResource ( 'c:FONTSMyFont.TTF' );
SendMessage ( HWND_BROADCAST , WM_FONTCHANGE , 0 , 0 );
end ;
procedure TForm1 . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
RemoveFontResource ( 'C:FONTSMyFont.TTF' );
SendMessage ( HWND_BROADCAST , WM_FONTCHANGE , 0 , 0 );
end ;
--------------------------------------------------------------------------------
//Bir Klasördeki Dosyaları Başka Bir Klasöre Kopyalama
uses k ı sm ı na ShellApi unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
var
OpStruc : TSHFileOpStruct ;
frombuf , tobuf : Array [ 0 .. 128 ] of Char ;
Begin
{The fillchars make sure the parameters are terminated by at least
two #0 characters, this is required since each parameter can hold
a list of zero-terminated strings, the extra #0 terminates the
list. }
fillChar ( OpStruc , Sizeof ( OpStruc ), 0 );
FillChar ( frombuf , Sizeof ( frombuf ), 0 );
FillChar ( tobuf , Sizeof ( tobuf ), 0 );
StrPCopy ( frombuf , 'c:deneme*.*' );
StrPCopy ( tobuf , 'd:deneme' );
With OpStruc DO Begin
Wnd := Handle ;
wFunc := FO_COPY ;
pFrom := @ frombuf ;
pTo :=@ tobuf ;
fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION ;
end ;
ShFileOperation ( OpStruc );
end ;
--------------------------------------------------------------------------------
//Windows'un Özel Klasörlerini Açma
//Aşağıdaki kodla Bilgisayarım, Masaüstü, Yazıcılar, Fontlar gibi özel Windows klasörlerini açabilirsiniz.
uses shellapi , ShlObj , ActiveX ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
exInfo : TShellExecuteInfo ;
Procedure FreePidl ( pidl : PItemIDList );
Var
allocator : IMalloc ;
Begin
If Succeeded ( SHGetMalloc ( allocator )) Then Begin
allocator . Free ( pidl );
{$IFDEF VER90}
allocator . Release ;
{$ENDIF}
End ;
End ;
Begin
FillChar ( exInfo , Sizeof ( exInfo ), 0 );
// initialize all fields to 0
With exInfo Do Begin
cbSize := Sizeof ( exInfo ); // required!
fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST ;
Wnd := Handle ;
nShow := SW_SHOWNORMAL ;
lpVerb := 'open' ;
ShGetSpecialFolderLocation ( handle , CSIDL_DESKTOP , PItemIDLIst ( lpIDList ));
End ;
ShellExecuteEx ( @ exInfo );
FreePIDL ( exinfo . lpIDList );
end ;
//Diğer özel klasörler : CSIDL_DESKTOP, CSIDL_PROGRAMS, CSIDL_CONTROLS, CSIDL_PRINTERS, CSIDL_PERSONAL, CSIDL_STARTUP, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET, CSIDL_STARTMENU, CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES (My Computer), CSIDL_NETWORK, CSIDL_NETHOOD, CSIDL_FONTS, CSIDL_TEMPLATES.
Delphi - .....................................
Drony - database kullanmadan tarih sıralama ve sayı sıralama örneği
{
drony
http://forum.donanimhaber.com
drony_dh@hotmail.com
Drony Application Protect 3.09 beta (DAP3)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197
Drony Image to Html 1.2e (I2H)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660
}
{
database kullanmadan tarih sıralama ve sayı sıralama örneği
}
var
Form1 : TForm1 ;
arabellek : Tstringlist ;
implementation
{$R *.dfm}
{
02.09.2005 13:40: 19 tarih formatı örneği
02.09.2005 tarih formatı örneği
}
Procedure sayisirala ( list : TStrings );
var bos : int64 ;
s : array of int64 ;
i , j , l : integer ;
begin
l := list . Count ;
SetLength ( s , l );
for i := 0 to l - 1 do
s := strtoint ( list . Strings );
for i := 0 to l do begin
for j := i to l do begin
if s > s [ j ] then begin
Bos := s ;
s := s [ j ];
s [ j ]:= Bos ;
end ;
end ;
end ;
list . clear ;
for i := 1 to l do
list . add ( inttostr ( s [ i - 1 ]) );
end ;
procedure TForm1 . siralaClick ( Sender : TObject );
var a , b : integer ;
begin
arabellek := TStringList . Create ;
arabellek . Clear ;
with tarihlist . items do begin
add ( '01.07.1993 01:40: 18' );
add ( '05.02.2002 07:40: 13' );
add ( '23.09.2015 08:40: 17' );
add ( '07.09.2006 ' );
add ( '25.12.2000 ' );
add ( '02.09.2005 23:15: 18' );
add ( '21.09.2004 ' );
add ( '09.12.2001 13:40: 10' );
add ( '11.09.1998 21:40: 14' );
add ( '20.09.2001 15:40: 11' );
end ;
for a := 0 to tarihlist . Items . Count - 1 do
arabellek . Add ( inttostr ( DateTimeToUnix ( StrToDateTime ( tarihlist . Items . Strings [ a ]))));
sayisirala ( arabellek );
siralitarih . clear ;
for b := 0 to arabellek . Count - 1 do
siralitarih . Items . Add ( DateTimeToStr ( EncodeDate ( 1970 , 1 , 1 )+ strtoint ( arabellek . Strings ) / SecsPerDay )) ;
arabellek . free ;
end ;
Delphi - .....................................
Drony - database kullanmadan tarih sıralama ve sayı sıralama örneği
{
drony
http://forum.donanimhaber.com
drony_dh@hotmail.com
Drony Application Protect 3.09 beta (DAP3)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197
Drony Image to Html 1.2e (I2H)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660
}
{
database kullanmadan tarih sıralama ve sayı sıralama örneği
}
var
Form1 : TForm1 ;
arabellek : Tstringlist ;
implementation
{$R *.dfm}
{
02.09.2005 13:40: 19 tarih formatı örneği
02.09.2005 tarih formatı örneği
}
Procedure sayisirala ( list : TStrings );
var bos : int64 ;
s : array of int64 ;
i , j , l : integer ;
begin
l := list . Count ;
SetLength ( s , l );
for i := 0 to l - 1 do
s := strtoint ( list . Strings );
for i := 0 to l do begin
for j := i to l do begin
if s > s [ j ] then begin
Bos := s ;
s := s [ j ];
s [ j ]:= Bos ;
end ;
end ;
end ;
list . clear ;
for i := 1 to l do
list . add ( inttostr ( s [ i - 1 ]) );
end ;
procedure TForm1 . siralaClick ( Sender : TObject );
var a , b : integer ;
begin
arabellek := TStringList . Create ;
arabellek . Clear ;
with tarihlist . items do begin
add ( '01.07.1993 01:40: 18' );
add ( '05.02.2002 07:40: 13' );
add ( '23.09.2015 08:40: 17' );
add ( '07.09.2006 ' );
add ( '25.12.2000 ' );
add ( '02.09.2005 23:15: 18' );
add ( '21.09.2004 ' );
add ( '09.12.2001 13:40: 10' );
add ( '11.09.1998 21:40: 14' );
add ( '20.09.2001 15:40: 11' );
end ;
for a := 0 to tarihlist . Items . Count - 1 do
arabellek . Add ( inttostr ( DateTimeToUnix ( StrToDateTime ( tarihlist . Items . Strings [ a ]))));
sayisirala ( arabellek );
siralitarih . clear ;
for b := 0 to arabellek . Count - 1 do
siralitarih . Items . Add ( DateTimeToStr ( EncodeDate ( 1970 , 1 , 1 )+ strtoint ( arabellek . Strings ) / SecsPerDay )) ;
arabellek . free ;
end ;
Delphi - .....................................
Drony - String İşlemleri [Unit]
{
drony
http://forum.donanimhaber.com
drony_dh@hotmail.com
Drony Application Protect 3.09 beta (DAP3)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197
Drony Image to Html 1.2e (I2H)
http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660
}
unit janStrings ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , dialogs ;
{file filter functions}
function decodefilter ( afilter : string ): string ;
function encodefilter ( avalue : string ): string ;
{xml functions}
function xmlformatLoadStr ( fn : string ): string ;
function prettyxml ( aText : string ): string ;
{test conversions}
function isInteger ( aStr : string ): boolean ;
{quotes}
function magic ( aStr : string ): string ;
function unquote ( aStr : string ): string ;
{name and value}
function strName ( aStr : string ): string ;
function strValue ( aStr : string ): string ;
{template functions}
function ReplaceFirst ( sourceStr , findStr , replaceStr : string ): string ;
function ReplaceLast ( sourceStr , findStr , replaceStr : string ): string ;
function GetBlock ( sourceStr , blockStr : string ): string ;
function InsertLastBlock ( var sourceStr : string ; blockStr : string ): boolean ;
function InsertIndexBlock ( var sourceStr : string ; blockStr : string ; index : integer ): boolean ;
function removeMasterBlocks ( sourceStr : string ): string ;
function removeFields ( sourceStr : string ): string ;
function removeImages ( sourceStr : string ): string ;
function renumberFields ( sourceStr : string ): string ;
procedure gettemplatefields ( aText : string ; aList : TStringList );
{http functions}
function URLEncode ( Value : String ) : String ; // Converts String To A URLEncoded String
function URLDecode ( Value : String ) : String ; // Converts String From A URLEncoded String
function HTMLEncode ( value : string ): string ;
{set functions}
procedure SplitSet ( aText : string ; aList : TStringList );
function JoinSet ( aList : TstringList ): string ;
function FirstOfSet ( aText : string ): string ;
function LastOfSet ( aText : string ): string ;
function CountOfSet ( aText : string ): integer ;
function SetRotateRight ( aText : string ): string ;
function SetRotateLeft ( aText : string ): string ;
function SetPick ( aText : string ; aIndex : integer ): string ;
function SetSort ( aText : string ): string ;
function SetUnion ( set1 , set2 : string ): string ;
function SetIntersect ( set1 , set2 : string ): string ;
function SetExclude ( set1 , set2 : string ): string ;
{replace any <,> etc by < >}
function XMLSafe ( aText : string ): string ;
{simple hash, result can be used in Encrypt}
function Hash ( aText : string ): integer ;
{ Base64 encode and decode a string }
function B64Encode ( const S : string ): string ;
function B64Decode ( const S : string ): string ;
{Basic encryption from a Borland Example}
function Encrypt ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
function Decrypt ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
{Using Encrypt and Decrypt in combination with B64Encode and B64Decode}
function EncryptB64 ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
function DecryptB64 ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
procedure csv2tags ( src , dst : TStringList );
// converts a csv list to a tagged string list
procedure tags2csv ( src , dst : TStringList );
// converts a tagged string list to a csv list
// only fieldnames from the first record are scanned ib the other records
procedure ListSelect ( src , dst : TStringList ; aKey , aValue : string );
{selects akey=avalue from src and returns recordset in dst}
procedure ListSelectSet ( src , dst : TStringList ; aKey , aValue : string );
{selects akey in (avalue) from src and returns recordset in dst}
{avalue is a comma seperated list of values}
procedure ListFilter ( src : TStringList ; aKey , aValue : string );
{filters src for akey=avalue}
procedure ListOrderBy ( src : TstringList ; aKey : string ; numeric : boolean );
{orders a tagged src list by akey}
function PosStr ( const FindString , SourceString : string ;
StartPos : Integer = 1 ): Integer ;
{ PosStr searches the first occurrence of a substring FindString in a string
given by SourceString with case sensitivity (upper and lower case characters
are differed). This function returns the index value of the first character
of a specified substring from which it occurs in a given string starting with
StartPos character index. If a specified substring is not found Q_PosStr
returns zero. The author of algorithm is Peter Morris (UK) (FastStrings unit
from www.torry.ru). }
function PosStrLast ( const FindString , SourceString : string ): integer ;
{finds the last occurance}
function StrRScan ( const S : string ; Ch : Char ; LastPos : Integer = MaxInt ): Integer ;
{scans from the right for a char position}
function PosText ( const FindString , SourceString : string ;
StartPos : Integer = 1 ): Integer ;
{ PosText searches the first occurrence of a substring FindString in a string
given by SourceString without case sensitivity (upper and lower case
characters are not differed). This function returns the index value of the
first character of a specified substring from which it occurs in a given
string starting with StartPos character index. If a specified substring is
not found Q_PosStr returns zero. The author of algorithm is Peter Morris
(UK) (FastStrings unit from www.torry.ru). }
function PosTextWild ( const FindString , SourceString : string ; var count : integer ;
StartPos : Integer = 1 ): Integer ;
{finds a form ddhdjd*dvkdj and returns the length of the found string in count}
function PosTextLast ( const FindString , SourceString : string ): integer ;
{finds the last occurance}
function NameValuesToXML ( aText : string ): string ;
procedure LoadResourceFile ( aFile : string ; ms : TMemoryStream );
procedure DirFiles ( aDir , amask : string ; aFileList : TStringlist );
procedure DirFilesEx ( aDir : string ; aFileList : TStringlist );
procedure RecurseDirFiles ( myDir : string ; var aFileList : TStringlist );
procedure RecurseDirProgs ( myDir : string ; var aFileList : TStringlist );
procedure SaveString ( aFile , aText : string );
function LoadString ( aFile : string ): string ;
function HexToColor ( aText : string ): Tcolor ;
function ColorToHex ( aColor : Tcolor ): String ;
function UppercaseHTMLTags ( aText : string ): string ;
function LowercaseHTMLTags ( aText : string ): string ;
procedure GetHTMLAnchors ( aFile : string ; aList : TStringList );
function relativepath ( aSrc , aDst : string ): string ;
function GetToken ( var start : integer ; SourceText : string ): string ;
function PosNonSpace ( Start : integer ; SourceText : string ): integer ;
function PosEscaped ( Start : integer ; SourceText , FindText : string ; escapeChar : char ): integer ;
function DeleteEscaped ( SourceText : string ; escapeChar : char ): string ;
function BeginOfAttribute ( Start : integer ; SourceText : String ): integer ;
// parses the beginning of an attribute: space + alpha character
function ParseAttribute ( var Start : integer ; SourceText : String ; var aName : string ; var aValue : string ): boolean ;
// parses a name="value" attribute from Start; returns 0 when not found or else the position behind the attribute
procedure ParseAttributes ( SourceText : string ; var Attributes : TStringList );
// parses all name=value attributes to the attributes TStringlist
function HasStrValue ( aText , aName : string ; var aValue : string ): boolean ;
// checks if a name="value" pair exists and returns any value
function GetStrValue ( aText , aName , aDefault : string ): string ;
// retrieves string value from a line like:
// name="jan verhoeven" email="jan1.verhoeven@wxs.nl"
// returns aDefault when not found
function GetHTMLColorValue ( aText , aName : string ; aDefault : Tcolor ): TColor ;
// same for a color
function GetIntValue ( aText , aName : string ; aDefault : Integer ): integer ;
// same for an integer
function GetFloatValue ( aText , aName : string ; aDefault : extended ): extended ;
// same for a float
function GetBoolValue ( aText , aName : string ): boolean ;
// same for boolean but without default
function GetValue ( aText , aName : string ): string ;
// retrieves string value from a line like:
// name="jan verhoeven" email="jan1.verhoeven@wxs.nl"
procedure SetValue ( var aText : string ; aName , aValue : string );
// sets a string value in a line
procedure DeleteValue ( var aText : string ; aName : string );
// deletes a aName="value" pair from aText
procedure GetNames ( aText : string ; aList : TStringList );
// get a list of names from a string with name="value" pairs
function GetHTMLColor ( aColor : TColor ): string ;
// converts a color value to the HTML hex value
function BackPosStr ( start : integer ; FindString , SourceString : string ): integer ;
// finds a string backward case sensitive
function BackPosText ( start : integer ; FindString , SourceString : string ): integer ;
// finds a string backward case insensitive
function PosRangeStr ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds a text range, e.g. <TD>....</TD> case sensitive
function PosRangeText ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds a text range, e.g. <TD>....</td> case insensitive
function BackPosRangeStr ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds a text range backward, e.g. <TD>....</TD> case sensitive
function BackPosRangeText ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds a text range backward, e.g. <TD>....</td> case insensitive
function PosTag ( Start : integer ; SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds a HTML or XML tag: <....>
function Innertag ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
// finds the innertext between opening and closing tags
function Easter ( nYear : Integer ): TDateTime ;
// returns the easter date of a year.
function getWeekNumber ( today : Tdatetime ): string ;
//gets a datecode. Returns year and weeknumber in format: YYWW
function removetags ( aText : string ): string ;
// removes html tags from atext
implementation
const
cr = chr ( 13 )+ chr ( 10 );
tab = chr ( 9 );
B64Table = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/' ;
ValidURLChars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$-_@.&+-!*"''(),;/#?:' ;
ToUpperChars : array [ 0 .. 255 ] of Char =
(#$00 , #$01 , #$02 , #$03 , #$04 , #$05 , #$06 , #$07 , #$08 , #$09 , #$0A , #$0B , #$0C , #$0D , #$0E , #$0F ,
#$10 , #$11 , #$12 , #$13 , #$14 , #$15 , #$16 , #$17 , #$18 , #$19 , #$1A , #$1B , #$1C , #$1D , #$1E , #$1F ,
#$20 , #$21 , #$22 , #$23 , #$24 , #$25 , #$26 , #$27 , #$28 , #$29 , #$2A , #$2B , #$2C , #$2D , #$2E , #$2F ,
#$30 , #$31 , #$32 , #$33 , #$34 , #$35 , #$36 , #$37 , #$38 , #$39 , #$3A , #$3B , #$3C , #$3D , #$3E , #$3F ,
#$40 , #$41 , #$42 , #$43 , #$44 , #$45 , #$46 , #$47 , #$48 , #$49 , #$4A , #$4B , #$4C , #$4D , #$4E , #$4F ,
#$50 , #$51 , #$52 , #$53 , #$54 , #$55 , #$56 , #$57 , #$58 , #$59 , #$5A , #$5B , #$5C , #$5D , #$5E , #$5F ,
#$60 , #$41 , #$42 , #$43 , #$44 , #$45 , #$46 , #$47 , #$48 , #$49 , #$4A , #$4B , #$4C , #$4D , #$4E , #$4F ,
#$50 , #$51 , #$52 , #$53 , #$54 , #$55 , #$56 , #$57 , #$58 , #$59 , #$5A , #$7B , #$7C , #$7D , #$7E , #$7F ,
#$80 , #$81 , #$82 , #$81 , #$84 , #$85 , #$86 , #$87 , #$88 , #$89 , #$8A , #$8B , #$8C , #$8D , #$8E , #$8F ,
#$80 , #$91 , #$92 , #$93 , #$94 , #$95 , #$96 , #$97 , #$98 , #$99 , #$8A , #$9B , #$8C , #$8D , #$8E , #$8F ,
#$A0 , #$A1 , #$A1 , #$A3 , #$A4 , #$A5 , #$A6 , #$A7 , #$A8 , #$A9 , #$AA , #$AB , #$AC , #$AD , #$AE , #$AF ,
#$B0 , #$B1 , #$B2 , #$B2 , #$A5 , #$B5 , #$B6 , #$B7 , #$A8 , #$B9 , #$AA , #$BB , #$A3 , #$BD , #$BD , #$AF ,
#$C0 , #$C1 , #$C2 , #$C3 , #$C4 , #$C5 , #$C6 , #$C7 , #$C8 , #$C9 , #$CA , #$CB , #$CC , #$CD , #$CE , #$CF ,
#$D0 , #$D1 , #$D2 , #$D3 , #$D4 , #$D5 , #$D6 , #$D7 , #$D8 , #$D9 , #$DA , #$DB , #$DC , #$DD , #$DE , #$DF ,
#$C0 , #$C1 , #$C2 , #$C3 , #$C4 , #$C5 , #$C6 , #$C7 , #$C8 , #$C9 , #$CA , #$CB , #$CC , #$CD , #$CE , #$CF ,
#$D0 , #$D1 , #$D2 , #$D3 , #$D4 , #$D5 , #$D6 , #$D7 , #$D8 , #$D9 , #$DA , #$DB , #$DC , #$DD , #$DE , #$DF );
ToLowerChars : array [ 0 .. 255 ] of Char =
(#$00 , #$01 , #$02 , #$03 , #$04 , #$05 , #$06 , #$07 , #$08 , #$09 , #$0A , #$0B , #$0C , #$0D , #$0E , #$0F ,
#$10 , #$11 , #$12 , #$13 , #$14 , #$15 , #$16 , #$17 , #$18 , #$19 , #$1A , #$1B , #$1C , #$1D , #$1E , #$1F ,
#$20 , #$21 , #$22 , #$23 , #$24 , #$25 , #$26 , #$27 , #$28 , #$29 , #$2A , #$2B , #$2C , #$2D , #$2E , #$2F ,
#$30 , #$31 , #$32 , #$33 , #$34 , #$35 , #$36 , #$37 , #$38 , #$39 , #$3A , #$3B , #$3C , #$3D , #$3E , #$3F ,
#$40 , #$61 , #$62 , #$63 , #$64 , #$65 , #$66 , #$67 , #$68 , #$69 , #$6A , #$6B , #$6C , #$6D , #$6E , #$6F ,
#$70 , #$71 , #$72 , #$73 , #$74 , #$75 , #$76 , #$77 , #$78 , #$79 , #$7A , #$5B , #$5C , #$5D , #$5E , #$5F ,
#$60 , #$61 , #$62 , #$63 , #$64 , #$65 , #$66 , #$67 , #$68 , #$69 , #$6A , #$6B , #$6C , #$6D , #$6E , #$6F ,
#$70 , #$71 , #$72 , #$73 , #$74 , #$75 , #$76 , #$77 , #$78 , #$79 , #$7A , #$7B , #$7C , #$7D , #$7E , #$7F ,
#$90 , #$83 , #$82 , #$83 , #$84 , #$85 , #$86 , #$87 , #$88 , #$89 , #$9A , #$8B , #$9C , #$9D , #$9E , #$9F ,
#$90 , #$91 , #$92 , #$93 , #$94 , #$95 , #$96 , #$97 , #$98 , #$99 , #$9A , #$9B , #$9C , #$9D , #$9E , #$9F ,
#$A0 , #$A2 , #$A2 , #$BC , #$A4 , #$B4 , #$A6 , #$A7 , #$B8 , #$A9 , #$BA , #$AB , #$AC , #$AD , #$AE , #$BF ,
#$B0 , #$B1 , #$B3 , #$B3 , #$B4 , #$B5 , #$B6 , #$B7 , #$B8 , #$B9 , #$BA , #$BB , #$BC , #$BE , #$BE , #$BF ,
#$E0 , #$E1 , #$E2 , #$E3 , #$E4 , #$E5 , #$E6 , #$E7 , #$E8 , #$E9 , #$EA , #$EB , #$EC , #$ED , #$EE , #$EF ,
#$F0 , #$F1 , #$F2 , #$F3 , #$F4 , #$F5 , #$F6 , #$F7 , #$F8 , #$F9 , #$FA , #$FB , #$FC , #$FD , #$FE , #$FF ,
#$E0 , #$E1 , #$E2 , #$E3 , #$E4 , #$E5 , #$E6 , #$E7 , #$E8 , #$E9 , #$EA , #$EB , #$EC , #$ED , #$EE , #$EF ,
#$F0 , #$F1 , #$F2 , #$F3 , #$F4 , #$F5 , #$F6 , #$F7 , #$F8 , #$F9 , #$FA , #$FB , #$FC , #$FD , #$FE , #$FF );
procedure SaveString ( aFile , aText : string );
begin
with TFileStream . Create ( aFile , fmCreate ) do try
writeBuffer ( aText [ 1 ], length ( aText ));
finally free ; end ;
end ;
function LoadString ( aFile : string ): string ;
var s : string ;
begin
with TFileStream . Create ( aFile , fmOpenRead ) do try
SetLength ( s , Size );
ReadBuffer ( s [ 1 ], Size );
finally free ; end ;
result := s ;
end ;
procedure DeleteValue ( var aText : string ; aName : string );
var index , p , p2 , L : integer ;
begin
L := length ( aName )+ 2 ;
p := PosText ( aName + '="' , aText );
if p = 0 then exit ;
p2 := PosStr ( '"' , aText , p + L );
if p2 = 0 then exit ;
if p > 1 then dec ( p ); // include the preceeding space if not the first one
delete ( aText , p , p2 - p + 1 );
end ;
function GetValue ( aText , aName : string ): string ;
var index , p , p2 , L : integer ;
begin
result := '' ;
L := length ( aName )+ 2 ;
p := PosText ( aName + '="' , aText );
if p = 0 then exit ;
p2 := PosStr ( '"' , aText , p + L );
if p2 = 0 then exit ;
result := copy ( atext , p + L , p2 -( p + L ));
result := stringreplace ( result , '~~' , cr ,[ rfreplaceall ]);
end ;
function HasStrValue ( aText , aName : string ; var aValue : string ): boolean ;
var index , p , p2 , L : integer ;
s : string ;
begin
result := false ;
L := length ( aName )+ 2 ;
p := PosText ( aName + '="' , aText );
if p = 0 then exit ;
p2 := PosStr ( '"' , aText , p + L );
if p2 = 0 then exit ;
s := copy ( atext , p + L , p2 -( p + L ));
aValue := stringreplace ( s , '~~' , cr ,[ rfreplaceall ]);
end ;
function GetStrValue ( aText , aName , aDefault : string ): string ;
var s : string ;
begin
s := '' ;
if hasStrValue ( aText , aName , s ) then
result := s
else
result := aDefault ;
end ;
function GetIntValue ( aText , aName : string ; aDefault : Integer ): integer ;
var s : string ;
begin
s := getValue ( aText , aName );
try
result := strtoint ( s );
except
result := adefault ;
end ;
end ;
function GetFloatValue ( aText , aName : string ; aDefault : extended ): extended ;
var s : string ;
begin
s := '' ;
if hasStrValue ( aText , aName , s ) then
try
result := strtofloat ( s );
except
result := aDefault ;
end
else
result := aDefault ;
end ;
function GetHTMLColorValue ( aText , aName : string ; aDefault : Tcolor ): TColor ;
var s : string ;
begin
s := '' ;
if hasStrValue ( aText , aName , s ) then begin
if copy ( s , 1 , 1 )= '#' then begin
s := '$' + copy ( s , 6 , 2 )+ copy ( s , 4 , 2 )+ copy ( s , 2 , 2 );
end
else
s := 'cl' + s ;
try
result := stringtocolor ( s );
except
result := aDefault ;
end ;
end
else
result := aDefault ;
end ;
procedure SetValue ( var aText : string ; aName , aValue : string );
var index , p , p2 , L : integer ;
begin
l := length ( aName )+ 2 ;
if aText = '' then
begin
aText := aName + '="' + aValue + '"' ;
end
else begin
p := PosText ( aName + '="' , aText );
if p = 0 then
begin
aText := aText + ' ' + aName + '="' + aValue + '"' ;
end
else begin
p2 := PosStr ( '"' , aText , p + L );
if p2 = 0 then exit ;
Delete ( aText , p + L , p2 -( p + L ));
insert ( aValue , aText , p + L );
end ;
end ;
end ;
function GetHTMLColor ( aColor : TColor ): string ;
begin
result := format ( '%6.6x' ,[ colortorgb ( acolor )]);
result := '="#' + copy ( result , 5 , 2 )+ copy ( result , 3 , 2 )+ copy ( result , 1 , 2 )+ '"' ;
end ;
function BackPosStr ( start : integer ; FindString , SourceString : string ): integer ;
var p , L : integer ;
begin
result := 0 ;
L := length ( FindString );
if ( L = 0 ) or ( SourceString = '' ) or ( start < 2 ) then exit ;
Start := Start - L ;
if Start < 1 then exit ;
repeat
p := PosStr ( FindString , SourceString , Start );
if p < Start then
begin
result := p ;
exit ;
end ;
Start := Start - L ;
until Start < 1 ;
end ;
function BackPosText ( start : integer ; FindString , SourceString : string ): integer ;
var p , L , from : integer ;
begin
result := 0 ;
L := length ( FindString );
if ( L = 0 ) or ( SourceString = '' ) or ( start < 2 ) then exit ;
from := Start - L ;
if from < 1 then exit ;
repeat
p := PosText ( FindString , SourceString , from );
if ( p > 0 ) and ( p < Start ) then
begin
result := p ;
exit ;
end ;
from := from - L ;
until from < 1 ;
end ;
function PosRangeStr ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
begin
result := false ;
RangeBegin := PosStr ( HeadString , SourceString , Start );
if RangeBegin = 0 then exit ;
RangeEnd := PosStr ( TailString , SourceString , RangeBegin + Length ( HeadString ));
if RangeEnd = 0 then exit ;
RangeEnd := RangeEnd + length ( TailString )- 1 ;
result := true ;
end ;
function PosRangeText ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
begin
result := false ;
RangeBegin := PosText ( HeadString , SourceString , Start );
if RangeBegin = 0 then exit ;
RangeEnd := PosText ( TailString , SourceString , RangeBegin + Length ( HeadString ));
if RangeEnd = 0 then exit ;
RangeEnd := RangeEnd + length ( TailString )- 1 ;
result := true ;
end ;
function Innertag ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
begin
result := false ;
RangeBegin := PosText ( HeadString , SourceString , Start );
if RangeBegin = 0 then exit ;
RangeBegin := RangeBegin + length ( HeadString );
RangeEnd := PosText ( TailString , SourceString , RangeBegin + Length ( HeadString ));
if RangeEnd = 0 then exit ;
RangeEnd := RangeEnd - 1 ;
result := true ;
end ;
function PosTag ( Start : integer ; SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
begin
result := PosRangeStr ( Start , '<' , '>' , SourceString , RangeBegin , RangeEnd );
end ;
function BackPosRangeStr ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
var p , L : integer ;
begin
// finds a text range backward, e.g. <TD>....</TD> case sensitive
result := false ;
L := length ( HeadString );
if ( L = 0 ) or ( start < 2 ) then exit ;
Start := Start - L ;
if Start < 1 then exit ;
repeat
if not PosRangeStr ( Start , HeadString , TailString , SourceString , RangeBegin , RangeEnd ) then exit ;
if RangeBegin < Start then
begin
result := true ;
exit ;
end ;
Start := Start - L ;
until Start < 1 ;
end ;
function BackPosRangeText ( Start : integer ; HeadString , TailString , SourceString : string ; var RangeBegin : integer ; var RangeEnd : integer ): boolean ;
var p , L : integer ;
begin
// finds a text range backward, e.g. <TD>....</TD> case insensitive
result := false ;
L := length ( HeadString );
if ( L = 0 ) or ( start < 2 ) then exit ;
Start := Start - L ;
if Start < 1 then exit ;
repeat
if not PosRangeText ( Start , HeadString , TailString , SourceString , RangeBegin , RangeEnd ) then exit ;
if RangeBegin < Start then
begin
result := true ;
exit ;
end ;
Start := Start - L ;
until Start < 1 ;
end ;
function PosNonSpace ( Start : integer ; SourceText : string ): integer ;
var p , L : integer ;
begin
result := 0 ;
L := length ( SourceText );
p := Start ;
if L = 0 then exit ;
while ( p < L ) and ( SourceText [ p ]= ' ' ) do inc ( p );
if SourceText [ p ]<> ' ' then result := p ;
end ;
function BeginOfAttribute ( Start : integer ; SourceText : String ): integer ;
var p , L : integer ;
begin
// parses the beginning of an attribute: space + alpha character
result := 0 ;
L := length ( SourceText );
if L = 0 then exit ;
p := PosStr ( ' ' , Sourcetext , start );
if p = 0 then exit ;
p := PosNonSpace ( p , SourceText );
if p = 0 then exit ;
if ( SourceText [ p ] in [ 'a' .. 'z' , 'A' .. 'Z' ]) then
result := p ;
end ;
function ParseAttribute ( var Start : integer ; SourceText : String ; var aName : string ; var aValue : string ): boolean ;
var pn , pv , p : integer ;
begin
// parses a name="value" attribute from Start; returns 0 when not found or else the position behind the attribute
result := false ;
pn := BeginOfAttribute ( Start , SourceText );
if pn = 0 then exit ;
p := PosStr ( '="' , SourceText , pn );
if p = 0 then exit ;
aName := trim ( copy ( SourceText , pn , p - pn ));
pv := p + 2 ;
p := PosStr ( '"' , SourceText , pv );
if p = 0 then exit ;
aValue := copy ( SourceText , pv , p - pv );
start := p + 1 ;
result := true ;
end ;
procedure ParseAttributes ( SourceText : string ; var Attributes : TStringList );
var aName , aValue : string ;
start : integer ;
begin
Attributes . Clear ;
start := 1 ;
while ParseAttribute ( Start , SourceText , aName , aValue ) do
Attributes . Append ( aName + '=' + aValue );
end ;
function GetToken ( var start : integer ; SourceText : string ): string ;
var p1 , p2 : integer ;
begin
result := '' ;
if start > length ( sourceText ) then exit ;
p1 := posNonSpace ( Start , SourceText );
if p1 = 0 then exit ;
if SourceText [ p1 ]= '"' then
begin // quoted token
p2 := PosStr ( '"' , SourceText , p1 + 1 );
if p2 = 0 then exit ;
result := copy ( SourceText , p1 + 1 , p2 - p1 - 1 );
start := p2 + 1 ;
end
else begin
p2 := PosStr ( ' ' , SourceText , p1 + 1 );
if p2 = 0 then p2 := length ( sourcetext )+ 1 ;
result := copy ( SourceText , p1 , p2 - p1 );
start := p2 ;
end ;
end ;
function Easter ( nYear : Integer ): TDateTime ;
var
nMonth , nDay , nMoon , nEpact , nSunday , nGold , nCent , nCorx , nCorz : Integer ;
begin
{ The Golden Number of the year in the 19 year Metonic Cycle }
nGold := ( ( nYear mod 19 ) + 1 );
{ Calculate the Century }
nCent := ( ( nYear div 100 ) + 1 );
{ No. of Years in which leap year was dropped in order to keep in step
with the sun }
nCorx := ( ( 3 * nCent ) div 4 - 12 );
{ Special Correction to Syncronize Easter with the moon's orbit }
nCorz := ( ( 8 * nCent + 5 ) div 25 - 5 );
{ Find Sunday }
nSunday := ( ( 5 * nYear ) div 4 - nCorx - 10 );
{ Set Epact (specifies occurance of full moon }
nEpact := ( ( 11 * nGold + 20 + nCorz - nCorx ) mod 30 );
if ( nEpact < 0 ) then
nEpact := nEpact + 30 ;
if ( ( nEpact = 25 ) and ( nGold > 11 ) ) or ( nEpact = 24 ) then
nEpact := nEpact + 1 ;
{ Find Full Moon }
nMoon := 44 - nEpact ;
if ( nMoon < 21 ) then
nMoon := nMoon + 30 ;
{ Advance to Sunday }
nMoon := ( nMoon + 7 - ( ( nSunday + nMoon ) mod 7 ) );
if ( nMoon > 31 ) then
begin
nMonth := 4 ;
nDay := ( nMoon - 31 );
end
else
begin
nMonth := 3 ;
nDay := nMoon ;
end ;
Result := EncodeDate ( nYear , nMonth , nDay );
end ;
//gets a datecode. Returns year and weeknumber in format: YYWW
function getWeekNumber ( today : Tdatetime ): string ;
{dayOfWeek function returns integer 1..7 equivalent to Sunday..Saturday.
ISO 8601 weeks start with Monday and the first week of a year is the one which
includes the first Thursday - Fiddle takes care of all this}
const Fiddle : array [ 1 .. 7 ] of Byte = ( 6 , 7 , 8 , 9 , 10 , 4 , 5 );
var
present, startOfYear : Tdatetime ;
firstDayOfYear, weekNumber , numberOfDays : integer ;
year, month , day : word ;
YearNumber: string ;
begin
present:= trunc ( today ); //truncate to remove hours, mins and secs
decodeDate( present , year , month , day ); //decode to find year
startOfYear:= encodeDate ( year , 1 , 1 ); //encode 1st Jan of the year
//find what day of week 1st Jan is, then add days according to rule
firstDayOfYear:= Fiddle [ dayOfWeek ( startOfYear )];
//calc number of days since beginning of year + additional according to rule
numberOfDays:= trunc ( present - startOfYear ) + firstDayOfYear ;
//calc number of weeks
weekNumber:= trunc ( numberOfDays / 7 );
//Format year, needed to prevent millenium bug and keep the Fluffy Spangle happy
YearNumber:= formatDateTime ( 'yyyy' , present );
YearNumber:= YearNumber + 'W' ;
if weekNumber < 10 then
YearNumber := YearNumber + '0' ; //add leading zero for week
//create datecode string
result:= YearNumber + inttostr ( weekNumber );
if weekNumber = 0 then //recursive call for year begin/end...
//see if previous year end was week 52 or 53
result := getWeekNumber ( encodeDate ( year - 1 , 12 , 31 ))
else if weekNumber = 53 then
//if 31st December less than Thursday then must be week 01 of next year
if dayOfWeek ( encodeDate ( year , 12 , 31 )) < 5 then
begin
YearNumber := formatDateTime ( 'yyyy' , encodeDate ( year + 1 , 1 , 1 ));
result := YearNumber + 'W01' ;
end ;
end ;
function relativepath ( aSrc , aDst : string ): string ;
var doc , sdoc , pardoc , img , simg , parimg , rel : string ;
pdoc , pimg , pslash , l1 , l2 : integer ;
begin
doc := aSrc ;
img := aDst ;
repeat
pdoc := pos ( '' , doc );
if pdoc > 0 then begin
pardoc := copy ( doc , 1 , pdoc );
pardoc [ length ( pardoc )]:= '/' ;
sdoc := sdoc + pardoc ;
delete ( doc , 1 , pdoc );
end ;
pimg := pos ( '' , img );
if pimg > 0 then begin
parimg := copy ( img , 1 , pimg );
parimg [ length ( parimg )]:= '/' ;
simg := simg + parimg ;
delete ( img , 1 , pimg );
end ;
if ( pdoc > 0 ) and ( pimg > 0 ) and ( sdoc <> simg ) then
rel := '../' + rel + parimg ;
if ( pdoc = 0 ) and ( pimg <> 0 ) then
begin
rel := rel + parimg + img ;
if pos ( ':' , rel )> 0 then rel := '' ;
result := rel ;
exit ;
end ;
if ( pdoc > 0 ) and ( pimg = 0 ) then
begin
rel := '../' + rel ;
end ;
until ( pdoc = 0 ) and ( pimg = 0 );
rel := rel + extractfilename ( img );
if pos ( ':' , rel )> 0 then rel := '' ;
result := rel ;
end ;
procedure GetHTMLAnchors ( aFile : string ; aList : TStringList );
var s , sa , sb : string ;
p1 , p2 : integer ;
begin
s := LoadString ( aFile );
p1 := 1 ;
repeat
p1 := PosText ( '<a name="' , s , p1 );
if p1 <> 0 then
begin
p2 := PosText ( '"' , s , p1 + 9 );
if p2 <> 0 then
begin
sa := copy ( s , p1 + 9 , p2 - p1 - 9 );
aList . Append ( sa );
p1 := p2 ;
end
else
p1 := 0 ;
end ;
until p1 = 0 ;
end ;
function UppercaseHTMLTags ( aText : string ): string ;
var p , p2 : integer ;
begin
result := '' ;
p := 0 ;
p2 := 1 ;
repeat
p := PosStr ( '<' , AText , p2 );
if p > 0 then
begin
result := result + copy ( AText , p2 , p - p2 );
p2 := p ;
if copy ( AText , p , 4 )= '<!--' then
begin
p := PosStr ( '-->' , AText , p );
if p > 0 then begin
result := result + copy ( AText , p2 , p + 3 - p2 );
p2 := p + 3 ;
end
else
result := result + copy ( AText , p2 , length ( AText ));
end
else begin
p := PosStr ( '>' , AText , p );
if p > 0 then begin
result := result + uppercase ( copy ( AText , p2 , p - p2 + 1 ));
p2 := p + 1 ;
end
else
result := result + copy ( AText , p2 , length ( AText ));
end ;
end
else
begin
result := result + copy ( AText , p2 , length ( AText ));
end ;
until p = 0 ;
end ;
function LowercaseHTMLTags ( aText : string ): string ;
var p , p2 : integer ;
begin
result := '' ;
p := 0 ;
p2 := 1 ;
repeat
p := PosStr ( '<' , AText , p2 );
if p > 0 then
begin
result := result + copy ( AText , p2 , p - p2 );
p2 := p ;
// now check for comments
if copy ( AText , p , 4 )= '<!--' then
begin
p := PosStr ( '-->' , AText , p );
if p > 0 then begin
result := result + copy ( AText , p2 , p + 3 - p2 );
p2 := p + 3 ;
end
else
result := result + copy ( AText , p2 , length ( AText ));
end
else begin
p := PosStr ( '>' , AText , p );
if p > 0 then
begin
result := result + lowercase ( copy ( AText , p2 , p - p2 + 1 ));
p2 := p + 1 ;
end
else
result := result + copy ( AText , p2 , length ( AText ));
end ;
end
else
begin
result := result + copy ( AText , p2 , length ( AText ));
end ;
until p = 0 ;
end ;
function HexToColor ( aText : string ): Tcolor ;
begin
result := clblack ;
if length ( aText )<> 7 then exit ;
if aText [ 1 ]<> '#' then exit ;
aText := '$' + copy ( AText , 6 , 2 )+ copy ( AText , 4 , 2 )+ copy ( AText , 2 , 2 );
try
result := stringtocolor ( aText );
except
result := clblack ;
end ;
end ;
function ColorToHex ( aColor : TColor ): String ;
begin
result := format ( '%6.6x' ,[ acolor ]);
result := '#' + copy ( result , 5 , 2 )+ copy ( result , 3 , 2 )+ copy ( result , 1 , 2 );
end ;
function PosEscaped ( Start : integer ; SourceText , FindText : string ; escapeChar : char ): integer ;
var p : integer ;
begin
result := PosText ( FindText , SourceText , Start );
if result = 0 then exit ;
if result = 1 then exit ;
if SourceText [ result - 1 ]<> escapeChar then exit ;
repeat
result := PosText ( FindText , SourceText , result + 1 );
if result = 0 then exit ;
until SourceText [ result - 1 ]<> escapeChar ;
end ;
function DeleteEscaped ( SourceText : string ; escapeChar : char ): string ;
var i : integer ;
begin
i := 1 ;
repeat
if SourceText [ i ]= escapeChar then
delete ( SourceText , i , 1 );
i := i + 1 ;
until i > length ( SourceText );
result := SourceText ;
end ;
procedure RecurseDirFiles ( myDir : string ; var aFileList : TStringlist );
var
sr : TSearchRec ;
FileAttrs , i : Integer ;
begin
FileAttrs := faArchive + faDirectory ;
if FindFirst ( myDir + '*.*' , FileAttrs , sr ) = 0 then
while FindNext ( sr ) = 0 do
begin
if ( sr . Attr and faDirectory )<> 0 then
begin
if ( sr . name <> '.' ) and ( sr . name <> '..' ) then
RecurseDirFiles ( myDir + '' + sr . Name , aFileList );
end
else if ( sr . Attr and faArchive )<> 0 then
begin
aFileList . AddObject ( mydir + '' + sr . name , TObject ( sr . size ));
// aFileList.append(myDir+''+sr.Name);
end ;
end ;
FindClose ( sr );
end ;
procedure RecurseDirProgs ( myDir : string ; var aFileList : TStringlist );
var
sr : TSearchRec ;
FileAttrs , i : Integer ;
e : string ;
begin
FileAttrs := faArchive + faDirectory ;
if FindFirst ( myDir + '*.*' , FileAttrs , sr ) = 0 then
while FindNext ( sr ) = 0 do
begin
if ( sr . Attr and faDirectory )<> 0 then
begin
if ( sr . name <> '.' ) and ( sr . name <> '..' ) then
RecurseDirProgs ( myDir + '' + sr . Name , aFileList );
end
else if ( sr . Attr and faArchive )<> 0 then
begin
e := lowercase ( extractfileext ( sr . name ));
if e = '.exe' then
aFileList . append ( myDir + '' + sr . Name );
end ;
end ;
FindClose ( sr );
end ;
procedure LoadResourceFile ( aFile : string ; ms : TMemoryStream );
var
HResInfo : HRSRC ;
HGlobal : THandle ;
Buffer , GoodType : pchar ;
I : integer ;
Ext : string ;
begin
ext := uppercase ( extractfileext ( aFile ));
ext := copy ( ext , 2 , length ( ext ));
if ext = 'HTM' then ext := 'HTML' ;
if ext = 'CSS' then ext := 'HTML' ;
Goodtype := pchar ( ext );
aFile := changefileext ( afile , '' );
HResInfo := FindResource ( HInstance , pchar ( aFile ), GoodType );
HGlobal := LoadResource ( HInstance , HResInfo );
if HGlobal = 0 then
raise EResNotFound . Create ( 'Can''t load resource: ' + aFile );
Buffer := LockResource ( HGlobal );
ms . clear ;
ms . WriteBuffer ( Buffer [ 0 ], SizeOfResource ( HInstance , HResInfo ));
ms . Seek ( 0 , 0 );
UnlockResource ( HGlobal );
FreeResource ( HGlobal );
end ;
procedure GetNames ( aText : string ; aList : TStringList );
var p : integer ;
s : string ;
begin
alist . clear ;
p := 1 ;
repeat
aText := Trim ( aText );
p := pos ( '="' , aText );
if p > 0 then begin
s := copy ( aText , 1 , p - 1 );
alist . append ( s );
delete ( aText , 1 , p + 1 );
p := pos ( '"' , atext );
if p > 0 then begin
delete ( aText , 1 , p );
end ;
end ;
until p = 0 ;
end ;
function NameValuesToXML ( aText : string ): string ;
var alist : TStringlist ;
i , c : integer ;
iname , ivalue , xml : string ;
begin
result := '' ;
if aText = '' then exit ;
aList := tstringlist . create ;
GetNames ( aText , aList );
c := alist . count ;
if c = 0 then begin alist . free ; exit end ;
xml := '<accountdata>' + cr ;
for i := 0 to c - 1 do begin
iname := alist [ i ];
ivalue := getvalue ( aText , iname );
ivalue := stringreplace ( ivalue , '~~' , cr ,[ rfreplaceall ]);
xml := xml + '<' + iname + '>' + cr ;
xml := xml + ' ' + ivalue + cr ;
xml := xml + '</' + iname + '>' + cr ;
end ;
xml := xml + '</accountdata>' + cr ;
alist . free ;
result := xml ;
end ;
function PosStr ( const FindString , SourceString : string ; StartPos : Integer ): Integer ;
asm
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EDX
TEST EAX,EAX
JE @@qt
TEST EDX,EDX
JE @@qt0
MOV ESI,EAX
MOV EDI,EDX
MOV EAX,[EAX-4]
MOV EDX,[EDX-4]
DEC EAX
SUB EDX,EAX
DEC ECX
SUB EDX,ECX
JNG @@qt0
MOV EBX,EAX
XCHG EAX,EDX
NOP
ADD EDI,ECX
MOV ECX,EAX
MOV AL,BYTE PTR [ESI]
@@lp1: CMP AL,BYTE PTR [EDI]
JE @@uu
@@fr: INC EDI
DEC ECX
JNZ @@lp1
@@qt0: XOR EAX,EAX
JMP @@qt
@@ms: MOV AL,BYTE PTR [ESI]
MOV EBX,EDX
JMP @@fr
@@uu: TEST EDX,EDX
JE @@fd
@@lp2: MOV AL,BYTE PTR [ESI+EBX]
XOR AL,BYTE PTR [EDI+EBX]
JNE @@ms
DEC EBX
JNE @@lp2
@@fd: LEA EAX,[EDI+1]
SUB EAX,[ESP]
@@qt: POP ECX
POP EBX
POP EDI
POP ESI
end ;
function PosText ( const FindString , SourceString : string ; StartPos : Integer ): Integer ;
asm
PUSH ESI
PUSH EDI
PUSH EBX
NOP
TEST EAX,EAX
JE @@qt
TEST EDX,EDX
JE @@qt0
MOV ESI,EAX
MOV EDI,EDX
PUSH EDX
MOV EAX,[EAX-4]
MOV EDX,[EDX-4]
DEC EAX
SUB EDX,EAX
DEC ECX
PUSH EAX
SUB EDX,ECX
JNG @@qtx
ADD EDI,ECX
MOV ECX,EDX
MOV EDX,EAX
MOVZX EBX,BYTE PTR [ESI]
MOV AL,BYTE PTR [EBX+ToUpperChars]
@@lp1: MOVZX EBX,BYTE PTR [EDI]
CMP AL,BYTE PTR [EBX+ToUpperChars]
JE @@uu
@@fr: INC EDI
DEC ECX
JNE @@lp1
@@qtx: ADD ESP,$08
@@qt0: XOR EAX,EAX
JMP @@qt
@@ms: MOVZX EBX,BYTE PTR [ESI]
MOV AL,BYTE PTR [EBX+ToUpperChars]
MOV EDX,[ESP]
JMP @@fr
NOP
@@uu: TEST EDX,EDX
JE @@fd
@@lp2: MOV BL,BYTE PTR [ESI+EDX]
MOV AH,BYTE PTR [EDI+EDX]
CMP BL,AH
JE @@eq
MOV AL,BYTE PTR [EBX+ToUpperChars]
MOVZX EBX,AH
XOR AL,BYTE PTR [EBX+ToUpperChars]
JNE @@ms
@@eq: DEC EDX
JNZ @@lp2
@@fd: LEA EAX,[EDI+1]
POP ECX
SUB EAX,[ESP]
POP ECX
@@qt: POP EBX
POP EDI
POP ESI
end ;
function PosTextWild ( const FindString , SourceString : string ; var count : integer ;
StartPos : Integer = 1 ): Integer ;
var
p , pb , pe : integer ;
sb , se : string ;
begin
result := 0 ;
p := posstr ( '*' , FindString );
if p = 0 then exit ; // must have wild card
if ( p = 1 ) or ( p = length ( FindString )) then exit ; // * may not be first or last character
sb := copy ( FindString , 1 , p - 1 );
se := copy ( FindString , p + 1 , length ( FindString ));
pb := postext ( sb , SourceString , StartPos );
if pb = 0 then exit ;
pe := postext ( se , SourceString , pb + length ( sb ));
if pe = 0 then exit ;
count := pe + length ( se )- pb ;
result := pb ;
end ;
function GetBoolValue ( aText , aName : string ): boolean ;
begin
result := lowercase ( GetValue ( aText , aName ))= 'yes' ;
end ;
procedure ListSelect ( src , dst : TStringList ; aKey , aValue : string );
var i , c : integer ;
begin
dst . Clear ;
c := src . count ;
if c = 0 then exit ;
for i := 0 to c - 1 do begin
if getvalue ( src [ i ], aKey )= aValue then
dst . Append ( src [ i ]);
end ;
end ;
procedure ListSelectSet ( src , dst : TStringList ; aKey , aValue : string );
var i , c : integer ;
tmplis : TStringlist ;
begin
dst . Clear ;
c := src . count ;
if c = 0 then exit ;
if avalue = '' then exit ;
tmplis := tStringlist . create ;
tmplis . CommaText := avalue ;
for i := 0 to c - 1 do begin
if tmplis . indexof ( getvalue ( src [ i ], aKey ))<>- 1 then
dst . Append ( src [ i ]);
end ;
tmplis . free ;
end ;
procedure ListFilter ( src : TStringList ; aKey , aValue : string );
var i , c : integer ;
dst : Tstringlist ;
begin
c := src . count ;
if c = 0 then exit ;
dst := TStringList . create ;
for i := 0 to c - 1 do begin
if getvalue ( src [ i ], aKey )= aValue then
dst . Append ( src [ i ]);
end ;
src . Assign ( dst );
dst . free ;
end ;
procedure ListOrderBy ( src : TstringList ; aKey : string ; numeric : boolean );
var i , c , index : integer ;
lit , dst : TStringlist ;
s : string ;
ivalue : integer ;
begin
c := src . count ;
if c < 2 then exit ; // nothing to sort
lit := TStringList . create ;
dst := TStringList . create ;
for i := 0 to c - 1 do begin
s := getvalue ( src [ i ], aKey );
if numeric then
try
ivalue := strtoint ( s );
// format to 5 decimal places for correct string sorting
// e.g. 5 becomes 00005
s := format ( '%5.5d' ,[ ivalue ]);
except
// just use the unformatted value
end ;
lit . AddObject ( s , TObject ( i ));
end ;
lit . Sort ;
for i := 0 to c - 1 do begin
index := integer ( lit . Objects [ i ]);
dst . Append ( src [ index ]);
end ;
lit . free ;
src . Assign ( dst );
dst . free ;
end ;
// converts a csv list to a tagged string list
procedure csv2tags ( src , dst : TStringList );
var
i , c , fi , fc : integer ;
names : TstringList ;
rec : TstringList ;
s : string ;
begin
dst . clear ;
c := src . count ;
if c < 2 then exit ;
try
names := TStringList . create ;
rec := TStringList . create ;
names . CommaText := src [ 0 ];
fc := names . count ;
if fc > 0 then
for i := 1 to c - 1 do begin
rec . CommaText := src [ i ];
s := '' ;
for fi := 0 to fc - 1 do
s := s + names [ fi ]+ '="' + rec [ fi ]+ '" ' ;
dst . Append ( s );
end ;
finally
rec . free ;
names . free ;
end ;
end ;
// converts a tagged string list to a csv list
// only fieldnames from the first record are scanned ib the other records
procedure tags2csv ( src , dst : TStringList );
var
i , c , fi , fc : integer ;
names : TstringList ;
rec : TstringList ;
s , v : string ;
begin
dst . clear ;
c := src . count ;
if c < 1 then exit ;
try
names := TStringList . create ;
GetNames ( src [ 0 ], names );
rec := TStringList . create ;
fc := names . count ;
if fc > 0 then begin
dst . append ( names . commatext );
for i := 0 to c - 1 do begin
s := '' ;
rec . clear ;
for fi := 0 to fc - 1 do
rec . append ( getvalue ( src [ i ], names [ fi ]));
dst . Append ( rec . commatext );
end ;
end ;
finally
rec . free ;
names . free ;
end ;
end ;
function B64Encode ;
var
i : integer ;
InBuf : array [ 0 .. 2 ] of byte ;
OutBuf : array [ 0 .. 3 ] of char ;
begin
SetLength ( Result ,(( Length ( S )+ 2 ) div 3 )* 4 );
for i := 1 to (( Length ( S )+ 2 ) div 3 ) do
begin
if Length ( S )< ( i * 3 ) then
Move ( S [( i - 1 )* 3 + 1 ], InBuf , Length ( S )-( i - 1 )* 3 )
else
Move ( S [( i - 1 )* 3 + 1 ], InBuf , 3 );
OutBuf [ 0 ]:= B64Table [(( InBuf [ 0 ] and $FC ) shr 2 ) + 1 ];
OutBuf [ 1 ]:= B64Table [((( InBuf [ 0 ] and $03 ) shl 4 ) or (( InBuf [ 1 ] and $F0 ) shr 4 )) + 1 ];
OutBuf [ 2 ]:= B64Table [((( InBuf [ 1 ] and $0F ) shl 2 ) or (( InBuf [ 2 ] and $C0 ) shr 6 )) + 1 ];
OutBuf [ 3 ]:= B64Table [( InBuf [ 2 ] and $3F ) + 1 ];
Move ( OutBuf , Result [( i - 1 )* 4 + 1 ], 4 );
end ;
if ( Length ( S ) mod 3 )= 1 then
begin
Result [ Length ( Result )- 1 ]:= '=' ;
Result [ Length ( Result )]:= '=' ;
end
else if ( Length ( S ) mod 3 )= 2 then
Result [ Length ( Result )]:= '=' ;
end ;
function B64Decode ;
var
i : integer ;
InBuf : array [ 0 .. 3 ] of byte ;
OutBuf : array [ 0 .. 2 ] of byte ;
begin
if ( Length ( S ) mod 4 )<> 0 then
raise Exception . Create ( 'Base64: Incorrect string format' );
SetLength ( Result ,(( Length ( S ) div 4 )- 1 )* 3 );
for i := 1 to (( Length ( S ) div 4 )- 1 ) do
begin
Move ( S [( i - 1 )* 4 + 1 ], InBuf , 4 );
if ( InBuf [ 0 ]> 64 ) and ( InBuf [ 0 ]< 91 ) then
Dec ( InBuf [ 0 ], 65 )
else if ( InBuf [ 0 ]> 96 ) and ( InBuf [ 0 ]< 123 ) then
Dec ( InBuf [ 0 ], 71 )
else if ( InBuf [ 0 ]> 47 ) and ( InBuf [ 0 ]< 58 ) then
Inc ( InBuf [ 0 ], 4 )
else if InBuf [ 0 ]= 43 then
InBuf [ 0 ]:= 62
else
InBuf [ 0 ]:= 63 ;
if ( InBuf [ 1 ]> 64 ) and ( InBuf [ 1 ]< 91 ) then
Dec ( InBuf [ 1 ], 65 )
else if ( InBuf [ 1 ]> 96 ) and ( InBuf [ 1 ]< 123 ) then
Dec ( InBuf [ 1 ], 71 )
else if ( InBuf [ 1 ]> 47 ) and ( InBuf [ 1 ]< 58 ) then
Inc ( InBuf [ 1 ], 4 )
else if InBuf [ 1 ]= 43 then
InBuf [ 1 ]:= 62
else
InBuf [ 1 ]:= 63 ;
if ( InBuf [ 2 ]> 64 ) and ( InBuf [ 2 ]< 91 ) then
Dec ( InBuf [ 2 ], 65 )
else if ( InBuf [ 2 ]> 96 ) and ( InBuf [ 2 ]< 123 ) then
Dec ( InBuf [ 2 ], 71 )
else if ( InBuf [ 2 ]> 47 ) and ( InBuf [ 2 ]< 58 ) then
Inc ( InBuf [ 2 ], 4 )
else if InBuf [ 2 ]= 43 then
InBuf [ 2 ]:= 62
else
InBuf [ 2 ]:= 63 ;
if ( InBuf [ 3 ]> 64 ) and ( InBuf [ 3 ]< 91 ) then
Dec ( InBuf [ 3 ], 65 )
else if ( InBuf [ 3 ]> 96 ) and ( InBuf [ 3 ]< 123 ) then
Dec ( InBuf [ 3 ], 71 )
else if ( InBuf [ 3 ]> 47 ) and ( InBuf [ 3 ]< 58 ) then
Inc ( InBuf [ 3 ], 4 )
else if InBuf [ 3 ]= 43 then
InBuf [ 3 ]:= 62
else
InBuf [ 3 ]:= 63 ;
OutBuf [ 0 ]:= ( InBuf [ 0 ] shl 2 ) or (( InBuf [ 1 ] shr 4 ) and $03 );
OutBuf [ 1 ]:= ( InBuf [ 1 ] shl 4 ) or (( InBuf [ 2 ] shr 2 ) and $0F );
OutBuf [ 2 ]:= ( InBuf [ 2 ] shl 6 ) or ( InBuf [ 3 ] and $3F );
Move ( OutBuf , Result [( i - 1 )* 3 + 1 ], 3 );
end ;
if Length ( S )<> 0 then
begin
Move ( S [ Length ( S )- 3 ], InBuf , 4 );
if InBuf [ 2 ]= 61 then
begin
if ( InBuf [ 0 ]> 64 ) and ( InBuf [ 0 ]< 91 ) then
Dec ( InBuf [ 0 ], 65 )
else if ( InBuf [ 0 ]> 96 ) and ( InBuf [ 0 ]< 123 ) then
Dec ( InBuf [ 0 ], 71 )
else if ( InBuf [ 0 ]> 47 ) and ( InBuf [ 0 ]< 58 ) then
Inc ( InBuf [ 0 ], 4 )
else if InBuf [ 0 ]= 43 then
InBuf [ 0 ]:= 62
else
InBuf [ 0 ]:= 63 ;
if ( InBuf [ 1 ]> 64 ) and ( InBuf [ 1 ]< 91 ) then
Dec ( InBuf [ 1 ], 65 )
else if ( InBuf [ 1 ]> 96 ) and ( InBuf [ 1 ]< 123 ) then
Dec ( InBuf [ 1 ], 71 )
else if ( InBuf [ 1 ]> 47 ) and ( InBuf [ 1 ]< 58 ) then
Inc ( InBuf [ 1 ], 4 )
else if InBuf [ 1 ]= 43 then
InBuf [ 1 ]:= 62
else
InBuf [ 1 ]:= 63 ;
OutBuf [ 0 ]:= ( InBuf [ 0 ] shl 2 ) or (( InBuf [ 1 ] shr 4 ) and $03 );
Result := Result + char ( OutBuf [ 0 ]);
end
else if InBuf [ 3 ]= 61 then
begin
if ( InBuf [ 0 ]> 64 ) and ( InBuf [ 0 ]< 91 ) then
Dec ( InBuf [ 0 ], 65 )
else if ( InBuf [ 0 ]> 96 ) and ( InBuf [ 0 ]< 123 ) then
Dec ( InBuf [ 0 ], 71 )
else if ( InBuf [ 0 ]> 47 ) and ( InBuf [ 0 ]< 58 ) then
Inc ( InBuf [ 0 ], 4 )
else if InBuf [ 0 ]= 43 then
InBuf [ 0 ]:= 62
else
InBuf [ 0 ]:= 63 ;
if ( InBuf [ 1 ]> 64 ) and ( InBuf [ 1 ]< 91 ) then
Dec ( InBuf [ 1 ], 65 )
else if ( InBuf [ 1 ]> 96 ) and ( InBuf [ 1 ]< 123 ) then
Dec ( InBuf [ 1 ], 71 )
else if ( InBuf [ 1 ]> 47 ) and ( InBuf [ 1 ]< 58 ) then
Inc ( InBuf [ 1 ], 4 )
else if InBuf [ 1 ]= 43 then
InBuf [ 1 ]:= 62
else
InBuf [ 1 ]:= 63 ;
if ( InBuf [ 2 ]> 64 ) and ( InBuf [ 2 ]< 91 ) then
Dec ( InBuf [ 2 ], 65 )
else if ( InBuf [ 2 ]> 96 ) and ( InBuf [ 2 ]< 123 ) then
Dec ( InBuf [ 2 ], 71 )
else if ( InBuf [ 2 ]> 47 ) and ( InBuf [ 2 ]< 58 ) then
Inc ( InBuf [ 2 ], 4 )
else if InBuf [ 2 ]= 43 then
InBuf [ 2 ]:= 62
else
InBuf [ 2 ]:= 63 ;
OutBuf [ 0 ]:= ( InBuf [ 0 ] shl 2 ) or (( InBuf [ 1 ] shr 4 ) and $03 );
OutBuf [ 1 ]:= ( InBuf [ 1 ] shl 4 ) or (( InBuf [ 2 ] shr 2 ) and $0F );
Result := Result + char ( OutBuf [ 0 ]) + char ( OutBuf [ 1 ]);
end
else
begin
if ( InBuf [ 0 ]> 64 ) and ( InBuf [ 0 ]< 91 ) then
Dec ( InBuf [ 0 ], 65 )
else if ( InBuf [ 0 ]> 96 ) and ( InBuf [ 0 ]< 123 ) then
Dec ( InBuf [ 0 ], 71 )
else if ( InBuf [ 0 ]> 47 ) and ( InBuf [ 0 ]< 58 ) then
Inc ( InBuf [ 0 ], 4 )
else if InBuf [ 0 ]= 43 then
InBuf [ 0 ]:= 62
else
InBuf [ 0 ]:= 63 ;
if ( InBuf [ 1 ]> 64 ) and ( InBuf [ 1 ]< 91 ) then
Dec ( InBuf [ 1 ], 65 )
else if ( InBuf [ 1 ]> 96 ) and ( InBuf [ 1 ]< 123 ) then
Dec ( InBuf [ 1 ], 71 )
else if ( InBuf [ 1 ]> 47 ) and ( InBuf [ 1 ]< 58 ) then
Inc ( InBuf [ 1 ], 4 )
else if InBuf [ 1 ]= 43 then
InBuf [ 1 ]:= 62
else
InBuf [ 1 ]:= 63 ;
if ( InBuf [ 2 ]> 64 ) and ( InBuf [ 2 ]< 91 ) then
Dec ( InBuf [ 2 ], 65 )
else if ( InBuf [ 2 ]> 96 ) and ( InBuf [ 2 ]< 123 ) then
Dec ( InBuf [ 2 ], 71 )
else if ( InBuf [ 2 ]> 47 ) and ( InBuf [ 2 ]< 58 ) then
Inc ( InBuf [ 2 ], 4 )
else if InBuf [ 2 ]= 43 then
InBuf [ 2 ]:= 62
else
InBuf [ 2 ]:= 63 ;
if ( InBuf [ 3 ]> 64 ) and ( InBuf [ 3 ]< 91 ) then
Dec ( InBuf [ 3 ], 65 )
else if ( InBuf [ 3 ]> 96 ) and ( InBuf [ 3 ]< 123 ) then
Dec ( InBuf [ 3 ], 71 )
else if ( InBuf [ 3 ]> 47 ) and ( InBuf [ 3 ]< 58 ) then
Inc ( InBuf [ 3 ], 4 )
else if InBuf [ 3 ]= 43 then
InBuf [ 3 ]:= 62
else
InBuf [ 3 ]:= 63 ;
OutBuf [ 0 ]:= ( InBuf [ 0 ] shl 2 ) or (( InBuf [ 1 ] shr 4 ) and $03 );
OutBuf [ 1 ]:= ( InBuf [ 1 ] shl 4 ) or (( InBuf [ 2 ] shr 2 ) and $0F );
OutBuf [ 2 ]:= ( InBuf [ 2 ] shl 6 ) or ( InBuf [ 3 ] and $3F );
Result := Result + Char ( OutBuf [ 0 ]) + Char ( OutBuf [ 1 ]) + Char ( OutBuf [ 2 ]);
end ;
end ;
end ;
{*******************************************************
* Standard Encryption algorithm - Copied from Borland *
*******************************************************}
function Encrypt ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
var
I : integer ;
begin
Result := '' ;
for I := 1 to Length ( InString ) do
begin
Result := Result + CHAR ( Byte ( InString [ I ]) xor ( StartKey shr 8 ));
StartKey := ( Byte ( Result [ I ]) + StartKey ) * MultKey + AddKey ;
end ;
end ;
{*******************************************************
* Standard Decryption algorithm - Copied from Borland *
*******************************************************}
function Decrypt ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
var
I : integer ;
begin
Result := '' ;
for I := 1 to Length ( InString ) do
begin
Result := Result + CHAR ( Byte ( InString [ I ]) xor ( StartKey shr 8 ));
StartKey := ( Byte ( InString [ I ]) + StartKey ) * MultKey + AddKey ;
end ;
end ;
function EncryptB64 ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
begin
result := B64Encode ( Encrypt ( InString , StartKey , MultKey , AddKey ));
end ;
function DecryptB64 ( const InString : string ; StartKey , MultKey , AddKey : Integer ): string ;
begin
result := Decrypt ( B64Decode ( Instring ), StartKey , MultKey , AddKey );
end ;
function Hash ( aText : string ): integer ;
var
i : integer ;
begin
result := 0 ;
if aText = '' then exit ;
result := ord ( aText [ 1 ]);
for I := 2 to Length ( aText ) do
result :=( result * ord ( aText [ i ])) xor result ;
end ;
{replace any <,> etc by < >}
function XMLSafe ( aText : string ): string ;
var i , c : integer ;
begin
c := length ( aText );
if c = 0 then begin
result := aText ;
exit ;
end ;
result := '' ;
for i := 1 to c do begin
if aText [ i ]= '<' then result := result + '<'
else if aText [ i ]= '>' then result := result + '>'
else if aText [ i ]= '&' then result := result + '&'
else if ( ord ( aText [ i ])>= 32 ) and ( ord ( aText [ i ])< 128 ) then result := result + aText [ i ]
else if ord ( aText [ i ])> 127 then result := result + '&#' + inttostr ( ord ( aText [ i ]))+ ';'
else result := result + ' ' ;
end ;
end ;
function FirstOfSet ( aText : string ): string ;
var s : string ;
p : integer ;
begin
result := Trim ( aText );
if result = '' then exit ;
if result [ 1 ]= '"' then begin
p := posStr ( '"' , result , 2 );
result := copy ( result , 2 , p - 2 );
end
else begin
p := pos ( ' ' , result );
result := copy ( result , 1 , p - 1 );
end ;
end ;
function LastOfSet ( aText : string ): string ;
var s : string ;
p : integer ;
i , c : integer ;
begin
result := Trim ( aText );
c := length ( result );
if c = 0 then exit ;
if result [ c ]= '"' then begin
while ( c > 1 ) and ( result [ c - 1 ]<> '"' ) do dec ( c );
result := copy ( result , c , length ( result )- c );
end
else begin
while ( c > 1 ) and ( result [ c - 1 ]<> ' ' ) do dec ( c );
result := copy ( result , c , length ( result ));
end ;
end ;
function CountOfSet ( aText : string ): integer ;
var lit : TStringlist ;
begin
lit := TstringList . create ;
splitset ( aText , lit );
result := lit . count ;
lit . free ;
end ;
function SetRotateRight ( aText : string ): string ;
var lit : TStringlist ;
i , c : integer ;
begin
lit := TstringList . create ;
splitset ( aText , lit );
c := lit . count ;
if c > 0 then begin
lit . Move ( c - 1 , 0 );
result := joinSet ( lit );
end
else
result := '' ;
lit . free ;
end ;
function SetRotateLeft ( aText : string ): string ;
var lit : TStringlist ;
i , c : integer ;
begin
lit := TstringList . create ;
splitset ( aText , lit );
c := lit . count ;
if c > 0 then begin
lit . Move ( 0 , c - 1 );
result := joinSet ( lit );
end
else
result := '' ;
lit . free ;
end ;
procedure SplitSet ( aText : string ; aList : TStringList );
var p : integer ;
s : string ;
begin
aList . Clear ;
if aText = '' then exit ;
aText := trim ( aText );
while aText <> '' do begin
if aText [ 1 ]= '"' then begin
delete ( aText , 1 , 1 );
p := pos ( '"' , aText );
if p <> 0 then begin
aList . append ( copy ( aText , 1 , p - 1 ));
delete ( aText , 1 , p );
end ;
end
else begin
p := pos ( ' ' , atext );
if p = 0 then begin
aList . Append ( aText );
atext := '' ;
end
else begin
aList . append ( copy ( aText , 1 , p - 1 ));
delete ( aText , 1 , p );
end ;
end ;
aText := trim ( aText );
end ;
end ;
function JoinSet ( aList : TstringList ): string ;
var
i , c : integer ;
begin
result := '' ;
c := aList . count ;
if c = 0 then exit ;
for i := 0 to c - 1 do
result := result + aList [ i ]+ ' ' ;
delete ( result , length ( result ), 1 );
end ;
function SetPick ( aText : string ; aIndex : integer ): string ;
var lit : TStringlist ;
i , c : integer ;
begin
lit := TstringList . create ;
splitset ( aText , lit );
c := lit . count ;
if ( c > 0 ) and ( aIndex < c ) then
result := lit [ aIndex ]
else
result := '' ;
lit . free ;
end ;
function SetSort ( aText : string ): string ;
var lit : TStringlist ;
i , c : integer ;
begin
lit := TstringList . create ;
splitset ( aText , lit );
c := lit . count ;
if c > 0 then begin
lit . Sort ;
result := joinSet ( lit );
end
else
result := '' ;
lit . free ;
end ;
function SetUnion ( set1 , set2 : string ): string ;
var
lit1 , lit2 , lit3 : Tstringlist ;
i , c : integer ;
begin
lit1 := tStringList . create ;
lit2 := tStringList . create ;
lit3 := tStringList . create ;
SplitSet ( set1 , lit1 );
SplitSet ( set2 , lit2 );
c := lit2 . count ;
if c <> 0 then begin
lit2 . AddStrings ( lit1 );
for i := 0 to lit2 . count - 1 do
if lit3 . IndexOf ( lit2 [ i ])=- 1 then
lit3 . Append ( lit2 [ i ]);
result := JoinSet ( lit3 );
end
else begin
result := JoinSet ( lit1 );
end ;
lit1 . free ;
lit2 . free ;
lit3 . free ;
end ;
function SetIntersect ( set1 , set2 : string ): string ;
var
lit1 , lit2 , lit3 : Tstringlist ;
i , c : integer ;
begin
lit1 := tStringList . create ;
lit2 := tStringList . create ;
lit3 := tStringList . create ;
SplitSet ( set1 , lit1 );
SplitSet ( set2 , lit2 );
c := lit2 . count ;
if c <> 0 then begin
for i := 0 to c - 1 do
if lit1 . IndexOf ( lit2 [ i ])<>- 1 then
lit3 . Append ( lit2 [ i ]);
result := JoinSet ( lit3 );
end
else begin
result := '' ;
end ;
lit1 . free ;
lit2 . free ;
lit3 . free ;
end ;
function SetExclude ( set1 , set2 : string ): string ;
var
lit1 , lit2 : Tstringlist ;
i , c , index : integer ;
begin
lit1 := tStringList . create ;
lit2 := tStringList . create ;
SplitSet ( set1 , lit1 );
SplitSet ( set2 , lit2 );
c := lit2 . count ;
if c <> 0 then begin
for i := 0 to c - 1 do begin
index := lit1 . IndexOf ( lit2 [ i ]);
if index <>- 1 then
lit1 . Delete ( index );
end ;
result := JoinSet ( lit1 );
end
else begin
result := JoinSet ( lit1 );
end ;
lit1 . free ;
lit2 . free ;
end ;
function HTMLEncode ( value : string ): string ;
var
s : string ;
i , c : integer ;
ch : char ;
begin
result := '' ;
if value = '' then exit ;
s := value ;
c := length ( s );
for i := 1 to c do begin
ch := s [ i ];
if ch = '<' then
result := result + '<'
else if ch = '>' then
result := result + '>'
else if ord ( ch )>= 128 then
result := result + '&#' + inttostr ( ord ( ch ))+ ';'
else
result := result + ch ;
end ;
end ;
// This function converts a string into a RFC 1630 compliant URL
function URLEncode ( Value : String ) : String ;
Var I : Integer ;
Begin
Result := '' ;
For I := 1 To Length ( Value ) Do
Begin
If Pos ( UpperCase ( Value [ I ]), ValidURLChars ) > 0 Then
Result := Result + Value [ I ]
Else
Begin
If Value [ I ] = ' ' Then
Result := Result + '+'
Else
Begin
Result := Result + '%' ;
Result := Result + IntToHex ( Byte ( Value [ I ]), 2 );
End ;
End ;
End ;
End ;
function URLDecode ( Value : String ) : String ;
Const HexChars = '0123456789ABCDEF' ;
Var I : Integer ;
Ch , H1 , H2 : Char ;
Begin
Result := '' ;
I := 1 ;
While I <= Length ( Value ) Do
Begin
Ch := Value [ I ];
Case Ch Of
'%' : Begin
H1 := Value [ I + 1 ];
H2 := Value [ I + 2 ];
Inc ( I , 2 );
Result := Result + Chr ((( Pos ( H1 , HexChars ) - 1 ) * 16 ) + ( Pos ( H2 , HexChars ) - 1 ));
End ;
'+' : Result := Result + ' ' ;
'&' : Result := Result + #13 + #10 ;
Else Result := Result + Ch ;
End ;
Inc ( I );
End ;
End ;
{template functions}
function ReplaceFirst ( sourceStr , findStr , replaceStr : string ): string ;
var
p : integer ;
begin
result := sourceStr ;
p := posText ( findstr , sourcestr , 1 );
if p = 0 then exit ;
result := copy ( sourcestr , 1 , p - 1 )+ replacestr + copy ( sourceStr , p + length ( findStr ), length ( sourceStr ));
end ;
function ReplaceLast ( sourceStr , findStr , replaceStr : string ): string ;
var
p : integer ;
begin
result := sourceStr ;
p := posTextLast ( findstr , sourcestr );
if p = 0 then exit ;
result := copy ( sourcestr , 1 , p - 1 )+ replacestr + copy ( sourceStr , p + length ( findStr ), length ( sourceStr ));
end ;
function GetBlock ( sourceStr , blockStr : string ): string ;
var
pe , pb , count : integer ;
sbb , sbe : string ;
sbbL , sbeL : integer ;
begin
result := '' ;
sbb := '<!--begin:' + BlockStr ;
sbbL := Length ( sbb );
sbe := 'end:' + BlockStr + '-->' ;
sbeL := Length ( sbe );
pb := posText ( sbb , sourceStr , 1 );
If pb = 0 Then Exit ;
pe := postext ( sbe , sourceStr , pb );
If pe = 0 Then Exit ;
pe := pe + sbeL - 1 ;
result := copy ( SourceStr , pb + sbbL , pe - pb - sbbL - sbeL + 1 );
end ;
// insert a block template
// the last occurance of {block:aBlockname}
// the block template is marked with {begin:aBlockname} and {end:aBlockname}
function InsertLastBlock ( var sourceStr : string ; blockStr : string ): boolean ;
var
// phead:integer;
pblock , pe , pb : integer ;
sbb , sbe , sb , sbr : string ;
sbL , sbbL , sbeL : integer ;
begin
result := false ;
sb := '{|block:' + blockstr + '|}' ;
sbL := length ( sb );
sbb := '<!--begin:' + BlockStr ;
sbbL := Length ( sbb );
sbe := 'end:' + BlockStr + '-->' ;
sbeL := Length ( sbe );
pblock := posTextlast ( sb , sourceStr );
If pblock = 0 Then Exit ;
pb := posText ( sbb , sourceStr , 1 );
If pb = 0 Then Exit ;
pe := postext ( sbe , sourceStr , pb );
If pe = 0 Then Exit ;
pe := pe + sbeL - 1 ;
// now replace
sbr := copy ( SourceStr , pb + sbbL , pe - pb - sbbL - sbeL + 1 );
SourceStr := copy ( SourceStr , 1 , pblock - 1 ) + sbr + copy ( SourceStr , pblock , length ( sourceStr ));
result := true ;
end ;
// the block template is marked with <!--begin:aBlockname} and end:aBlockname-->}
function InsertIndexBlock ( var sourceStr : string ; blockStr : string ; index : integer ): boolean ;
var
// phead:integer;
pblock , pe , pb : integer ;
sbb , sbe , sb , sbr : string ;
sbL , sbbL , sbeL : integer ;
begin
result := false ;
sb := '<span class="waf">block:' + blockstr + '</span>' ;
sbL := length ( sb );
sbb := '<!--begin:' + BlockStr ;
sbbL := Length ( sbb );
sbe := 'end:' + BlockStr + '-->' ;
sbeL := Length ( sbe );
pblock := posTextlast ( sb , sourceStr );
If pblock = 0 Then Exit ;
pb := posText ( sbb , sourceStr , 1 );
If pb = 0 Then Exit ;
pe := postext ( sbe , sourceStr , pb );
If pe = 0 Then Exit ;
pe := pe + sbeL - 1 ;
// now replace
sbr := copy ( SourceStr , pb + sbbL , pe - pb - sbbL - sbeL + 1 );
SourceStr := copy ( SourceStr , 1 , pblock - 1 ) + sbr + copy ( SourceStr , pblock , length ( sourceStr ));
result := true ;
end ;
// removes all <!--begin:somefield to end:somefield--> from aSource
function removeMasterBlocks ( sourceStr : string ): string ;
var
s , src : String ;
pb : Integer ;
pe : Integer ;
pee : Integer ;
begin
result := sourceStr ;
repeat
pb := postext ( '<!--begin:' , result );
If pb > 0 Then begin
pe := postext ( 'end:' , result , pb );
If pe > 0 Then begin
pee := posstr ( '-->' , result , pe );
If pee > 0 Then begin
delete ( result , pb , pee + 3 - pb );
End ;
End ;
End ;
Until pb = 0 ;
end ;
// renumber all field id's in a template
function renumberFields ( sourceStr : string ): string ;
var
p , p2 , id : integer ;
s : string ;
begin
id := 1 ;
s := '' ;
p := postext ( '<body' , sourceStr );
s := s + copy ( sourceStr , 1 , p - 1 );
delete ( sourceStr , 1 , p - 1 );
repeat
p := postext ( '<span class="waf"' , sourceStr );
if p > 0 then begin
s := s + copy ( sourceStr , 1 , p - 1 );
delete ( sourceStr , 1 , p - 1 );
p2 := posstr ( '>' , sourceStr );
if p2 > 0 then begin
s := s + '<span class="waf" id="waf' + inttostr ( id )+ '">' ;
delete ( sourceStr , 1 , p2 );
inc ( id );
end
else
p := 0 ;
end ;
until p = 0 ;
result := s + sourceStr ;
end ;
// removes all {|field|} entries in a template
function removeFields ( sourceStr : string ): string ;
var
pb , pe , pbod : integer ;
begin
result := sourceStr ;
pbod := postext ( '<body' , result );
if pbod = 0 then exit ;
repeat
pb := posstr ( '{|' , result , pbod );
if pb > 0 Then begin
pe := posstr ( '|}' , result , pb );
If pe > 0 Then
delete ( result , pb , pe + 2 - pb )
else
pb := 0 ;
End ;
Until pb = 0 ;
end ;
// removes all <img src="{|field|} entries in a template
function removeImages ( sourceStr : string ): string ;
var
pb , pe , pbod : integer ;
begin
result := sourceStr ;
pbod := postext ( '<body' , result );
if pbod = 0 then exit ;
repeat
pb := postext ( '<img src="./images/"' , result , pbod );
if pb > 0 Then begin
pe := posstr ( '>' , result , pb );
If pe > 0 Then
delete ( result , pb , pe + 1 - pb )
else
pb := 0 ;
End ;
Until pb = 0 ;
end ;
{return a list of all template fields after the <body> tag}
procedure gettemplatefields ( aText : string ; aList : TStringList );
var p , p2 : integer ;
begin
alist . clear ;
p := postext ( '<body' , atext , 1 );
if p = 0 then exit ;
repeat
p := posstr ( '{|' , aText , p );
if p > 0 then begin
p2 := posstr ( '|}' , aText , p );
if p2 > 0 then begin
aList . Append ( copy ( aText , p + 2 , p2 - p - 2 ));
p := p2 + 1 ;
end
else
p := 0 ;
end ;
until p = 0 ;
end ;
{finds the last occurance}
function PosStrLast ( const FindString , SourceString : string ): integer ;
var i , p , L : integer ;
begin
result := 0 ;
L := length ( FindString );
if L = 0 then exit ;
i := length ( SourceString );
if i = 0 then exit ;
i := i - L + 1 ;
while i > 0 do begin
result := posStr ( FindString , SourceString , i );
if result > 0 then exit ;
i := i - L ;
end ;
end ;
{finds last occurance of a character}
function StrRScan ( const S : string ; Ch : Char ; LastPos : Integer ): Integer ;
asm
TEST EAX,EAX
JE @@qt
PUSH EBX
DEC ECX
JS @@m1
MOV EBX,[EAX-4]
PUSH EDI
CMP ECX,EBX
JA @@ch
TEST ECX,ECX
JE @@m2
@@nx: LEA EDI,[EAX+ECX-1]
STD
XCHG EAX,EDX
REPNE SCASB
INC EDI
CLD
CMP AL,BYTE PTR [EDI]
JNE @@m2
SUB EDI,EDX
MOV EAX,EDI
POP EDI
INC EAX
POP EBX
RET
@@ch: MOV ECX,EBX
TEST EBX,EBX
JNE @@nx
@@m2: POP EDI
@@m1: XOR EAX,EAX
POP EBX
@@qt:
end ;
{finds the last occurance}
function PosTextLast ( const FindString , SourceString : string ): integer ;
var i , p , L : integer ;
begin
result := 0 ;
L := length ( FindString );
if L = 0 then exit ;
i := length ( SourceString );
if i = 0 then exit ;
i := i - L + 1 ;
while i > 0 do begin
result := posText ( FindString , SourceString , i );
if result > 0 then exit ;
i := i - L ;
end ;
end ;
procedure DirFiles ( aDir , amask : string ; aFileList : TStringlist );
var
sr : TSearchRec ;
FileAttrs , i : Integer ;
begin
FileAttrs := faArchive + faDirectory ;
if FindFirst ( aDir + amask , FileAttrs , sr ) = 0 then
while FindNext ( sr ) = 0 do
if ( sr . Attr and faArchive )<> 0 then
aFileList . addobject ( aDir + sr . Name , TObject ( sr . size ));
FindClose ( sr );
end ;
procedure DirFilesEx ( aDir : string ; aFileList : TStringlist );
var
sr : TSearchRec ;
FileAttrs , i : Integer ;
begin
FileAttrs := faArchive + faDirectory ;
if FindFirst ( aDir + '*.*' , FileAttrs , sr ) = 0 then
while FindNext ( sr ) = 0 do
if ( sr . Attr and faArchive )<> 0 then
aFileList . addobject ( sr . Name , TObject ( sr . size ))
else if ( sr . Attr and faDirectory )<> 0 then
aFileList . addobject ( '[' + sr . Name + ']' , TObject ( sr . size ));
FindClose ( sr );
end ;
function removetags ( aText : string ): string ;
var s : string ;
p1 , p2 : integer ;
begin
s := atext ;
p1 := posstr ( '<' , s , 1 );
repeat
if p1 > 0 then begin
p2 := posstr ( '>' , s , p1 );
if p2 > 0 then begin
delete ( s , p1 , p2 - p1 + 1 );
end
else p1 := 0 ;
end ;
until p1 = 0 ;
result := s ;
end ;
{name and value}
function strName ( aStr : string ): string ;
var p : integer ;
begin
p := pos ( '=' , aStr );
if p > 0 then
result := copy ( aStr , 1 , p - 1 )
else
result := aStr ;
end ;
function strValue ( aStr : string ): string ;
var p : integer ;
begin
p := pos ( '=' , aStr );
if p > 0 then
result := copy ( aStr , p + 1 , length ( aStr ))
else
result := aStr ;
end ;
function magic ( aStr : string ): string ;
begin
result := stringreplace ( astr , '"' , '''' ,[ rfreplaceall ]);
end ;
function unquote ( aStr : string ): string ;
var
c : integer ;
begin
result := trim ( aStr );
if result = '' then exit ;
if ( result [ 1 ]= '"' ) or ( result [ 1 ]= '''' ) then
delete ( result , 1 , 1 );
c := length ( result );
if c = 0 then exit ;
if ( result [ c ]= '"' ) or ( result [ c ]= '''' ) then
delete ( result , c , 1 );
end ;
{test conversions}
function isInteger ( aStr : string ): boolean ;
var i : integer ;
begin
result := false ;
try
i := strtoint ( aStr );
result := true ;
except
end;
end ;
{xml functions}
function xmlformatLoadStr ( fn : string ): string ;
var
si , so : string ;
i , level : integer ;
begin
si := loadstring ( fn );
so := '' ;
level := 0 ;
for i := 1 to length ( si ) do begin
if si [ i ]= '<' then begin
if si [ i + 1 ]= '/' then begin
so := so + cr + stringofChar ( ' ' , level )+ '<' ;
dec ( level , 2 );
end
else begin
inc ( level , 2 );
so := so + cr + stringofChar ( ' ' , level )+ '<' ;
end ;
end
else
so := so + si [ i ];
end ;
showmessage ( so );
result := so ;
end ;
function prettyxml ( aText : string ): string ;
var
s : string ;
pb , pe , peold : integer ;
level : integer ;
begin
s := '' ;
pe := 1 ;
peold := 1 ;
level := 1 ;
repeat
pb := posstr ( '<' , aText , pe );
if pb > 0 then begin
pe := posstr ( '>' , aText , pb );
if pe > 0 then begin
if aText [ pb + 1 ]= '/' then begin // close tag
if pb >( peold + 1 ) then
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , peold + 1 , pb - peold - 1 )+ cr ;
if level > 1 then dec ( level );
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , pb , pe - pb + 1 )+ cr ;
end
else begin
if aText [ pe - 1 ]<> '/' then begin
if pb >( peold + 1 ) then
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , peold + 1 , pb - peold - 1 )+ cr ;
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , pb , pe - pb + 1 )+ cr ;
inc ( level );
end
else begin // xml shortcut
if pb >( peold + 1 ) then
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , peold + 1 , pb - peold - 1 )+ cr ;
s := s + stringofChar ( ' ' , level * 2 )+ copy ( aText , pb , pe - pb + 1 )+ cr ;
if level > 1 then dec ( level );
end ;
end ;
peold := pe ;
end ;
end ;
until ( pb = 0 ) or ( pe = 0 );
if length ( aText )> pe then
s := s + copy ( aText , peold , maxint );
result := s ;
end ;
{file filter functions}
function decodefilter ( afilter : string ): string ;
var
b : boolean ;
p : integer ;
begin
result := afilter ;
b := true ;
repeat
p := pos ( '|' , result );
if p > 0 then begin
if b then begin
delete ( result , p , 1 );
insert ( '=' , result , p );
end
else begin
delete ( result , p , 1 );
insert ( cr , result , p );
end ;
b := not b ;
end ;
until p = 0 ;
end ;
function encodefilter ( avalue : string ): string ;
begin
result := avalue ;
result := stringreplace ( result , cr , '|' ,[ rfreplaceall ]);
result := stringreplace ( result , '=' , '|' ,[ rfreplaceall ]);
end ;
end .
