Delphi Huge Tricks

HUGE TRICKS

By TanZ tHe AnthroX

1

Bir Tlistbox icerisinde bulunan satirlarin, belli sartlara göre farkli renklerde olmasi mümkündür. Asagidaki kod örneginde bunun yapilisi gösterilmektedir. Dikkat edilmesi gereken en önemli husus, Listbox bileseninin Style özelligi lbOwnerDrawFixed olmalidir. //Style= lbOwnerDrawFixed olmali… procedure TForm1.ListBox1DrawItem(Control: TWinControl;Index: Integer; Rect: TRect; State: TOwnerDrawState); begin with ( Control as TListBox ).Canvas do begin case Index of 0: begin Font.Color := clBlue; Brush.Color := clYellow; end; 1: begin Font.Color := clRed; Brush.Color := clLime; end; 2: begin Font.Color := clGreen; Brush.Color := clFuchsia; end; end; FillRect(Rect); TextOut(Rect.Left, Rect.Top, ( Control as TListBox).Items[Index]); end; end;

2

//IDE Servers bölümündeki Wordapplication ile Dosya acmak //gerci Comobj ile Oleobj kullanmak daha kolay ama Nokta //dan sonra prosedür ve metotlari gösterdiginden bu faydali. //Degiskenler bos birakilmammali, olevariant olarak tanimlanmali. //Degiskenler hakkinda bilgiyi(tipi vs.) word Visual basic penceresindeki yardimdan ögrenebilirsiniz. procedure TForm1.Button2Click(Sender: TObject); var filename:Olevariant; s1,s2,s3,s4,s5,s6,s7,s8,s9:Olevariant; begin s1:=false;//ConfirmConversions Optional Variant. True s2:=false;//readonly s3:=false;//AddToRecentFiles Optional Variant. True s4:='';// The password for opening the document. s5:='';// The password for opening the template. s6:=true;//Revert s7:=''; //The password for saving changes to the document. s8:=''; //The password for saving changes to the template. s9:=wdOpenFormatAuto;//format. wa1.Disconnect;//wordü elle kaparsa hata vermemesi icin wa1.Connect; filename:='d:\worddelphi\ykdsubat2001.doc'; wa1.Visible:=true;//wordü göster wa1.Documents.Open(filename,s1,s2,s3,s4,s5,s6,s7,s8,s9);//degisken kac adetse tanimlanmali. end; procedure TForm1.Button3Click(Sender: TObject); begin wa1.Disconnect;//Word elle kapanirsa hata vermesin diye. //wordapplication1.Visible:=false;// Bunu kullanma. word cikarken degisiklikleri kaydetmek istiyormusunuz vs. diye sordugunda göremedigin icin acik kaliyor. wa1.Quit; end;

3

Masaüstündeki ikonlarin gizlenmesi Asagidaki program calistirildiginda, görev cubugu üzerindeki uyari bölümünde bir ikon olarak görünür. Bu ikon üzerinde tiklandiginda desktop üzerindeki ikonlar saklanir, bir kez daha basildiginda ise geri gelir. program DeskPop; uses Windows, Messages, ShellAPI, sysutils; {$R *.RES} const AppName = 'DeskTop Sakla'; var x: integer; tid: TNotifyIconData; WndClass: array[0..50] of char; procedure Panic (szMessage: PChar); begin if szMessage <> nil then MessageBox (0, szMessage, AppName, mb_ok); Halt (0); end; procedure HandleCommand (Wnd: hWnd; Cmd: Word); begin case Cmd of Ord ('A'): MessageBox (0, 'Merhaba', AppName, mb_ok); Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0); end; end; function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt; stdcall; var TrayHandle: THandle; dc: hDC; i: Integer; pm: HMenu; pt: TPoint; begin DummyWindowProc := 0; StrPCopy(@WndClass[0], 'Progman'); TrayHandle := FindWindow(@WndClass[0], nil); case Msg of wm_Create: begin tid.cbSize := sizeof (tid); tid.Wnd := Wnd; tid.uID := 1; tid.uFlags := nif_Message or nif_Icon or 4

tid.uFlags := nif_Message or nif_Icon or nif_Tip; tid.uCallBackMessage := wm_User; tid.hIcon := LoadIcon (hInstance, 'MAINICON'); lstrcpy (tid.szTip,'Desktop is on'); Shell_NotifyIcon (nim_Add, @tid); end; wm_Destroy: begin Shell_NotifyIcon (nim_Delete, @tid); PostQuitMessage (0); ShowWindow(TrayHandle, SW_RESTORE); end; wm_Command: begin HandleCommand (Wnd, LoWord (wParam)); Exit; end; wm_User: // Had a tray notification - see what to do if (lParam = wm_LButtonDown) then begin if x = 0 then begin ShowWindow(TrayHandle, SW_HIDE); //tid.hIcon := LoadIcon (hInstance, 'offICON'); lstrcpy (tid.szTip,'Desktop Kapali'); Shell_NotifyIcon (NIM_MODIFY, @tid); x:=1 end else begin ShowWindow(TrayHandle, SW_RESTORE); //tid.hIcon := LoadIcon (hInstance, 'ONICON'); lstrcpy (tid.szTip,'Desktop Acik'); Shell_NotifyIcon (NIM_MODIFY, @tid); x:= 0; end; end else if (lParam = wm_RButtonDown) then begin GetCursorPos (pt); pm := CreatePopupMenu; AppendMenu (pm, 0, Ord ('A'), 'Hakkinda...'); AppendMenu (pm, mf_Separator, 0, nil); AppendMenu (pm, 0, Ord ('E'), ''); SetForegroundWindow (Wnd); dc := GetDC (0); if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign, pt.x,GetDeviceCaps(dc,HORZRES){pt.y}, 0, Wnd, nil) then SetForegroundWindow (Wnd); DestroyMenu (pm) end; end; DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam); 5

end; procedure WinMain; var Wnd: hWnd; Msg: TMsg; cls: TWndClass; begin { Previous instance running ? If so, exit } if FindWindow (AppName, nil) <> 0 then exit; //Panic (AppName + ' is already running.'); { window Sinifini kaydettir } FillChar (cls, sizeof (cls), 0); cls.lpfnWndProc := @DummyWindowProc; cls.hInstance := hInstance; cls.lpszClassName := AppName; RegisterClass (cls); { Bos pencereyi yarat } Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow, cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault, 0, 0, hInstance, nil); x:= 0; if Wnd <> 0 then begin ShowWindow (Wnd, sw_Hide); while GetMessage (Msg, 0, 0, 0) do begin TranslateMessage (Msg); DispatchMessage (Msg); end; end; end; begin WinMain; end.

6

Edit bileseninde sadece sayi yazmak function rakam(Key:Char):Char; begin if (Key>='0') and (Key<='9') or (Key=#8) or (Key=#13) then begin Result:=Key; end else Result:=Chr(0); end; //Kullanimi: procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin Key:=rakam(key); end;

Gönderen: ykaygisiz

7

Harici bir ortamdan basilan tusu anlamak Keyboard Hook {*************************************************************} { TKeySpy Component for Delphi 16/32 } { Version: 2.8 } { E-Mail: [email protected] } { Home page: www.utilmind.com } { Created: August, 16, 1998 } { Modified: June, 6, 2000 } { Legal: Copyright (c) 1998-2000, UtilMind Solutions } {*************************************************************} { KEYBOARD SPY: } { This component is intended for interception of pressing the } { keyboard. The KeySpy is possible to apply for interception } { of the typed text of the another's programs, as keyboard } { spy, or for processing events at type certain keywords etc..} {*************************************************************} { Properties: ************************************************} { Enabled: as it usual... } { Keyword: At a set of this word event will be } { carried out (See OnKeyword event). } { ActiveLayout: Active keyboard layout (string) Win32 only } { SpyLayout: now present English, Russian, German } { & Italian } {ActiveWindowTitle: Title of active window (Read only) } { Events: ************************************************} { OnKeySpyDown: as OnKeyDown, but in any place (window). } { OnKeySpyUp: as OnKeyUp, but in any place (window). } { OnKeyword: The Keyword has been typed (See Keyword). } { OnLayoutChanged: The Keyboard layout was changed. Win32 only} { OnActiveWindowChanged: } {*************************************************************} { IMPORTANT NOTE: } { This code may be used and modified by anyone so long as } { this header and copyright information remains intact. By } { using this code you agree to indemnify UtilMind Solutions } { from any liability that might arise from its use. You must } { obtain written consent before selling or redistributing } { this code. } {*************************************************************} { Changes: } { 20.I.1999: Added 32-bit support } { 14.V.1999: Added OnChangeLayout event. } { Added Italian and Russian keyboard layouts. } { 28.V.1999: Added ActiveWindowTitle property. } { 27.VII.1999: Added Portugese keyboard layout. } { Thanks to Tiago Correia ([email protected])} { 19.IX.1999: Added German keyboard layout (added by Slaine, } { [email protected]) } { 5.V.2000: Added French keyboard layout (added by Vincent } { CALLIES, [email protected]) } {*************************************************************} unit KeySpy; 8

interface uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs,{$ENDIF} SysUtils, Controls, Classes, Messages, Forms; type TSpyLayout = (klAmerican, klItalian, klRussian, klPortuguese, klGerman, klFrench); TOnKeySpy = procedure(Sender: TObject; Key: Byte; KeyStr: string) of object; {$IFDEF Win32} TOnLayoutChanged = procedure(Sender: TObject; Layout: string) of object; {$ENDIF} TOnActiveWindowChanged = procedure(Sender: TObject; ActiveTitle: string) of object; TKeySpy = class(TComponent) private {$IFDEF Win32} CurrentLayout: string; FActiveLayout: string; {$ENDIF} CurrentActiveWindowTitle: string; FActiveWindowTitle: string; FSpyLayout: TSpyLayout; FWindowHandle: HWnd; FOnKeySpyDown, FOnKeySpyUp: TOnKeySpy; FOnKeyword: TNotifyEvent; {$IFDEF Win32} FOnLayoutChanged: TOnLayoutChanged; {$ENDIF} FOnActiveWindowChanged: TOnActiveWindowChanged; FEnabled: Boolean; FKeyword, KeyComp: string; OldKey: Byte; LShiftUp, RShiftUp: Boolean; procedure UpdateTimer; procedure SetEnabled(Value: Boolean); procedure SetKeyword(Value: string); procedure WndProc(var Msg: TMessage); procedure SetNothingStr(Value: string); protected procedure KeySpy; dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ActiveWindowTitle: string read FActiveWindowTitle write SetNothingStr; property Enabled: Boolean read FEnabled write SetEnabled; property Keyword: string read FKeyword write SetKeyword; property SpyLayout: TSpyLayout read FSpyLayout write FSpyLayout; {$IFDEF Win32} property ActiveLayout: string read FActiveLayout write FActiveLayout; {$ENDIF} property OnKeySpyDown: TOnKeySpy read FOnKeySpyDown write FOnKeySpyDown; 9

property OnKeySpyUp: TOnKeySpy read FOnKeySpyUp write FOnKeySpyUp; property OnKeyword: TNotifyEvent read FOnKeyword write FOnKeyword; {$IFDEF Win32} property OnLayoutChanged: TOnLayoutChanged read FOnLayoutChanged write FOnLayoutChanged; {$ENDIF} property OnActiveTitleChanged: TOnActiveWindowChanged read FOnActiveWindowChanged write FOnActiveWindowChanged; end; procedure register; implementation {$I KLayouts.inc} constructor TKeySpy.Create(AOwner: TComponent); begin inherited Create(AOwner); LShiftUp := True; RShiftUp := True; FEnabled := True; FWindowHandle := AllocateHWnd(WndProc); if FEnabled then UpdateTimer; end; destructor TKeySpy.Destroy; begin FEnabled := False; UpdateTimer; DeallocateHWnd(FWindowHandle); inherited Destroy; end; procedure TKeySpy.WndProc(var Msg: TMessage); begin with Msg do if Msg = WM_TIMER then try KeySpy; except Application.HandleException(Self); end else Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam); end; procedure TKeySpy.UpdateTimer; var b: Byte; begin KillTimer(FWindowHandle, 1); if FEnabled then begin asm 10

mov al, 60h mov b, al end; OldKey := b; if SetTimer(FWindowHandle, 1, 1, nil) = 0 then raise EOutOfResources.Create('No timers'); end; end; procedure TKeySpy.SetEnabled(Value: Boolean); begin if Value <> FEnabled then begin FEnabled := Value; UpdateTimer; end; end; procedure TKeySpy.SetKeyword(Value: string); begin Value := LowerCase(Value); if Value <> FKeyword then FKeyword := Value; end; procedure TKeySpy.KeySpy; var PC: array[0..$FFF] of Char; Key: Byte; St: string; Wnd: hWnd; begin {$IFDEF Win32} Wnd := GetForegroundWindow; {$ELSE} Wnd := GetActiveWindow; {$ENDIF} SendMessage(Wnd, wm_GetText, $FFF, LongInt(@PC)); FActiveWindowTitle := StrPas(PC); if CurrentActiveWindowTitle <> FActiveWindowTitle then begin CurrentActiveWindowTitle := FActiveWindowTitle; if Assigned(FOnActiveWindowChanged) then FOnActiveWindowChanged(Self, FActiveWindowTitle); end; {$IFDEF Win32} GetKeyboardLayoutName(PC); FActiveLayout := StrPas(PC); if (FActiveLayout <> CurrentLayout) then begin CurrentLayout := FActiveLayout; if Assigned(FOnLayoutChanged) then FOnLayoutChanged(Self, FActiveLayout); end; 11

{$ENDIF} asm in al, 60h mov Key, al end; if Key = 170 then begin Key := 84; LShiftUp := True; end; if Key = 182 then begin Key := 85; RShiftUp := True; end; if Key = 42 then LShiftUp := False; if Key = 54 then RShiftUp := False; if Key <> OldKey then begin OldKey := Key; if Key <= 88 then begin case FSpyLayout of klAmerican: if LShiftUp and RShiftUp then St := StrPas(LowButtonName[Key]) else St := StrPas(HiButtonName[Key]); klItalian: if LShiftUp and RShiftUp then St := StrPas(ItalianLowButtonName[Key]) else St := StrPas(ItalianHiButtonName[Key]); klRussian: if LShiftUp and RShiftUp then St := StrPas(RussianLowButtonName[Key]) else St := StrPas(RussianHiButtonName[Key]); klPortuguese: if LShiftUp and RShiftUp then St := StrPas(PortugueseLowButtonName[Key]) else St := StrPas(PortugueseHiButtonName[Key]); klGerman: if LShiftUp and RShiftUp then St := StrPas(GermanLowButtonName[Key]) else St := StrPas(GermanHiButtonName[Key]); klFrench: if LShiftUp and RShiftUp then St := StrPas(FrenchLowButtonName[Key]) else St := StrPas(FrenchHiButtonName[Key]); end; if Assigned(FOnKeySpyDown) then FOnKeySpyDown(Self, Key, St); if Assigned(FOnKeyword) then begin KeyComp := KeyComp + St; 12

if Length(KeyComp) > Length(FKeyword) then begin Move(KeyComp[Length(St) + 1], KeyComp[1], Length(KeyComp)); {$IFDEF WIN32} SetLength(KeyComp, Length(FKeyword)); {$ELSE} KeyComp[0] := char(Length(FKeyword)); {$ENDIF} end; if LowerCase(KeyComp) = FKeyword then FOnKeyword(Self); end; end else if Key - 128 <= 88 then begin case FSpyLayout of klAmerican: if LShiftUp and RShiftUp then St := StrPas(LowButtonName[Key - 128]) else St := StrPas(HiButtonName[Key - 128]); klItalian: if LShiftUp and RShiftUp then St := StrPas(ItalianLowButtonName[Key - 128]) else St := StrPas(ItalianHiButtonName[Key - 128]); klRussian: if LShiftUp and RShiftUp then St := StrPas(RussianLowButtonName[Key - 128]) else St := StrPas(RussianHiButtonName[Key - 128]); klPortuguese: if LShiftUp and RShiftUp then St := StrPas(PortugueseLowButtonName[Key - 128]) else St := StrPas(PortugueseHiButtonName[Key - 128]); klGerman: if LShiftUp and RShiftUp then St := StrPas(GermanLowButtonName[Key - 128]) else St := StrPas(GermanHiButtonName[Key - 128]); klFrench: if LShiftUp and RShiftUp then St := StrPas(FrenchLowButtonName[Key - 128]) else St := StrPas(FrenchHiButtonName[Key - 128]); end; if Assigned(FOnKeySpyUp) then FOnKeySpyUp(Self, Key, St) end; end; end; procedure TKeySpy.SetNothingStr(Value: string); begin {} end; procedure register; begin RegisterComponents('UtilMind', [TKeySpy]); end; 13

end. Gönderen: kizer

14

avi Dosyalarini Fullscreen oynatma( aviden baska da olabilir) Gerekenler: 1 Mediaplayer 2 Button 3 Panel "align client olacak" procedure TForm1.Button1Click(Sender: TObject); begin MediaPlayer1.FileName:='c:\hands.avi'; MediaPlayer1.Open; MediaPlayer1.Display := panel1; MediaPlayer1.DisplayRect := Rect(0 , 0, Form1.Clientwidth, Form1.ClientHeight); //avi dosyasini panel e yayyarak genisletme komutu// MediaPlayer1.Play; end; procedure TForm1.FormActivate(Sender: TObject); begin button1.click ; end; end. Gönderen: skywalker

15

programin ayni anda sadece 1 kez calismasi function AlreadyLoaded: Boolean; var wHandle: Integer; wTitle: array[0..100] of Char; wClass: array[0..100] of Char; begin StrPCopy(wTitle, Application.Title); StrPCopy(wClass, 'TApplication'); Application.Title := '$Test$'; wHandle := findWindow(wClass, wTitle); Application.Title := wTitle; Result := wHandle <> 0; if Result then begin ShowWindow(wHandle, SW_SHOWNORMAL); SetForegroundWindow(wHandle); end; end; Gönderen: mkx

16

internet baglanti tipinin bulunmasi function ConnectionKind :boolean; var flags: dword; begin Result := InternetGetConnectedState(@flags, 0); if Result then begin if (flags and INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM then begin showmessage('Modem'); end; if (flags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then begin showmessage('LAN'); end; if (flags and INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY then begin showmessage('Proxy'); end; if (flags and INTERNET_CONNECTION_MODEM_BUSY)=INTERNET_CONNECTION_MOD EM_BUSY then begin showmessage('Modem Busy'); end; end; end; /////kulanim procedure TForm1.Button3Click(Sender: TObject); begin ConnectionKind ; end; Gönderen: meymenet

17

Ctrl+Esc ve Alt+Tab Tuslarini Devre Disi Birakmak Devre Disi Birakmak icin: var OldVal : LongInt; begin SystemParametersInfo (97, Word (True), @OldVal, 0) end; Eski Haline Döndürmek: var OldVal : LongInt; begin SystemParametersInfo (97, Word (False), @OldVal, 0) end; Gönderen: erdem_15 Programi taskbardan saklamak procedure TForm1.FormCreate(Sender: TObject); begin WS_EX_TOOLWINDOW); //taskbardan saklar SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); end; Gönderen: metinsdr

18

Running an external application (and waiting)

People have been asking me over and over: how can I run an external program from within a Delphi program? And also: how can I make the Delphi program wait until the external program is terminated? For just running an external application (or opening a registered file, opening a folder, printing a file, and so on), there are several functions available. In most cases, the Windows API-function ShellExecute is used. It gives some degree of control and at the same time it's not to complicated. Some examples: · Start any application: ShellExecute(Handle, 'open', PChar('c:\test\app.exe'), nil, nil, SW_SHOW); · Start NotePad (which is in the system's "path", so we don't have to specify the full path): ShellExecute(Handle, 'open', PChar('notepad'), nil, nil, SW_SHOW); · Start NotePad and load a file: ShellExecute(Handle, 'open', PChar('notepad'), PChar('c:\test\readme.txt', nil, SW_SHOW); · Open a textfile with NotePad (*.txt files are registered with the system): ShellExecute(Handle, 'open', PChar('c:\test\readme.txt'), nil, nil, SW_SHOW); · You can do the previuos trick with any type of registered data-file, e.g. launch your browser with a certain URL: ShellExecute(Handle, 'open', PChar('http://www.festra.com/'), nil, nil, SW_SHOW); · Print a file: ShellExecute(Handle, 'print', PChar('c:\test\readme.txt'), nil, nil, SW_SHOW); · Explore a folder with Windows Explorer: ShellExecute(Handle, 'explore', PChar('c:\windows)', nil, nil, SW_SHOW); ------Ayrı bir dosya (program) nasıl çalıştırılır? Herhangi bir programı çalıştırmak için · ShellExecute(Handle, 'open', PChar('c:\test\Tanz_AnthroX.exe'), nil, nil, SW_SHOW); NOTEPAD'I çalıştırmak · ShellExecute(Handle, 'open', PChar('notepad'), nil, nil, SW_SHOW); NOTEPAD'e BeniOku.TXT dosyasını açtırmak · ShellExecute(Handle, 'open', PChar('notepad'), PChar('c:\AnthroX\benioku.txt', nil, SW_SHOW); Web sayfasını açtırmak · ShellExecute(Handle, 'open', PChar('http://www.delphiturk.com/'), nil, nil, SW_SHOW); Print ettirmek · ShellExecute(Handle, 'print', PChar('c:\test\readme.txt'), nil, nil, SW_SHOW); WINDOWS EXPLORER la dizinlere bakmak · ShellExecute(Handle, 'explore', PChar('c:\windows)', nil, nil, SW_SHOW);

19

Yuvarlak Form Olusyurma procedure TForm1.FormCreate(Sender: TObject); var region: HRgn; begin { yuvarlak form olusturur } region:=CreateEllipticRgn(1,1,200,200); SetWindowRgn(handle, region, true); end; Gönderen: aliuzun

20

Sisteme admin olarak mi girilmis ? (NT/2000) const SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)); SECURITY_BUILTIN_DOMAIN_RID = $00000020; DOMAIN_ALIAS_RID_ADMINS = $00000220; function IsAdmin: Boolean; var hAccessToken: THandle; ptgGroups: PTokenGroups; dwInfoBufferSize: DWORD; psidAdministrators: PSID; x: Integer; bSuccess: BOOL; begin Result := False; bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken); if not bSuccess then begin if GetLastError = ERROR_NO_TOKEN then bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken); end; if bSuccess then begin GetMem(ptgGroups, 1024); bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize); CloseHandle(hAccessToken); if bSuccess then begin AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators); {$R-} for x := 0 to ptgGroups.GroupCount - 1 do if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then begin Result := True; Break; end; {$R+} FreeSid(psidAdministrators); end; FreeMem(ptgGroups); end; end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); begin if isAdmin then 21

begin ShowMessage('Administrator olarak girilmis'); end; end.

Microsot Outlook ile programdan mail gondermek uses comobj; procedure SendMail(Recipients, Attachments: TStringList; Subject, Body: string); const // OlItemType sabitleri // mail, not, kisi vs. olMailItem = 0; olAppointmentItem = 1; olContactItem = 2; olTaskItem = 3; olJournalItem = 4; olNoteItem = 5; olPostItem = 6; // OlAttachmentType constants olByValue = 1; olByReference = 4; olEmbeddedItem = 5; olOLE = 6; var myOlApp, myItem: OleVariant; i: integer; begin myOlApp := CreateOLEObject('Outlook.Application'); myItem := myOlApp.CreateItem(olMailItem); myItem.Subject := Subject; for i := 0 to Recipients.Count - 1 do myItem.Recipients.Add(Recipients[i]); for i := 0 to Attachments.Count - 1 do myItem.Attachments.Add(Attachments[i], olByValue, 1, Attachments[i]); myItem.Body := Body; myItem.Send; myOlApp := VarNull; myItem := VarNull; end; // kullanimi: procedure TForm1.Button1Click(Sender: TObject); var Alicilar, Dosyalar: TStringList; begin Alicilar := TStringList.Create; Alicilar.Add('[email protected]'); 22

Alicilar.Add('[email protected]'); Dosyalar := TStringList.Create; Dosyalar.Add('C:\autoexec.bat'); Dosyalar.Add('C:\config.sys'); try SendMail(Alicilar, Dosyalar, 'Deneme Mail, Autoexec.bat ve config.sys', Memo1.Lines.Text); finally Alicilar.Free; Dosyalar.Free; end; end; Gönderen: webmaster

23

Microsoft Outlook'ta tanimli mail hesaplarinin alinmasi { Daha fazla bilgi ve detay icin Registry'de HKEY_CURRENT_USER anahtarinin altinda Software\Microsoft\Internet Account Manager\Accounts 'a bakiniz. } uses registry; function GetEMailAccounts: string; var Emails, Res: TStrings; AccountName, EmailTemp: string; POP3Server, POP3User, SMTPServer, SMTPName, SMTPEmailAdress: string; i: integer; begin Emails := TStringlist.create; Res := TStringlist.create; with TRegistry.Create do begin RootKey := HKEY_CURRENT_USER; LazyWrite := false; if KeyExists('Software\Microsoft\Internet Account Manager\Accounts') then OpenKey('Software\Microsoft\Internet Account Manager\Accounts', false); GetKeyNames(Emails); CloseKey; if Emails.Count > 0 then begin for i := 0 to Emails.Count - 1 do begin OpenKey('Software\Microsoft\Internet Account Manager\Accounts\' + Emails.Strings[i], False); AccountName := ReadString('Account Name'); POP3Server := ReadString('POP3 Server'); POP3User := ReadString('POP3 User Name'); SMTPServer := ReadString('SMTP Server'); SMTPName := ReadString('SMTP Display Name'); SMTPEmailAdress := ReadString('SMTP Email Address'); if AccountName = '' then AccountName := 'name not found'; if POP3User = '' then POP3User := 'login not found'; if SMTPName = '' then SMTPName := 'name not found'; if SMTPEmailAdress = '' then SMTPEmailAdress := 'email not found'; EmailTemp := '"' + AccountName + '": ' + SMTPName + ' <' + SMTPEMailAdress + '> (' + POP3User + '; ' + POP3Server + '/' + SMTPServer; if POP3Server <> '' then begin if SMTPServer <> '' then begin Res.Add(EmailTemp); end; end; CloseKey; end; Destroy; end; //with Emails.Free; end; 24

if Res.count = 0 then Res.Add('(email accounts not found)'); Result := ReS.Text; Res.Free; end;

TListbox'a yatay scrollbar eklenmesi { Form'un create event handlerina asagidaki kodu ekleyin. Form uzerinde bulunan her bir listbox icin yapmaniz gerekli } procedure TForm1.FormCreate(Sender: TObject); begin SendMessage(ListBox1.Handle, LB_SetHorizontalExtent, 1000, // Kaydirma yapilcak uzunluk longint(0)); end; Gönderen: webmaster

25

Windows Taskbar'in saklanmasi ve tekrar gozukur hale getirilmesi procedure hideTaskbar; var wndHandle : THandle; wndClass : array[0..50] of Char; begin StrPCopy(@wndClass[0], 'Shell_TrayWnd'); wndHandle := FindWindow(@wndClass[0], nil); ShowWindow(wndHandle, SW_HIDE); // Sakla end; procedure showTaskbar; var wndHandle : THandle; wndClass : array[0..50] of Char; begin StrPCopy(@wndClass[0], 'Shell_TrayWnd'); wndHandle := FindWindow(@wndClass[0], nil); ShowWindow(wndHandle, SW_RESTORE); // Göster end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); begin ShowTaskBar; end; procedure TForm1.Button2Click(Sender: TObject); begin HideTaskBar; end; Gönderen: webmaster

26

Verilen bir kredi karti numarasi'nin gecerli olup olmadiginin kontrolü {------------------------------------------------Credit card validator Returns: 0 : Card is invalid or unknown 1 : Card is a valid AmEx 2 : Card is a valid Visa 3 : Card is a valid MasterCard -------------------------------------------------} function Vc(c: string): integer; var card: string[21]; Vcard: array[0..21] of byte absolute card; Xcard: integer; Cstr: string[21]; y, x: integer; begin Cstr := ''; fillchar(Vcard, 22, #0); card := c; for x := 1 to 20 do if (Vcard[x] in [48..57]) then Cstr := Cstr + chr(Vcard[x]); card := ''; card := Cstr; Xcard := 0; if not odd(length(card)) then for x := (length(card) - 1) downto 1 do begin if odd(x) then y := ((Vcard[x] - 48) * 2) else y := (Vcard[x] - 48); if (y >= 10) then y := ((y - 10) + 1); Xcard := (Xcard + y) end else for x := (length(card) - 1) downto 1 do begin if odd(x) then y := (Vcard[x] - 48) else y := ((Vcard[x] - 48) * 2); if (y >= 10) then y := ((y - 10) + 1); Xcard := (Xcard + y) end; 27

x := (10 - (Xcard mod 10)); if (x = 10) then x := 0; if (x = (Vcard[length(card)] - 48)) then Vc := ord(Cstr[1])-ord('2') else Vc := 0 end; Gönderen: webmaster

28

Network'e baglanmis sürücü listesinin alinmasi function GetNetworkDriveMappings(SList:TStrings):Integer; var I:Char; ThePath:string; MaxNetPathLen:DWord; begin SList.Clear; MaxNetPathLen:=MAX_PATH; SetLength(ThePath,MAX_PATH); for I := 'A' to 'Z' do if WNetGetConnection( PChar(''+I+':'),PChar(ThePath), MaxNetPathLen)=NO_ERROR then SList.Add(I+': '+ThePath); Result := SList.Count; end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); begin GetNetworkDriveMappings(Form1.ListBox1.Items); end; Gönderen: webmaster

29

CD Sürücünün kapagini acmak ve mak uses MMSystem; // Ac procedure Opendoor; begin mciSendString('Set cdaudio door open', nil, 0, 0); end; // procedure CloseDoor; begin mciSendString('Set cdaudio door closed', nil, 0, 0); end; //Kullanimi: procedure TForm1.Button1Click(Sender: TObject); begin Opendoor; end; procedure TForm1.Button2Click(Sender: TObject); begin Closedoor; end; Gönderen: webmaster

30

Dos Programini calistirip, input ve output'unu yonlendirmek ve bitene kadar beklemek {InputFile '' ise Dos programi klavyeden okuma yapar} function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile, ErrMsg :string): boolean; const ROUTINE_ID = '[function: CreateDOSProcessRedirected]'; var OldCursor : TCursor; pCommandLine : array[0..MAX_PATH] of char; pInputFile, pOutPutFile : array[0..MAX_PATH] of char; StartupInfo : TStartupInfo; ProcessInfo : TProcessInformation; SecAtrrs : TSecurityAttributes; hAppProcess, hAppThread, hInputFile, hOutputFile : THandle; begin Result := FALSE; if (InputFile <> '') and (not FileExists(InputFile)) then raise Exception.CreateFmt(ROUTINE_ID + #10#10 + '* %s *' + #10 + 'does not exist' + #10#10 + ErrMsg, [InputFile]); hAppProcess := 0; hAppThread := 0; hInputFile := 0; hOutputFile := 0; OldCursor := Screen.Cursor; Screen.Cursor := crHourglass; try StrPCopy(pCommandLine, CommandLine); StrPCopy(pInputFile, InputFile); StrPCopy(pOutPutFile, OutputFile); FillChar(SecAtrrs, SizeOf(SecAtrrs), #0); SecAtrrs.nLength := SizeOf(SecAtrrs); SecAtrrs.lpSecurityDescriptor := nil; SecAtrrs.bInheritHandle := TRUE; if InputFile <> '' then begin hInputFile := CreateFile( pInputFile, GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, @SecAtrrs, 31

OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH, 0); if hInputFile = INVALID_HANDLE_VALUE then raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 + 'WinApi function returned an invalid handle value' + #10 +'for the input file * %s *' + #10 + #10 + ErrMsg, [InputFile]); end else hInputFile := 0; hOutputFile := CreateFile( pOutPutFile, GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, @SecAtrrs, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH, 0 ); if hOutputFile = INVALID_HANDLE_VALUE then raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 + 'WinApi function returned an invalid handle value' + #10 + 'for the output file * %s *' + #10 + #10 + ErrMsg, [OutputFile]); FillChar(StartupInfo, SizeOf(StartupInfo), #0); StartupInfo.cb := SizeOf(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; StartupInfo.wShowWindow := SW_HIDE; StartupInfo.hStdOutput := hOutputFile; StartupInfo.hStdInput := hInputFile; Result := CreateProcess( nil, pCommandLine, nil, nil, TRUE, HIGH_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo); if Result then begin WaitforSingleObject(ProcessInfo.hProcess, INFINITE); hAppProcess := ProcessInfo.hProcess; hAppThread := ProcessInfo.hThread; 32

end else raise Exception.Create(ROUTINE_ID + #10 + #10 + 'Function failure' + #10 + #10 + ErrMsg); finally if hOutputFile <> 0 then CloseHandle(hOutputFile); if hInputFile <> 0 then CloseHandle(hInputFile); if hAppThread <> 0 then CloseHandle(hAppThread); if hAppProcess <> 0 then CloseHandle(hAppProcess); Screen.Cursor:= OldCursor; end; end; // Kullanimi: procedure TForm1.Button2Click(Sender: TObject); begin CreateDOSProcessRedirected('chkdsk c:\', '', 'C:\sil.txt', ''); Memo1.Lines.LoadFromFile('C:\sil.txt'); end; Gönderen: webmaster

33

Bilgisayar adinin alinmasi {Bilgisayar'a login olmus kullanici adi ile karistirmayiniz} function GetCompName: string; var buffer:array[0..MAX_COMPUTERNAME_LENGTH+1] of Char; length:Cardinal; begin length:=MAX_COMPUTERNAME_LENGTH+1; GetComputerName(@Buffer,length); Result := Buffer; end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); begin Label1.Caption := GetCompName; end; Gönderen: webmaster

34

Bios bilgilerinin alinmasi procedure TForm1.Button1Click(Sender: TObject); begin with Memo1.Lines do begin Add('Tip:'+Î+string(Pchar(Ptr($FE061)))); Add('CopyRight:'+Î+string(Pchar(Ptr($FE091)))); Add('Bios Tarihi:'+Î+string(Pchar(Ptr($FFFF5)))); Add('Diger Bilgiler:'+Î+string(Pchar(Ptr($FEC71)))); end; end; Gönderen: webmaster

35

Sisteme login olmus kullanici adinin alinmasi function GetNetUser : Ansistring; var dwI : DWord; begin dwI := MAX_PATH; SetLength (Result, dwI + 1); if WNetGetUser (nil, PChar (Result), dwI) = NO_ERROR then SetLength (Result, StrLen (PChar (Result))) else SetLength (Result, 0) end; Gönderen: webmaster

Programdan Start Menu'yu acmak Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_TASKLIST,0); Gönderen: webmaster

±

36

Windows Explorer'dan program'a sürüklenen dosyalarin program tarafindan alinmasi uses ShellApi; procedure TForm1.FormCreate(Sender: TObject); begin DragAcceptFiles(Form1.Handle, true); Application.OnMessage := AppMessage; end; procedure TForm1.AppMessage(var Msg: Tmsg; var Handled: Boolean); const BufferLength : DWORD = 511; var DroppedFilename : string; FileIndex : DWORD; NumDroppedFiles : DWORD; pDroppedFilename : array [0..511] of Char; DroppedFileLength : DWORD; begin if Msg.message = WM_DROPFILES then begin FileIndex := $FFFFFFFF; NumDroppedFiles := DragQueryFile(Msg.WParam, FileIndex, pDroppedFilename, BufferLength); Memo1.Lines.Clear; for FileIndex := 0 to (NumDroppedFiles - 1) do begin DroppedFileLength := DragQueryFile(Msg.WParam, FileIndex, pDroppedFilename, BufferLength); DroppedFilename := StrPas(pDroppedFilename); Memo1.Lines.Add(pDroppedFilename); end; DragFinish(Msg.WParam); Handled := true; end; end; Gönderen: webmaster

37

Recycle Bin'in program icinden bosaltilmasi procedure EmptyRecycleBin; const SHERB_NOCONFIRMATION = $00000001; SHERB_NOPROGRESSUI = $00000002; SHERB_NOSOUND = $00000004; type TSHEmptyRecycleBin = function (Wnd: HWND; LPCTSTR: PChar; DWORD: Word): integer; stdcall; var SHEmptyRecycleBin: TSHEmptyRecycleBin; LibHandle: THandle; begin LibHandle := LoadLibrary(PChar('Shell32.dll')); if LibHandle <> 0 then @SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA') else begin MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0); Exit; end; if @SHEmptyRecycleBin <> nil then SHEmptyRecycleBin(Application.Handle, '', SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND); FreeLibrary(LibHandle); @SHEmptyRecycleBin := nil; end; Gönderen: webmaster

38

TImage yazicidan nasil yazdirilir ? // Printers unit'ini eklemeyi unutmayin. procedure TForm1.PrintBitmap(TheImage : TImage); var SourceRect, PrintRect: TRect; Info: PBitmapInfo; InfoSize: dword; Image: Pointer; ImageSize: dword; Bits: HBitmap; DIBWidth, DIBHeight: LongInt; PrintWidth, PrintHeight: LongInt; PrintBitmap: TBitmap; begin Printer.BeginDoc; PrintBitmap := TBitmap.Create; SourceRect.Left := TheImage.Left; SourceRect.Top := TheImage.Top; SourceRect.Right := TheImage.Left + Image1.Width; SourceRect.Bottom := TheImage.Top + Image1.Height; { Set up the height and width of the destination bitmap } PrintBitmap.Height := SourceRect.Bottom - SourceRect.Top + 1; PrintBitmap.Width := SourceRect.Right - SourceRect.Left + 1; { Set the destination coordinates } PrintRect.Top := 0; PrintRect.Left := 0; PrintRect.Right := PrintBitmap.Width; PrintRect.Bottom := PrintBitmap.Height; { Copy from the screen to the printer } PrintBitmap.Canvas.CopyRect(PrintRect, self.Canvas, SourceRect); { Here we will stretch the bitmap, and do the printing } with Printer, Canvas do begin { Get the handle to the Print bitmap } Bits := PrintBitmap.Handle; { Get the information from the bitmap } GetDIBSizes(Bits, InfoSize, ImageSize); { Allocate the required memory for the operation } GetMem(Info, InfoSize); try GetMem(Image, ImageSize); try GetDIB(Bits, 0, Info^, Image^); with Info^.bmiHeader do begin DIBWidth := biWidth; 39

DIBHeight := biHeight; end; { Adjust the print sizes (expand or contract) } PrintWidth := MulDiv(DIBWidth, GetDeviceCaps(Handle, LOGPIXELSX), PixelsPerInch); PrintHeight := MulDiv(DIBHeight, GetDeviceCaps(Handle, LOGPIXELSY), PixelsPerInch); { Move from one canvas to the other while stretching or compressing the image } StretchDIBits(Canvas.Handle, 0, 0, PrintWidth, PrintHeight, 0, 0,DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY); finally FreeMem(Image, ImageSize); end; finally FreeMem(Info, InfoSize); end; end; Printer.EndDoc; end; Gönderen: webmaster

40

Ip adresinden herhangi bir bilgisayar adinin bulunmasi uses winsock; function IPAddrToName(IPAddr : string): string; var SockAddrIn: TSockAddrIn; HostEnt: PHostEnt; WSAData: TWSAData; begin WSAStartup($101, WSAData); SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr)); HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET); if HostEnt<>nil then begin result:=StrPas(Hostent^.h_name) end else begin result:=''; end; end; procedure TForm1.Button1Click(Sender: TObject); begin label1.Caption:=IPAddrToName(edit1.text); end;

Gönderen: webmaster

41

Programin End Task menusunde gorunmesini engellemek (CTRL-ALT-DEL) ... implementation function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external 'KERNEL32.DLL'; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin // sakla RegisterServiceProcess(GetCurrentProcessID,1); end; procedure TForm1.Button2Click(Sender: TObject); begin // tekrar göster RegisterServiceProcess(GetCurrentProcessID,0); end; Gönderen: webmaster

42

Host adindan IP adresini bulmak function HostToIPAddr(Name: string; var Ip: string): Boolean; var wsdata : TWSAData; hostName : array [0..255] of char; hostEnt : PHostEnt; addr : PChar; begin WSAStartup ($0101, wsdata); try gethostname (hostName, sizeof (hostName)); StrPCopy(hostName, Name); hostEnt := gethostbyname (hostName); if Assigned (hostEnt) then if Assigned (hostEnt^.h_addr_list) then begin addr := hostEnt^.h_addr_list^; if Assigned (addr) then begin IP := Format ('%d.%d.%d.%d', [byte (addr [0]), byte (addr [1]), byte (addr [2]), byte (addr [3])]); Result := True; end else Result := False; end else Result := False else begin Result := False; end; finally WSACleanup; end end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); var IP: string; begin if HostToIpAddr(Edit1.Text, IP) then Label1.Caption := IP; end; Gönderen: webmaster

43

Exe dosyasina her hangibir dosya (Txt, mid vb) nasil gomulur ? { Projenize resource eklemek icin Sirayla takip ediniz. Delphi 4.0 icin: 1. Project|Resources komutu veriniz. 2. Gelen pencerede sag tiklayip New|User Data 3. Resource tipini yaziniz. Ornek: EXE (RcData gelecektir) 3. Hangi dosyayi eklemek istiyorsaniz seciniz 4. Exe_1 olarak Exe tipinde eklenecektir. EXE_1 in üzerinde sag tiklayip Rename dedikten sonra EXE_1'i herhangi bir tamsayi ile adini degistirin. Ör: 1 (EXE_1 -> 1) } procedure SaveRessourceToFile(const FileName, ResType: string; ResId: Integer); var MStream: TResourceStream; begin MStream := TResourceStream.CreateFromID(HInstance, ResId, PChar(ResType)); try MStream.SaveToFile(FileName); finally MStream.Free; end; end; // Kullanimi: (Yukardaki islemden sonra SaveRessourceToFile('c:\deneme.exe', 'EXE', 1); Gönderen: webmaster

44

Herhangi bir internet adresinin (HTTP, FTP, Bilgisayar Adi) gecerli olup olmadigi kontrol etmek, IP adresini bulmak uses winsock; function HostToIPAddr(Name: string; var Ip: string): Boolean; var wsdata : TWSAData; hostName : array [0..255] of char; hostEnt : PHostEnt; addr : PChar; begin WSAStartup ($0101, wsdata); try gethostname (hostName, sizeof (hostName)); StrPCopy(hostName, Name); hostEnt := gethostbyname (hostName); if Assigned (hostEnt) then if Assigned (hostEnt^.h_addr_list) then begin addr := hostEnt^.h_addr_list^; if Assigned (addr) then begin IP := Format ('%d.%d.%d.%d', [byte (addr [0]), byte (addr [1]), byte (addr [2]), byte (addr [3])]); Result := True; end else Result := False; end else Result := False else begin Result := False; end; finally WSACleanup; end end; // Kullanimi: procedure TForm1.Button1Click(Sender: TObject); var IP: string; begin if HostToIpAddr(Edit1.Text, IP) then ShowMessage(Format('Gecerli Adres. IP: %s', [IP])) else ShowMessage('Gecerisiz adres'); end; Gönderen: webmaster

45

Ayri bir dosya (program) nasil calistirilir? print edilir? //Ayri bir dosya (program) nasil calistirilir? //Herhangi bir programi calistirmak icin ShellExecute(Handle, 'open', PChar('c:\test\Tanz_AnthroX.exe'), nil, nil, SW_SHOW); //NOTEPAD'I calistirmak ShellExecute(Handle, 'open', PChar('notepad'), nil, nil, SW_SHOW); //NOTEPAD'e BeniOku.TXT dosyasini actirmak ShellExecute(Handle, 'open', PChar('notepad'), PChar('c:\AnthroX\benioku.txt', nil, SW_SHOW); //Web sayfasini actirmak ShellExecute(Handle, 'open', PChar('http://www.delphiturk.com/'), nil, nil, SW_SHOW); //Print ettirmek ShellExecute(Handle, 'print', PChar('c:\test\readme.txt'), nil, nil, SW_SHOW); //WINDOWS EXPLORER la dizinlere bakmak ShellExecute(Handle, 'explore', PChar('c:\windows)', nil, nil, SW_SHOW); Gönderen: Tanz_AnthroX

46

Sanirim degil :)) Neyse al sana hem TaskManagerden hemde TaskBardan gizleme ile ilgili bilgiler. Kisa ve acik! Isin sirri toolwindow olmasinda... // Make the Form invisible Application.ShowMainForm := False; // Hide from the Taskbar for ever ShowWindow (Application.Handle, SW_HIDE); SetWindowLong(Application.Handle, GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW); // Hide from Task-Manager RegisterServiceProcess (0, 1) Look in the WinApi help for more informaton about RegisterServiceProcess I use this code in the OnCreate-Event

47

!************************************** ! Name: File Splitter / Joiner ! Description:The Functions Can Split A ! File Into Many Pieces And Then Rejoin At ! A Later Date. ! By: wrastus ! ! Inputs:Two Sample Calls: SplitFile('C:\afilename.exe',40000); UnSplit('C:\samefilenameasabovewith-rtr-extension.rtr',40000); ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.311/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** function Smaller(const a,b:LongInt) :LongInt; begin if(a < b)then begin Result := a; end else if(b > 0)then begin Result := b end else Result := 0; end; Function SplitFile(FFileName : AnsiString; SplitSize : Longint): Boolean; Var InFile : TFileStream; OutFile : TFileStream; FilePlace : Integer; INI : TIniFile; FileInfo : TFinfo; Begin InFile := TFileStream.Create(FFileName,fmOpenRead); If InFile.Size > SplitSize Then Begin FilePlace := 0; While InFile.Position < InFile.Size Do Begin Inc(FilePlace); OutFile := TFileStream.Create(FFileName + '.' + FormatFloat('000',FilePlace),fmCreate); OutFile.CopyFrom(InFile,Smaller(SplitSize,InFile.Size - InFile.Position)); OutFile.Free; End; End Else ShowMessage('The File Is To Small To Split'); InFile.Free; INI := TIniFile.Create(ChangeFileExt(FFileName,'.rtr')); INI.WriteString('Files','Number',IntToStr(FilePlace)); INI.WriteString('Files','Name',FFileName); INI.Free; Result := True; End; Function UnSplit(FFileName : TFileName; BufferSize : LongInt):Boolean; Var INI : TIniFile; InFile : TFileStream; OutFile : TFileStream; FilePlace : Integer; NFiles : Integer; FFile : TFileName; BytesRead : LongInt; Buffer : Pointer;

48

FString : TFileName; Begin GetMem(Buffer,BufferSize); INI := TIniFile.Create(FFileName); NFiles := StrToInt(INI.ReadString('Files','Number','0')); FFile := INI.ReadString('Files','Name','0'); OutFile := TFileStream.Create(FFile,fmCreate); FilePlace := 1; While FilePlace <= NFiles Do Begin FString := (FFile + '.' + FormatFloat('000',FilePlace)); InFile := TFileStream.Create(FString,fmOpenRead); While InFile.Size <> InFile.Position Do Begin Inc(FilePlace); BytesRead := InFile.Read(Buffer^,BufferSize); OutFile.Write(Buffer^,BytesRead); End; InFile.Free; End; Result := True; OutFile.Free; End; { Also Two Sample Calls: SplitFile('C:\afilename.exe',40000); UnSplit('C:\samefilenameasabovewith-rtr-extension.rtr',40000); }

49

Source for Non-Rectangular Windows unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormClick(Sender: TObject); procedure FormCreate(Sender: TObject); private IsRound : Boolean; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormClick(Sender: TObject); var R : HRgn; begin if IsRound then begin SetWindowRgn(Handle,0,True); DeleteObject(R); IsRound := False; end else begin R := CreateEllipticRgn(-15,-15,Width+15,Height+15); SetWindowRgn(Handle,R,True); IsRound := True; end; end; procedure TForm1.FormCreate(Sender: TObject); begin IsRound := False; end; end.

50

The application code

Listing A shows our example application's main unit. We've added some painting code to outline the window in black so it's easier to see. We've also added code that lets you drag the window by clicking anywhere in it. Note that the title bar of the window is still there--it's just invisible. You can still close the application by pressing [Alt][F4]. Listing A: StarRgnU.pas unit StarRgnU; interface uses Windows, Forms, Controls, StdCtrls, Classes, Messages; type TForm1 = class(TForm) CloseBtn: TButton; Label1: TLabel; procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); procedure CloseBtnClick(Sender: TObject); private { Private declarations } procedure WmNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const { An array of points for the star region. } RgnPoints : array[1..10] of TPoint = ((X:203;Y:22), (X:157;Y:168), (X:3;Y:168), (X:128;Y:257), (X:81;Y:402), (X:203;Y:334), (X:325;Y:422), (X:278;Y:257), (X:402;Y:168), (X:249;Y:168)); { An array of points used to draw a line } { around the region in the OnPaint handler. } LinePoints : array[1..11] of TPoint = ((X:199;Y:0), (X:154;Y:146), (X:2;Y:146), (X:127;Y:235), (X:79;Y:377), (X:198;Y:308), (X:320;Y:396), (X:272;Y:234),(X:396;Y:146), (X:244;Y:146), (X:199;Y:0)); procedure TForm1.FormCreate(Sender: TObject); var Rgn : HRGN; begin { Create a polygon region from our points. } Rgn := CreatePolygonRgn( RgnPoints, High(RgnPoints), ALTERNATE); { Set the window region. } SetWindowRgn(Handle, Rgn, True); end;

51

procedure TForm1.FormPaint(Sender: TObject); begin { Draw a line around the star. } Canvas.Pen.Width := 3; Canvas.Polyline(LinePoints); end; procedure TForm1.CloseBtnClick(Sender: TObject); begin Close(); end; { Catch the WM_NCHITTEST message so the user } { can drag the window around the screen. } procedure TForm1. WmNCHitTest(var Msg: TWMNCHitTest); begin DefaultHandler(Msg); if Msg.Result = HTCLIENT then Msg.Result := HTCAPTION; end; end.

52

All I was asking was how to create a irregular window from a region, cause I missed the function that does the trick!!!! I found it... It is the SetWindowRgn function. I can now have a form in any shape... Thank you for replying to my question, and here is the answer: ---Example - Making a form in the shape of a baloon ----{ Put the following code in the event handler of a button in a form. Put the button in the center of the form. When the button is clicked, the form will change shape. See the Win32.Hlp and look into the Region Reference to be able to create any Region for the window } procedure TForm1.Button1Click(Sender: TObject); var Reg1: HRGN; Reg2: HRGN; Reg: HRGN; Apoint: Array[0..2] of TPoint; begin APoint[0] := Point(40,ClientHeight-30); APoint[1] := Point(30,ClientHeight); APoint[2] := Point(20,ClientHeight-20); Reg1 := CreatePolygonRgn(Apoint, 3, WINDING); Reg2 := CreateRoundRectRgn ( Width-ClientWidth, Height-ClientHeight, ClientWidth, ClientHeight 10, 55, 55); Reg := CreateRectRgn(150,50,200,100); CombineRgn(Reg, Reg1, Reg2, RGN_OR); SetWindowRgn (handle, Reg, true); DeleteObject(Reg1); DeleteObject(Reg2); { Do not delete Reg object cause it is now owned by the OS } end; { You can make the form to be dragged when the user clicks inside it by setting the OnMouseDownEvent for it to the following .} procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin If button = mbleft then begin ReleaseCapture; Perform (WM_syscommand, $F012, 0); end; end; { COMMENTS: --------- $F012 is the WParam of the SysCommand message received when the user click in the window caption. Whe can fool it into thinking that the Caption was hit and then begin to drag the Window. The value $F012 is not documented in the Win32 API, so o made the following event handler and discovered it: Declared this function in the private section of Form1: procedure WMSysCommand(var Message: TMessage); message WM_SYSCOMMAND; Implemented it this way: procedure TForm2.WMSysCommand(var Message: TMessage); begin ShowMessage(IntToHex(Message.WParam,4) ); inherited; end; When you Hit the caption of the form if shows a message box with $F012 Why didn't those pretty useful thing aren't documented? } Following is the help for the SetWindowRgn function >>> ---Help for SetWindowRgn ------ SetWindowRgn (WIN32.HLP) [New - Windows NT] The SetWindowRgn function sets the window region of a window. The window region determines the area 53

within the window where the operating system permits drawing. The operating system does not display any portion of a window that lies outside of the window region int SetWindowRgn( HWND hWnd, // handle to window whose window region is to be set HRGN hRgn, // handle to region BOOL bRedraw // window redraw flag ); Parameters hWnd Handle to the window whose window region is to be set. hRgn Handle to a region. The function sets the window region of the window to this region. If hRgn is NULL, the function sets the window region to NULL. bRedraw Boolean value that specifies whether the operating system redraws the window after setting the window region. If bRedraw is TRUE, the operating system does so; otherwise, it does not. Typically, you set bRedraw to TRUE if the window is visible. Return Value If the function succeeds, the return value is non-zero. If the function fails, the return value is zero. Comments If the bRedraw parameter is TRUE, the system sends the WM_WINDOWPOSCHANGING and WM_WINDOWPOSCHANGED messages to the window. The coordinates of a window's window region are relative to the upper-left corner of the window, not the client area of the window. After a successful call to SetWindowRgn, the operating system owns the region specified by the region handle hRgn. The operating system does not make a copy of the region. Thus, you should not make any further function calls with this region handle. In particular, do not close this region handle. To obtain the window region of a window, call the GetWindowRgn function. ---- End of help Sometimes it is cool to make some research by our own, Bye, Felipe Rocha Machado GPS Tecnologia Ltda.

54

Ag ortamindayken, ayni aga giris yapmaya yetkili kullanicilarin (bilgisayarlarin), isimlerini bulup getiren bir bilesene ait unit asagidadir. Kullanilabilmesi icin, sisteme bilesen olarak tanimlanmasi gereklidir. Bunun icin, Components | Install components menüsü kullanilir. unit NetUsers; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TNetUsers = class(TComponent) private { Private declarations } fServer : string; protected { Protected declarations } procedure SetServer(Server : string); public { Public declarations } UserList: TStringList; constructor Create(Owner:TComponent); override; destructor Destroy; override; function Execute : Boolean; published { Published declarations } property Server :string read fServer write SetServer; end; PnetResourceArr = ^TNetResource; procedure register; implementation procedure TNetUsers.SetServer(Server : string); begin if fServer <> Server then fServer := Server; end; constructor TNetUsers.Create(Owner:TComponent); begin inherited Create(Owner); if not ( csDesigning in ComponentState ) then begin UserList := TStringList.Create; UserList.Sorted := True; end; end; destructor TNetUsers.Destroy; begin 55

if not( csDesigning in ComponentState ) then UserList.Destroy; inherited Destroy; end; function TNetUsers.Execute : Boolean; var NetResource: TNetResource; Buf:Pointer; Count, BufSize, Res: DWORD; i : Integer; lphEnum: THandle; p : PnetResourceArr; begin Execute := False; UserList.Clear; GetMem(Buf, 8192); try FillChar(NetResource, SizeOf(NetResource), 0); NetResource.lpRemoteName := PChar(fServer); NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER; NetResource.dwUsage := RESOURCEUSAGE_CONTAINER; NetResource.dwScope := RESOURCETYPE_DISK; Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum); if Res <> 0 then Exit; while true do begin Count := -1; BufSize := 8192; Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); if Res = ERROR_NO_MORE_ITEMS then Exit; if (Res <> 0) then Exit; p := PNetResourceArr(Buf); for i := 0 to Count - 1 do begin { Agdaki kullanici isimlerini Userlist listesine ekle} UserList.Add(p^.lpRemoteName + 2); Inc(p); end; end; Res := WNetCloseEnum(lphEnum); if Res <> 0 then raise Exception(Res); finally FreeMem(Buf); Execute := True; end; end; procedure register; begin RegisterComponents('Sil', [TNetUsers]); end; end. 56

//kullanimi { procedure TForm1.Button1Click(Sender: TObject); begin NETUSERS1.EXECUTE; listbox1.items.assign(netusers1.userlist) end;}

57

Masaüstü görüntüsünün yakalanip, form üzerine aktarilmasi; procedure Tform1.GrabScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; DeskTopRect := Rect(0,0,Screen.Width,Screen.Height); Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect); ReleaseDC(GetDeskTopWindow,DeskTopDC); end; veya; var width, height : word; desktop : HDC; begin width := Screen.Width; height := Screen.Height; desktop := GetWindowDC(GetDesktopWindow); Image1.Picture.Bitmap.Width := width; Image1.Picture.Bitmap.Height := height; BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0, width, height, desktop, 0, 0, SRCCOPY ); end;

58

Yildiz (*****) Sifrelerinin Gösterilmesi

Kapat

//**********************************************************// //** Copyright © 2001 *// //** Bu Programin Tüm Haklari Kemal GÜLOL'a Aittir ... *// //** Programcinin izni olmaksizin bu programin icerigi *// //** degistirilemez ve kullanilamaz ... *// //** *// //** e-mail : [email protected] *// //** Tel : 0312 2807980 cep Tel : 0535 666 6762 Turkey *// //**********************************************************// unit AsterixUnt; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Buttons; var HSonrakiWinMsg : HWND; type TAsterix = class(TForm) OrnekEdit: TEdit; Zamanlayici: TTimer; ShowPanel: TPanel; Ornek: TLabel; BitBtn1: TBitBtn; Bilgi: TLabel; BilgiLabel: TLabel; ShowTime: TTimer; Reklam: TBitBtn; Ticari: TLabel; procedure ZamanlayiciTimer(Sender: TObject); procedure ShowTimeTimer(Sender: TObject); procedure ReklamClick(Sender: TObject); private { Private declarations } public procedure AsterixSifreleriniCoz(); end; var Asterix: TAsterix; implementation uses Reklam; {$R *.DFM} procedure TAsterix.AsterixSifreleriniCoz(); var 59

HFare : HWND; // Mouse isaretleyici isaretleyici : TPOINT; // isaretleyici SifreUzunlugu : integer; // Sifre Uzunlugu Sifre : string; // Sifre begin GetCursorPos(isaretleyici); HFare := WindowFromPoint(isaretleyici); if HFare = HSonrakiWinMsg then Exit; HSonrakiWinMsg := HFare; if SendMessage(HSonrakiWinMsg, EM_GETPASSWORDCHAR, 0, 0) = 0 then Exit; SifreUzunlugu := SendMessage(HFare, WM_GETTEXTLENGTH, 0, 0) + 1; SetLength(Sifre, SifreUzunlugu); SendMessage(HSonrakiWinMsg, WM_GETTEXT, SifreUzunlugu,LongInt(@Sifre[1])); ShowPanel.Caption:='Sifre Uzunlugu = '+IntToStr(SifreUzunlugu-1) +' Buluna Sifre = '+PChar(Sifre); end; procedure TAsterix.ZamanlayiciTimer(Sender: TObject); begin AsterixSifreleriniCoz; end; procedure TAsterix.ShowTimeTimer(Sender: TObject); begin if not (ShowPanel.Caption='') then begin if ShowPanel.Font.Color=ClBlack then ShowPanel.Font.Color:=ClRed else ShowPanel.Font.Color:=ClBlack; end; end; end. // Programlar Bölümünde Tüm Kod ve exe Dahildir.

60

Windows icon ve bitmap'lerini program icinden almak

Kapat

{ Cesitli icon sabitleri: (Daha fazlasi icin Windows unit'ine bakin) - IDI_APPLICATION - IDI_ASTERISK - IDI_EXCLAMATION - IDI_HAND - IDI_QUESTION } //Icons procedure TForm1.Button1Click(Sender: TObject); begin Image1.Picture.Icon.Handle:=LoadIcon(0,IDI_HAND); end; { Bitmap sabitleri: (Daha fazlasi icin Windows unit'ine bakin) - OBM_BTNCORNERS - OBM_BTSIZE - OBM_CHECK - OBM_CHECKBOXES - OBM_CLOSE - OBM_COMBO - OBM_DNARROW - OBM_DNARROWD - OBM_DNARROWI - OBM_LFARROW - OBM_LFARROWD - OBM_LFARROWI - OBM_MNARROW - OBM_REDUCE - OBM_RESTORE - OBM_REDUCED - OBM_SIZE - OBM_UPARROW - OBM_ZOOM } //Bitmap: procedure TForm1.Button2Click(Sender: TObject); begin image1.picture.bitmap.Handle:=LoadBitmap(0,makeintresource(OBM_RESTORE)); end; Gönderen: webmaster

61

Exe dosyasina her hangibir dosya (Txt, mid vb) nasil gomulur ?

Kapat

{ Projenize resource eklemek icin Sirayla takip ediniz. Delphi 4.0 icin: 1. Project|Resources komutu veriniz. 2. Gelen pencerede sag tiklayip New|User Data 3. Resource tipini yaziniz. Ornek: EXE (RcData gelecektir) 3. Hangi dosyayi eklemek istiyorsaniz seciniz 4. Exe_1 olarak Exe tipinde eklenecektir. EXE_1 in üzerinde sag tiklayip Rename dedikten sonra EXE_1'i herhangi bir tamsayi ile adini degistirin. Ör: 1 (EXE_1 -> 1) } procedure SaveRessourceToFile(const FileName, ResType: string; ResId: Integer); var MStream: TResourceStream; begin Mstream := TResourceStream.CreateFromID(HInstance, ResId, PChar(ResType)); try Mstream.SaveToFile(FileName); finally Mstream.Free; end; end; // Kullanimi: (Yukardaki islemden sonra SaveRessourceToFile('c:\deneme.exe', 'EXE', 1);

62

Istenilen font'u programinizda windows'a install etmeden kullanmak

Kapat

{ Programinizla beraber kullandiginiz font dosyasini kuracaginiz bilgisayara kopyalamaniz gereklidir. (C:\programim\fuente.ttf gibi) } procedure TForm1.FormCreate(Sender: TObject); begin AddFontResource('c:\programim\FUENTE.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin RemoveFontResource('c:\programim\FUENTE.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end;

63

Harici bir ortamdan basilan tusu anlamak Keyboard Hook {*************************************************************} { TKeySpy Component for Delphi 16/32 } { Version: 2.8 } { E-Mail: [email protected] } { Home page: www.utilmind.com } { Created: August, 16, 1998 } { Modified: June, 6, 2000 } { Legal: Copyright (c) 1998-2000, UtilMind Solutions } {*************************************************************} { KEYBOARD SPY: } { This component is intended for interception of pressing the } { keyboard. The KeySpy is possible to apply for interception } { of the typed text of the another's programs, as keyboard } { spy, or for processing events at type certain keywords etc..} {*************************************************************} { Properties: ************************************************} { Enabled: as it usual... } { Keyword: At a set of this word event will be } { carried out (See OnKeyword event). } { ActiveLayout: Active keyboard layout (string) Win32 only } { SpyLayout: now present English, Russian, German } { & Italian } {ActiveWindowTitle: Title of active window (Read only) } { Events: ************************************************} { OnKeySpyDown: as OnKeyDown, but in any place (window). } { OnKeySpyUp: as OnKeyUp, but in any place (window). } { OnKeyword: The Keyword has been typed (See Keyword). } { OnLayoutChanged: The Keyboard layout was changed. Win32 only} { OnActiveWindowChanged: } {*************************************************************} { IMPORTANT NOTE: } { This code may be used and modified by anyone so long as } { this header and copyright information remains intact. By } { using this code you agree to indemnify UtilMind Solutions } { from any liability that might arise from its use. You must } { obtain written consent before selling or redistributing } { this code. } {*************************************************************} { Changes: } { 20.I.1999: Added 32-bit support } { 14.V.1999: Added OnChangeLayout event. } { Added Italian and Russian keyboard layouts. } { 28.V.1999: Added ActiveWindowTitle property. } { 27.VII.1999: Added Portugese keyboard layout. } { Thanks to Tiago Correia ([email protected])} { 19.IX.1999: Added German keyboard layout (added by Slaine, } { [email protected]) } { 5.V.2000: Added French keyboard layout (added by Vincent } { CALLIES, [email protected]) } {*************************************************************} unit KeySpy;

Kapat

interface 64

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs,{$ENDIF} SysUtils, Controls, Classes, Messages, Forms; type TSpyLayout = (klAmerican, klItalian, klRussian, klPortuguese, klGerman, klFrench); TOnKeySpy = procedure(Sender: Tobject; Key: Byte; KeyStr: string) of object; {$IFDEF Win32} TOnLayoutChanged = procedure(Sender: TObject; Layout: string) of object; {$ENDIF} TOnActiveWindowChanged = procedure(Sender: TObject; ActiveTitle: string) of object; TKeySpy = class(TComponent) private {$IFDEF Win32} CurrentLayout: string; FActiveLayout: string; {$ENDIF} CurrentActiveWindowTitle: string; FActiveWindowTitle: string; FSpyLayout: TSpyLayout; FWindowHandle: HWnd; FOnKeySpyDown, FOnKeySpyUp: TOnKeySpy; FOnKeyword: TNotifyEvent; {$IFDEF Win32} FOnLayoutChanged: TOnLayoutChanged; {$ENDIF} FOnActiveWindowChanged: TOnActiveWindowChanged; FEnabled: Boolean; FKeyword, KeyComp: string; OldKey: Byte; LShiftUp, RShiftUp: Boolean; procedure UpdateTimer; procedure SetEnabled(Value: Boolean); procedure SetKeyword(Value: string); procedure WndProc(var Msg: TMessage); procedure SetNothingStr(Value: string); protected procedure KeySpy; dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ActiveWindowTitle: string read FActiveWindowTitle write SetNothingStr; property Enabled: Boolean read FEnabled write SetEnabled; property Keyword: string read FKeyword write SetKeyword; property SpyLayout: TSpyLayout read FSpyLayout write FSpyLayout; {$IFDEF Win32} property ActiveLayout: string read FActiveLayout write FActiveLayout; {$ENDIF} property OnKeySpyDown: TOnKeySpy read FOnKeySpyDown write FOnKeySpyDown; property OnKeySpyUp: TOnKeySpy read FOnKeySpyUp write FOnKeySpyUp; property OnKeyword: TNotifyEvent read FOnKeyword write FOnKeyword; 65

{$IFDEF Win32} property OnLayoutChanged: TOnLayoutChanged read FOnLayoutChanged write FOnLayoutChanged; {$ENDIF} property OnActiveTitleChanged: TonActiveWindowChanged read FOnActiveWindowChanged write FOnActiveWindowChanged; end; procedure register; implementation {$I KLayouts.inc} constructor TKeySpy.Create(AOwner: Tcomponent); begin inherited Create(AOwner); LShiftUp := True; RShiftUp := True; FEnabled := True; FWindowHandle := AllocateHWnd(WndProc); if FEnabled then UpdateTimer; end; destructor TKeySpy.Destroy; begin FEnabled := False; UpdateTimer; DeallocateHWnd(FWindowHandle); inherited Destroy; end; procedure TKeySpy.WndProc(var Msg: TMessage); begin with Msg do if Msg = WM_TIMER then try KeySpy; except Application.HandleException(Self); end else Result := DefWindowProc(FwindowHandle, Msg, wParam, lParam); end; procedure TKeySpy.UpdateTimer; var b: Byte; begin KillTimer(FWindowHandle, 1); if FEnabled then begin asm mov al, 60h mov b, al 66

end; OldKey := b; if SetTimer(FWindowHandle, 1, 1, nil) = 0 then raise EOutOfResources.Create('No timers'); end; end; procedure TKeySpy.SetEnabled(Value: Boolean); begin if Value <> FEnabled then begin FEnabled := Value; UpdateTimer; end; end; procedure TKeySpy.SetKeyword(Value: string); begin Value := LowerCase(Value); if Value <> FKeyword then FKeyword := Value; end; procedure TKeySpy.KeySpy; var PC: array[0..$FFF] of Char; Key: Byte; St: string; Wnd: hWnd; begin {$IFDEF Win32} Wnd := GetForegroundWindow; {$ELSE} Wnd := GetActiveWindow; {$ENDIF} SendMessage(Wnd, wm_GetText, $FFF, LongInt(@PC)); FActiveWindowTitle := StrPas(PC); if CurrentActiveWindowTitle <> FActiveWindowTitle then begin CurrentActiveWindowTitle := FActiveWindowTitle; if Assigned(FOnActiveWindowChanged) then FOnActiveWindowChanged(Self, FactiveWindowTitle); end; {$IFDEF Win32} GetKeyboardLayoutName(PC); FActiveLayout := StrPas(PC); if (FActiveLayout <> CurrentLayout) then begin CurrentLayout := FActiveLayout; if Assigned(FOnLayoutChanged) then FOnLayoutChanged(Self, FActiveLayout); end; {$ENDIF} 67

asm in al, 60h mov Key, al end; if Key = 170 then begin Key := 84; LShiftUp := True; end; if Key = 182 then begin Key := 85; RShiftUp := True; end; if Key = 42 then LShiftUp := False; if Key = 54 then RShiftUp := False; if Key <> OldKey then begin OldKey := Key; if Key <= 88 then begin case FSpyLayout of klAmerican: if LShiftUp and RShiftUp then St := StrPas(LowButtonName[Key]) else St := StrPas(HiButtonName[Key]); klItalian: if LShiftUp and RShiftUp then St := StrPas(ItalianLowButtonName[Key]) else St := StrPas(ItalianHiButtonName[Key]); klRussian: if LShiftUp and RShiftUp then St := StrPas(RussianLowButtonName[Key]) else St := StrPas(RussianHiButtonName[Key]); klPortuguese: if LShiftUp and RShiftUp then St := StrPas(PortugueseLowButtonName[Key]) else St := StrPas(PortugueseHiButtonName[Key]); klGerman: if LShiftUp and RShiftUp then St := StrPas(GermanLowButtonName[Key]) else St := StrPas(GermanHiButtonName[Key]); klFrench: if LShiftUp and RShiftUp then St := StrPas(FrenchLowButtonName[Key]) else St := StrPas(FrenchHiButtonName[Key]); end; if Assigned(FOnKeySpyDown) then FOnKeySpyDown(Self, Key, St); if Assigned(FOnKeyword) then begin KeyComp := KeyComp + St; if Length(KeyComp) > Length(FKeyword) then begin 68

Move(KeyComp[Length(St) + 1], KeyComp[1], Length(KeyComp)); {$IFDEF WIN32} SetLength(KeyComp, Length(FKeyword)); {$ELSE} KeyComp[0] := char(Length(FKeyword)); {$ENDIF} end; if LowerCase(KeyComp) = FKeyword then FOnKeyword(Self); end; end else if Key - 128 <= 88 then begin case FSpyLayout of klAmerican: if LShiftUp and RShiftUp then St := StrPas(LowButtonName[Key - 128]) else St := StrPas(HiButtonName[Key - 128]); klItalian: if LShiftUp and RShiftUp then St := StrPas(ItalianLowButtonName[Key - 128]) else St := StrPas(ItalianHiButtonName[Key - 128]); klRussian: if LShiftUp and RShiftUp then St := StrPas(RussianLowButtonName[Key - 128]) else St := StrPas(RussianHiButtonName[Key - 128]); klPortuguese: if LShiftUp and RShiftUp then St := StrPas(PortugueseLowButtonName[Key - 128]) else St := StrPas(PortugueseHiButtonName[Key - 128]); klGerman: if LShiftUp and RShiftUp then St := StrPas(GermanLowButtonName[Key - 128]) else St := StrPas(GermanHiButtonName[Key - 128]); klFrench: if LShiftUp and RShiftUp then St := StrPas(FrenchLowButtonName[Key - 128]) else St := StrPas(FrenchHiButtonName[Key - 128]); end; if Assigned(FOnKeySpyUp) then FOnKeySpyUp(Self, Key, St) end; end; end; procedure TKeySpy.SetNothingStr(Value: string); begin {} end; procedure register; begin RegisterComponents('UtilMind', [TkeySpy]); end; end. 69

Calisma Esnasinda Program Icerisinden Bilesen Yaratma... var Label1: TLabel ; ComboBox1:TComboBox; SpinEdit1:TSpinEdit; DateTimePicker1:TDateTimePicker; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin //Label1 Bileseni Olusturuldu Label1 := TLabel.Create(self) ; with Label1 do begin Parent:=Self; Left := 5; Top := 70; Width := 70; Height := 13; Alignment := taRightJustify; AutoSize := False; Caption := 'Listeler:'; end; //ComboBox1 Bileseni Olusturuldu ComboBox1:=TComboBox.Create(self); with ComboBox1 do begin Parent:=Self; Left := 85; Top := 65; Width := 145; Height := 21; ItemHeight := 13; TabOrder := 3; Text := 'Liste1'; Items.Clear; Items.Add('Liste1'); Items.Add('Liste2'); Items.Add('Liste3');; end; //DateTimePicker1 Bileseni Olusturuldu DateTimePicker1:=TDateTimePicker.Create(self); with DateTimePicker1 do begin Parent:=Self; Left := 85; Top := 90; Width := 146; Height := 21; CalAlignment := dtaLeft; Date := 36964.028340625; Time := 36964.028340625; DateFormat := dfShort; DateMode := dmComboBox; Kind := dtkDate; ParseInput := False; TabOrder := 4; end;

Kapat

70

end; end;

71

Bir DOS komutunun kullanilmasi

Kapat

Windows 95 ortamindayken, bir DOS komutunun calistirilmasi icin gereken yordam sudur. procedure doskomutu(komut:string;mesajver:boolean); var Startupinfo:TStartupinfo; ProcessInfo:TProcessInformation; begin if terminateprocess(processinfo.hProcess,0)=NULL then begin if mesajver then showmessage('Devam eden islem iptal edilemedi'); exit; end; FillChar(StartupInfo,Sizeof(StartupInfo),#0); StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.wShowWindow := SW_HIDE; StartupInfo.dwFlags:=STARTF_USESHOWWINDOW; if not CreateProcess(nil, Pchar('c:\command.com /c '+komut), nil, nil, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then begin if mesajver then ShowMessage('Islem gerceklestirilemedi') end else begin if mesajver then ShowMessage('Islem tamam') end; end; Bu yordamin kullanimi; procedure TForm1.Button1Click(Sender: TObject); begin doskomutu('copy c:\autoexec.bat a:\autoexec.dat',false); end;

72

Cep Telefonlari icin Genel AT Komutlari

Kapat

Cep Telefonuna Gönderilen AT Komutlari AT+CBC // Batarya Durumu AT+CGMI // Üretici Firma AT+CGMM // Telefonun Modeli AT+CGSN // Telefonun Seri numarasi AT+CPBF // Rehberden Buldurma AT+CPBR // Tüm Adres Defterinin okutulmasi AT+CPBS // SIM yada Telefonun hafizasinin secilmesi ATD0535XXXXXXX; // Telefon numarasi cevirme AT*EKEB="123456" // TUSLAMA AT*EICO=X,Y // X:ICON Y:ON(1)-OFF(0) Mesaj veya diger iconlari degistirme AT*ESOM=1,"aAffFgaAgfEpgGefgeafDC" // Melodi Yazdirma AT*ETXT=1,"SELAM" // KARSILAMA MESAJI AT+COPS? // OPERATORU BELIRTIYOR TURKCELL VEYA TELSIM MI ? AT+CKPD="C",20 // EKRANI TEMIZLE AT+CKPD="<",1 // SOL MENUYE GEC AT+CKPD=">",20 // SAG MENUYE GEC AT*EMMI=1,1,1 //!! oRTADAKI KLAVYE ENABLE 1 DISABLE 0 ENSONDAKI EKRAN ISIGI 1-0 AT+CPBW // Rehbere Telefon numarasi Ekleme AT+CSQ // Telefonun Sinyal degerinin ölcülmesi AT+CSMS // Mesaj Servisini Belirle AT+CMGF // Mesajin Formatini belirle AT+CSCA // Mesaj Merkezi AT+CSMP // Text modu telefonun AT+CSDH // Text Modun paremetrelerini göster AT+CSCB // Telefondaki Mesaj Ayarini sec AT+CSAS // Ayarlari Kaydet AT+CRES // Ayarlari düzenle AT+CNMI // TE de yeni mesaj indikatörü ac AT+CMGL // Mesajlari Listele AT+CMGR // Mesaj Oku AT+CMGS // Mesaj Gönder AT+CMSS // Hafizadaki Mesaji Gönder AT+CMGW // Hafizaya Mesaj Yaz AT+CMGD // Mesaj Sil AT+CMGL // Mesajlari Listele AT+CMGR // Mesajlari Oku AT+CMGS // Mesaj Gönder AT+CMGW // Hafizaya Mesaj Yaz not : Mesajlari her islemden Sonra konulacak Win98 isletim sistemlerinda DADCom98 cekilmesi gerkiyor Mesajlariniz icin [email protected] adresine bildiriniz iyi calismalar ...

73

Bir resmin seffaf olarak baska bir resim üzerine yapistirilmasi

Kapat

Unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Image1: TImage; ColorDialog1: TColorDialog; Panel1: TPanel; Button2: TButton; Image2: TImage; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor); end; var Form1: TForm1; bmp:tbitmap; clr:tcolor; implementation {$R *.DFM} procedure tform1.DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor); var bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap; oldcol: Longint; begin try bmpAND := TBitmap.Create; bmpAND.Width := s.Width; bmpAND.Height := s.Height; bmpAND.Monochrome := True; oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol)); BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); 74

SetBkColor(s.Canvas.Handle, oldcol); bmpINVAND := TBitmap.Create; bmpINVAND.Width := s.Width; bmpINVAND.Height := s.Height; bmpINVAND.Monochrome := True; BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY); bmpXOR := TBitmap.Create; bmpXOR.Width := s.Width; bmpXOR.Height := s.Height; BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND); bmpTarget := TBitmap.Create; bmpTarget.Width := s.Width; bmpTarget.Height := s.Height; BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpXOR.Canvas.Handle, 0,0, SRCINVERT); BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY); finally bmpXOR.Free; bmpAND.Free; bmpINVAND.Free; bmpTarget.Free; end;{End of TRY section} end; procedure TForm1.Button1Click(Sender: TObject); begin DrawTransparent(image1.Canvas, 1,1, bmp, clr); image1.Invalidate; image1.repaint; end; procedure TForm1.FormCreate(Sender: TObject); begin bmp:=tbitmap.create; bmp.width:=image1.width; bmp.height:=image1.height; bmp.assign(image2.picture); // clr:=tcolor.create;; clr:=clgreen; panel1.color:=clr; end; procedure TForm1.FormDestroy(Sender: TObject); begin bmp.free; 75

end; procedure TForm1.Button2Click(Sender: TObject); begin if colordialog1.execute then clr:=colordialog1.Color; panel1.color:=clr; end; end. Unit1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 617 Height = 302 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Image1: TImage Left = 264 Top = 8 Width = 329 Height = 201 Stretch = True end object Image2: TImage Left = 8 Top = 8 Width = 249 Height = 201 Stretch = True end object Button1: TButton Left = 144 Top = 224 Width = 75 Height = 25 Caption = 'Button1' TabOrder = 0 OnClick = Button1Click end object Panel1: TPanel Left = 304 Top = 216 Width = 113 Height = 41 Caption = 'Panel1' 76

TabOrder = 1 object Button2: TButton Left = 22 Top = 8 Width = 75 Height = 25 Caption = 'Button2' TabOrder = 0 OnClick = Button2Click end end object ColorDialog1: TColorDialog Ctl3D = True Left = 112 Top = 352 end end

77

{ "My application is minimized in the Tray and I want to know how can a short-cut key, for example Alt-Shift-F9, bring my application on the front of the screen?" } //In the main forms //OnClose event remove the handler: UnRegisterHotkey( Handle, 1 ); //Add a handler for the //WM_HOTKEY message to the form: private // form declaration Procedure WMHotkey( Var msg: TWMHotkey ); message WM_HOTKEY; Procedure TForm1.WMHotkey( Var msg: TWMHotkey ); Begin If msg.hotkey = 1 Then Begin If IsIconic( Application.Handle ) Then Application.Restore; BringToFront; End; End;

78

{ Here's a function that will check if a given string exist in a string list. You can use it when you want to add only the unique strings to any object with a string list property such as list boxes, memos, etc. } function StrIsInList( sl : TStrings; s : string; bCaseSensitive : boolean ) : boolean; var n : integer; begin Result := False; if (not bCaseSensitive) then s := LowerCase(s); for n := 0 to (sl.Count - 1) do begin if((bCaseSensitive and (s = LowerCase( sl.Strings[n]))) or (s = sl.Strings[n])) then begin Result := True; Exit; end; end; end; { Usage: } procedure TForm1.Button1Click(Sender: TObject); begin if (not StrIsInList(ListBox1.Items, Edit1.Text, False)) then ListBox1.Items.Add(Edit1.Text); end;

79

Here's a little unit placing an application as an icon in the Tray to the left of the clock in the task bar. The program also remover itself from the taskbar and doesn't appear there even when the main form is visible. unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, ShellAPI, Menus; const WM_MINIMALIZE = WM_USER + 1; // our own message type TForm1 = class(TForm) PopupMenu1: TPopupMenu; Show1: TMenuItem; Hide1: TMenuItem; Quit1: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Show1Click(Sender: TObject); procedure Hide1Click(Sender: TObject); procedure Quit1Click(Sender: TObject); private FIconData : TNotifyIconData; public // a proceudre reacting to our own message: procedure WMMinimalize(var Message : TMessage); message WM_MINIMALIZE; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var i : Integer; begin with FIconData do begin cbSize := SizeOf(FIconData); Wnd := Self.Handle; uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; hIcon := Application.Icon.Handle; uCallbackMessage := WM_MINIMALIZE; // ties our message to the icon szTip := 'My own application'; // "tip" end; Shell_NotifyIcon(NIM_ADD, @FIconData); end; procedure TForm1.FormDestroy(Sender: TObject); begin 80

Shell_NotifyIcon(NIM_DELETE, @FIconData); end; procedure TForm1.WMMinimalize(var Message : TMessage); var p : TPoint; begin case Message.LParam of WM_RBUTTONUP: begin GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); end; // here, you can react to other standard // messages, for example WM_LBUTTONDBLCLK end; end; procedure TForm1.Show1Click(Sender: TObject); begin Form1.Visible := TRUE; // this takes the program away from the Task Bar: ShowWindow(Application.Handle, SW_HIDE); end; procedure TForm1.Hide1Click(Sender: TObject); begin Self.Visible := FALSE; end; procedure TForm1.Quit1Click(Sender: TObject); begin Application.Terminate; end; end. And one more thing. To make the form desapear directly after start, add the following to your *.dpr file: Application.ShowMainForm := FALSE;

81

{ One of those things that Delphi does not have is a sleep function, where a program will wait a number of seconds before proceding on to its next task. In the meantime, it will allow Windows background operations to process. The Turbo Pascal equivalent to this is delay, but unfortunately, I haven't been able to find any documentation on it, so I don't know if it is still available. It should be, but to be safe, I came up with a new function, called Sleep. The procedure makes use of a Windows API function called GetTickCount, which returns the number of milliseconds that have elapsed since Windows has started. The WinAPI documentation states that after 49 days of continuous use, the tick count recycles back to zero, so if your machine runs on a continuous basis with Windows, you may consider this. } procedure GoSleep(SleepSecs : Integer); var StartValue : LongInt; begin StartValue := GetTickCount; While ((GetTickCount - StartValue) <= (SleepSecs * 1000)) do Application.ProcessMessages; end; {Usage:} Sleep(10);

21/2001. List Devices (LPT, COM ports, ...) { The following procedure will list all the devices on your computer. You can then extract the com ports and printer ports by looking for the 'COM' and 'LPT' characters in the list. Add a Memo and a Button and place this code in the OnClick of a button... } procedure TForm1.Button1Click(Sender: TObject); var istr: string; isize, i: dword; begin setlength(istr, 4000); isize := QueryDosDevice(nil, @istr[1], 4000); for i := 1 to isize do if istr[i] = #0 then istr[i] := #10; memo1.lines.CommaText := istr; end;

20/2001. Get system info (free memory, etc) { Put a TMemo (Memo1) and a TButton (Button1) in your form. Put this code into OnClick of Button1: } procedure TForm1.Button1Click(Sender: TObject);

82

var MemoryStatus: TMemoryStatus; begin Memo1.Lines.Clear; MemoryStatus.dwLength := SizeOf(MemoryStatus); GlobalMemoryStatus(MemoryStatus); with MemoryStatus do begin Memo1.Lines.Add(IntToStr(dwLength) + ' Size of ''MemoryStatus'' record'); Memo1.Lines.Add(IntToStr(dwMemoryLoad) + '% memory in use'); Memo1.Lines.Add(IntToStr(dwTotalPhys) + ' Total Physical Memory in bytes'); Memo1.Lines.Add(IntToStr(dwAvailPhys) + ' Available Physical Memory in bytes'); Memo1.Lines.Add(IntToStr(dwTotalPageFile) + ' Total Bytes of Paging File'); Memo1.Lines.Add(IntToStr(dwAvailPageFile) + ' Available bytes in paging file'); Memo1.Lines.Add(IntToStr(dwTotalVirtual) + ' User Bytes of Address space'); Memo1.Lines.Add(IntToStr(dwAvailVirtual) + ' Available User bytes of address space'); end; end;

19/2001. Get Cursor Image (draw in on a Canvas) { The DrawCursor procedure draws a current cursor image on ACanvas at the Position point. } procedure DrawCursor (ACanvas:TCanvas; Position:TPoint); var HCursor : THandle; begin HCursor := Screen.Cursors [Ord(Screen.Cursor)]; DrawIconEx(ACanvas.Handle, Position.X, Position.Y, HCursor, 32, 32, 0, 0, DI_NORMAL); end; { Usage (top-left on a form1): DrawCursor(form1.Canvas,Point(0,0)); }

18/2001. Activate/Deactivate the Screen Saver { Sometimes you want to deactivate the current screensaver when performing some very long process. You can use this function to activate or deactivate the screensaver. Pass True to activate it, or False to deactivate it. } function ActivateScreenSaver (Activate: boolean): boolean; var IntActive: byte; begin if Activate then IntActive := 1 else IntActive := 0; Result := SystemParametersInfo

83

(SPI_SETSCREENSAVEACTIVE, IntActive, nil, 0); end;

17/2001. List All Network Drives { To show a list of all mapped network drives, use the GetNetworkDriveMappings() function. Example usage: GetNetworkDriveMappings(Memo1.Lines); } function GetNetworkDriveMappings (SList: TStrings): integer; var i: Char; ThePath: string; MaxNetPathLen: DWord; begin SList.Clear; MaxNetPathLen := MAX_PATH; SetLength(ThePath, MAX_PATH); for i := 'A' to 'Z' do if WNetGetConnection(PChar('' + i + ':'), PChar(ThePath), MaxNetPathLen) = NO_ERROR then SList.Add(i + ': ' + ThePath); Result := SList.Count; end;

16/2001. Get IE favorites { The GetIEFavourites function called from the OnClick event of a button returns a list of all the favorites from your Internet Explorer in a ListBox. } function GetIEFavourites (const favpath: string):TStrings; var searchrec:TSearchrec; str:TStrings; path,dir,filename:String; Buffer: array[0..2047] of Char; found:Integer; begin str:=TStringList.Create; try path:=FavPath+'\*.url'; dir:=ExtractFilepath(path); found:=FindFirst(path,faAnyFile,searchrec); while found=0 do begin SetString(filename, Buffer, GetPrivateProfileString('InternetShortcut', PChar('URL'), NIL, Buffer, SizeOf(Buffer), PChar(dir+searchrec.Name))); str.Add(filename); found:=FindNext(searchrec); end; found:=FindFirst(dir+'\*.*',faAnyFile,searchrec); while found=0 do begin if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1]<>'.') then str.AddStrings(GetIEFavourites

84

(dir+'\'+searchrec.name)); found:=FindNext(searchrec); end; FindClose(searchrec); finally Result:=str; end; end; procedure TForm1.Button1Click(Sender: TObject); var pidl: PItemIDList; FavPath: array[0..MAX_PATH] of char; begin SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl); SHGetPathFromIDList(pidl, favpath); ListBox1.Items:=GetIEFavourites(StrPas(FavPath)); end;

15/2001. Change glyphs of TBDNavigator Buttons { Form1 has DBNavigator1. In the OnCreate event for the form the custom bitmap ('GoFirst') for the First button is loaded from the resource. } procedure TForm1.FormCreate(Sender: TObject); var i : Integer; tempGlyph : tBitmap; begin tempGlyph :=TBitmap.Create; try tempGlyph.LoadFromResourceName (HInstance,'GoFirst'); with DBNavigator1 do begin for i := 0 to ControlCount - 1 do if Controls[c] is TNavigateBtn then with TNavigateBtn(Controls[c]) do begin case Index of nbFirst: Glyph := tempGlyph; end; end; end; finally tempGlyph.Free; end; end;

14/2001. Height/Width of a Character { When using OwnerDrawing or Printing it is good to know the (max) Height and Width of character for a given Canvas - in pixels. The SomeComponents represents a component with a Canvas (the one derived from TWinControl) } SomeSomponent.Canvas.TextWidth('H'); SomeSomponent.Canvas.TextHeight('I');

13/2001. Paint the Form with a Tiled Bitmap type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); procedure FormClose(Sender: TObject;

85

var Action: TCloseAction); private public end; var Form1: TForm1; Bitmap: TBitmap; ... procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP'); end; procedure TForm1.FormClose (Sender: TObject; var Action: TCloseAction); begin Bitmap.Free; end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end; end;

12/2001. Convert a BMP to a JPG { Usage: BMPtoJPG('mybitmap.bmp','myjpeg.jpg') } function BMPtoJPG (var BMPpic, JPGpic: string):boolean; var Bitmap: TBitmap; JpegImg: TJpegImage; begin Result:=False; Bitmap := TBitmap.Create; try Bitmap.LoadFromFile(BMPpic); JpegImg := TJpegImage.Create; try JpegImg.Assign(Bitmap); JpegImg.SaveToFile(JPGpic); Result:=True; finally JpegImg.Free

86

end; finally Bitmap.Free end; end;

11/2001. Save Text From Clipboard to a File { Usage: ClipboardTxtToFile(c:\dir\cliptext.txt) } uses Clipbrd; function ClipboardTxtToFile (sFileTXT : string) : boolean; var ps1, ps2 : PChar; dwLen : DWord; tf : TextFile; hData : THandle; begin Result := False; with Clipboard do begin try Open; if(HasFormat(CF_TEXT)) then begin hData := GetClipboardData(CF_TEXT); ps1 := GlobalLock(hData); dwLen := GlobalSize(hData); ps2 := StrAlloc(1 + dwLen); StrLCopy( ps2, ps1, dwLen ); GlobalUnlock( hData ); AssignFile(tf, sFileTXT); ReWrite(tf); Write(tf, ps2); CloseFile(tf); StrDispose( ps2 ); Result := True; end; finally Close; end; end; end;

10/2001. TColor to Hex & Hex to TColor function TColorToHex(Color : TColor) : string; begin Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2); end; function HexToTColor(sColor : string) : TColor; begin Result := RGB( StrToInt('$'+Copy(sColor, 1, 2)), StrToInt('$'+Copy(sColor, 3, 2)), StrToInt('$'+Copy(sColor, 5, 2)) ); end;

87

. 09/2001. Capture the Output From a DOS Window { The example runs 'chkdsk.exe c:\' and displays the output to Memo1 Put a TMemo (Memo1) and a TButton (Button1) in your form Put this code in the OnCLick of Button1: } procedure TForm1.Button1Click(Sender: TObject); procedure RunDosInMemo(DosApp:String;AMemo:TMemo); const ReadBuffer = 2400; var Security : TSecurityAttributes; ReadPipe,WritePipe : THandle; start : TStartUpInfo; ProcessInfo : TProcessInformation; Buffer : Pchar; BytesRead : DWord; Apprunning : DWord; begin With Security do begin nlength := SizeOf(TSecurityAttributes); binherithandle := true; lpsecuritydescriptor := nil; end; if Createpipe (ReadPipe, WritePipe, @Security, 0) then begin Buffer := AllocMem(ReadBuffer + 1); FillChar(Start,Sizeof(Start),#0); start.cb := SizeOf(start); start.hStdOutput := WritePipe; start.hStdInput := ReadPipe; start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW; start.wShowWindow := SW_HIDE; if CreateProcess(nil, PChar(DosApp), @Security, @Security, true, NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo) then begin repeat Apprunning := WaitForSingleObject (ProcessInfo.hProcess,100); Application.ProcessMessages; until (Apprunning <> WAIT_TIMEOUT); Repeat BytesRead := 0; ReadFile(ReadPipe,Buffer[0], ReadBuffer,BytesRead,nil); Buffer[BytesRead]:= #0; OemToAnsi(Buffer,Buffer); AMemo.Text := AMemo.text + String(Buffer); until (BytesRead < ReadBuffer); end;

88

FreeMem(Buffer); CloseHandle(ProcessInfo.hProcess); CloseHandle(ProcessInfo.hThread); CloseHandle(ReadPipe); CloseHandle(WritePipe); end; end; begin {button 1 code} RunDosInMemo('chkdsk.exe c:\',Memo1); end;

04/2001. Exit From Windows //reboot windows ExitWindowsEx(EWX_REBOOT,0); //shut down windows ExitWindowsEx(EWX_SHUTDOWN,0); // log off and prompt for login ExitWindowsEx(EWX_LOGOFF,0);

08/2000. Copying Group of Files - Standard Animation Dialog. { The following example demonstrates using the SHFileOperation function to copy a group of files and display a progress dialog. You can also use the following flags to delete, move and rename a group of files. FO_COPY FO_DELETE FO_MOVE FO_RENAME Note: The buffer that contains the file names to copy must end with a double null terminating character The following example copies three files to 'e' drive. } uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); var Fos : TSHFileOpStruct; Buf : array[0..4096] of char; p : pchar; sDest : string; begin FillChar(Buf, sizeof(Buf), #0); p := @buf; p := StrECopy(p, 'C:\FirstFile.ext1') + 1; p := StrECopy(p, 'C:\SecondFile.ext2') + 1; StrECopy(p, 'C:\ThirdFile.ext3'); sDest := 'e:\'; FillChar(Fos, sizeof(Fos), #0); with Fos do begin Wnd := Handle; wFunc := FO_COPY; pFrom := @Buf; pTo := sDest; fFlags := 0; end; if ((SHFileOperation(Fos) <> 0) or

89

(Fos.fAnyOperationsAborted <> false)) then ShowMessage('Cancelled') end;

07/2001. Long ListBox entries as Hints { Sometimes the data you want to display in a list is too long for the size of ListBox you can use. When this happens, you can use the simple code to display the ListBox entries as Hints when the mouse passes over the ListBox. Just make sure that ShowHints is True. } procedure TForm1.ListBox1MouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer); var lstIndex : Integer ; begin with ListBox1 do begin lstIndex:=SendMessage(Handle, LB_ITEMFROMPOINT, 0, MakeLParam(x,y)); if (lstIndex >= 0) and (lstIndex <= Items.Count) Then Hint := Items[lstIndex] else Hint := '' end; end; end.

06/2001. Add a Check Box to a Standard Dialog Box { For example, we have some dialog for confirmation and the user can check a checkbox ("Don't show this message again") - program can store this in a global variable and the next time this dialog will not show.

The idea of realization in the next: 1. we must create a dialog using CreateMessageDialog 2. this function will return a form object with dialog 3. in this object we can add a checkbox 4. show diallog using ShowModal 5. check a result and process a state of our checkbox 6. destroy a created checkbox and dialog object } procedure TForm1.Button1Click(Sender: TObject); var AMsgDialog: TForm; ACheckBox: TCheckBox; begin AMsgDialog := CreateMessageDialog ('This is a test message.', mtWarning, [mbYes, mbNo]); ACheckBox := TCheckBox.Create(AMsgDialog); with AMsgDialog do try Caption := 'Dialog Title' ; Height := 169; with ACheckBox do begin Parent := AMsgDialog; Caption := 'Don''t show me again.';

90

Top := 121; Left := 8; end; if (ShowModal = ID_YES) then begin if ACheckBox.Checked then begin //... do if checked end; //... do if NOT checked end; finally ACheckBox.Free; Free; end; end;

. 05/2001. Get Memory Status { To retrieve the current memory status, use the GlobalMemoryStatus() function: } var Status : TMemoryStatus; begin Status.dwLength := sizeof( TMemoryStatus ); GlobalMemoryStatus( Status ); ... { The TMemoryStatus contains several fields indicating the status of the memory: .dwMemoryLoad: Total memory used in percentage (%). .dwTotalPhys: Total physical memory in bytes. .dwAvailPhys: Physical memory left in bytes. .dwTotalPageFile: Total page file in bytes. .dwAvailPageFile:Page file left in bytes. .dwTotalVirtual: Total virtual memory in bytes. .dwAvailVirtual: Virtual memory left in bytes. Before presenting the memory values, convert them into giga, mega or kilobytes. }

04/2001. Exit From Windows //reboot windows ExitWindowsEx(EWX_REBOOT,0); //shut down windows ExitWindowsEx(EWX_SHUTDOWN,0); // log off and prompt for login ExitWindowsEx(EWX_LOGOFF,0);

03/2000. Empty Recycle Bin

{Put a Button on Form1 and replace Unit1 code with:} unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, ShellApi,Controls, Forms, Dialogs,StdCtrls, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject);

91

end; var Form1: TForm1; function SHEmptyRecycleBin (Wnd:HWnd; LPCTSTR:PChar; DWORD:Word):Integer; stdcall; const SHERB_NOCONFIRMATION = $00000001; SHERB_NOPROGRESSUI = $00000002; SHERB_NOSOUND = $00000004; implementation {$R *.DFM} function SHEmptyRecycleBin; external 'SHELL32.DLL' name 'SHEmptyRecycleBinA'; procedure TForm1.Button1Click(Sender: TObject); begin SHEmptyRecycleBin(self.handle,'', SHERB_NOCONFIRMATION); end; end.

02/2001. Secret Command-Line Switches { The Delphi IDE supports a number of command-line switches. Here are some of the undocumented: ns Delphi 2 and later. No splash screen. This suppresses display of the splash screen during IDE startup. hm Delphi 2 and later. Heap Monitor. Displays information in the IDE title bar regarding the amount of memory allocated using the memory manager. Displays the number of blocks and bytes allocated. Information gets updated when the IDE is idle. hv Delphi 3 and later. Heap Verify. Performs validation of memory allocated using the memory manager. Displays error information in the IDE title bar if errors are found in the heap. attach Delphi 4 and later. Attach to running process. This command-line is used to make Delphi a JIT debugger on Windows 95/98/NT. ---------------------------------------------Note that these command-line switches are case-insensitive and can be prefixed with either - or /. }

01/2001. Be notified: CD in/out

{we capture the WM_DEVICECHANGE message} {Put this line into private section of your form's declaration}

92

procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE; {the implementation part:} procedure TForm1.WMDeviceChange (var Msg: TMessage); const CD_IN = $8000; CD_OUT = $8004; var Msg : String; begin inherited; case Msg.wParam of CD_IN : Msg := 'CD in'; CD_OUT : Msg := 'CD out'; end; ShowMessage(Msg); end;

93

Get File From the Net Create a Delphi application that downloads files from the Internet; add an auto-update feature to your programs. If your program relies on Packages or DLLs than deploying new versions of your libraries certainly takes some time. The Internet now provides a fairly easy way to accomplish this task. Adding an autoupdate option to your applications could be the best way to keep your Delphi applications up to date. Let's see how to create the most important peace of code in any FTP application. Delphi gives us full access to the WinInet API (wininet.pas) which we can use to connect to and retrieve files from any Web site that uses either Hypertext Transfer Protocol (HTTP) or File Transfer Protocol (FTP). For example, we could use the functions inside the WinInet API to: add an FTP browser to any application, create an application that automatically downloads files from a public FTP site or search the Internet site for references to graphics and download only the graphics. GetInetFile function uses Wininet; function GetInetFile (const fileURL, FileName: String): boolean; const BufferSize = 1024; var hSession, hURL: HInternet; Buffer: array[1..BufferSize] of Byte; BufferLen: DWORD; f: File; sAppName: string; begin Result:=False; sAppName := ExtractFileName(Application.ExeName); hSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); try hURL := InternetOpenURL(hSession, PChar(fileURL), nil,0,0,0); try AssignFile(f, FileName); Rewrite(f,1); repeat InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen); BlockWrite(f, Buffer, BufferLen) until BufferLen = 0; CloseFile(f); Result:=True; finally InternetCloseHandle(hURL) end finally InternetCloseHandle(hSession) end end;

Note: In order to provide some visual feedback to the user you could add a line like FlashWindow(Application.Handle,True) in the body of the repeat/until block. The FlashWindow API call flashes the caption of your applications name in the task bar. Usage To call the GetInetFile function you could use the next peace of code: var FileOnNet, LocalFileName: string begin FileOnNet:=

94

'http://delphi.about.com/library/forminbpl.zip'; LocalFileName:='File Downloaded From the Net.zip' if GetInetFile(FileOnNet,LocalFileName)=True then ShowMessage('Download successful') else ShowMessage('Error in file download') end;

This code will get the 'forminbpl.zip' file from this site, download it, and save it as 'File Downloaded From the Net.zip'. Note: Depending on vhich version of Delphi you have, several components can be found on the Internet page of the VCL palette that are designed to ease the task of Internet enabling your applications. For an example of a FTP component look for TNMFTP in the FastNet VCL page.

95

52/2000. Get Text from the Control at Pos x,y on Screen { This form has 3 labels and a timer component} unit unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Timer1: TTimer; Label1: TLabel; Label2: TLabel; Label3: TLabel; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); private procedure ShowHwndAndClassName(CrPos: TPoint); public end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.ShowHwndAndClassName(CrPos: TPoint); var hWnd: THandle; aName, Text : array [0..255] of char; begin hWnd := WindowFromPoint(CrPos); Label1.Caption := 'Handle : ' + IntToStr(hWnd); if boolean(GetClassName(hWnd, aName, 256)) then Label2.Caption := 'ClassName : ' + string(aName) else Label2.Caption := 'ClassName : not found'; SendMessage(hWnd, WM_GETTEXT, SizeOf(Text), integer(@Text)); Label3.Caption := 'Text :' + Text; end; procedure TForm1.FormCreate(Sender: TObject); begin Form1.FormStyle := fsStayOnTop; Timer1.Interval := 50; end; procedure TForm1.Timer1Timer(Sender: TObject); var rPos: TPoint; begin if boolean(GetCursorPos(rPos)) then ShowHwndAndClassName(rPos); end; end.

51/2000. Add Columns to a ListBox {

96

Put in the TabWidth property the width of the column in pixels (test it with 100, for example) When you add items to the listbox, separate the columns with Î } ListBox1.Items.Add('FirstColumn'Î'Second'Î'Third');

50/2000. Hide/Show Tray Icons procedure TraySHOW var TopWindow : HWND; begin TopWindow:= FindWindow('Shell_TrayWnd', nil); TopWindow:= FindWindowEx(TopWindow,0, 'ReBarWindow32', nil); TopWindow:= FindWindowEx(TopWindow,0, 'SysPager', nil); ShowWindow( TopWindow,Sw_Show); end; procedure TrayHIDE var TopWindow : HWND; begin TopWindow:= FindWindow('Shell_TrayWnd', nil); TopWindow:= FindWindowEx(TopWindow,0, 'ReBarWindow32', nil); TopWindow:= FindWindowEx(TopWindow,0, 'SysPager', nil); ShowWindow( TopWindow,Sw_Hide); end;

49/2000. Disable Mouse and Keyboard {Button1 on Form1 - disable mouse and keyboard for 5 seconds} procedure TForm1.Button1Click(Sender: TObject); function FuncAvail (_dllname, _funcname: string; var _p: pointer): boolean; var _lib: tHandle; begin Result := false; _p := NIL; if LoadLibrary(PChar(_dllname)) = 0 then exit; _lib := GetModuleHandle(PChar(_dllname)); if _lib <> 0 then begin _p := GetProcAddress(_lib, PChar(_funcname)); if _p <> NIL then Result := true; end; end; var xBlockInput : function(Block: BOOL): BOOL; stdcall; begin if FuncAvail ('USER32.DLL', 'BlockInput', @xBlockInput) then begin xBlockInput(true); Sleep(5000); xBlockInput(false);

97

end; end;

48/2000. Get Windows Version type TWin32Version = (wvUnknown, wvWin95, wvWin98, wvWinNT, wvWin2000); function GetWinVersion: TWin32Version; begin Result := wvUnknown; if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then if (Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)) then Result := wvWin98 else Result := wvWin95 else if Win32MajorVersion <= 4 then Result := wvWinNT else if Win32MajorVersion = 5 then Result := wvWin2000 end;

47/2000. Use TTF Without Installing {How to use a TTF font in your application without having to install it in Windows} {First load it in the OnCreate event of a form): procedure TForm1.FormCreate(Sender: TObject); begin AddFontResource('c:\FONTS\MyFont.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; {Before application terminates we must free it:} procedure TForm1.FormClose (Sender: TObject; var Action: TCloseAction); begin RemoveFontResource('C:\FONTS\MyFont.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end;

46/2000. Are we Connected to the Internet? {Button1 on a Form1:} procedure TForm1.Button1Click(Sender: TObject); function FuncAvail(_dllname, _funcname: string; var _p: pointer): boolean; {return True if _funcname exists in _dllname} var _lib: tHandle; begin Result := false; if LoadLibrary(PChar(_dllname)) = 0 then exit; _lib := GetModuleHandle(PChar(_dllname)); if _lib <> 0 then begin _p := GetProcAddress(_lib, PChar(_funcname)); if _p <> NIL then Result := true; end; end;

98

{ Call SHELL32.DLL for Win > Win98 otherwise call URL.dll } {buton code:} var InetIsOffline : function(dwFlags: DWORD): BOOL; stdcall; begin if FuncAvail('URL.DLL', 'InetIsOffline', @InetIsOffline) then if InetIsOffLine(0) = true then ShowMessage('Not connected') else ShowMessage('Connected!'); end;

45/2000. Activate Windows "Start" by Code {Button1 on a Form1:} procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(Form1.handle, WM_SYSCOMMAND, SC_TASKLIST,0); end;

44/2000. Form Gradient Fill {Like instalation programs:} procedure TForm1.FormPaint(Sender: TObject); var Row, Ht: Word ; begin Ht := (ClientHeight + 255) div 256 ; for Row := 0 to 255 do with Canvas do begin Brush.Color := RGB(0, 0, Row); FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht)) ; end; end;

43/2000. TColor to HTML Color {Put a TColorDialog (ColorDialog1), a TLabel (Label1) and a TButton (Button1) in your form, and assign the Button1.OnClick procedure as follows: } procedure TForm1.Button1Click(Sender: TObject); function ColorToHtml(DColor:TColor):string; var tmpRGB : TColorRef; begin tmpRGB := ColorToRGB(DColor); Result:=Format('#%.2x%.2x%.2x', [GetRValue(tmpRGB), GetGValue(tmpRGB), GetBValue(tmpRGB)]); end; {function ColorToHtml} begin if ColorDialog1.Execute then Label1.Caption:=ColorToHtml(ColorDialog1.Color); end;

42/2000. Play System Predefined Sounds 99

uses mmsystem; ... PlaySound(pChar('SYSTEMSTART'),0,SND_ASYNC); {other constants are: SYSTEMSTART SYSTEMEXIT SYSTEMHAND SYSTEMASTERISK SYSTEMQUESTION SYSTEMEXCLAMATION SYSTEMWELCOME SYSTEMDEFAULT }

41/2000. Get the Line Number From a TRichEdit { Yes, this function is missing from TRichEdit. You can get the line number from cursor by using a windows message (on a RichEdit named REdit): REdit.Perform(EM_LINEFROMCHAR,REdit.SelStart,0); this will return the line number. There is also a windows message (EM_CHARFROMPOS) that will return the character position from the screen cursor coordinates. Look in the windows help file for more info. Beware that these functions are pretty slow, and should not be used inside of loop that get called a lot. }

40/2000. Enable/Disable Desktop Icons {Disable:} EnableWindow(FindWindowEx(FindWindow ('Progman', nil), HWND(0), 'ShellDll_DefView', nil), FALSE); {Enable:} EnableWindow( FindWindowEx( FindWindow ('Progman', nil), HWND(0), 'ShellDll_DefView', nil), TRUE);

39/2000. Change the Window's Start Button Bitmap {We'll need several global variables} var Form1: TForm1; StartButton : hWnd; OldBitmap : THandle; NewImage : TPicture; ... {Now, we put this code in the OnCreate event of the form:} procedure TForm1.FormCreate(Sender: TObject); begin NewImage:=TPicture.create; NewImage.LoadFromFile('C:\Windows\Circles.BMP'); StartButton := FindWindowEx (FindWindow( 'Shell_TrayWnd', nil), 0,'Button', nil); OldBitmap:=SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle); end;

100

... {And this other in the OnDestroy:} procedure TForm1.FormDestroy(Sender: TObject); begin SendMessage(StartButton,BM_SetImage,0,OldBitmap); NewImage.Free; end;

38/2000. TImage.Bitmap Fade Out {On a form: put a TImage (Image1) and load in it a bitmap of 24 bits or 32 bits; put a TButton (Button1) and put this code in its OnClick event:} procedure TForm1.Button1Click(Sender: TObject); procedure FadeOut(const BMP:TImage; Pause:integer); var BytesPorScan : integer; w,h : integer; p : pByteArray; counter : integer; begin {This only works with 24 or 32 bits bitmaps} If Not (BMP.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then raise exception.create ('Error, bitmap format not supported.'); try BytesPorScan:= Abs(Integer(BMP.Picture.Bitmap.ScanLine[1])Integer(BMP.Picture.Bitmap.ScanLine[0])); except raise exception.create('Error'); end; {Decrease the RGB for each single pixel} for counter:=1 to 256 do begin for h:=0 to BMP.Picture.Bitmap.Height-1 do begin P:=BMP.Picture.Bitmap.ScanLine[h]; for w:=0 to BytesPorScan-1 do if P^[w] >0 then P^[w]:=P^[w]-1; end; Sleep(Pause); BMP.Refresh; end; end; {procedure FadeOut} begin {button1_click} FadeOut(Image1,5); end;

37/2000. Margins in Memo {EM_SETRECT message is sent to Memo to fix the size of the canvas of the component.} procedure TForm1.Button1Click(Sender: TObject); var R : TRect; LeftMargin:integer; RightMargin:integer; begin LeftMargin:=20;

101

RightMargin:=10; R := Memo1.ClientRect; R.Left:=R.Left + LeftMargin; R.Top:=R.Top + 2; R.Bottom:=R.Bottom - 2; R.Right:=R.Right-RightMargin; SendMessage(Memo1.Handle, EM_SETRECT, 0, Longint(@R)); end;

36/2000. Get Windows Temp directory {thePath holds the Windows Temp directory} var lng: DWORD; thePath: string; begin SetLength(thePath, MAX_PATH); lng := GetTempPath(MAX_PATH, PChar(thePath)); SetLength(thePath, lng); end;

35/2000. Abort a Loop by Pressing a Key { It is a question that I see many times... There is an option that is to use a global boolean variable that is set from a OnClick event, for example and other that it is the one used in this trick that consists on reading the state of the key in the loop, to know if it is or not pressed: var i : integer; begin for i:=0 to 9999999 do begin Label1.Caption:=IntToStr(i); {.... loop main body here ...} Application.ProcessMessages; {ESC key stops the loop} if GetKeyState(VK_Escape) AND 128=128 then break; end; end;

34/2000. How To "HotTrack" any Control { HotTracking is used when we want to highlight components when the mouse passes over them; for example we could hot track an URL label component http://delphi.about.com/library/weekly/aa112498.htm Code below "HotTracks" Labels and Check Boxex, with a little modification use it to HotTrack any control. } {We have to override the WndProc procedure} procedure WndProc(var Message : TMessage); override; procedure TForm1.WndProc(var Mesg : TMessage); begin { Here we see which component gets changed. This bit here tells us which component the mouse is over}

102

if Mesg.LParam = Longint(Label1) then ChangeColor(Label1, Mesg.Msg); if Mesg.LParam = Longint(Label2) then ChangeColor(Label2, Mesg.Msg); if Mesg.LParam = Longint(Label3) then ChangeColor(Label3, Mesg.Msg); if Mesg.LParam = Longint(CheckBox1) then ChangeColor(CheckBox1, Mesg.Msg); inherited WndProc(Mesg); end; procedure TForm1.ChangeColor (Sender : TObject; Msg : Integer); Begin {If a label is the one that the mouse is over then we do this} if Sender IS TLabel Then begin if (Msg = CM_MOUSELEAVE) then (Sender as TLabel).Font.Color:=clWindowText; if (Msg = CM_MOUSEENTER) then (Sender as TLabel).Font.Color:=clBlue; end; {If a CheckBox is the one...} if Sender IS TCheckBox Then begin if (Msg = CM_MOUSELEAVE) then (Sender as TCheckBox).Font.Color:=clWindowText; if (Msg = CM_MOUSEENTER) then (Sender as TCheckBox).Font.Color:=clRed; end; end;

33/2000. Mail from Outlook with Delphi {the following code can be used to send an Outlook e-mail message from Delphi Submitted by Mike Shkolnik} const olMailItem = 0; var Outlook: OLEVariant; MailItem: Variant; begin try Outlook:=GetActiveOleObject('Outlook.Application'); except Outlook:=CreateOleObject('Outlook.Application'); end; MailItem := Outlook.CreateItem(olMailItem); with MailItem do begin Recipients.Add('[email protected]'); Subject := 'Subject: Outlook Mail From Delphi'; Body := 'Welcome to my homepage: http://delphi.about.com'; Attachments.Add('C:\Windows\Win.ini'); Send; end; {with} Outlook := Unassigned; end;

32/2000. Controling Sound Volume Submitted by [email protected] uses MMSystem; type

103

TVolumeRec = record case Integer of 0: (LongVolume: Longint); 1: (LeftVolume, RightVolume : Word); end; const DeviceIndex=5 {0:Wave 1:MIDI 2:CDAudio 3:Line-In 4:Microphone 5:Master 6:PC-loudspeaker} procedure SetVolume(aVolume:Byte); var Vol: TVolumeRec; begin Vol.LeftVolume := aVolume shl 8; Vol.RightVolume:= Vol.LeftVolume; auxSetVolume(UINT(DeviceIndex), Vol.LongVolume); end; function GetVolume:Cardinal; var Vol: TVolumeRec; begin AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume); Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9; end;

31/2000. Is Mouse Over Form? { To tell if the mouse is over Delphi Form, we can use the GetCapture() windows API function to capture the mouse. See the Windows documentation for additional information and limitations on mouse capturing. } procedure TForm1.FormDeactivate(Sender: TObject); begin ReleaseCapture; end; procedure TForm1.FormMouseMove (Sender: TObject; Shift: TShiftState; X,Y: Integer); begin If GetCapture = 0 then SetCapture(Form1.Handle); if PtInRect(Rect(Form1.Left, Form1.Top, Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then Form1.Caption := 'Mouse is over form' else Form1.Caption := 'Mouse is outside of form'; end;

. 30/2000. Routine Navigation Submitted by: James Wagner [[email protected]] If you're in a procedure and want to go to the declaration line, press Shift-Control-Up Arrow. Shift-Control-Down Arrow will go from the

104

declaration line to the implementation of the procedure or function. This makes navigating large programs easier.

29/2000. Associate Filetype (extension) with your APP When creating applications, it's often necessary to store information as a file on the hard drive. You may choose to create your own extension and then associate that extension with your application through Windows. Basically, you need to add two keys to the registry under HKEY_CLASSES_ROOT. Say your extension in ".ext", then the first key you add is the extension itself: HKEY_CLASSES_ROOT\ .ext\ and set the "default" string value of this key to an "internal name" for your file type - for example MyApp.Document: HKEY_CLASSES_ROOT\ .ext\ Default = "MyApp.Document" You then create another key with this name: HKEY_CLASSES_ROOT\ MyApp.Document\ Create a sub-key of this called "shell", a sub-key of *this* called "open" and a further sub-key of "open" called "command". The default value uder this key is the location and name of your your application folled by "%1" which represents the filename parameter that Windows will pass to your executable: HKEY_CLASSES_ROOT\ MyApp.Document\ shell\ open\ command\ Default = "C:\myapp\myapp.exe %1" You can do this in code with the TRegistry object, or use InstallShield, which can make registry changes for you. I'd advise doing both, in case the user trashes your registry entry. p.s. To work with registry from Delphi, read: Delphi and Registry.

28/2000. Label: FocusControl One of the lesser-known properties of a Label component is the FocusControl property. This property links the Label's control with another control on the form. If the Label's caption includes an accelerator key, the control specified in its FocusControl property gets the focus when the user hits that accelerator key.

105

27/2000. Scrolling Memo Text From Code procedure MemoScrollDown(Memo: TMemo); var ScrollMessage:TWMVScroll; i:integer; begin ScrollMessage.Msg:=WM_VScroll; for i := 0 to Memo.Lines.Count do begin ScrollMessage.ScrollCode:=sb_LineDown; ScrollMessage.Pos:=0; Memo.Dispatch(ScrollMessage); end; end; {Usage, simply call: } MemoScrollDown(Memo1)

26/2000. Make an Application Window Full Screen {Set the Borderstyle of your main form to bsNone and then use SystemParametersInfo message to get the SPI_GETWORKAREA value then use SetBounds to make your Window the correct size.} procedure TSomeForm.FormShow(Sender: TObject); var r : TRect; begin Borderstyle := bsNone; SystemParametersInfo (SPI_GETWORKAREA, 0, @r,0); SetBounds (r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top); end;

25/2000. Use Arrow Keys to Move Between Controls { The UP and DOWN arrow keys are virtually useless in edit controls. So why not use them for navigating between fields. If you set the KeyPreview property of a form to True you can use the following code snippet in the OnKeyDown event of the form to control navigation. } procedure TForm1.FormKeyDown( Sender : Tobject; var Key: Word; Shift : TShiftState ); var Direction : Integer; begin Direction := -1; case Key of VK_DOWN, VK_RETURN : Direction := 0; {Next} VK_UP : Direction := 1; {Previous} end; if Direction <> -1 then begin Perform(WM_NEXTDLGCTL, Direction, 0); Key := 0; end; end;

106

24/2000. Open an Applet From the Control Panel { To start a Windows Control Panel Applet use the following function: } function RunControlPanelApplet( const sAppletFileName : string) : integer; begin Result := WinExec( PChar('rundll32.exe shell32.dll,'+ 'Control_RunDLL ' + sAppletFileName), SW_SHOWNORMAL); end; {Usage: RunControlPanelApplet('sysdm.cpl'); Note: Applet Names! access.cpl: Hardware appwiz.cpl: Software desk.cpl: Display intl.cpl: RegionalSettings joy.cpl: Joystick main.cpl: Mouse mmsys.cpl: Multimedia modem.cpl: Modems sysdm.cpl: System timedate.cpl: Time }

23/2000. Summing Multiple Selected Rows in a TDBGrid { 1. First use Object Inspector and set True to properties: dgMultiSelect and dgRowSelect. Note that when you set dgRowSelect to true, the dgEditing is automatically set to false. 2. Then, you can use the following function to sum, for example, values in the AField filed in all the rows selected (in the Table1, DBGrid1)! } function SUMSomething: Float; var i: Integer; Sum: Currency; begin Sum := 0; for i := 1 to DBGrid1.SelectedRows.Count do begin Table1.GotoBookMark (Pointer(DBGrid1.SelectedRows.Items[i-1])); { The TDBGrid component keeps all the selections as Bookmarks in a TStringList, and all the Bookmarks must be converted to a Pointer (what they really are) before using it. } Sum := Sum + Table1.FieldByName('AField').AsFloat; end; Result := Sum;

107

end;

. 22/2000. Show/Hide Desktop Icons

{To hide or show all the icons on the Windows Desktop, use the following procedure} procedure ShowDesktop(const YesNo : boolean); var h : THandle; begin h := FindWindow('ProgMan', nil); h := GetWindow(h, GW_CHILD); if YesNo = True then ShowWindow(h, SW_SHOW) else ShowWindow(h, SW_HIDE); end; {Usage:} {Hide desktop icons} ShowDesktop(False); {Show desktop icons} ShowDesktop(true);

21/2000. ListBox with a Horizontal Scroll Bar {To add a horizontal scroll bar to a list box component, use the following procedure} procedure SetHorizontalScrollBar(lb : TListBox); var i, MaxWidth: integer; begin MaxWidth := 0; for i := 0 to lb.Items.Count - 1 do if MaxWidth < lb.Canvas.TextWidth(lb.Items[i]) then MaxWidth := lb.Canvas.TextWidth(lb.Items[i]); SendMessage(lb.Handle, LB_SETHORIZONTALEXTENT, MaxWidth + 5, 0); end; {Usage:} SetHorizontalScrollBar(ListBox1);

20/2000. Detecting and Preventing Windows Shut Down

{When Windows is about to shut down, it sends a WM_QueryEndSession to all open applications. To detect (and prevent shutdown), we must define a message handler to this message. Put this definition on the private section of the main form:} procedure WMQueryEndSession (var Msg : TWMQueryEndSession); message WM_QueryEndSession; {Also, to prevent Windows shutting down put this method in the implementation section of the unit:} procedure TForm1.WMQueryEndSession (var Msg : TWMQueryEndSession); begin if MessageDlg('Close Windows ?', mtConfirmation,

108

[mbYes,mbNo], 0) = mrNo then Msg.Result := 0 else Msg.Result := 1; end; {To detect Windows Shutdown, we must trap the WM_EndSession message. Declare a message handling procedure in your main Form's Private section: } Procedure WMEndSession (var Msg : TWMEndSession); message WM_ENDSESSION; {Also, add the following procedure to the implementation section of your Unit:} procedure TForm1.WMEndSession (var Msg : TWMEndSession); begin if Msg.EndSession = TRUE then ShowMessage('Windows is shutting down ' + #10#13 + 'at ' + FormatDateTime('c', Now)); inherited; end;

19/2000. Overwrite in TMemo and TEdit { The Windows TEdit and TMemo controls have no overwrite capability. It is possible to emulate this behavior however, by setting the SelLength property of the edit or memo control to one during the processing of the KeyPress event. This causes the character at the current position of the caret to be overwritten. The following example demonstrates emulation of an overwrite capability of a TMemo component. The state of the overwrite mode can be toggled by pressing the insert key. Example: } type TForm1 = class(TForm) Memo1: TMemo; procedure Memo1KeyDown (Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1KeyPress (Sender: TObject; var Key: Char); private { Private declarations } InsertOn : bool; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM}

109

procedure TForm1.Memo1KeyDown (Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key = VK_INSERT) and (Shift = []) then InsertOn := not InsertOn; end; procedure TForm1.Memo1KeyPress (Sender: TObject; var Key: Char); begin if ((Memo1.SelLength = 0) and (not InsertOn)) then Memo1.SelLength := 1; end;

18/2000. Clear All Edit Controls on a Form { Sometimes we need to clear all the Edit components that are on the form. The task is easy with the following procedure: } procedure ClearEdits; var i : Integer; begin for i := 0 to ComponentCount-1 do if (Components[i] is TEdit) then (Components[i] as TEdit).Text := ''; end;

17/2000. Path Shortener: c:\AB\C...DE\F.ghi Tip submited by: Vijay Kishan, [email protected] { Sometimes when a huge path [any long string] is to be displayed in a small space, it is desirable to see the start and the end of the path with ellipses in-between, rather than truncating one of the ends. For example "C:\Program Files\Delphi\DDrop\TargetDemo\main.pas" is desired to be seen as "C:\Program F....Demo\main.pas" then the following "Mince" function could be used. } function Mince (PathToMince :String; InSpace :Integer): String; var TotalLength, FLength : Integer; begin TotalLength := Length(PathToMince); if TotalLength > InSpace then begin FLength := (Inspace Div 2) - 2; Result := Copy(PathToMince, 0, fLength) + '...' + Copy(PathToMince, TotalLength-fLength, TotalLength); end else Result := PathToMince; end; {

110

The "InSpace" is an approximate number of charecters the intended space can hold. For example, if i need to fit a long path in a TLabel that can hold 10 charecters 'M' then InSpace is 10. Though it is approximate it does the job 99% of the time. Of course this could be modified to take into account the font width. For example: Label1.caption := Mince(Label1.caption, 15); }

16/2000. Shift, Ctrl, Alt Key Checking function CtrlDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Control] And 128) <> 0); end; function ShiftDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Shift] and 128) <> 0); end; function AltDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Menu] and 128) <> 0); end; { The following example demonstrates checking if the Shift key is pressed during a Button Click. } procedure TForm1.Button1Click(Sender: TObject); begin if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := 'No Shift'; end;

15/2000. Hide a Process in the 'Close Program' Window. { This is the code that will hide a Delphi application in the Ctrl+Alt+Del menu! } ... implementation const RSPSIMPLESERVICE = 1; RSPUNREGISTERSERVICE = 0; function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external 'KERNEL32.DLL'; procedure TForm1.FormDestroy (Sender: TObject);

111

begin RegisterServiceProcess (GetCurrentProcessID, RSPUNREGISTERSERVICE) end; procedure TForm1.FormCreate (Sender: TObject); begin RegisterServiceProcess (GetCurrentProcessID, RSPSIMPLESERVICE) end;

14/2000. Does my CD-ROM Drive Contain an Audio CD? { We can use the Windows API function GetDriveType() to test if the drive is a CD-ROM drive then use the Windows API function GetVolumeInformation() to test if the VolumeName is 'Audio CD'. } function IsAudioCD(Drive : char) : bool; var DrivePath : string; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; VolumeName : string; begin Result := false; DrivePath := Drive + ':\'; if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then exit; SetLength(VolumeName, 64); GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil, MaximumComponentLength, FileSystemFlags, nil, 0); if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true; end; {Usage:} procedure TForm1.Button1Click(Sender: TObject); begin if not IsAudioCD('D') then ShowMessage('Not an Audio CD in drive D'); end;

09/2000. Convert a Mapped Drive to it's Full UNC Path {Contributor: Wayne Atchley, [email protected]} function ConvertToUNCPath (MappedDrive: string) : string; var RemoteString : array[0..255] of char; lpRemote : PChar; StringLen : Integer; begin lpRemote := @RemoteString; StringLen := 255; WNetGetConnection (Pchar(ExtractFileDrive(MappedDrive)),

112

lpRemote, StringLen); Result := RemoteString; end; {Usage:} procedure MyTestForm.ConvertClick(Sender: TObject); begin UNCLabel.Caption := ConvertToUNCPath(ExtractFileDrive(Edit1.Text)); end;

08/2000. New Program Group In The Start-Menu { How to create a new program group inside the Start-Programs menu } uses shlobj; ... function CreateFolder (Foldername: string; aLocation: integer): boolean; var pIdl: PItemIDList; hPath: PChar; begin Result := False; if SUCCEEDED(SHGetSpecialFolderLocation (0, aLocation, pidl)) then begin hPath := StrAlloc(max_path); SHGetPathFromIDList(pIdl, hPath); SetLastError(0); CreateDirectory (PChar(hPath + '\\' + Foldername), nil ); if (GetLastError()=0) or (GetLastError()=ERROR_ALREADY_EXISTS) then Result := true; StrDispose(hPath); end; end; {Usage:} procedure TForm1.Button1Click(Sender: TObject); begin {constants like 'CSIDL_PROGRAMS' are defined in ShlObj} CreateFolder('MyProgramgroup', CSIDL_PROGRAMS); end;

07/2000. Standard Dialogs: Changing Default Button Title { Suppose you have Form1 with Opendialog1:TOpendialog component and would like to change its button title from default '&Open' to something else. } procedure TForm1.Opendialog1Show(Sender: TObject); begin {"OPEN" - > "Do Open"} SetDlgItemText (GetParent (Opendialog1.Handle), IDOK, PChar ('&Do Open')); {"Cancel" - > "No, Dismiss"} SetDlgItemText (GetParent (Opendialog1.Handle), IDCANCEL, PChar ('&No, Dismiss')); end;

113

{ Note: IDOK is integer identifier for dialog's Open button (corresponding buttons for different types of dialogs, say Save button for TSaveDialog, have IDOK identifier as well). }

06/2000. Send Char to Another App { The following code is used to insert a character into another application - Notepad } procedure TForm1.Button1Click(Sender: TObject); var g,d:integer; begin {Find the main window of the Application} g:=FindWindow('Notepad',nil); {Find the window of the application's text box} d:=ChildWindowFromPoint(g,point(50,50)); {Now send it a character!!} SendMessage(d,WM_CHAR,Ord('A'),0); end;

05/2000. Week Number Calculating { Calculate a week-of-the-year index (0-51) for a given date. Week 0 is the week containing the first Sunday of the year. } function WeekNum(const TDT:TDateTime) : Word; var Y,M,D:Word; dtTmp:TDateTime; begin DecodeDate(TDT,Y,M,D); dtTmp := EnCodeDate(Y,1,1); Result := (Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) DIV 7; if Result <> 0 then Result := Result - 1; end;

13/2000. TMediaPlayer: What track am I on? { Drop a TMediaPlayer component on the form, with all the properties correctly set and bound to the CD player. Also, add "MMSystem" to the uses clause in the calling form. To complete, create a TTimer and put the code below in its OnTimer event: } uses MMSystem; var Trk, Min, Sec : word; begin with MediaPlayer1 do begin Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position); Sec := MCI_TMSF_SECOND(Position); Label1.Caption := Format('%.2d',[Trk]); Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);

114

end; end;

12/2000. Which Type a Variant Currently Is? { How do we get a glimpse into the contents of a variant type variable? Does it hold a string or an integer or something else? A variant can have most any kind of value assigned to it. How can we tell which it is? This is how: } function GetVariantType(const v: variant): string; begin case TVarData(v).vType of varEmpty: result := 'Empty'; varNull: result := 'Null'; varSmallInt: result := 'SmallInt'; varInteger: result := 'Integer'; varSingle: result := 'Single'; varDouble: result := 'Double'; varCurrency: result := 'Currency'; varDate: result := 'Date'; varOleStr: result := 'OleStr'; varDispatch: result := 'Dispatch'; varError: result := 'Error'; varBoolean: result := 'Boolean'; varVariant: result := 'Variant'; varUnknown: result := 'Unknown'; varByte: result := 'Byte'; varString: result := 'String'; varTypeMask: result := 'TypeMask'; varArray: result := 'Array'; varByRef: result := 'ByRef'; end; // case end;

11/2000. Memo Printing {Simple procedure that prints the content of a Memo component} uses printers; procedure TForm1.PrintIt(Sender: TObject); var PrintBuf: TextFile; begin AssignPrn(PrintBuf); Rewrite(PrintBuf); try for i := 0 to Memo1.Lines.Count-1 do WriteLn(PrintBuf, Memo1.Lines[i]); finally CloseFile(PrintBuf); end; end;

10/2000. Determine the Actual Size of a Blob Field in the Table { Here is a function GetBlobSize that returns the size of a given blob, memo, or graphic field. } Function GetBlobSize(Field: TBlobField): Longint; begin

115

with TBlobStream.Create(Field, bmRead) do try Result := Seek(0, 2); finally Free; end; end; {Usage:} procedure TForm1.Button1Click(Sender: TObject); begin {This sets the Edit1 edit box to display the size of} {a memo field named Notes.} Edit1.Text := IntToStr(GetBlobSize(Notes)); end;

. 38. ToolTip Font Hint Properties {Change the font in Tool Tip (Hint box)} Type TMyHintWindow = Class (THintWindow) Constructor Create (AOwner: TComponent);override; end; Constructor TMyHintWindow.Create(AOwner:TComponent); begin Inherited Create (AOwner); Canvas.Font.Name := 'Courier New'; Canvas.Font.Size := 72; end; procedure TForm1.FormCreate(Sender: TObject); begin Application.ShowHint := false; HintWindowClass := TMyHintWindow; Application.ShowHint := True; end;

37. Date/Time and other International Settings { By default, Delphi gets its date/time, currency and numeric format from Control Panel's International settings. We can set the constants defined in Delphi, like DecimalSeparator, ShortDateFormat and others like: } procedure SetLocale; begin DecimalSeparator := '.'; ThousandSeparator : = ','; ShortDateFormat := 'mm/dd/yy'; end; { To a complete list of these variables, look at Currency and date/time formatting variables in Delphi Help }

36. Window Flashing { Flashing a window means changing the appearance

116

of its caption bar as if the window were changing from inactive to active status, or vice versa. Typically, a window is flashed to inform the user that the window requires attention but that it does not currently have the keyboard focus. The FlashWindow API function flashes the window only once. To create a flashing window add a TTimer component on a form, and use the following code in the OnTimer event handler: } procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow (Handle, True); end;

35. Open & Close CD-drive {To OPEN the CD-ROM:} mciSendString ('Set cdaudio door open wait', nil, 0, handle); {To CLOSE the CD-ROM:} mciSendString ('Set cdaudio door closed wait', nil, 0, handle); {Remember to include the MMSystem unit in your uses clause.}

. 04/2000. Close Another Application

{ To programmatically close another application, send to the application a WM_QUIT message. "Window caption" is the caption of the window that you are sending the message to. } function KillApp(const sCapt: PChar) : boolean; var AppHandle:THandle; begin AppHandle:=FindWindow(Nil, sCapt); Result:=PostMessage(AppHandle, WM_QUIT, 0, 0); end; {Usage:} if not KillApp('Window caption') then ShowMessage('App not closed');

03/2000. IsTrueTypeFont

{ Given a font's name (such as Arial, Verdana, Times New Roman, etc), function returns a boolean value meaning if the font is or isn't a True Type font. } function IsTrueTypeFont(FontName : string):boolean; const PITCH_MASK: byte = $0F; var TxMet: TTextMetric; TempCanvas : TCanvas; PitchTest : byte;

117

begin TempCanvas:=TCanvas.Create; TempCanvas.Handle:=CreateCompatibleDC(0); TempCanvas.Font.Name:=FontName; GetTextMetrics(TempCanvas.Handle, TxMet); PitchTest:=TxMet.tmPitchAndFamily and PITCH_MASK; Result:=(PitchTest and TMPF_TRUETYPE) <> 0; TempCanvas.free; end;

02/2000. ALT+TAB, CTRL+ESC, CTRL+ALT+DEL { If you wish to disable those keys while your application is running call SystemKeys: When you call SystemKeys, if Disable is True, the keys will be disabled, False otherwise. } procedure SystemKeys(Disable: Boolean); var OldVal : LongInt; begin SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(Disable), @OldVal, 0); end;

01/2000. Hide Title Bar

{A quick way to hide your program's title bar:} procedure TForm1.FormCreate(Sender: TObject); begin SetWindowLong( Handle, GWL_STYLE, GetWindowLong( Handle, GWL_STYLE ) and not WS_CAPTION ); ClientHeight := Height; end;

. 30. Left, Mid, Right String

{ . LeftStr() takes a certain portion of the left side of a string. . MidStr() takes a specified number of characters from a string. . RightStr() takes a certain portion of the right side of a string. } function RightStr (Const Str: String; Size: Word): String; begin if Size > Length(Str) then Size := Length(Str); RightStr := Copy(Str, Length(Str)-Size+1, Size) end; function MidStr (Const Str: String; From, Size: Word): String; begin MidStr := Copy(Str, From, Size) end; function LeftStr (Const Str: String; Size: Word): String; begin LeftStr := Copy(Str, 1, Size) end;

118

{ Let's say we have a string Dstr := 'Delphi is the BEST', then LeftStr(Dstr, 5) := 'Delph' MidStr(Dstr, 6, 7) := 'i is th' RightStr(Dstr, 6) := 'e BEST' }

29. Reverse a String { This function returns a string whose values are all reversed. The first character is last and the last is first. } Function String_Reverse(S : String): String; Var i : Integer; Begin Result := ''; For i := Length(S) DownTo 1 Do Begin Result := Result + Copy(S,i,1); End; End; { Let's say you have a string 'testing string reverse' than String_reverse would result in 'esrever gnirts gnitset' }

28. Search And Replace function SearchAndReplace (sSrc, sLookFor, sReplaceWith : string) : string; var nPos, nLenLookFor : integer; begin nPos := Pos(sLookFor, sSrc); nLenLookFor := Length(sLookFor); while (nPos > 0) do begin Delete(sSrc, nPos, nLenLookFor); Insert(sReplaceWith, sSrc, nPos); nPos := Pos(sLookFor, sSrc); end; Result := sSrc; end; { Let's say you have a string 'testing;search;and;replace' and you want to replace ';' with spaces. Here's how you'd call this function sOldString:='testing;search;and;replace'; sNewString:=SearchAndReplace(sOldString, ';', ' ') }

27. Convert The First Letter In Any Word To A Capital

{ Tip submitted by: Andrew Burt, [email protected] } procedure TForm1.Button1Click(Sender: TObject); var

119

GetString : string; GetLength : Integer; I : Integer; T : String; begin if edit1.SelLength > 0 then GetString:= Edit1.Seltext else GetString:= Edit1.Text; GetLength:= Length(Edit1.Text); if GetLength>0 then begin for I:= 0 to GetLength do begin if (GetString[I] = ' ') or (I=0) then begin if GetString[I+1] in ['a'..'z'] then begin T:=GetString[I+1]; T:=UpperCase(T); GetString[I+1]:=T[1]; end; end; end; if edit1.Sellength>0 then Edit1.Seltext:=GetString else Edit1.Text:=GetString; end; end;

. 34. DelTree Function uses ShellAPI; Function DelTree(DirName : string): Boolean; { Completely deletes a directory regardless of whether the directory is filled or has subdirectories. No confirmation is requested so be careful. If the operation is successful then True is returned, False otherwise } var SHFileOpStruct : TSHFileOpStruct; DirBuf : array [0..255] of char; begin try Fillchar(SHFileOpStruct,Sizeof(SHFileOpStruct),0); FillChar(DirBuf, Sizeof(DirBuf), 0 ); StrPCopy(DirBuf, DirName); with SHFileOpStruct do begin Wnd := 0; pFrom := @DirBuf; wFunc := FO_DELETE; fFlags := FOF_ALLOWUNDO; fFlags := fFlags or FOF_NOCONFIRMATION; fFlags := fFlags or FOF_SILENT; end; Result := (SHFileOperation(SHFileOpStruct) = 0); except Result := False; end; end; { Usage if DelTree('c:\TempDir') then ShowMessage('Directory deleted!') else ShowMessage('Errors occured!'); }

120

33. From/To the 8.3 Format To/From the Long Format unit LFN_ALT; interface { This unit provides two functions that convert filenames from the long format to the 8.3 format, and from the 8.3 format to the long format. } function AlternateToLFN(AltName:String):String; function LFNToAlternate(LongName:String):String; implementation uses Windows; function AlternateToLFN(AltName:String):String; var temp: TWIN32FindData; searchHandle: THandle; begin searchHandle:=FindFirstFile(PChar(AltName),temp); if searchHandle <> ERROR_INVALID_HANDLE then result := String(temp.cFileName) else result := ''; Windows.FindClose(searchHandle); end; function LFNToAlternate(LongName:String):String; var temp: TWIN32FindData; searchHandle: THandle; begin searchHandle:=FindFirstFile(PChar(LongName),temp); if searchHandle <> ERROR_INVALID_HANDLE then result := String(temp.cALternateFileName) else result := ''; Windows.FindClose(searchHandle); end; end.{unit}

32. Get Files "Last Modified" Attribute function FileLastModified (const TheFile: string): string; var FileH : THandle; LocalFT : TFileTime; DosFT : DWORD; LastAccessedTime : TDateTime; FindData : TWin32FindData; begin Result := ''; FileH := FindFirstFile(PChar(TheFile), FindData); if FileH <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); if (FindData.dwFileAttributes AND FILE_ATTRIBUTE_DIRECTORY) = 0 then begin FileTimeToLocalFileTime (FindData.ftLastWriteTime,LocalFT); FileTimeToDosDateTime (LocalFT,LongRec(DosFT).Hi,LongRec(DosFT).Lo); LastAccessedTime := FileDateToDateTime(DosFT); Result := DateTimeToStr(LastAccessedTime);

121

end; end; end; { Usage: label1.Caption:=FileLastModified('c:\autoexec.bat'); }

31. Reading a Directory's Content procedure FindAll (const Path: String; Attr: Integer; List: TStrings); var Res: TSearchRec; EOFound: Boolean; begin EOFound:= False; if FindFirst(Path, Attr, Res) < 0 then exit else while not EOFound do begin List.Add(Res.Name); EOFound:= FindNext(Res) <> 0; end; FindClose(Res); end;

{ The following example lists all files and subdirectories of the C:\Windows directory into a TListBox called ListBox1: FindAll('C:\Windows\*.*',faAnyFile,ListBox1.Items); }

. 22. Making a Form Non-Moveable

{ Here is how to keep the window from moving: First, make the borderstyle something like bsDialog, so that the window cant be resized. Next, add the following declaration to your form class: } procedure PosChange(var Msg: TWmWindowPosChanging); message WM_WINDOWPOSCHANGING; //Finally, implement the procedure like: procedure TForm1.PosChange (var Msg: TWmWindowPosChanging); begin Msg.WindowPos.x := Left; Msg.WindowPos.y := Top; Msg.Result := 0; end; { Thats it. Easy as can be. The only problem with this is that you cant move the form if you want your code to. To get around this, just set up a Boolean variable called PosLocked, set it to True when you want to lock the forms position, and to false when you need to move the form (when

122

your done, remember to set it back to true). Then to implement the proc above, just make it } if PosLocked then begin Msg.WindowPos.x := Left; Msg.WindowPos.y := Top; Msg.Result := 0; end else inherited;

21. Execute the Windows Explorer Find File Dialog Box { The following example demonstrates using DDE to execute Explorer's find file dialog. The example opens the dialog in the Directory "C:\DelphiTips". } uses ddeman; procedure TForm1.Button1Click(Sender: TObject); begin with TDDEClientConv.Create(Self) do begin ConnectMode := ddeManual; ServiceApplication := 'explorer.exe'; SetLink( 'Folders', 'AppProperties'); OpenLink; ExecuteMacro ('[FindFolder(, C:\DelphiTips)]', False); CloseLink; Free; end; end;

20. Delete files with the ability to UNDO { Delete a file with the ability to undo by sending the file to the "Recycle Bin." Function FileDeleteRB will return True if the operation was successful. } uses ShellAPI; function FileDeleteRB( FileName:string): boolean; var fos : TSHFileOpStruct; begin FillChar(fos, SizeOf(fos), 0); with fos do begin wFunc := FO_DELETE; pFrom := PChar(FileName); fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT; end; Result := (ShFileOperation(fos)=0); end;

19. Add documents to the Windows Start-Documents Menu { If you would like to add documents to the new "Start-Documents" menu that was added with the creation of Windows 95/NT, use the following function. Be sure to add ShellAPI and ShlOBJ to your uses clause. }

123

procedure AddtoDocMenu(fName : String); begin SHAddToRecentDocs(SHARD_PATH, PChar(fName)); end;

18. Making a transparent form {Add a button to a form and try this:} procedure TForm1.FormCreate(Sender: TObject); var FullRgn, ClientRgn, ButtonRgn: THandle; Margin, X, Y: Integer; begin Margin := (Width - ClientWidth) div 2; FullRgn := CreateRectRgn(0, 0, Width, Height); X := Margin; Y := Height - ClientHeight - Margin; ClientRgn := CreateRectRgn (X, Y, X + ClientWidth, Y + ClientHeight); CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF); X := X + Button1.Left; Y := Y + Button1.Top; ButtonRgn := CreateRectRgn (X, Y, X + Button1.Width, Y + Button1.Height); CombineRgn(FullRgn, FullRgn, ButtonRgn, RGN_OR); SetWindowRgn(Handle, FullRgn, True); end;

26. Rotating Fonts { Here is an example of creating a font that is rotated 45 degrees } procedure TForm1.Button1Click(Sender: TObject); var lf : TLogFont; tf : TFont; begin with Form1.Canvas do begin Font.Name := 'Arial'; Font.Size := 24; tf := TFont.Create; try tf.Assign(Font); GetObject(tf.Handle, sizeof(lf), @lf); lf.lfEscapement := 450; lf.lfOrientation := 450; tf.Handle := CreateFontIndirect(lf); Font.Assign(tf); finally tf.Free; end; TextOut(20, Height div 2, 'Rotated Text!'); end; end;

25. Checking If File Is In Use { IsFileInUse will return true if the file is locked for exclusive access. It would fail if the file doesn't exist at all. } function IsFileInUse(fName : string) : boolean; var

124

HFileRes : HFILE; begin Result := false; if not FileExists(fName) then exit; HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (HFileRes = INVALID_HANDLE_VALUE); if not Result then CloseHandle(HFileRes); end;

24. Capture Maximize/Minimize Buttons ... public procedure WMSysCommand (var Msg: TWMSysCommand); message WM_SYSCOMMAND; ... implementation ... procedure TForm1.WMSysCommand; begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0); DefaultHandler(Msg); end;

23. Enlarge a Form Over Screen Size {Add a button to a form and try this:} //Due to the default Windows handling of //the WM_GETMINMAXINFO message, //the max size of the form is set to //the screen size. ... private procedure WMGetMinMaxInfo (var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; ... implementation procedure TForm1.WMGetMinMaxInfo (var msg: TWMGetMinMaxInfo); begin inherited; with msg.MinMaxInfo^.ptMaxTrackSize do begin X := GetDeviceCaps(Canvas.Handle, HORZRES) + (Width - ClientWidth); Y := GetDeviceCaps(Canvas.Handle, VERTRES) + (Height - ClientHeight); end; end; procedure TForm1.Button1Click(Sender: TObject); Const Rect: TRect = (Left:0; Top:0; Right:0; Bottom:0); begin if Left > 0 then begin

125

Rect := BoundsRect; SetBounds( Left - ClientOrigin.X, Top - ClientOrigin.Y, GetDeviceCaps(Canvas.Handle, HORZRES) + (Width - ClientWidth), GetDeviceCaps(Canvas.Handle, VERTRES) + (Height - ClientHeight) ); end else BoundsRect := Rect; end;

17. Convert the First Character in an Edit Box to Uppercase { When users enter data, they often need to format it in a standard way. You can't depend on the user to do it, so the best bet is to make your program do the formatting itself. For example, if the user types a name in all lowercase letters, the program could automatically convert the first character in the first and last names to uppercase letters. Add the following code to the OnKeyPress event for the Edit1 component: } with Sender as TEdit do if (SelStart = 0) or (Text[SelStart] = ' ') then if Key in ['a'..'z'] then Key := UpCase(Key);

16. Using the RunOnce Registry Key { Under Win32, unless you are running from a removable drive, you cannot delete a running executable. You can have Windows delete the executable the next time Windows is run by adding an entry to the RunOnce key in the Window registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows \CurrentVersion\RunOnce You can name the key anything you like, and specify a command line to another executable or to a dos command made passed to command.com } uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := False; reg.OpenKey( 'Software\Microsoft\Windows\ CurrentVersion\RunOnce', False); reg.WriteString('Delete Me!', 'command.com /c del Dummy.txt');

126

reg.CloseKey; reg.free; end;

15. Select a block of code by column //Submited by Joe Ebbeler { Many times you may want to select a block of code in the Delphi editor by column rather than line. e.g.. You just removed a loop of some kind and you want to shift a big block of text over 2 spaces. You can do this by pressing Ctrl + O + C then use the arrow keys to select the number of characters then the number of rows. Then press the delete key or copy or cut. To go back to regular select mode you can press Ctrl + O + L or you can click anywhere with the mouse. }

. 14. Setting Paradox password automatically { The table component's ACTIVE property must be set to FALSE. Then, put this code on the form's create event: } Session.AddPassword('My secret password'); TableName.Active := True;

13. Enable/Disable the Windows "START" button //Enable: EnableWindow(FindWindowEx(FindWindow ('Shell_TrayWnd', nil), 0,'Button',nil),TRUE); //Disable: EnableWindow(FindWindowEx(FindWindow ('Shell_TrayWnd', nil), 0,'Button',nil),FALSE);

12. Is IDE running? { If you want to check whether IDE is runing or not try this function: (Supose you want your new shareware component to work only when IDE is running, or something like that) } Function RunningInTheIDE: boolean; Begin Result:=FindWindow('TAppBuilder', nil) > 0; End;

11. Hint and Warning messages { It's a good idea to turn on hint and warning messages specially when writing and compiling your own code. Although some of these hints and warnings can be ignored, most of them - if nothing else - will remind you of things you could do to improve your code. - Go to "Project | Options" - Change to the "Compiler" tab - Make sure "Show hints" and "Show warnings" check boxes are checked }

10. Show/Hide the TaskBar in Windows 95 //To hide the task bar use ShowWindow(FindWindow ('Shell_TrayWnd',nil), SW_HIDE);

127

//To show the task bar use ShowWindow(FindWindow ('Shell_TrayWnd',nil), SW_SHOWNA);

5. Desktop to Bitmap procedure ScreenShot(DestBitmap : TBitmap); var DC : HDC; begin DC := GetDC (GetDesktopWindow); try DestBitmap.Width := GetDeviceCaps (DC, HORZRES); DestBitmap.Height := GetDeviceCaps (DC, VERTRES); BitBlt(DestBitmap.Canvas.Handle, 0, 0, DestBitmap.Width, DestBitmap.Height, DC, 0, 0, SRCCOPY); finally ReleaseDC (GetDesktopWindow, DC); end; end;

4. Remove App from TaskBar procedure TForm1.FormCreate(Sender: TObject); begin ShowWindow(Application.Handle, SW_HIDE); SetWindowLong(Application.Handle, GWL_EXSTYLE, getWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW ); ShowWindow( Application.Handle, SW_SHOW ); end;

3. Show window contents while dragging { If you see the Microsoft Plus! you should notice the "Show window contents while dragging", you can use this option from your program by calling the API function: SystemParametersInfo } //To Show window contents while dragging: SystemParametersInfo (SPI_SETDRAGFULLWINDOWS, 1, nil, 0); //To disable this option call the function: SystemParametersInfo (SPI_SETDRAGFULLWINDOWS, 0, nil, 0);

2. Life Cycle Of A Form { When determining which events of a form to define to do what you want, it's good to know the life cycle of a form. } ACTION Create Show Paint Activate ReSize Paint Close query

128

Close Deactivate Hide Destroy EVENT OnCreate OnShow OnPaint OnActivate OnResize OnPaint OnCloseQuery OnClose OnDeactivate OnHide OnDestroy

1. Updating Cursor immediately { For example, if I change my cursor to a waiting clock cursor before some time-consuming operations is executed, why isn't my waiting clock cursor activated immediately? It's only activated after the event! This peace of code will update cursor immediately. } begin Try Screen.Cursor:=crHourGlass; MyDataForm := TMyDataForm.Create(Application); Screen.Cursor:=crDefault; MyDataForm.ShowModal; MyDataForm.Free; Finally Screen.Cursor:=crDefault; end; end;

129

İnternete bağlımıyım ???? unit deneme; interface uses Windows, SysUtils, Registry, WinSock, WinInet; type TConnectionType = (ctNone, ctProxy, ctDialup); function ConnectedToInternet : TConnectionType; function RasConnectionCount : Integer; implementation //For RasConnectionCount ======================= const cERROR_BUFFER_TOO_SMALL = 603; cRAS_MaxEntryName = 256; cRAS_MaxDeviceName = 128; cRAS_MaxDeviceType = 16; type ERasError = class(Exception); HRASConn = DWord; PRASConn = ^TRASConn; TRASConn = record dwSize: DWORD; rasConn: HRASConn; szEntryName: Array[0..cRAS_MaxEntryName] Of Char; szDeviceType : Array[0..cRAS_MaxDeviceType] Of Char; szDeviceName : Array [0..cRAS_MaxDeviceName] of char; end; TRasEnumConnections = function (RASConn: PrasConn; { buffer to receive Connections data } var BufSize: DWord; { size in bytes of buffer } var Connections: DWord { number of Connections written to buffer } ): LongInt; stdcall; //End RasConnectionCount ======================= function ConnectedToInternet: TConnectionType; var Reg : TRegistry; bUseProxy : Boolean; UseProxy : LongWord; begin Result := ctNone; Reg := TRegistry.Create; with REG do try try RootKey := HKEY_CURRENT_USER; if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings',False) then begin //I just try to read it, and trap an exception if GetDataType('ProxyEnable') = rdBinary then ReadBinaryData('ProxyEnable', UseProxy, SizeOf(LongWord) ) else begin bUseProxy := ReadBool('ProxyEnable'); if bUseProxy then UseProxy := 1 else 130

UseProxy := 0; end; if (UseProxy <> 0) and ( ReadString('ProxyServer') <> " ) then Result := ctProxy; end; except //Obviously not connected through a proxy end; finally Free; end; //We can check RasConnectionCount even if dialup networking is not installed //simply because it will return 0 if the DLL is not found. if Result = ctNone then begin if RasConnectionCount > 0 then Result := ctDialup; end; end; function RasConnectionCount : Integer; var RasDLL : HInst; Conns : Array[1..4] of TRasConn; RasEnums : TRasEnumConnections; BufSize : DWord; NumConns : DWord; RasResult : Longint; begin Result := 0; //Load the RAS DLL RasDLL := LoadLibrary('rasapi32.dll'); if RasDLL = 0 then exit; try RasEnums := GetProcAddress(RasDLL,'RasEnumConnectionsA'); if @RasEnums = nil then raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll'); Conns[1].dwSize := Sizeof (Conns[1]); BufSize := SizeOf(Conns); RasResult := RasEnums(@Conns, BufSize, NumConns); If (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns; finally FreeLibrary(RasDLL); end; end;

131

procedure TForm1.btnKitleClick(Sender: TObject); var B: LongInt; Begin SystemParametersInfo(97,word(True),@B,0); {CTRL+ALT+DELETE, ALT+TAB tuş takımını iptal eder} end; procedure TForm1.btnAcClick(Sender: TObject); var B: LongInt; begin SystemParametersInfo(97,word(False),@B,0); {CTRL+ALT+DELETE, ALT+TAB tuş takımını tekrar aktif eder} end; -------------------------------------------------------------------------form minimize maximize kontorlu nasıl yapılır? WM_SYSCOMMAND messagini hooklamaniz lazim type TForm1 = class(TForm) public procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; end; procedure TForm1.WMSysCommand; begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then begin // Napmak istiyorsaniz yazin iste end; DefaultHandler(Msg); end; -----------------------------------------------------------------ENTER'ı TAB gibi kullanma procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if Key = #13 then Self.Perform(WM_NEXTDLGCTL, 0, 0); end; -----------------------------------------------------------------------RICHEDITTE MANUAL SCROLL YAPMA.... with MainFrm.RichEdit1 do begin SelStart := Length(Text); Perform(EM_SCROLLCARET, 0, 0); end; -------------------------------------------------------------------------On key Down da kullanilcak key ler arada lazim oluyor :) 132

vk_LButton = $01; vk_RButton = $02; vk_Cancel = $03; vk_MButton = $04; vk_Back = $08; vk_Tab = $09; vk_Clear = $0C; vk_Return = $0D; vk_Shift = $10; vk_Control = $11; vk_Menu = $12; vk_Pause = $13; vk_Capital = $14; vk_Escape = $1B; vk_Space = $20; vk_Prior = $21; vk_Next = $22; vk_End = $23; vk_Home = $24; vk_Left = $25; vk_Up = $26; vk_Right = $27; vk_Down = $28; vk_Select = $29; vk_Print = $2A; vk_Execute = $2B; vk_SnapShot = $2C; vk_Copy = $2C vk_Insert = $2D; vk_Delete = $2E; vk_Help = $2F; equivalents: 'A' thru 'Z' }ascii leri ile ayni equivalents: '0' thru '9' }ascii leri ile ayni vk_NumPad0 = $60; vk_NumPad1 = $61; vk_NumPad2 = $62; vk_NumPad3 = $63; vk_NumPad4 = $64; vk_NumPad5 = $65; vk_NumPad6 = $66; vk_NumPad7 = $67; vk_NumPad8 = $68; vk_NumPad9 = $69; vk_Multiply = $6A; vk_Add = $6B; vk_Separator = $6C; vk_Subtract = $6D; vk_Decimal = $6E; vk_Divide = $6F; vk_F1 = $70; vk_F2 = $71; vk_F3 = $72; vk_F4 = $73; vk_F5 = $74; vk_F6 = $75; 133

vk_F7 = $76; vk_F8 = $77; vk_F9 = $78; vk_F10 = $79; vk_F11 = $7A; vk_F12 = $7B; vk_F13 = $7C; vk_F14 = $7D; vk_F15 = $7E; vk_F16 = $7F; vk_F17 = $80; vk_F18 = $81; vk_F19 = $82; vk_F20 = $83; vk_F21 = $84; vk_F22 = $85; vk_F23 = $86; vk_F24 = $87; vk_NumLock = $90; vk_Scroll = $91; -----------------------------------------------------sisteme hotkey nasıl eklenir? type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); protected procedure hotykey(var msg:TMessage); message WM_HOTKEY; end; var Form1: TForm1; id,id2:Integer; implementation {$R *.DFM} procedure TForm1.hotykey(var msg:TMessage); begin if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then begin ShowMessage('Ctrl + Q ya basildi !'); end; if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then begin ShowMessage('Ctrl + R ye basildi !'); end; end; procedure TForm1.FormCreate(Sender: TObject); 134

begin id:=GlobalAddAtom('hotkey'); RegisterHotKey(handle,id,mod_control,81); id2:=GlobalAddAtom('hotkey2'); RegisterHotKey(handle,id2,mod_control,82); end; procedure TForm1.FormDestroy(Sender: TObject); begin UnRegisterHotKey(handle,id); UnRegisterHotKey(handle,id2); end;

135

{ []-----------------------------------------------------------------------[] CON001 - Show various Console API functions. Checked with Win95 version 1.01 by Alex G. Fedorov, May-July, 1997 [email protected] 09-Jul-97 some minor corrections (shown in comments) []-----------------------------------------------------------------------[] } program Con001; {$APPTYPE CONSOLE} uses Windows, SysUtils; const // Some common colors YellowOnBlue = FOREGROUND_GREEN OR FOREGROUND_RED OR FOREGROUND_INTENSITY OR BACKGROUND_BLUE; WhiteOnBlue = FOREGROUND_BLUE OR FOREGROUND_GREEN OR FOREGROUND_RED OR FOREGROUND_INTENSITY OR BACKGROUND_BLUE; RedOnWhite = FOREGROUND_RED OR FOREGROUND_INTENSITY OR BACKGROUND_RED OR BACKGROUND_GREEN OR BACKGROUND_BLUE OR BACKGROUND_INTENSITY; WhiteOnRed = BACKGROUND_RED OR BACKGROUND_INTENSITY OR FOREGROUND_RED OR FOREGROUND_GREEN OR FOREGROUND_BLUE OR FOREGROUND_INTENSITY; var ConHandle : THandle; // Handle to console window Coord : TCoord; // To store/set screen position MaxX, MaxY : Word; // To store max window size CCI : TConsoleCursorInfo; NOAW : LongInt; // To store results of some functions //----------------------------------------// Get handle to console input //----------------------------------------function GetConInputHandle : THandle; begin Result := GetStdHandle(STD_INPUT_HANDLE) end; //----------------------------------------// Get handle to console output //----------------------------------------function GetConOutputHandle : THandle; begin Result := GetStdHandle(STD_OUTPUT_HANDLE) end; //----------------------------------------// Position cursor to X, Y //----------------------------------------procedure GotoXY(X, Y : Word); 136

begin Coord.X := X; Coord.Y := Y; SetConsoleCursorPosition(ConHandle, Coord); end; //----------------------------------------// Clear Screen - fill it with spaces //----------------------------------------procedure Cls; begin Coord.X := 0; Coord.Y := 0; FillConsoleOutputCharacter(ConHandle, ' ', MaxX*MaxY, Coord, NOAW); GotoXY(0, 0); end; //-------------------------------------// Show/Hide cursor //-------------------------------------procedure ShowCursor(Show : Bool); begin CCI.bVisible := Show; SetConsoleCursorInfo(ConHandle, CCI); end; //-------------------------------------// Initialize global variables //-------------------------------------procedure Init; begin // Get console output handle ConHandle := GetConOutputHandle; // Get max window size Coord := GetLargestConsoleWindowSize(ConHandle); MaxX := Coord.X; MaxY := Coord.Y; end; //--------------------------------------// Draw "status line" //--------------------------------------procedure StatusLine(S : String); begin Coord.X := 0; Coord.Y := 0; WriteConsoleOutputCharacter(ConHandle, PChar(S), Length(S)+1, Coord, NOAW); FillConsoleOutputAttribute (ConHandle, WhiteOnRed, Length(S), Coord, NOAW); end; //----------------------------------------------------// Console Event Handler //----------------------------------------------------function ConProc(CtrlType : DWord) : Bool; stdcall; far; var S : String; begin case CtrlType of CTRL_C_EVENT : S := 'CTRL_C_EVENT'; CTRL_BREAK_EVENT : S := 'CTRL_BREAK_EVENT'; CTRL_CLOSE_EVENT : S := 'CTRL_CLOSE_EVENT'; CTRL_LOGOFF_EVENT : S := 'CTRL_LOGOFF_EVENT'; 137

CTRL_SHUTDOWN_EVENT : S := 'CTRL_SHUTDOWN_EVENT'; else S := 'UNKNOWN_EVENT'; end; MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK); Result := True; end; { []---------------------------------------------------------------[] Main program - shows usage of some subroutines above and some of console API functions []---------------------------------------------------------------[] } var R : TSmallRect; Color : Word; OSVer : TOSVersionInfo; IBuff : TInputRecord; IEvent : DWord; Continue : Bool; begin // Initialize global variables Init; // Position window on screen With R do {!! 1.01 !!} begin Left := 10; Top := 10; Right := 40; Bottom := 40; end {!! 1.01 !!} SetConsoleWindowInfo(ConHandle, False, R); // Set event handler SetConsoleCtrlHandler(@ConProc, True); // Check event handler GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0); // Change window title SetConsoleTitle('Console Demo'); // Hide cursor ShowCursor(False); Coord.X := 0; Coord.Y := 0; // Set white text on blue Color := WhiteOnBlue; FillConsoleOutputAttribute(ConHandle, Color, MaxX*MaxY, Coord, NOAW); // Console Code Page API is not supported under Win95 - only GetConsoleCP Writeln('Console Code Page = ', GetConsoleCP); Writeln('Max X=', MaxX,' Max Y=', MaxY); Readln; // wait for user input Cls; // clear screen ShowCursor(True); // show cursor // // Use some Win32API stuff // OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); GetVersionEx(OSVer); 138

With OSVer do Begin Writeln('dwMajorVersion = ', dwMajorVersion); Writeln('dwMinorVersion = ', dwMinorVersion); Writeln('dwBuildNumber = ', dwBuildNumber); Writeln('dwPlatformID = ', dwPlatformID); End; // Readln; // wait for user input // Remove event handler SetConsoleCtrlHandler(@ConProc, False); Cls; // // "Message Loop" // Continue := True; While Continue do Begin ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent); Case IBuff.EventType of KEY_EVENT : Begin // Check for ESC Key and terminate program If ((IBuff.KeyEvent.bKeyDown = True) AND (IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) Then Continue := False; End; _MOUSE_EVENT : Begin With IBuff.MouseEvent.dwMousePosition do StatusLine(Format('%d, %d', [X, Y])); End; end; End {While} end.

139

PAINTING DIRECTLY DESKTOP var MyCanvas: TCanvas; DesktopCanvas: hDC; begin DesktopCanvas := GetDC (GetDesktopWindow); if DesktopCanvas <> 0 then begin MyCanvas := TCanvas.Create; MyCanvas.Handle := DesktopCanvas; { Put the code to paint on the canvas here, you'll be painting on the desktop! } MyCanvas.Free; ReleaseDC (GetDesktopWindow, DesktopCanvas); end; end; This code is not very difficult, I don't think it'll need much explanation. The WinAPI function GetDC gets the handle of the "display device contect", as the Win32 help file calls it, or simply the handle of canvas of the form specified. The function GetDesktopWindow returns the handle of the desktop. Then, if the variable DesktopCanvas contains the correct handle, there is a new canvas made, called MyCanvas, which is assigned to the canvas of the desktop. You can paint on the desktop. Finally all the created objects are freed again.

RESTART WINDOWS

There are two ways shown here The First One -Restart Windows:

procedure TMainForm.RestartWindowsBtnClick(Sender: TObject); begin if not ExitWindows(EW_RestartWindows, 0) then ShowMessage('An application refused to terminate'); end; The Second One -Reboot System: procedure TMainForm.RebootSystemBtnClick(Sender: TObject); begin if not ExitWindows(EW_RebootSystem, 0) then ShowMessage('An application refused to terminate'); end;

SHELL EXECUTE

Edit1.text :='www.yourdomain.com'; ShellExecute(0,nil, pchar(edit1.text),nil,nil,1);

140

Disable the close (X) button on any application!

! Description:This code will enable you to disable the X on any application (The X to close a program). ! By: Niel Corns ! ! ! Inputs:None ! ! Returns:None ! !Assumes:None ! !Side Effects:None !This code is copyrighted and has limited warranties. !Please see http://www.Planet-SourceCode.com/xq/ASP/txtCodeId.128/lngWId.7/qx/vb/scripts/ShowCode.htm !for details. !************************************** Presume you will enter this code into a button. var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Untitled - Notepad'); if (hwndHandle <> 0) then begin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end;

141

! Name: Change screen resolution Instantly

! Description:This procedure will allow ! you to change the screen resolution. Car ! eful though, not all monitors support th ! e same amount! ! By: Niel Corns ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.123/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** procedure SetResolution(ResX, ResY: DWord); var lDeviceMode : TDeviceMode; begin EnumDisplaySettings(nil, 0, lDeviceMode); lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT; lDeviceMode.dmPelsWidth :=ResX; lDeviceMode.dmPelsHeight:=ResY; ChangeDisplaySettings(lDeviceMode, 0); end;

! Name: Turn monitor on and off standby

! Description:This code makes the monito ! r standby on/off. ! By: Niel Corns ! ! Side Effects:Umm....it can be a pain t ! o turn the monitor on standby and not be ! able to get back into windows ;-) ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.117/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !**************************************

This code turns the monitor ON. Put this code into a button etc...: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1) ; This code turns the monitor into standby mode!: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;

142

/////////////////////////////////////////////////////////////////////

// Project:

Password Revealer v1.0 asterix remover (prjPWREV.zip)

// Programmer: Nathan Factor // E-Mail Addr: [email protected] // Written In: Borland Delphi 5.0 (Pro) // Date: August 09, 2000 // Level: Advanced // Description: This project demonstrates how to create a program // without the overhead of the Delphi VCL by using // pure API (the executable itself is only 20kb!). // The application itself can be used to reveal a // password that is stored in an Edit control from // behind the asterisks (e.g. '*****'). // Other Notes: This project assumes that you possess a fairly // solid understanding of the Windows API. However, // if you are still unclear about some of the API // calls, you can always search the MSDN library // (http://msdn.microsoft.com) for CreateWindow, and // CreateWindowEx, as well as the other calls used // in this project. ///////////////////////////////////////////////////////////////////// program prjPWREV; uses Windows, Messages; var Msg : TMsg; wClass : TWndClassA; intScrX, intScrY : integer; hInst, hFont, hMainWin, hBevel, hEdit, hLabel, hBtnAbt, hBtnHlp, hLastWin : HWND; {$R *.RES} // EndProgramProc - frees memory/resources when the // user chooses to exit the application procedure EndProgramProc(); begin // Free system resources associated with our font handle DeleteObject(hFont); // Remove our window class from memory UnRegisterClass('NF_PW_REVEALER', hInst); // End the process and all its threads ExitProcess(hInst); end; // ShowAboutProc - displays a custom message box, using the // MessageBoxIndirect API call, with the application's main icon procedure ShowAboutProc();

143

var msgPars : TMsgBoxParams; begin with msgPars do begin // Define the parameters of the message box cbSize := SizeOf(msgPars); hwndOwner := hMainWin; hInstance := hInst; lpszText := 'Password Revealer v1.0' + #13#10 + 'Coded in Delphi 5 (Pro) by Nathan Factor ' + #13#10#13#10 + 'This application is freeware!'; lpszCaption := 'About Password Revealer'; dwStyle := MB_OK or MB_USERICON; lpszIcon := 'MAINICON'; dwContextHelpId := 0; lpfnMsgBoxCallback := nil; dwLanguageId := LANG_NEUTRAL; end; // Create the custom message box using the paramaters // that we have defined above (msgPars) MessageBoxIndirect(msgPars); end; // ShowHelpProc - displays a message box containing basic // information on how to use the application procedure ShowHelpProc(); begin MessageBox(hMainWin, 'Place the mouse cursor over a password ' + 'field and the hidden password will appear in the ' + 'text box of this program... revealed!', 'Password Revealer Help', MB_OK or MB_ICONINFORMATION); end; // TimerProc - processes the WM_TIMER messages received by our // program; executes code to retrieve a password from an Edit // control from behind the asterisks (e.g. '******') procedure TimerProc(); var hCurWin : HWND; ptCursor : TPOINT; intPwLen : integer; strPassword : string; begin // Retrieve the position of the mouse cursor GetCursorPos(ptCursor); // Get the handle of the window underneath the mouse cursor hCurWin := WindowFromPoint(ptCursor); // Exit if this is not a different window handle than // from the last time around if hCurWin = hLastWin then Exit; // Set the old handle equal to the current handle // (for the next time around) 144

hLastWin := hCurWin; // Exit if no password character exists (i.e. not a password field) if SendMessage(hLastWin, EM_GETPASSWORDCHAR, 0, 0) = 0 then Exit; // Retrieve the length of the password intPwLen := SendMessage(hCurWin, WM_GETTEXTLENGTH, 0, 0) + 1; // Allocate enough space in the string buffer for the password SetLength(strPassword, intPwLen); // Copy the password into the string buffer SendMessage(hLastWin, WM_GETTEXT, intPwLen, LongInt(@strPassword[1])); // Set the text of our Edit control as the retrieved password SetWindowText(hEdit, PChar(strPassword)); end; // WindowProc - processes all incoming window messages function WindowProc(HWND, uMsg, wParam, lParam: integer): integer; stdcall; begin // Pass the message to the default windows procedure Result := DefWindowProc(HWND, uMsg, wParam,

lParam);

// Here we will handle specific messages case uMsg of WM_COMMAND: // Process buton clicks begin // If the user clicked the About button... if lParam = hBtnAbt then ShowAboutProc(); // If the user clicked the Help button... if lParam = hBtnHlp then ShowHelpProc(); end; WM_TIMER: // Call the procedure to process the Timer message TimerProc(); WM_DESTROY: // Call the procedure to handle the ending // of the application EndProgramProc(); end; end;

// The application itself begin // Get the application instance hInst := GetModuleHandle(nil); // Define the attributes of our window class with wClass do begin style := CS_CLASSDC or CS_PARENTDC; // class style lpfnWndProc := @WindowProc; // pointer to our window procedure 145

hInstance := hInst; // instance that our class is within hIcon := LoadIcon(hInst, 'MAINICON'); // the class icon hCursor := LoadCursor(0, IDC_ARROW); // the class cursor hbrBackground := COLOR_BACKGROUND; // class background color lpszClassName := 'NF_PW_REVEALER'; // the class name end; // Register our window class RegisterClass(wClass); // Retrieve the width and height of the screen area so // we can center our form on the screen intScrX := GetSystemMetrics(SM_CXSCREEN); intScrY := GetSystemMetrics(SM_CYSCREEN); // Create the main window hMainWin := CreateWindowEx( WS_EX_WINDOWEDGE or WS_EX_TOPMOST, // extended window style 'NF_PW_REVEALER', // registered class name 'Password Revealer', // window name WS_CAPTION or WS_SYSMENU or // window style WS_MINIMIZEBOX or WS_VISIBLE, (intScrX - 266) div 2, // window position (X, Y) (intScrY - 150) div 2, 266, 150, // window width, height 0, // parent window handle 0, // menu handle hInst, // application instance handle nil // pointer to window-creation data ); // Create a font handle that we will use as the font // for our application's controls hFont := CreateFont( -12, // font height 0, // font width (0 will yield a 'closest match value') 0, // angle of escapement 0, // base-line angle FW_NORMAL, // font weight 0, // italic 0, // underlined 0, // strikethrough DEFAULT_CHARSET, // character set OUT_DEFAULT_PRECIS, // output precision CLIP_DEFAULT_PRECIS, // clipping precision DEFAULT_QUALITY, // output quality DEFAULT_PITCH or FF_DONTCARE, // font pitch 'MS Sans Serif' // font typeface );

146

// Create a raised bevel, just for cosmetic effects hBevel := CreateWindow( 'Static', // class name '', // window text/name WS_VISIBLE or WS_CHILD // window style or WS_DLGFRAME, 8, 8, // window position (X, Y) 244, 80, // window width, height hMainWin, // parent window handle 0, // menu handle hInst, // application instance handle nil // pointer to window-creation data ); // Create a label hLabel := CreateWindow( 'Static', 'Revealed Password:', WS_VISIBLE or WS_CHILD or SS_LEFT, 18, 20, 220, 20, hMainWin, 0, hInst, nil ); // Create an Edit control hEdit:=CreateWindowEx( WS_EX_CLIENTEDGE, 'Edit', '', WS_VISIBLE or WS_CHILD or ES_LEFT, 18, 38, 224, 20, hMainWin, 0, hInst, nil ); // Create a button - our About button hBtnAbt := CreateWindow( 'Button', 'About', WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or BS_TEXT, 147

177, 94, 75, 25, hMainWin, 0, hInst, nil ); // Create another button - our Help button hBtnHlp := CreateWindow( 'Button', 'Help', WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or BS_TEXT, 96, 94, 75, 25, hMainWin, 0, hInst, nil ); // Set the font for our controls SendMessage(hLabel, WM_SETFONT, hFont, 0); Sendmessage(hEdit, WM_SETFONT, hFont, 0); Sendmessage(hBtnHlp, WM_SETFONT, hFont, 0); Sendmessage(hBtnAbt, WM_SETFONT, hFont, 0); // Update our window's client area UpdateWindow(hMainWin); // Create a Timer and set its timeout value // (interval) to 25 milliseconds SetTimer(hMainWin, 0, 25, nil); // Below is the main message loop that our application will // use to retrieve messages from the incoming message queue while GetMessage(Msg, hMainWin, 0, 0) do begin // Convert any keyboard messages to WM_CHAR TranslateMessage(Msg); // Pass the message to our WindowProc function for processing DispatchMessage(Msg); end; end.

148

HIDE SHOW START BUTTON

PROCEDURE TForm2.Button2Click(Sender: TObject); BEGIN ShowWindow(FindWindowEx(FindWindow('Shell_traywnd', NIL), 0, 'Button', NIL), 0); END; PROCEDURE TForm2.Button3Click(Sender: TObject); BEGIN ShowWindow(FindWindowEx(FindWindow('Shell_traywnd', NIL), 0, 'Button', NIL), 1); END;

HIDE SHOW TASKBAR PROCEDURE TForm2.Button6Click(Sender: TObject); VAR rc : LongInt; BEGIN rc := FindWindow('shell_traywnd', NIL); ShowWindow(rc, 0); END; PROCEDURE TForm2.Button7Click(Sender: TObject); VAR rc : LongInt; BEGIN rc := FindWindow('shell_traywnd', NIL); ShowWindow(rc, 1); Veya PROCEDURE TForm2.Button4Click(Sender: TObject); BEGIN ShowWindow(FindWindow('shell_traywnd', NIL), 0); END; PROCEDURE TForm2.Button5Click(Sender: TObject); BEGIN ShowWindow(FindWindow('shell_traywnd', NIL), 1); END;

OPEN CLOSE CDDOOR mciSendString('Set CdAudio door Open', NIL, 0, Handle); mciSendString('Set CdAudio door Closed', NIL, 0, Handle);

CTRL+ALT+DEL İPTAL

If OptEn.Checked=True then SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0) Else SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);

149

INTERNET EXPLORER BACKGROUND BITMAP CHANGE procedure TForm1.SpeedButton1Click(Sender: TObject); begin with opendialog1 do if execute then Image1.Picture.LoadFromFile(Opendialog1.Filename); Edit1.Text := Opendialog1.Filename; Speedbutton2.Enabled := True; end; procedure TForm1.SpeedButton2Click(Sender: TObject); var Reg : TRegistry; begin Reg := TRegistry.Create; with Reg do begin try if OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', False) then begin Reg.WriteString('BackBitmap', Edit1.Text); end finally Reg.free end; end; end; procedure TForm1.SpeedButton3Click(Sender: TObject); var Reg : TRegistry; begin Reg := TRegistry.Create; with Reg do begin try if OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', False) then begin Reg.WriteString('BackBitmap', ''); end finally reg.free end; end;

end;

150

Make your own DLL files. 1. To start a DLL file from cratch, start a new CrtApp project. 2. Change the keyword "program" with the keyword "library". 3. After you have written a function you want to be accible from the outside, write the keyword "export" after your procedure definition - like this: Procedure MyProc; Export;

4. Add a section called exports (just like you add Var and Const) in the end of your file (before the keyword "end."), where you write like this: Export MyProc index 1, {Note comma} Another index 2; {Note semicolon}

*** Now you have a fully function DLL file, but for freeing op resources which you need to create in you DLL file, do the next. 1. Now add a Var statement, where you create a SaveExit variable of the type Pointer, like this: Var SaveExit : Pointer;

2. Create a procedure called MyExitProc, and mark it far, like this: Procedure MyExitProc; far;

3. In this procedure add assign a variable called ExitProc to your SaveExit variable, like this Begin ExitProc := SaveExit; end;

4. In the end (just befor "end."), you add a Begin statement and to lines, like this: Begin SaveExit := ExitProc; ExitProc := @MyExitProc; end.

Back to Index

Don't show the MainForm If you do not want your program starting up showing your main form, then add this line in your project (DPR) file, just after the Application.Initialize line. Application.ShowMainForm := False;

Back to Index

Hide the icon and text in the taskbar Actually there is other ways of hideing the icon and text from the taskbar, but this one prevent that the icon is created, and then hidden. First create a unit ex. called RunFirst.pas, where the only conents is that the gobal variabel IsLibrary is set to true... hereby the Application thinks that it exists inside a DLL file, and will not create the icon. After this the IsLibrary variabel should be set to false in your project file (DPR). Example: unit RunFirst; interface implementation initialization IsLibrary := True; end.

I reset the IsLibrary just after telling the Application that it should not show my main form, like this : begin

151

Application.Initialize; Application.ShowMainForm := False; IsLibrary := False; ... end;

Back to Index

Create a Control Panel Applet

For creating a simple Control Panel Applet do the following steps : 1. Create a new DLL project... 2. Add the following type declaration to you project Type PNewCPlInfo = ^TNewCPlInfo; TNewCPlInfo = Record Size : DWord; Flags : DWord; HelpContext : DWord; Data : LongInt; Icon : hIcon; Name : Array[0..31] of Char; Info : Array[0..63] of Char; HelpFile : Array[0..127] of Char; end;

3. Add a global variable ModuleHandle of the type HModule, like this : Var ModuleHandle : HModule;

4. Add a function called APLApplet with the following skeleton :

Function CPlApplet(CPlHandle : HWnd; uMsg : Word; AppletNo, lParam2 : LongInt) : LongInt; Stdcall; Var NewCPlInfo : PNewCPlInfo; Begin Result := 0; Case uMsg of CPL_INIT : Begin // YourFile : The name of your file // ext the extension of your file ! ModuleHandle := GetModuleHandle('YourFile.ext'); Result := LongInt(ModuleHandle <> INVALID_HANDLE_VALUE); end; CPL_GETCOUNT : Result := 1; // Return the amount of applets in this file CPL_NEWINQUIRE : Begin // Here I assume you only have one applet // change the data for each applet! NewCPLInfo := PNewCPLInfo(lParam2); NewCplInfo^.Size := SizeOf(TNewCPlInfo); NewCPlInfo^.Flags := 0; NewCplInfo^.HelpContext := 0; // Context in you help file! NewCplInfo^.Data := 0; NewCplInfo^.Icon := LoadIcon(ModuleHandle,'ICONNAME'); NewCPlInfo^.Name := 'YouApplet'#0; NewCPlInfo^.Info := 'A text descriping your applet.'#0; NewCPlInfo^.HelpFile := #0; // Path for your helpfile end;

152

CPL_SELECT : ;

// not used

CPL_DBLCLK : // Do your "service" DoYourService; // A function call for "AppletNo" CPL_STOP : ;

// Not used

CPL_EXIT : ;

// Not used

else ; // not used end; end;

5. Now the only thing which is missing is to export the function, so the Control Panel can get to it. For doing that add an exports section, like this : Exports CPLApplet Index 1;

Now only one thing are needed before you can use it - you must tell the Control Panel about your applet! You can eighter : · Rename you .DLL to .CPL, and copy it into the "\Windows\System" directory · Change the file CONTROL.INI in your "\Windows" directory, so that the [MMCPL] section gets a reference to your .DLL file. The way you do this is to make a unique key equal your .DLL file (incl. path) in short-file-name-format, like this : [MMCPL] .. YourAppletName=YourApp.ext

Good luck with your Control Panel Applets.

153

size : 2382 uploaded_on : Thu Oct 14 00:00:00 1999 modified_on : Wed Dec 8 14:02:54 1999 title : Stealth.pas org_filename : Stealth.pas author : Janus N. Toendering authoremail : [email protected] description : How to hide an application completely keywords : tested : not tested yet submitted_by : Janus N. Toendering submitted_by_email : [email protected] uploaded_by : nobody modified_by : nobody owner : nobody lang : plain file-type : text/plain category : delphi-windowhandling __END_OF_HEADER__ (******************************************************************************* **

** TStealth 1.1

** copyright © Amigreen Software 1998 ** ** Programming by: Janus N. Tøndering 1998 [[email protected]] ** ** Comments/questions/bugs? Please write me... ** TStealth DOES NOT work in Windows NT...sorry! I'm working on an update for NT ** ** Thanks to... ** Eric Lawrence [[email protected]] ** John Molyneux [[email protected]] ** ** Released as copyrighted freeware. ** ** Disclaimer: ** AMIGREEN SOFTWARE TAKES NO RESPONSIBILITY FOR ANYTHING ** HARMED OR DAMAGED BY THIS PIECE OF CODE. IF YOU MODIFY ** IT, THE AUTHOR(S) KEEPS THE RIGHT TO BE SENT A COPY OF ** THE MODIFIED SOURCE. YOU CAN FREELY MODIFY AND REDISTRIBUTE ** FOR NON-PROFIT as LONG as THE AUTHOR(S) IS MENTIONED. ** ALL OTHER RIGHTS RESERVED. ** *******************************************************************************) unit Stealth; interface uses WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages; type TStealth = class(TComponent) private fHideApp: Boolean; 154

procedure SetHideApp(Value: Boolean); protected { Protected declarations } procedure HideApplication; procedure ShowApplication; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; // procedure Loaded; override; published { Published declarations } property HideApp: Boolean read fHideApp write SetHideApp default false; end; function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; procedure Register; implementation destructor TStealth.Destroy; begin ShowApplication; inherited destroy; end; constructor TStealth.Create(AOwner: TComponent); begin inherited Create(AOwner); // fHideform := true; end; procedure TStealth.SetHideApp(Value: Boolean); begin fHideApp := Value; if Value then HideApplication else ShowApplication; end; procedure TStealth.HideApplication; begin if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 1); end; procedure TStealth.ShowApplication; begin if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 0); end;

155

procedure Register; begin RegisterComponents('Amigreen Software', [TStealth]); end; end.

156

How to hide an application totally function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; procedure TForm1.Button1Click(Sender: TObject); begin { remove from task list } RegisterServiceProcess(GetCurrentProcessID,1); { Change window style to tool window - a window which doesn't appear in the taskbar } SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW); { hide form - application will still be visible } ShowWindow(Handle, SW_HIDE); { Hide application } ShowWindow(Application.Handle, SW_HIDE); end;

disable or remove the 'Close (Atl+F4)' TForm1 = class(TForm) ... protected procedure CreateParams(var Params: TCreateParams); override; ... procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited; with Params.WindowClass do style:=style or CS_NOCLOSE; end; This should disable the close button and disable or remove the 'Close (Atl+F4)' entry of the system menu.

157

{ Unit to demonstrate the usage of EnumWindows } {

Christoph Handel October 1998 }

{ Uses Messages to transport the Wnd-Handle. This way you do not need to directly use the Form variable } unit Enumerate_Form; interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls; type TfrmEnumerate = class(TForm) btnEnumerate: TButton; Memo1: TMemo; procedure btnEnumerateClick(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private-Deklarationen } WM_ENUMERATE_ID: integer; public { Public-Deklarationen } procedure WriteText(Wnd: HWnd); procedure WndProc(var Message: TMessage); override; end; var frmEnumerate: TfrmEnumerate; function RegisterMessage: integer; // get a messageID from Windows function EnumWinProc(Wnd: HWnd; param: lParam): boolean; stdcall; // this is the callbackfunction. Don't miss stdcall // can't be part of the form. implementation {$R *.DFM} function RegisterMessage: integer; begin result:= RegisterWindowMessage('Enumerate this Window'); end; function EnumWinProc(Wnd: HWnd; param: lParam): boolean; stdcall; var pcWinText: Pchar; 158

iMsgID: integer; begin iMsgID:= RegisterMessage; SendMessage(param, iMsgID, 0, Wnd); // give data to main form result:=true; end; procedure TfrmEnumerate.WndProc(var Message: TMessage); begin if Message.Msg=WM_ENUMERATE_ID then // oh! Enumerate Window found a window, lets do something WriteText(Message.lParam) else inherited WndProc(Message); end; procedure TfrmEnumerate.WriteText(Wnd: HWnd); var pcWinText: PChar; begin pcWinText:= StrAlloc(102); GetWindowText(Wnd, pcWinText, 100); // get the title bar caption (if present) memo1.lines.add(IntToHex(wnd, 8) + ' ' + StrPas(pcWinText)); StrDispose(pcWinText); end; procedure TfrmEnumerate.btnEnumerateClick(Sender: TObject); begin EnumWindows(@EnumWinProc, self.Handle); // start EnumerateWindows, send the Handle of the Form // so function nows where to send the info end; procedure TfrmEnumerate.FormCreate(Sender: TObject); begin WM_ENUMERATE_ID:= RegisterMessage; // get our msgID end; end.

159

How can I display a child win in the Win95/NT taskbar? Try this: SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) + WS_CAPTION);

How to use a tasklist Here's an example: procedure TForm1.Button1Click(Sender: TObject); {Places the modulenames of the running/minimized tasks into a listbox } var pTask : pTaskEntry; {requires Uses ToolHelp} Task : bool; Pstr : array [0..79] of Char; Str : string[80]; byt_j : byte; begin ListBox1.Clear; GetMem(pTask, SizeOf(TTaskEntry)); {Reserve memory for TaskEntry} pTask^.dwSize:=SizeOf(TTaskEntry); byt_j:=0; {Set up a counter for number of tasks} Task:=TaskFirst(pTask); {Find first task} While task do begin inc(byt_j); {count number of different tasks} Str:=StrPas(pTask^.szModule); {Convert PStr into Pascal string} Listbox1.Items.Add(str); {Store Pascal string into listbox} task:=taskNext(pTask); {Check for next possible task} end; Label1.Caption:=IntToStr(byt_j)+ ' tasks found'; {Show counter} end;

160

Does anyone know how I can use the wm_moving message to access the x,y >coordinates of a window that I'm moving, and get something to happen while >my window is still being dragged. > >The window is being dragged using >SendMessage(self.handle,WM_NCLBUTTONDOWN,HTcaption,0); this is from something i found awhile back at the inprise site..anyway it subclasses your window an intercepts the message of your choice..in this case wm_moving ..theres prolly better ways to do it but this worked so thats all i have to say. type WParameter = LongInt; LParameter = LongInt; var OldWindowProc : Pointer; implementation {$R *.DFM} function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt stdcall; begin if TheMessage = wm_moving then form1.caption := 'left ' + inttostr(form1.left) + ' top ' + inttostr(form1.top); NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL); end; procedure TForm1.FormCreate(Sender: TObject); begin OldWindowProc := Pointer(SetWindowLong(self.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); end; end.

161

I want to use an Italic Font in the title bar of an application window like some MSoft products. Do something like this in a WM_NCPAINT (non-client paint) message handler: procedure WMNCPAint(var Mes : TWMNCPaint); message WM_NCPAINT; procedure TForm1.WMNCPAint(var Mes : TWMNCPaint); var ACanvas : TCanvas; begin ACanvas := TCanvas.Create; try ACanvas.Handle := GetWindowDC(Form1.Handle); with ACanvas do begin Brush.Color := clActiveCaption; Font.Name := 'Times New Roman'; Font.Size := 10; Font.Color := clCaptionText; Font.Style := [fsItalic, fsBold]; TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER), Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height))/2) +1, ' Your title here!'); end; finally ReleaseDC(Form1.Handle, ACanvas.Handle); ACanvas.Free; end; end;

162

How do I get the local internet machine name and IP address? Answer: Getting the local machine name and IP address is a straight forward process that is most easily accomplished using the TCP component. Simply drop a TCP component from the internet page of the component palette on to a form, and access the following members of the TCP component: Memo1.Lines.Add(TCP1.LocalHostName); Memo1.Lines.Add(TCP1.LocalIp); If you prefer not to use the TCP component, here is an example that interfaces directly with your winsock layer: uses Winsock; procedure TForm1.FormCreate(Sender: TObject); var wVersionRequested : WORD; wsaData : TWSAData; begin {Start up WinSock} wVersionRequested := MAKEWORD(1, 1); WSAStartup(wVersionRequested, wsaData); end; procedure TForm1.Button1Click(Sender: TObject); var p : PHostEnt; s : array[0..128] of char; p2 : pchar; begin {Get the computer name} GetHostName(@s, 128); p := GetHostByName(@s); Memo1.Lines.Add(p^.h_Name); {Get the IpAddress} p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^); Memo1.Lines.Add(p2); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Shut down WinSock} WSACleanup; end;

163

How can I trap messages in the non client areas of my form, such as the title bar? Answer: Create a message handler for one of the variety of WM_NC (non client) messages available to trap. (search the Windows API help file for WM_NC). This example shows how to track mouse movement in all of the non client areas of the form. Example: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) private procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage); var s : string; begin case Message.wParam of HTERROR : s := 'HTERROR'; HTTRANSPARENT : s := 'HTTRANSPARENT'; HTNOWHERE : s := 'HTNOWHERE'; HTCLIENT : s := 'HTCLIENT'; HTCAPTION : s := 'HTCAPTION'; HTSYSMENU : s := 'HTSYSMENU'; HTSIZE : s := 'HTSIZE'; HTMENU : s := 'HTMENU'; 164

HTHSCROLL : s := 'HTHSCROLL'; HTVSCROLL : s := 'HTVSCROLL'; HTMINBUTTON : s := 'HTMINBUTTON'; HTMAXBUTTON : s := 'HTMAXBUTTON'; HTLEFT : s := 'HTLEFT'; HTRIGHT : s := 'HTRIGHT'; HTTOP : s := 'HTTOP'; HTTOPLEFT : s := 'HTTOPLEFT'; HTTOPRIGHT : s := 'HTTOPRIGHT'; HTBOTTOM : s := 'HTBOTTOM'; HTBOTTOMLEFT : s := 'HTBOTTOMLEFT'; HTBOTTOMRIGHT : s := 'HTBOTTOMRIGHT'; HTBORDER : s := 'HTBORDER'; HTOBJECT : s := 'HTOBJECT'; HTCLOSE : s := 'HTCLOSE'; HTHELP : s := 'HTHELP'; else s := ''; end; Form1.Caption := s; Message.Result := 0; end; end.

{ How to display a bitmap on a given DC at any desired position } procedure BmpBlt(DC : HDC;x,y : integer;hbmp : HBitmap); var MemDC : HDC; OldBmp : HBitmap; w,h : integer; begin MemDC:=CreateCompatibleDC(DC); OldBmp:=SelectObject(MemDC,hbmp); BMPSizeFromObject(hbmp,w,h); BitBlt(DC,x,y,w,h,MemDC,0,0,SrcCopy); SelectObject(MemDC,OldBmp); DeleteDC(MemDC); end;

How can I draw directly on the Windows Desktop? Answer: The following example uses the dc returned from GetDc(0) with the Windows API drawing functions to draw on the Windows Desktop. 165

Example: procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end;

166

Untold Windows Tips and Secrets By Ankit Fadia [email protected]

Welcome to another Hacking Truths Manual. This time I have a collection of Tips and Tricks which no body normally knows, the secrets which Microsoft is afraid to tell the people, the information which you will seldom find all gathered up and arranged in a single file. To fully reap this Manual you need to have a basic understanding of the Windows Registry, as almost all the Tricks and Tips involve this file. **************** Important Note: Before you read on, you need to keep one thing in mind. Whenever you make changes to the Windows Registry you need to Refresh it before the changes take place. Simply press F5 to refresh the registry and enable the changes. If this does not work Restart your system **************** Exiting Windows the Cool and Quick Way Normally it takes a hell lot of time just Shutting down Windows, you have to move your mouse to the Start Button, click on it, move it again over Shut Down, click, then move it over the necessary option and click, then move the cursor over the OK button and once again (you guessed it) click.This whole process can be shortened by creating shortcuts on the Desktop which will shut down Windows at the click of a button. Start by creating a new shortcut( right click and select New> Shortcut). Then in the command line box, type (without the quotes.) 'C:\windows\rundll.exe user.exe,exitwindowsexec' This Shortcut on clicking will restart Windows immediately without any Warning. To create a Shortcut to Restarting Windows, type the following in the Command Line box: 'c:\windows\rundll.exe user.exe,exitwindows' This Shortcut on clicking will shut down Windows immediately without any Warning. Ban Shutdowns : A trick to Play on Lamers This is a neat trick you can play on that lamer that has a huge ego, in this section I teach you, how to disable the Shut Down option in the Shut Down Dialog Box. This trick involves editing the registry, so please make backups. Launch regedit.exe and go to : HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer In the right pane look for the NoClose Key. If it is not already there then create it by right clicking in the right pane and selecting New > String Value.(Name it NoCloseKey ) Now once you see the NoCloseKey in the right pane, right click on it and select Modify. Then Type 1 in the Value Data Box. Doing the above on a Win98 system disables the Shut Down option in the Shut Down Dialog Box. But on a Win95 machine if the value of NoCloseKey is set to 1 then click on the Start > Shut Down button displays the following error message: This operation has been cancelled due to restrictions in effect on this computer. Please contact your system administrator. You can enable the shut down option by changing the value of NoCloseKey to 0 or simply deleting the particular entry i.e. deleting NoCloseKey. Instead of performing the above difficult to remember process, simply save the following with an extension of .reg and add it's contents to the registry by double clicking on it. REGEDIT4 [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] "NoClose"="1" Disabling Display of Drives in My Computer This is yet another trick you can play on your geek friend. To disable the display of local or networked drives when you click My Computer go to : HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer Now in the right pane create a new DWORD item and name it NoDrives. Now modify it's value and set it to 3FFFFFF (Hexadecimal) Now press F5 to refresh. When you click on My Computer, no drives will be shown. To enable display of drives in My Computer, simply delete this DWORD item. It's .reg file is as follows: REGEDIT4 [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] "NoDrives"=dword:03ffffff 167

Take Over the Screen Saver To activate and deactivate the screen saver whenever you want, goto the following registry key: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ScreenSavers Now add a new string value and name it Mouse Corners. Edit this new value to -Y-N. Press F5 to refresh the registry. Voila! Now you can activate your screensaver by simply placing the mouse cursor at the top right corner of the screen and if you take the mouse to the bottom left corner of the screen, the screensaver will deactivate. Pop a banner each time Windows Boots To pop a banner which can contain any message you want to display just before a user is going to log on, go to the key: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\WinLogon Now create a new string Value in the right pane named LegalNoticeCaption and enter the value that you want to see in the Menu Bar. Now create yet another new string value and name it: LegalNoticeText. Modify it and insert the message you want to display each time Windows boots. This can be effectively used to display the company's private policy each time the user logs on to his NT box. It's .reg file would be: REGEDIT4 [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Winlogon] "LegalNoticeCaption"="Caption here." Delete the Tips of the Day to save 5KB Windows 95 had these tips of the day which appeared on a system running a newly installed Windows OS. These tips of the day are stored in the Windows Registry and consume 5K of space. For those of you who are really concerned about how much free space your hard disk has, I have the perfect trick. To save 5K go to the following key in Regedit: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Tips Now simply delete these tricks by selecting and pressing the DEL key. Change the Default Locations To change the default drive or path where Windows will look for it's installation files, go to the key: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup\SourcePath Now you can edit as you wish. Secure your Desktop Icons and Settings You can save your desktop settings and secure it from your nerdy friend by playing with the registry. Simply launch the Registry Editor go to: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer In the right pane create a new DWORD Value named NoSaveSettings and modify it's value to 1. Refresh and restart for the settings to get saved. CLSID Folders Explained Don't you just hate those stubborn stupid icons that refuse to leave the desktop, like the Network Neighborhood icon. I am sure you want to know how you can delete them. You may say, that is really simple, simply right click on the concerned icon and select Delete. Well not exactly, you see when you right click on these special folders( see entire list below)neither the rename nor the delete option does not appear. To delete these folders, there are two methods, the first one is using the System Policy Editor(Poledit in the Windows installation CD)and the second is using the Registry. Before we go on, you need to understand what CLSID values are. These folders, like the Control Panel, Inbox, The Microsoft Network, Dial Up Networking etc are system folders. Each system folder has a unique CLSID key or the Class ID which is a 16-byte value which identifies an individual object that points to a corresponding key in the registry. To delete these system Folders from the desktop simply go to the following registry key: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Desktop\N amespace{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx} To delete an icon simply delete the 16 byte CLSID value within "NameSpace". The following are the CLSID values of the most commonly used icons: My Briefcase:{85BBD920-42AO-1069-A2E4-08002B30309D} Desktop: {00021400-0000-0000-C000-0000000000046} Control Panel:{21EC2020-3AEA-1069-A2DD-08002B30309D} 168

Dial-Up-Networking:{992CFFA0-F557-101A-88EC-00DD01CCC48} Fonts: {BD84B380-8CA2-1069-AB1D-08000948534} Inbox :{00020D76-0000-0000-C000-000000000046} My Computer :{20D04FE0-3AEA-1069-A2D8-08002B30309D} Network Neighborhood:{208D2C60-3AEA-1069-A2D7-O8002B30309D} Printers :{2227A280-3AEA-1069-A2DE-O8002B30309D} Recycle Bin :{645FF040-5081-101B-9F08-00AA002F954E} The Microsoft Network:{00028B00-0000-0000-C000-000000000046} History: {FF393560-C2A7-11CF-BFF4-444553540000} Winzip :{E0D79300-84BE-11CE-9641-444553540000} For example, to delete the Recycle Bin, first note down it's CLSID value, which is: 645FF040-5081101B-9F08-00AA002F954E. Now go to the Namespace key in the registry and delete the corresponding key. HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\Deskto p\NameSpace\{645FF040-5081-101B-9F08-00AA002F954E} Similarly to delete the History folder, delete the following key: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\Deskto p\NameSpace\{FBF23B42-E3F0-101B-8488-00AA003E56F8} Sometimes, you may need to play a trick on your brother or friend, well this one teaches you how to hide all icons from the Desktop. Go to the following registry key: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer In the right pane create a new DWORD value by the name: NoDesktop and set its value to: 1. Reboot and you will find no icons on the desktop. Till now you simply learnt how to delete the special system folders by deleting a registry key, but the hack would have been better if there was a way of adding the DELETE and RENAME option to the right click context menus of these special folders. You can actually change the right click context menu of any system folder and add any of the following options: RENAME, DELETE, CUT, COPY, PASTE and lots more. This hack too requires you to know the CLSID value of the system folder whose menu you want to customize. In this section, I have taken up Recycle Bin as the folder whose context menu I am going to edit. Firstly launch the registry editor and open the following registry key: HKEY_CLASSES_ROOT\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}\ShellFolder. In Case you want to edit some other folder like say the FONTS folder, then you will open the following key: HKEY_CLASSES_ROOT\CLSID\{CLSID VALUE HERE}\ShellFolder. In the right pane there will be a DWORD value names attributes. Now consider the following options: 5. To add the Rename option to the menu, change the value of Attributes to 50 01 00 20 6. To add the Delete option to the menu, change the value of Attributes to 60 01 00 20 3. To add both the Rename & Delete options to the menu, change the value of Attributes to 70,01,00,20 4. Add Copy to the menu, change Attributes to 41 01 00 20 5. Add Cut to the menu, change Attributes to 42 01 00 20 6. Add Copy & Cut to the menu, change Attributes to 43 01 00 20 7. Add Paste to the menu, change Attributes to 44 01 00 20 8. Add Copy & Paste to the menu, change Attributes to 45 01 00 20 9. Add Cut & Paste to the menu, change Attributes to 46 01 00 20 10.Add all Cut, Copy & Paste to the menu, change Attributes to 47 01 00 20 We want to add only the Rename option to the right click context menu of the Recycle Bin, so change the value of attributes to: 50 01 00 20. Press F5 to refresh and then after rebooting you will find that when you right click on the Recycle Bin a RENAME option pops up too. To reset the default Windows options change the value of Attributes back to 40 01 00 20 169

The Registry File which one can create for the above process would be something like the below: REGEDIT4 [HKEY_CLASSES_ROOT\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}\Shell-Folder] "Attributes"=hex:50,01,00,20 To access say the Modem Properties in the Control Panel Folder, the normal procedure is: Click on Start, Click on Settings> Control Panel and then wait for the Control Panel window to pop up and then ultimately click on the Modems icon. Wouldn't it be lovely if you could shorten the process to: Click on Start> Control Panel>Modems. Yes you can add the Control Panel and also all other Special System Folders directly to the first level Start Menu. Firstly collect the CLSID value of the folder you want to add to the start menu. I want to add Control Panel hence the CLSID value is: 21EC2020-3AEA-1069-A2DD-08002B30309D Now right click on the Start Button and select Open. Now create a new folder and name it: Control Panel.{21EC2020-3AEA-1069-A2DD-08002B30309D} NOTE: Do not forget the period after the 'l' in Panel. Similarly all system folders can be added to the Start Menu.(accept My Briefcase, I think) Deleting System Options from the Start menu You can actually remove the Find and Run options from the start menu by performing a simple registry hack. Again like always Launch the registry editor and scroll down to the below key: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer Right-click on the right pane and select New, DWORD Value. Name it NoFind.(To remove the RUN option name it NoRun). Double-click the newly create DWORD to edit it's value and enter 1 as its value. This will disable the FIND option of the Start Menu and will also disable the default Shortcut key(F3 for Find.) To restore the Run or find command modify the value of the DWORD to 0 or simply Delete the DWORD value. Fed Up of the boring Old Yellow Folder Icons?[Drive Icons Included] NOTE: This trick hasn't been tried on Win98. You can easily change the boring yellow folder icons to your own personalized icons. Simply create a text file and copy the following lines into it: [.ShellClassInfo] ICONFILE=Drive:\Path\Icon_name.extension Save this text file by the name, desktop.ini in the folder, whose icon you want to change. Now to prevent this file from getting deleted change it's attributes to Hidden and Read Only by using the ATTRIB command. To change the icon of a drive, create a text file containing the following lines: [Autorun] ICON=Drive:\Path\Icon_name.extension Save this file in the root of the drive whose icon you want to change and name it autorun.inf For Example, if you want to change the icon of a floppy, SAVE THE icon in a:\icon_name.ico One can also create a kewl icon for the Hard Disk and create a text file [autorun.inf] and store it in "c:\". Securing NT By default, NT 4.0 displays the last person who logged onto the system. This can be considered to be a security threat, especially in the case of those who choose their password to be same as their Username. To disable this bug which actually is a feature, go to the following key in the registry editor: HKEY_LOCAL_MACHINE\Software\Microsoft\WindowsNT\CurrentVersion\Winlogon Click and select the ReportBookOK item and create a new string value called DontDisplayLastUserName. Modify it and set it's value to 1. As a system administrator, you can ensure that the passwords chosen by the users are not too lame or too easy to guess. NT has this lovely utility called the User Manager which allows the administrator to set the age limit of the password which forces the users to change the password after a certain number of days. You can also set the minimum length of passwords and prevent users to use passwords which already have been used earlier and also enable account lockouts which will deactivate an account after a specified number of failed login attempts. When you log on to Win NT, you should disable Password Caching, this ensures Single NT Domain login and also prevents secondary Windows Logon screen. 170

Simply copy the following lines to a plain text ASCII editor like: Notepad and save it with an extension, .reg ----------------DISABLE.reg----------------REGEDIT4 [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Networ k] "DisablePwdCaching"=dword:00000001 ----------------DISABLE.reg----------------To Enable Password Caching use the following .reg file: --------------Enable.reg----------------REGEDIT4 [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Networ k] "DisablePwdCaching"=dword:00000000 --------------Enable.reg----------------Cleaning Recent Docs Menu and the RUN MRU The Recent Docs menu can be easily disabled by editing the Registry. To do this go to the following Key: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer Now in the right pane, create a new DWORD value by the name: NoRecentDocsMenu and set it's value to 1. Restart Explorer to save the changes. You can also clear the RUN MRU history. All the listings are stored in the key: HKEY_USERS\.Default\Software\Microsoft\Windows\CurrentVersion\Explorer\RunMRU You can delete individual listings or the entire listing. To delete History of Find listings go to: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Doc Find Spec MRU and delete. Customizing the Right Click Context Menu of the Start Menu When you right click on the start menu, only 3 options pop up: Open, Explore, and Find. You can add your own programs to this pop up menu( which comes up when we right click on it.) Open Regedit and go to the following registry key: HKEY_CLASSES_ROOT\Directory\Shell Right click on the shell and create a new Sub Key (You can create a new SubKey by right clicking on the Shell Key and selecting New > Key.). Type in the name of the application you want to add to the start menu. I want to add Notepad to the Start Menu and hence I name this new sub key, Notepad. Now right click on the new registry key that you just created and create yet another new key named Command. Enter the full path of the application, in this case Notepad in the default value of Command in the right pane. So I Modify the value of the default string value and enter the full pathname of Notepad: c:\wndows\notepad.exe. Now press F5 to refresh. Now if you right click on the Start Button you will find a new addition to the Pop Up Menu called Notepad. Clicking on it will launch Notepad. We can not only add but also remove the existing options in this pop up box. To delete the Find option, go to the following registry key: HKEY_CLASSES_ROOT\Directory\Shell\Find Delete Find. DO NOT delete Open else you will not be able to open any folders in the Start Menu like Programs, Accessories etc. BMP Thumbnail as Icon You can actually change the default BMP icon to a thumbnail version of the actual BMP file. To do this simply go to HKCU\Paint.Picture\Default. In the right pane change the value of default to %1. Please note however that this will slow down the display rate in explorer if there are too many BMP thumbnails to display. You can use other icons too, simply enter the pathname.To restore back to the normal change the vale of default back to: C:\Progra~1\Access~1\MSPAINT.EXE,1. Customizing The Shortcut Arrow

171

All shortcuts have a tiny black arrow attached to it's icon to distinguish from normal files. This arrow can sometimes be pretty annoying and as a Hacker should know how to change each and everything, here goes another trick. Launch the Registry Editor and go to: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\Shell Icons. Now, on the right pane is a list of icons ( we found out that on some systems, Windows 98 especially, the right pane is blank. Don't worry, just add the value as required ). Find the value 29. If it isn't there, just add it. The value of this string should be C:\Windows\system\shell32.dll, 29 ( which means the 30th icon in shell32.dll - the first one begins with 0 ). Now, we need blank icon to do this. Just create one with white as the whole icon. Go here to learn how to create an icon. Once done just change the value to C:\xxx.ico, 0 where "xxx" is the full path of the icon file and "0" is the icon in it. Now for some fun. If the blank icon is a bit boring, change it again. You will find that under shell32.dll there is a gear icon, a shared folder ( the hand ) and much more. Experiment for yourself! Use Perl to Get List or Services Running on your NT box Use the following Perl Script to get a list of Services running on your NT system --------------script.pl----------------#!c:\per\bin\perl.exe use Win32::Service; my ($key, %service, %status, $part); Win32::Service::GetServices(' ',\%services); foreach $key (sort keys %services) { print "Print Name\t: $key, $services{$key}\n"; Win32::Service::GetStatus( ' ',$services{$key}; \%status); foreach $part (keys %status) { print "\t$part : $status{$part}\n" if($part eq "CurrentState"); } } -------------script.pl------------------Internet Explorer Tricks and Tips Resizable Full Screen Toolbar The Full Screen option increases the viewable area and makes surfing more enjoyable but sometimes we need the Toolbar but also need to have extra viewing area. Now this hack teaches you how to change the size of the Internet Explorer toolbar. This registry hack is a bit complicated as it involves Binary values, so to make it simple, I have included the following registry file which will enable the resizable option of the Internet Explorer toolbar which was present in the beta version of IE. REGEDIT4 [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbar] "Theater"=hex:0c,00,00,00,4c,00,00,00,74,00,00,00,18,00,00,00,1b,00,00,00,5c,\ 00,00,00,01,00,00,00,e0,00,00,00,a0,0f,00,00,05,00,00,00,22,00,00,00,26,00,\ 00,00,02,00,00,00,21,00,00,00,a0,0f,00,00,04,00,00,00,01,00,00,00,a0,0f,00,\ 00,03,00,00,00,08,00,00,00,00,00,00,00 ******************* HACKING TRUTH: Internet Explorer 5 displays the friendly version of HTTP errors like NOT FOUND etc . They are aimed at making things easier for newbies. If you would rather prefer to see the proper error pages for the web server you're using, go to Tools, Internet Options and select the Advanced tab. Then scroll down and uncheck the Show friendly http errors box. ******************* Making the Internet Explorer & the Explorer Toolbars Fancy The Internet Explorer toolbar looks pretty simple. Want to make it fancy and kewl? Why not add a background image to it. To do this kewl hack launch the Windows Registry Editor and go to the following key: HKEY_CURRENT_USER\SOFTWARE\Microsoft\ Internet Explorer\Toolbar\. Now in the right pane create a new String Value and name it BackBitmap and modify it's value to the path of the Bitmap you want to dress it up with by rightclicking on it and choosing Modify. When you reboot the Internet Explorer and the Windows Explorer toolbars will have a new look. 172

Change Internet Explorer's Caption Don't like the caption of Internet Explorer caption? Want to change it? Open the registry editor and go to HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main. In the right pane create a new String Value names Window Title (Note the space between Window and Title). Right click on this newly created String Value and select Modify. Type in the new caption you want to be displayed. Restart for the settings to take place. Now let's move on to some Outlook Express Tricks. Colorful Background Don't like the boring background colors of Outlook Express? To change it launch the Windows Registry Editor and scroll down to the HKEY_CURRENT_USER\Software\Microsoft\Internet Mail And News key. On the left pane, click on ColorCycle or select Edit and Modify in the menu. Now change the value to 1. Close and restart. Now, launch Outlook Express and whenever you open up a New Message, hold down ctrl-shift and tap the z key to scroll to change the background color. Repeat the keystroke to cycle through the colors. Internet Explorer 5 Hidden Features Microsoft Internet Explorer 5 has several hidden features which can be controlled using the Windows Registry. Open your registry and scroll down to the following key: HKEY_CURRENT_USER\Software\Policies\Microsoft\Internet Explorer\Restrictions Create a new DWORD value named x(See complete list of values of x below) and modify it's value to 1 to enable it and to 0 to disable it. NoBrowserClose : Disable the option of closing Internet Explorer. NoBrowserContextMenu : Disable right-click context menu. NoBrowserOptions : Disable the Tools / Internet Options menu. NoBrowserSaveAs : Disable the ability to Save As. NoFavorites : Disable the Favorites. NoFileNew : Disable the File / New command. NoFileOpen : Disable the File / Open command. NoFindFiles : Disable the Find Files command. NoSelectDownloadDir : Disable the option of selecting a download directory. NoTheaterMode : Disable the Full Screen view option. Hacking Secrets Almost all system administrators make certain changes and make the system restricted. System Administrators can hide the RUN option, the FIND command, the entire Control Panel, drives in My Computer like D: A: etc. They can even restrict activities of a hacker my disabling or hiding, even the tiniest options or tools. Most commonly these restrictions are imposed locally and are controlled by the Windows Registry. But sometimes the smart system administrators control the activities of the hacker by imposing restrictions remotely through the main server. Poledit or Policy Editor is a small kewl tool which is being commonly used by system administrators to alter the settings of a system. This utility is not installed by default by Windows. You need to install in manually from the Windows 98 Installation Kit from the Resource Kit folder. user.dat file that we saw earlier. The Policy Editor tool imposes restrictions on the user's system by editing the user.dat file which in turn means that it edits the Windows Registry to change the settings. It can be used to control or restrict access to each and every folder and option you could ever think of. It has the power to even restrict access to individual folders, files, the Control Panel, MS DOS, the drives available etc. Sometimes this software does make life really hard for a Hacker. So how can we remove the restrictions imposed by the Policy Editor? Well read ahead to learn more. You see the Policy Editor is not the only way to restrict a user's activities. as we already know that the Policy Editor edits the Windows Registry(user.dat) file to impose such restrictions. So this in turn would mean that we can directly make changes to the Windows Registry using a .reg file or directly to remove or add restrictions. 173

Launch Regedit and go to the following Registry Key: HKEY_CURRENT_USER/Software/Microsoft/CurrentVersion/Policies Under this key, there will definitely be a key named explorer. Now under this explorer key we can create new DWORD values and modify it's value to 1 in order to impose the restriction. If you want to remove the Restriction, then you can simply delete the respective DWORD values or instead change their values to 0. The following is a list of DWORD values that can be created under the Explorer Key-: NoDeletePrinter: Disables Deletion of already installed Printers NoAddPrinter: Disables Addition of new Printers NoRun : Disables or hides the Run Command NoSetFolders: Removes Folders from the Settings option on Start Menu (Control Panel, Printers, Taskbar) NoSetTaskbar: Removes Taskbar system folder from the Settings option on Start Menu NoFind: Removes the Find Tool (Start >Find) NoDrives: Hides and does not display any Drives in My Computer NoNetHood: Hides or removes the Network Neighborhood icon from the desktop NoDesktop: Hides all items including, file, folders and system folders from the Desktop NoClose: Disables Shutdown and prevents the user from normally shutting down Windows. NoSaveSettings: Means to say, 'Don't save settings on exit' DisableRegistryTools: Disable Registry Editing Tools (If you disable this option, the Windows Registry Editor(regedit.exe) too will not work.) NoRecentDocsHistory: Removes Recent Document system folder from the Start Menu (IE 4 and above) ClearRecentDocsOnExit: Clears the Recent Documents system folder on Exit. Nolnternetlcon: Removes the Internet (system folder) icon from the Desktop Under the same key: HKEY_CURRENT_USER/Software/Microsoft/CurrentVersion/Policies you can create new subkeys other than the already existing Explorer key. Now create a new key and name it System. Under this new key, system we can create the following new DWORD values(1 for enabling the particular option and 0 for disabling the particular option): NODispCPL: Hides Control Panel NoDispBackgroundPage: Hides Background page. NoDispScrsavPage: Hides Screen Saver Page NoDispAppearancePage: Hides Appearance Page NoDispSettingsPage: Hides Settings Page NoSecCPL: Disables Password Control Panel NoPwdPage: Hides Password Change Page NoAdminPaqe: Hides Remote Administration Page NoProfilePage: Hides User Profiles Page NoDevMgrPage: Hides Device Manager Page NoConfigPage: Hides Hardware Profiles Page NoFileSysPage: Hides File System Button NoVirtMemPage: Hides Virtual Memory Button Similarly, if we create a new subkey named Network, we can add the following DWORD values under it(1 for enabling the particular option and 0 for disabling the particular option): NoNetSetupSecurityPage: Hides Network Security Page NoNelSetup: Hides or disables the Network option in the Control Panel NoNetSetupIDPage: Hides the Identification Page NoNetSetupSecurityPage: Hides the Access Control Page NoFileSharingControl: Disables File Sharing Controls NoPrintSharing: Disables Print Sharing Controls Similarly, if we create a new subkey named WinOldApp, we can add the following DWORD values under it(1 for enabling the particular option and 0 for disabling the particular option): Disabled: Disable MS-DOS Prompt NoRealMode: Disable Single-Mode MS-DOS. 174

So you see if you have access to the Windows Registry, then you can easily create new DWORD values and set heir value to 1 for enabling the particular option and 0 for disabling the particular option. But Sometimes, access to the Windows Registry is blocked. So what do you do? Go to the Windows Directory and delete either user.dat or system.dat (These 2 files constitute the Windows Registry.) and reboot. as soon as Windows logs in, it will display a Warning Message informing you about an error in the Windows Registry. Simply ignore this Warning Message and Press CTRL+DEL+ALT to get out of this warning message.(Do not press OK) You will find that all restrictions have been removed. The most kind of restriction found quite commonly is the Specific Folder Restriction, in which users are not allowed access to specific folders, the most common being the Windows folder, or sometimes even access to My Computer is blocked. In effect, you simply cannot seem to access the important kewl files which are needed by you to do remove restrictions. What do you? Well use the RUN command. (START >RUN). But unfortunately a system administrator who is intelligent enough to block access to specific folder, would definitely have blocked access to the RUN command. Again we are stuck. Windows is supposed to be the most User Friendly Operating System on earth. (At least Microsoft Says so.) It gives the User an option to do the same thing in various ways. You see the RUN command is only the most convenient option of launching applications, but not the only way. In Windows you can create shortcuts to almost anything from a file, folder to a Web URL. So say your system administrator has blocked access to the c:\windows\system folder and you need to access it. What do you do? Simply create a Shortcut to it. To do this right click anywhere on the desktop and select New > Shortcut. A new window titled Create Shortcut pops up. Type in the path of the restricted folder you wish to access, in this case c:\windows\system. Click Next, Enter the friendly name of the Shortcut and then click Finish. Now you can access the restricted folder by simply double clicking on the shortcut icon. Well that shows how protected and secure *ahem Windows *ahem is. **************** HACKING TRUTH: Sometimes when you try to delete a file or a folder, Windows displays an error message saying that the file is protected. This simply means that the file is write protected, or in other words the R option is +. Get it? Anyway, you can stop Windows from displaying this error message and straightaway delete this file by changing its attributes to Non Read Only. This can be done by Right Clicking on the file, selecting Properties and then unselecting the Read Only Option. *************** There is yet another way of accessing restricted folders. Use see, DOS has a lovely command known as START. Its general syntax is: START application_path It does do what it seems to do, start applications. So in you have access to DOS then you can type in the START command to get access to the restricted folder. Now mostly access to DOS too would be blocked. So again you can use the shortcut trick to launch, c:\command.com or c:\windows\command.com. (Command.com is the file which launches MS DOS). Accessing Restricted Drives. The problem with most system administrators is that they think that the users or Hackers too are stupid. Almost all system administrators use the Registry Trick (Explained Earlier) to hide all drives in My Computer. So in order to unhide or display all drives, simply delete that particular key.(Refer to beginning of Untold Secrets Section.) Some systems have the floppy disk disabled through the BIOS. On those systems if the BIOS is protected, you may need to crack the BIOS password. (For that Refer to the Windows Hacking Chapter). Sometimes making drives readable (Removing R +) and then creating Shortcuts to them also helps us to get access to them. Further Changing your Operating System's Looks by editing .htt files If you have installed Windows Desktop Update and have the view as Web Page option enabled, you can customise the way the folder looks by selecting View > Customise this folder. Here you can change the background and other things about that particular folder. Well that is pretty lame, right? We hackers already know things as lame as that. Read on for some kewl stuff.

175

Well, you could also change the default that is stored in a Hidden HTML Template file (I think so..) which is nothing but a HTML document with a .htt extension. This .htt file is found at: %systemroot%\web\folder.htt. The %systemroot% stands for the drive in which Windows is Installed, which is normally C: You can edit these .htt files almost just like you edit normal .HTM or .HTML files. Simply open them in an ASCII editor like Notepad. The following is a list of .htt files on your system which control various folders and which can be edited to customise the way various folders look. controlp.htt Control Panel printers.htt Printers mycomp.htt My Computer safemode.htt Safe Mode All these files are found in the web folder in %systemfolder%. The folder.htt file has a line: 'Here's a good place to add a few lines of your own" which is the place where you can add your own A HREF links. These links would then appear in the folder whose folder.htt file you edited. All this might sound really easy and simple, but you see these .htt files do not contain normal HTML code, instead they contain a mixture of HTML and web bots. Hence they can be difficult for newbies to understand. Well that's it for now, more tricks later, till then goodbye. Ankit Fadia [email protected]

Get the Archive of Manuals [EVERYTHING YOU DREAMT OFF] written by Ankit Fadia

176

This article shows how to add a link on the desktop to your application. Adding a link (lnk) to the desktop directory is pretty simple. First we will need to create a com object to be able to create our .lnk file. Then we will have to get our desktop directory, which we will get using the WIN32 API call SHGetSpecialFolderLocation() since the desktop directory is a Windows special directory. I have gone over getting special folder locations in a previous tip so this should be familiar to you. We will be using Delphi's CreateComObject() function along with the WIN32 API calls SHGetSpecialFolderLocation() and SHGetPathFromIDList() with the PItemIDList record structure. [CODE] procedure TForm1.Button1Click(Sender: TObject); var tmpObject : IUnknown; tmpSLink : IShellLink; tmpPFile : IPersistFile; PIDL : PItemIDList; StartupDirectory : array[0..MAX_PATH] of Char; StartupFilename : String; LinkFilename : WideString; begin StartupFilename := 'c:\windows\notepad.exe'; tmpObject := CreateComObject(CLSID_ShellLink); tmpSLink := tmpObject as IShellLink; tmpPFile := tmpObject as IPersistFile; { tmpSLink.SetArguments('ADD COMMAND LINE PARAMETERS HERE');} tmpSLink.SetPath(pChar(StartupFilename)); tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename))); SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL); SHGetPathFromIDList(PIDL, StartupDirectory); LinkFilename := StartupDirectory + '\MyNotepad.lnk'; tmpPFile.Save(pWChar(LinkFilename),FALSE); end;

177

This article demonstrates how users can alter their GUI at runtime.

Delphi Developer

February 1999

Copyright Pinnacle Publishing, Inc. All rights reserved.

Give Your Clients Control of the GUI

Steve Zimmelman

How many times have you delivered what you thought was a completed application, only to hear your client say, "Gee, this is nice, but I'd really like the Name on the left, and the Status field should be red, not black, and . . ." Wouldn't it be nice if all your users had to do was right-click the mouse over the control, and up comes a popup menu allowing them to change the control's attributes? Or if they press Ctrl-ArrowKey or Shift-ArrowKey to change the position or size of the control? Giving users control of the GUI is a two-step process. First you have to create controls with properties users can change at runtime, and then you must have a way to save and restore the changes. Usually, the control that gets the most use is the DBEdit. So this example will focus on creating a DBEdit that uses a customized PopupMenu that's activated on the right-click of the mouse. The menu will allow the user to change Color, Font, Tab Order, and Text Case. Additionally, the key combination of CtrlArrow and Shift-Arrow will change the position and size of the control, respectively. Before I begin, I want to introduce you to a new text-case property: ProperCase. Most proper-case conversions usually capitalize only the first letter, then any letter that follows a space. But this leaves a host of names and abbreviated titles looking a bit awkward, like McDonald, O'Hara, M.D., and so forth. So in my attempt to create a better mouse-trap, I included a proper-case conversion that has the intelligence to handle these special names. I placed the functions used for the proper-case conversion in a unit called StrFunc.pas and then included the unit StrFunc in the Uses statement of the component. Creating the changeable DBEdit The first thing I did was create a new component using TDBEdit as the parent class. I called the new class TPSIDBEdit because the name of the company I work for is PSI, and it was a simple way to distinguish the component. Next I created a new CharCase type that includes ProperCase. It will be used to override the DBEdit's TCharCase. I also changed the CharCase property to a new type, TPSICharCase. In addition to overriding the CharCase property, I introduced two new properties: AllowUserChange and PopupChangeMenu. The property AllowUserChange is a simple Boolean switch that engages or disengages the user's ability to change any of the component's properties at runtime, and PopupChangeMenu is a pointer to the PopupMenu that's in effect when AllowUserChange is set to True. A bulk of the component's changing is actually done by the PopupChangeMenu, but I'll discuss that a little later. Listing 1 presents the PSIDBEdit unit. Listing 1. The PSIDBEdit unit. unit PSIDBEdit; interface uses Windows, SysUtils, Classes, Controls, Forms, Dialogs, DBCtrls, Menus, db, StrFunc; type 178

TPSICharCase = (ecNormal, ecUpperCase, ecLowerCase, ecProperCase); TPSIDBEdit = class(TDBEdit) private fCharCase : TPSICharCase ; fIsChanging : Boolean ; fAllowUserChange : Boolean ; fStartMove : Boolean ; fTop : Integer ; fLeft : Integer ; fChangeMenu : TpopupMenu ; fPopupSave : TPopupMenu ; Procedure SetAllowUserChange(Value:Boolean); Procedure SetChangeMenu(Value:TpopupMenu) ; Procedure SetPopUpMenu ; Procedure SetCharCase(Value:TPSICharCase); Procedure SetTextCase(Const bCheckState:Boolean) ; protected public Procedure Loaded ; Override ; Procedure Change ; Override ; procedure KeyDown(var Key: Word; Shift: TShiftState); override; Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override ; procedure MouseMove(Shift: TShiftState; X, Y: Integer); Override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; published Property AllowUserChange : Boolean Read fAllowUserChange Write SetAllowUserChange ; Property CharCase : TPSICharCase Read fCharCase Write SetCharCase ; Property PopupChangeMenu : TPopupMenu Read fChangeMenu Write SetChangeMenu ; end; I wanted the component to have two states: a default state, which would behave like its ancestor, and a design state, which would allow the user to change its properties at runtime. The Boolean property AllowUserChange distinguishes these two states. When AllowUserChange is True, the component's PopupMenu is changed to point to the value stored in the PopupChangeMenu property. If it's False, then the PopupMenu property reverts to its previous design time assignment. It also allows the component to be moved or resized. I thought it would be nice for the user to be able to see a 179

difference between the two states, so I changed the cursor to crHandPoint (-21) in the SetAllowUserChange method. The PopupMenu assignment is changed via the SetPopupMenu method when the AllowUserChange property is changed. In order to swap the PopupMenu pointers, the default PopupMenu is stored in fPopupSave in the Loaded method (see Listing 2). Then the SetPopupMenu method is called to ensure that the proper popup menu is assigned based on the value of AllowUserChange. Listing 2. The Loaded method. Procedure TPSIDBEdit.Loaded; Begin Try If (csDesigning in ComponentState) Then Exit ; // Capture PopupMenu Assignment fPopupSave := PopupMenu ; SetPopupMenu ; Finally inherited Loaded; End; End; With the advent of the new text case ProperCase and the new type TPSICharCase, I had to completely override and re-implement all of the other standard text-case conversions in the Change method of the component (see Listing 3). Listing 3. The Change method. Procedure TPSIDBEdit.Change ; Var iSelStart : Integer ; Begin Try If (csDesigning in ComponentState) Or fIsChanging Then Exit ; // Capture Cursor Position iSelStart := SelStart ; SetTextCase(False) ; // Restore Cursor Position SelStart := iSelStart ; Finally Inherited ; End; End; The actual changing of the Text was a little tricky. If you change the text programmatically when the object has focus, and the DataSet isn't in Edit or Insert mode, then the exception "Dataset not in Edit or Insert mode" is generated. So before changing the text, the component's DataSet.State must be interrogated and changed if necessary. We must also handle any potential multi-user conflicts that might occur. The parameter bCheckState is used to determine whether the DataSet.State needs to be placed in Edit or Insert mode before changing the text. If it does, then the method must also Post the 180

changes. The Post method is called only if the memory variable bPost is set to True. Listing 4 shows where all this happens in the SetTextCase method. Listing 4. The SetTextCase method. Procedure TPSIDBEdit.SetTextCase(Const bCheckState: Boolean) ; Var bPost : Boolean ; Function CanChange : Boolean ; Begin Try If Not bCheckState Then Begin Result := True ; Exit ; End; If (DataSource <> Nil) Then Begin If Not (DataSource.DataSet.State In [dsEdit, dsInsert]) Then Begin If DataSource.DataSet.Active Then Begin DataSource.DataSet.Edit ; bPost := True ; End; End; End; Result := True ; Except Result := False ; End; End; Begin // If the Text changes and the DataSet // is not in EditState, then an Exception // is generated. Make sure DataSet is // in EditState before changing Text. fIsChanging := True ; Try bPost := False ; If CanChange Then Begin Case CharCase Of ecNormal : {Do Nothing} ; ecUpperCase : Text := UpperCase(Text) ; ecLowerCase : Text := LowerCase(Text) ; ecProperCase: Text := ToProper(Text); End; If bPost Then DataSource.DataSet.Post ; End Else MessageDlg('Another user may be using this '+ 'record.'+#13+#13+ 'TextCase changes may not be '+ 'visible for this record.' , 181

mtWarning,[mbOK],0); Finally fIsChanging := False ; End; End; Changing the CharCase property executes the SetCharCase method (see Listing 5), which, in turn, executes the SetTextCase method. Listing 5. The SetCharCase method. Procedure TPSIDBEdit.SetCharCase(Value:TPSICharCase); Begin If fCharCase <> Value Then Begin fCharCase := Value ; SetTextCase(True) ; End; End; In order for the control to have movement capabilities, I overrode the KeyDown method (see Listing 6). Borrowing the Delphi IDE keystrokes for component moving and sizing, I used the CtrlArrowKeys for movement and the Shift-ArrowKeys for sizing. Pressing these keys causes the control to change its size or position by one pixel. Listing 6. The KeyDown method. Procedure TPSIDBEdit.KeyDown(var Key: Word; Shift: TShiftState); Begin If (Key in [vk_up,vk_down,vk_left,vk_right]) And AllowUserChange Then Begin If (Shift = [ssCtrl]) Then Begin // Change position Case Key Of vk_Up : Top := Top - 1; vk_Down : Top := Top + 1; vk_Left : Left := Left - 1; vk_Right: Left := Left + 1 ; End; End Else If (Shift = [ssShift]) Then Begin // Change Size Case Key Of vk_Up : Height := Height - 1; vk_Down : Height := Height + 1; vk_Left : Width := Width - 1; vk_Right: Width := Width + 1 ; End; End; Key := 0 ; End Else Begin inherited KeyDown(Key,Shift); End; End;

182

I also wanted the user to be able to move the component with the mouse, so I overrode the methods MouseDown, MouseUp, and MouseMove. So far, what you have is a DBEdit that allows a user to change its position and size, but little else. The Font, Color, Tab Order, 3D effect, and Border will be done with the addition of the component ChangeMenu. The basis for this component is found in the unit TypInfo.pas, which allows you to have access to an object's RTTI (runtime type information). TypInfo.pas contains functions and procedures that can Get or Set an object's property values during the execution of the application. Some simple methods of Setting or Getting an object's property value at runtime can look something like Listing 7. Listing 7. Getting and Setting an object's property at runtime. Function GetProperty(Sender:TComponent ;sPropName:String):Variant Var PropInfo : PPropinfo; Begin // From the class information, get the property PropInfo := GetPropInfo(Sender.ClassInfo, sPropName); // Does the property exist? If (PropInfo <> Nil) Then Begin Case propinfo^.PropType^.Kind Of tkEnumeration,tkInteger: Begin Result := GetOrdProp(Sender,PropInfo) End; tkString,tkLString,tkWString: Begin Result := GetStrProp(Sender,PropInfo) End; End; End Else Result := Null; End; Procedure SetProperty(Sender:TComponent ;sPropName:String ;vValue:Variant) Var PropInfo : PPropinfo; Begin // From the class information, get the property PropInfo := GetPropInfo(Sender.ClassInfo, sPropName); // Does the property exist? If (PropInfo <> Nil) Then Begin Case propinfo^.PropType^.Kind Of

183

tkEnumeration,tkInteger: Begin SetOrdProp(Sender,PropInfo,vValue); End; tkString,tkLString,tkWString: Begin SetStrProp(Sender,PropInfo,vValue); End; End; End; End; Usage of these two methods could look like this: SetProperty(DBEdit1,'Ctl3D',False); DBEdit2.Ctrl3D := GetProperty(DBEdit1.'Ctl3D') ; Granted, this example is probably over-simplified, but procedures like these can be quite handy if you don't know the component's name, or even its class. The three main methods used in ChangeMenu -- GetProperty(), SetProperty(), and IsProperty() -- are found in the unit PropFunc.pas that's part of this library. IsProperty() is a Boolean function that checks for the existence of a specified property in an object and returns a value of True if the property exists. It can be used something like this: If IsProperty(Form1.Components[i],'Ctl3D') Then Components[i].Ctl3D := False ; TChangeMenu is a subclass of TPopupMenu with two additional properties: FontDialog and ColorDialog, which are used to change the component's Font and Color and can point to any matching class types that are in the scope of the component. The methods MenuClick and OnMenuPopup do the bulk of the work and are assigned to the OnClick and OnPopup events of the menu items when the component is created. All this happens, of course, in the ChangeMenu unit (see Listing 8). Listing 8. The ChangeMenu unit. unit ChangeMenu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus,comctrls, StdCtrls,dbctrls, db,extctrls ; type TChangeMenu = class(TPopupMenu) private { Private declarations } pm_Font : TMenuItem ; 184

pm_bgColor : TMenuItem ; pm_TabOrder : TMenuItem ; pm_Ctrl3D : TMenuItem ; pm_BorderStyle: TMenuItem ; pm_Columns : TMenuItem ; pm_Caption : TMenuItem ; pm_Divider1 : TMenuItem ; pm_UpperCase : TMenuItem ; pm_LowerCase : TMenuItem ; pm_MixedCase : TMenuItem ; pm_ProperCase : TMenuItem ; pm_Height : TMenuItem ; pm_Width : TMenuItem ; pm_Style : TMenuItem ; fFontDialog :TFontDialog ; fColorDialog :TColorDialog ; Procedure Procedure Procedure Procedure

SetColorDialog(Value:TColorDialog); SetFontDialog(Value:TFontDialog); MenuClick(Sender:TObject); OnMenuPopup(Sender:TObject) ;

protected { Protected declarations } public { Public declarations } Procedure Loaded ; Override ; Destructor destroy; override ; Constructor Create(AOwner: TComponent); override; published { Published declarations } Property FontDialog :TFontDialog Read fFontDialog Write SetFontDialog ; Property ColorDialog : TColorDialog Read fColorDialog Write SetColorDialog ; end; procedure Register; implementation uses PropFunc, col_edit ; Because of the specialized use of this menu, the menu items are created only at runtime, not at designtime in the IDE. After the menu items are created, the method MenuClick() is assigned to the OnClick event of each menu item. The menu will look like Figure 1. The Loaded method (see Listing 9) captures the pointer to the component's OnPopup method, then assigns the OnPopup event to the method OnMenuPoup(). This is done so the developer's OnPopup method will execute after the OnMenuPopup method has finished processing its own menu items. 185

Listing 9. The Loaded method. Procedure TChangeMenu.Loaded; Begin Try // Save pointer to Component's OnPopup Method FOtherOnPopup := OnPopup ; // Assign OnPopup Method OnPopup := OnMenuPopup ; Finally Inherited ; End; End; When the user right-clicks the mouse over the component, the OnMenuPopup method is executed (see Listing 10) and initializes the menu items based on the menu's PopupComponent property. PopupComponent is a pointer to the object that was responsible for activating the menu and is type TComponent. Notice the use of the method IsProperty to set the Visible property of the menu items. Listing 10. The OnMenuPopup method. Procedure TChangeMenu.OnMenuPopup(Sender:TObject) ; // Initialize menu items based on the // focused component's type and properties. Var bSet : Boolean ; Begin // Don't show Font item if the Font // Dialog property is Nil or the Font // Property doesn't exist in the focused // component. pm_Font.Visible := (Not (FontDialog = Nil)) And IsProperty(PopupComponent,'Font'); // Don't show Color item if the ColorDialog // Property is Nil or the Color property doesn't // exist in the focused component. pm_bgColor.Visible := Not (ColorDialog = Nil) And IsProperty(PopupComponent,'Color'); // Initialize Radio and Checked Menu Items If IsProperty(PopupComponent, 'BorderStyle') Then Begin pm_BorderStyle.Checked := (GetProperty(PopupComponent, 'BorderStyle') = bsSingle) ; pm_BorderStyle.Visible := True ; End Else Begin pm_BorderStyle.Visible := False ; End; If IsProperty(PopupComponent,'Ctl3D') Then Begin pm_Ctrl3D.Checked := 186

GetProperty(PopupComponent,'Ctl3D'); pm_Ctrl3D.Visible := True ; End Else Begin pm_Ctrl3D.Visible := False ; End; // If the TabOrder property exists in the component, // show the Menu item 'Tab Order'. pm_TabOrder.Visible:= IsProperty(PopupComponent,'TabOrder') ; // If the Columns property exists in the component // and the component is TListView, // show the menu item. If (PopupComponent Is TListView) Then pm_columns.Visible := ( IsProperty(PopupComponent,'Columns') And (TListView(PopupComponent).Columns.Count >0)) Else pm_columns.Visible := False ; // You should have the idea by now ... pm_Caption.Visible := IsProperty(PopupComponent,'Caption'); // If the focused component has CharCase and // AllowUser Change properties, then process more // menu items. If (IsProperty(PopupComponent,'CharCase') And IsProperty(PopupComponent, 'AllowUserChange')) Then Begin bSet := True ; // Don't show CharCase items if the // DataType isn't String. If IsProperty(PopupComponent, 'DataSource') Then Begin If (PopupComponent is TDBEdit) Then Begin With TDBEdit(PopupComponent) Do Begin If (DataField <> '') Then Begin If Not (Field.DataType = ftString) Then Begin bSet := False ; End; End Else bSet := False ; End; End; End; pm_UpperCase.Visible := bSet ; pm_LowerCase.Visible := bSet ; pm_MixedCase.Visible := bSet ; pm_ProperCase.Visible := bSet ; pm_Divider1.Visible := bSet ; 187

// Initialize CharCase Radio Items. Case GetProperty(PopupComponent,'CharCase') Of //ecNormal 0: pm_MixedCase.Checked := True ; //ecUpperCase 1: pm_UpperCase.Checked := True ; //ecLowerCase 2: pm_LowerCase.Checked := True ; //ecProperCase 3: pm_ProperCase.Checked := True ; End; End Else Begin pm_UpperCase.Visible := False ; pm_LowerCase.Visible := False ; pm_MixedCase.Visible := False ; pm_ProperCase.Visible := False ; pm_Divider1.Visible := False ; End; pm_Width.Visible := (PopupComponent is TBevel); pm_Height.Visible := (PopupComponent is TBevel); pm_Style.Visible := (PopupComponent is TBevel); If pm_Style.Visible Then Begin If GetProperty(PopupComponent,'Style')=0 Then pm_Style.Caption := 'Raised Bevel' Else pm_Style.Caption := 'Lowered Bevel' ; End; // execute component's OnPopup Event. If Assigned(FOtherOnPopup) Then FOtherOnPopup(Sender); End; When an item is selected (see Listing 11) the method SetProperty() is used to change the object's property values. Listing 11. The MenuClick method. Procedure TChangeMenu.MenuClick(Sender:TObject); // Process the menu selection for the focused // component. Var sString : String ; i,iInt : Integer ; b : Boolean ; Begin If (TMenuItem(Sender)= pm_Ctrl3D) Then Begin // Process 3D - If 3D is selected // then BorderStyle must be changed // to Single. 188

b := Not Boolean(GetProperty(PopupComponent, 'Ctl3D')); SetProperty(PopupComponent,'Ctl3D',Ord(b)); If b And (GetProperty(PopupComponent, 'BorderStyle') = bsNone) Then SetProperty(PopupComponent, 'BorderStyle',bsSingle); End Else If (TMenuItem(Sender)= pm_BorderStyle) Then Begin // Process BorderStyle If (GetProperty(PopupComponent, 'BorderStyle') = bsSingle) Then Begin SetProperty(PopupComponent, 'BorderStyle',bsNone); // If BorderStyle is set to None, then // turn 3D Off. SetProperty(PopupComponent,'Ctl3D',False); End Else SetProperty(PopupComponent, 'BorderStyle',bsSingle); End Else If (TMenuItem(Sender)= pm_TabOrder) Then Begin // Process TabOrder sString := IntToStr(GetProperty(PopupComponent, 'TabOrder')); Try sString := InputBox('Set Tab Order', 'Enter Tab Order',sString); iInt := StrToInt(sString); SetProperty(PopupComponent,'TabOrder',iInt) ; Except Raise Exception.Create('Tab Order Must '+ 'Be An Integer'); End; End Else If (TMenuItem(Sender)= pm_Font) Then Begin // Process Font selection If (FontDialog <> Nil) Then Begin FontDialog.Font.Name := GetProperty(PopupComponent,'Font.Name') ; FontDialog.Font.Size := GetProperty(PopupComponent,'Font.Size') ; FontDialog.Font.Color := GetProperty(PopupComponent,'Font.Color') ; FontDialog.Font.Style := TFontStyles(TFontStyle( GetProperty(PopupComponent,'Font.Style'))); If FontDialog.Execute Then Begin SetProperty(PopupComponent,'Font.Name' ,FontDialog.Font.Name); SetProperty(PopupComponent,'Font.Size', 189

FontDialog.Font.Size); SetProperty(PopupComponent,'Font.Color', FontDialog.Font.Color); SetProperty(PopupComponent,'Font.Style', Ord(TFontStyle(FontDialog.Font.Style))); // Force Font Height to refresh // the component i:= GetProperty(PopupComponent, 'Font.Height'); SetProperty(PopupComponent, 'Font.Height',i+(-5)); SetProperty(PopupComponent, 'Font.Height',i); End; End; End Else If (TMenuItem(Sender) = pm_BgColor) Then Begin // Process Color If ColorDialog <> Nil Then Begin ColorDialog.Color := GetProperty(PopupComponent,'Color') ; If ColorDialog.Execute Then Begin SetProperty(PopupComponent,'Color', ColorDialog.Color) ; End; End; End Else If (TMenuItem(Sender) = pm_Caption) Then Begin // Process Caption sString := GetProperty(PopupComponent,'Caption'); sString := InputBox('Change Caption', 'Enter Caption',sString); SetProperty(PopupComponent,'Caption',sString) ; End Else If (TMenuItem(Sender) = pm_columns) Then Begin // Process Columns for TListView. This is done // with an external form. Application.CreateForm(TfrmEditColumns, frmEditColumns); Try frmEditColumns.ColObject := TListView(PopupComponent) ; frmEditColumns.ShowModal ; Finally frmEditColumns.Free ; End; End Else If (TMenuItem(Sender)=pm_Width) Then Begin // Process Width for TBevel sString := IntToStr(GetProperty(PopupComponent, 'Width')); Try sString := InputBox('Set Width', 'Enter Width',sString); iInt := StrToInt(sString); 190

SetProperty(PopupComponent,'Width',iInt) ; Except Raise Exception.Create('Width Must Be '+ 'An Integer'); End; End Else If (TMenuItem(Sender)=pm_Height) Then Begin // Process Height for TBevel sString := IntToStr(GetProperty(PopupComponent, 'Height')); Try sString := InputBox('Set Height', 'Enter Height',sString); iInt := StrToInt(sString); SetProperty(PopupComponent,'Height',iInt) ; Except Raise Exception.Create('Height Must Be '+ 'An Integer'); End; End Else If (TMenuItem(Sender)=pm_Style) Then Begin // Process Bevel Stype for TBevel // Raised or Lowered If GetProperty(PopupComponent,'Style')=0 Then SetProperty(PopupComponent,'Style',1) Else SetProperty(PopupComponent,'Style',0) End Else Begin TMenuItem(Sender).Checked := Not TMenuItem(Sender).Checked; If pm_MixedCase.Checked Then Begin // Normal SetProperty(PopupComponent,'CharCase',0) ; End Else If pm_UpperCase.Checked Then Begin //CharCase := ecUpperCase ; SetProperty(PopupComponent,'CharCase',1) ; End Else If pm_LowerCase.Checked Then Begin //CharCase := ecLowerCase ; SetProperty(PopupComponent,'CharCase',2) ; End Else If pm_ProperCase.Checked Then Begin //CharCase := ecProperCase ; SetProperty(PopupComponent,'CharCase',3) ; End; End; End; TChangeMenu can actually be used on almost any standard component that has any of the supported properties. It even supports TListView column headings and widths. Half-way there Creating a component that allows the user to change its size, position, font, color, and so forth is good. But it isn't very helpful without the ability so save and restore the changed properties. You don't want your users to have to customize the application again and again every time they run your application, 191

do you? The next step is to create a component that has the ability to save and restore the classes and properties that the developer specifies. TComponentStates When designing the component to save the component property values, I wanted to make it flexible enough to save only the values that the developer wanted. The values needed to be stored in a place that would be easily accessible and transportable. I also wanted the values to be able to be accessed by more than one user or workstation. For these reasons, I chose to store the property values in an INI file instead of the Windows Registry. TComponentStates works in much the same way TChangeMenu does by accessing the routines in PropFunc.pas to Save and Restore component properties at runtime. There are three exposed methods in this component: Save, Restore, and SetProperties. I think the first two are self-explanatory. The SetProperties method is used to set a specific property of all objects on the form that are of the same class type. For example, if I wanted to change the font of all the TDBEdit objects on Form1 to Arial 12, the code would look like this: ComponentStates1.SetProperties(Form1,'TDBEdit', 'Font.Name','Arial'); ComponentStates1.SetProperties(Form1,'TDBEdit', 'Font.Size',12); The routine to accomplish this is actually not too complicated. It uses the SetProperty method in PropFunc.pas, as discussed earlier. It spins through all the components on the form and checks the classname. If the classname is a match, it executes the SetProperty() method, changing the component's property (see Listing 12). Listing 12. The SetProperties method. Procedure TComponentStates.SetProperties( Const Frm:TForm ;Const sClassName:String ;Const sPropertyName:String ;Const vValue:Variant); //**************************************************** //Sets all components properties on the Form Frm where //component.classname = sClassName with vValue. //**************************************************** Var i : Integer ; Begin With Frm Do Begin For i := 0 To (ComponentCount-1) Do Begin If Components[i].ClassNameIs(sClassName) Then Begin SetProperty(Components[i],sPropertyName, vValue); End; End; End; //with Frm End; The most essential property in this component is ClassesToSave. It's a TStrings type that contains a list 192

of classes and properties to save to the INI file. For example, to save all the essential information about each TPSIDBEdit that's on the form, the contents of ClassesToSave would look like this: TPSIDBEdit.Left TPSIDBEdit.Top TPSIDBEdit.Height TPSIDBEdit.Width TPSIDBEdit.TabOrder TPSIDBEdit.Font.Name TPSIDBEdit.Font.Size TPSIDBEdit.Font.Style TPSIDBEdit.Font.Color TPSIDBEdit.Color TPSIDBEdit.Ctl3D TPSIDBEdit.BorderStyle TPSIDBEdit.CharCase When the Save method is executed, the INI file would look something like this: [Form1] PSIDBEdit1.Left=313 PSIDBEdit1.Top=319 PSIDBEdit1.Height=21 PSIDBEdit1.Width=121 PSIDBEdit1.TabOrder=5 PSIDBEdit1.Font.Name=MS Sans Serif PSIDBEdit1.Font.Size=8 PSIDBEdit1.Font.Style=0 PSIDBEdit1.Font.Color=-2147483640 PSIDBEdit1.Color=-2147483643 PSIDBEdit1.Ctl3D=1 PSIDBEdit1.BorderStyle=1 PSIDBEdit1.CharCase=0 The Save and Restore methods use the same procedure called Process (see Listing 13). The Boolean parameter bSave is the switch for saving or restoring the values. Listing 13. The Process method. Procedure TComponentStates.Process(bSave:Boolean); Var i,ii : Integer ; sPropertyName : String ; sSection : String ; sClassName : String ; sID : String ; vValue : Variant ; slPropList : TStrings ; Begin If Not Active Then Exit ; slPropList := TStringList.Create ; fIniFile := TIniFile.Create(FIniPath+ SaveToINIFileName); 193

Try // Use the form's name for the section ID in // the INI file. sSection := fOwner.Name ; For i := 0 To (fOwner.ComponentCount-1) Do Begin slPropList.Clear ; sClassName := fOwner.Components[i].ClassName ; // Get Property List For Class slPropList.Text := ProcessClass(fOwner.Components[i]) ; If (slPropList.Text <> '') Then Begin //********************************************* //Process all defined properties for this Class //********************************************* For ii := 0 To (slPropList.Count-1) Do Begin sPropertyName := slPropList.Strings[ii] ; sID := fOwner.Components[i].Name+'.'+ sPropertyName ; If bSave Then Begin // Write Property Values to INI file vValue := GetProperty(fOwner.Components[i], sPropertyName); If (vValue <> Null) Then Begin Case VarType(vValue) Of varInteger: fIniFile.WriteInteger(sSection,sID, vValue); varString: fIniFile.WriteString(sSection, sID,vValue); End; // Case VarType(vValue) End; End Else Begin // *********************************** // Read property from INI file and set // component's property. // *********************************** // Get Current Property Value as a default vValue := GetProperty(fOwner.Components[i], sPropertyName); If (vValue <> Null) Then Begin // Read property value from INI file 194

Case VarType(vValue) Of varInteger: Begin vValue := fIniFile.ReadInteger(sSection, sID, vValue); End; varString: Begin vValue := fIniFile.ReadString(sSection, sID, vValue); End; Else vValue := Null ; End; // Case VarType(vValue) If (vValue <> Null) Then Begin SetProperty(fOwner.Components[i], sPropertyName,vValue); End; End; End; // If bSave End; // For ii End; // If (slPropList.Text <> '') End; // For i Finally slPropList.Free ; fIniFile.Free ; End; End; A single INI file can be used to save the component values for every form in the application. It uses the Form's name property for the INI file's section ID and places each component's values for the form under the ID. Putting it all together The final step is actually using these components together. I thought building a simple address book would be easiest. Starting with the DataModule, I added a ColorDialog, FontDialog, ComponentStates, ChangeMenu, Table, and DataSource (see Figure 2). Then I filled in the FontDialog and ColorDialog properties of the ChangeMenu to point to the Color and Font dialogs that are on the DataModule. I then pointed the Table to ADDRESS.DBF, and the DataSource to the Table. I also changed the ComponentStates.Active property to True. The next step is to lay out the form using the TPSIDBEdit and point them to their respective fields, and populate the ChangeMenu property to point to the TChangeMenu that's on the DataModule. I also added a couple of buttons that globally change the background and font of all the TPSIDBEdit's on the form, and a CheckBox that changes the component's AllowUserChange property to True or 195

False. I used another subclassed label component, TLabel3D, that has some of the same changeable features found in TPSIDBEdit, in order to show the flexibility of these components. Label3D.pas is included in the accompanying Download file. Figure 3 shows the complete Address Book form. Next I populated the ClassesToSave property (see Figure 4) of the ComponentStates component with all the classes and properties I wanted saved as part of this application. In the OnShow event of the form, I placed the code that will restore the saved values from the INI file. The Restore() and Save() methods take one parameter and is the TForm that is to be processed. In this I case, I used the Self pointer to make it generic. procedure TForm1.FormShow(Sender: TObject); begin DataModule1.ComponentStates1.Restore(Self); end; The Save() method can be implemented a couple of different ways. You can place the Save code in the OnClose event of the Form, or you can give the user a button or menu item to use to save the GUI changes. In this example, I used the OnClose event of the form. But in a live application, I'd probably use a Button or Menu item for the save. procedure TForm1.FormClose(Sender: Tobject ;var Action: TCloseAction); begin DataModule1.ComponentStates1.Save(Self); end; To change the AllowUserChange property for all the components, I used the SetProperties method in the OnClick event of the CheckBox. I pass in the TForm using Self, the classname and the property I want changed, and the value to change it to. procedure TForm1.cbAllowUserChangeClick(Sender: TObject); begin // Globally set the property of AllowUserChange on // all Components that are of type TPSIDBEdit // and TLabel3D With DataModule1.ComponentStates1 Do Begin SetProperties(Self,'TPSIDBEdit','AllowUserChange', cbAllowUserChange.Checked); SetProperties(Self,'TLabel3D','AllowUserChange', cbAllowUserChange.Checked); End; end; To globally change the Font and Color of all the TPSIDBEdit objects on the form, I again used the SetProperties() method of the TComponentStates object: procedure TForm1.btnGlobalBGClick(Sender: TObject); begin // Globally set the Color property of // all Components that are of type TPSIDBEdit. 196

With DataModule1 Do Begin If ColorDialog1.Execute Then Begin ComponentStates1.SetProperties( Self,'TPSIDBEdit','Color', ColorDialog1.Color); End; End; end; procedure TForm1.btnGlobalFGClick(Sender: TObject); begin // Globally set the Font.Color property of // all Components that are of type TPSIDBEdit. With DataModule1 Do Begin If ColorDialog1.Execute Then Begin ComponentStates1.SetProperties( Self,'TPSIDBEdit','Font.Color', ColorDialog1.Color); End; End; end; While not every application you build will require the user to change the GUI, think how nice it would be if you didn't have to hard-code the changes, recompile, and hand your client a new application only to hear, "Oh, there's just one more thing . . ." Steve Zimmelman is the director of R&D for PSI/Pulse Systems, Inc., in Wilmington, MA, and a contributor to Pinnacle Publishing's FoxTalk newsletter and InfoWorld magazine. He also plays a pretty good blues guitar.

197

This article demonstrates how to implement the Microsoft Agent into your own applications. This article originally appeared in Delphi Developer Copyright Pinnacle Publishing, Inc. All rights reserved.

USING MICROSOFT AGENT IN DELPHI by Clay Shannon When I tell people how fun and effective it is to use Microsoft Agents in my programs, they either already know what I’m talking about and heartily agree, or they look at me as if I just fell off the back of a rutabaga truck and say something like: “You mean that paperclip guy who makes Twiggy look like a sumo wrestler?! I hate that guy!” Well, I’m not overly fond of those Agents, either. If when you hear “Microsoft Agent” you think of the “Office Agents”, such as “that paperclip guy” in the ugly dialog box who’s always pestering you with questions like “it looks like you’re doing this, do you want me to help?”, and “it looks like you’re doing that, do you want help, huh? huh?”, you’re thinking of a different breed of Microsoft Agent than those which will be discussed in this article. Aren’t you glad? These Agents are not trapped inside a dialog box, and they appear when and where you tell them to, and say exactly what you program them to say. So let’s introduce them. They are: Peedy (the Bird), Robby (the Robot), Merlin (the Magician), and Genie (the… well, the Genie): Are these “cute” little characters of any practical value? In some programs, indubitably not. In others, though, they can not only add appeal (depending on the user’s preferences, of course) but also be of use in helping the user learn to use the program and make it through “the rough spots”. I tend to think of the Agents as a sort of “Master of Ceremonies”. They can be used to introduce the user to the program – what does it do? How can you use it? They can be utilized as an adjunct to, or even a replacement of, a help file. Additionally, the Agents have a great potential, or future, as “guides” in CBT (Computer-Based Training) and in demo programs. Not all machines will have the Microsoft Agents installed. If you’re not sure whether your users will have the Agents installed or not, you have two options: distribute the agents to your users in case they don’t have them, or write your code in such a way that it is transparent to the Agent-less users that your program is even able to use Agents (“they don’t know what they’re missing”). To deploy the agents, you must go to Microsoft’s Agent web site, download a form, fill it out, send it to them, etc. in order to get permission to distribute the agents. I don’t know about you, but for me that is, in the words of Chuck Berry “too much monkey business”. I opt to code for either situation: if they have the Agents installed, they will see them, otherwise they won’t. The first thing you as a developer need to know is to download and install the Agent technology yourself, if you have not done so already. The Agent components are available at http://msdn.microsoft.com/workshop/imedia/agent/default.asp The most pertinent downloads there are: 7. The Agent Server 8. The characters/Agents 9. A Text-to-Speech piece 10. Voice command (input) piece This article will not deal with the Voice Command download and functionality (repeat after me: “that is an exercise left to the reader”). The site also contains info about a new book entitled “Microsoft Agent Software Development Kit” and you can also download the Microsoft Agent Character Editor 198

(software) for creating your own agents. This is “beyond the scope of this article” and is thus also “left as an exercise…” - well, you know the rest. Let’s get down to “business”, or fun, or whatever it is we’re having here (funsiness?). The only downloads you will absolutely need are the Agent Server and one character. I recommend downloading all the characters and the Text-to-Speech functionality, though. The download from Microsoft installs and registers the Agent server on your machine. What’s left for you to do is install the Agent control into Delphi. To do so, follow these steps: 5. Select Component | Import ActiveX Control 6. Locate the Microsoft Agent Control from the list box and select the Add button The Agent should now be installed on your ActiveX page: If you drop this control on a form, you will see that a component of type TAgent is added to your form’s definition. However, if we are not sure whether the user will have the Agent server installed on their machine, we will want to create the Agent dynamically. Not doing so can cause the same problem as having a statically loaded .DLL that is not found by the application on the user’s machine. We will first check for the existence of the Agent technology, and only then create the Agent, if such exists. Add a Boolean field to your form which reflects the state of Agent technology presence. For example, this could be a field called AgentInstalled. This is shown below along with other Agent-specific Boolean fields and their corresponding public properties that you may want to declare: TYourObject private AgentInstalled: Boolean; function AgentIsInstalled: Boolean; procedure CreateAndLoadAgentIfInstalled; function GetColorDepth: Word; function GetWinDir: String; procedure SetFormColor; function AgentWasClicked You can populate this field with its appropriate value with a procedure that checks for the existence of the Agent files on the user’s machine. For example, if you’re using Robby (the Robot) as your Agent, your code might look like this: {----------------------------------------------------------------} function TYourObject.AgentIsInstalled: Boolean; begin Result := (FileSearch('Robby.acs', Format('%s\MSAGENT\CHARS', [GetWinDir]))<>''); end; {----------------------------------------------------------------} function TYourObject.GetWinDir : string; var WinDirZ : array[0..256] of Char; begin GetWindowsDirectory(WinDirZ, SizeOf(WinDirZ)); Result := StrPas(WinDirZ); 199

end; NOTE: Don’t assume that the agents have been downloaded to their “normal place” on the user’s machine C:\WINDOWS\MSAGENT\CHARS). We all know what can happen (and usually eventually does) when we assume too much. So, you can use the GetWinDir function above along with the call to FileSearch to find the Windows directory on the user's machine. As we are going to create the Agent component dynamically, don’t place an Agent ActiveX control on the form. Instead, add the OLECtrls and AgentObjects_TLB units to the implementation uses clause of the form[s] on which you want to use the agent: implementation uses AgentDemoConsts, Registry, OLECtrls, AgentObjects_TLB; You can then dynamically create the Agent component in this way: {-----------------------------------------------------------------} procedure TYourObject.CreateAndLoadAgentIfInstalled; const RightBias = 80; TopBias = 70; var tp: TPoint; begin if (AgentInstalled) and not (Assigned(RobotAgent)) then begin RobotAgent := TAgent.Create(Application); RobotAgent.Characters.Load('Robby','Robby.acs'); { Move the Agent to the center of the screen } tp.x := (Screen.Width div 2)-(Width div 2); tp.y := (Screen.Height div 2)-(Height div 2); with RobotAgent.Characters.Item['Robby'] do begin MoveTo(tp.x+RightBias, tp.y+TopBias, 0); Show(0); Play('Greet'); Play('Explain'); Speak(SDemoIntro, ''); Play('Pleased'); Play('RestPose'); Speak(SWhisper, ''); Speak(SMonotone, ''); Speak(SMap, ''); { You can have him filibuster and gesture like a madman if you want… } end; end; end;

200

Adding expression There are several special speech/text options that you can use to more exactly control how the Agent speaks. For example, you can make him whisper, speak in a monotone, pause, emphasize a certain part of his oratory, or even have him say one thing while the balloon above his head reads differently. You could use the latter functionality to have him speak in English, and show the translation into another language in the balloon. Or, you could go the “Mad magazine” route and have him say one thing while thinking another. These capabilties are available through the following additions: The Agent will whisper the following text \Chr=’Whisper”\ \Pau=N\ \Emp\ \Chr=”Montone”\ \Map==

The Agent will pause for the designated number of milliseconds The Agent will give special emphasis to the following phrase The Agent will emphasize nothing at all The Agent will say one thing, and “think” another.

Here are some examples of using these speech “qualities”: SFuzzyWuzzy = 'Fuzzy wuzzy was a bear;\Pau=500\ fuzzy wuzzy had no ' + 'hair;\Pau=500\fuzzy wuzzy wasn''t very \Emp\fuzzy, ' + '\Emp\was he?'; SWhisper = '\Chr="Whisper"\Now I will whisper: Whisper whisper ' + 'whisper.'; SMonotone = '\Chr="Monotone"\Now I will speak in a monotone. Pat ' + 'Paulsen for President.'; SMap = '\Map="I will now continue to speak in English, but you will '+ 'see my words translated into German in the ballon above my ' + 'head. ' + 'How are you today? I am just \Emp\dandy!"="Jetzt werde ich ' + 'zwar immer noch in Englisch reden, sie werden aber meine ' + 'Woerte im Ballon obenauf ins Deutsch uebersetzt sehen. ' + 'Wie geht es Ihnen heute? Mir geht es ganz gut!"\'; Note: Not all actions (arguments passed to the Play method) are available for all Agents. See the corresponding documentation contained in the Microsoft files downloaded with the Agent to see which characters (Agents) support which actions.

Interaction If you want to respond to the Agent’s events, you can hook these up by following these steps: 6. Drop an Agent component on a form. 7. Go to the Object Inspector’s event page 8. Click the event you want to handle 9. Copy its method signature (to the clipboard, to Notepad, or whatever) 10. Add a method with that signature to your form’s declaration 11. After creation of the Agent, assign your method to the event you want to handle. 201

For example, if you want to handle the Agent’s OnClick event, write a method with this signature: procedure AgentWasClicked(Sender: TObject; const CharacterID: WideString; Button, Shift, x, y: Smallint); Make the assignment of the event handler to your method directly after creating the Agent: RobotAgent := TAgent.Create(Application); RobotAgent.OnClick := AgentWasClicked; and then write the definition for the event handler in the unit’s implementation section: procedure TYourObject.AgentWasClicked( Sender: TObject; const CharacterID: WideString; Button, Shift, x, y: Smallint); begin ShowMessage(‘Don’’t touch me there!’); end; {----------------------------------------------------------------} function TfrmAgent.UsersName: String; var Buff: DWord; CharArray: array[0..255] of Char; begin Buff := SizeOf(CharArray); GetUserName(CharArray, Buff); Result := CharArray; end; Clay Shannon is an independent Delphi consultant based in northern Idaho. He is available for: 1) Delphi consulting work in the greater Spokane/Coeur d'Alene areas 2) Remote development (no job too small!) 3) Short-term or part-time assignments in other locales. Clay is a certified Delphi 5 developer, and is the author of Developer's Guideto Delphi Troubleshooting [Wordware, 1999]. You can reach him at [email protected] (c) Clay Shannon

202

This article demonstrates how to format a drive from a Delphi application. procedure FormatDriveDialog; begin ShellExecute(Application.Handle, 'Open', 'C:\Windows\Rundll32.exe', 'Shell32.dll,SHFormatDrive', 'C:\Windows', SW_SHOWNORMAL); end; function SHFormatDrive(hWnd : HWnd; Drive, fmtID, Options : LongInt):longint; stdcall; external 'shell32.dll'; procedure QuietFormatDrive; const SHFMT_ID_DEFAULT = $FFFF; SHFMT_OPT_QUICK = $0000; SHFMT_OPT_FULL = $0001; SHFMT_OPT_SYSONLY = $0002; SHFMT_ERROR = $FFFFFFFF; SHFMT_CANCEL = $FFFFFFFE; SHFMT_NOFORMAT = $FFFFFFFD; begin case SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT, SHFMT_OPT_FULL) of SHFMT_ERROR : ShowMessage('Error on last format, drive may be formatable'); SHFMT_CANCEL : ShowMessage('Last format was canceled'); SHFMT_NOFORMAT : ShowMessage('Drive is not formatable'); end; end; (c) Peter Morris

203

#75: How can I map/unmap the network disk in run-time? Sometimes in run-time you must map/unmap the some remote resource. You can make it with the next code: uses Windows;

var nw: TNetResource; begin nw.dwType := RESOURCETYPE_DISK; nw.lpLocalName := nil; nw.lpRemoteName := PChar('\\yourServerName\yourDiskOnServer'); nw.lpProvider := nil; errCode := WNetAddConnection2(nw, nil, nil, 0); if errCode = NO_ERROR then end;

If the remote server have the password, then you must call the errCode := WNetAddConnection2(nw, 'strPassword', nil, 0); If you want to map this disk as own local resource, you must define the lpLocalName. For example, nw.lpLocalName := 'F:'; When you want to un-map resource, you must call the WNetCancelConnection2 procedure. #105: How can I refresh a desktop? Yesterday I answered on this question in delphi programming mailing list. I want to post this answer as tip because I sure that this question can ask a lot of developers but to find an answer is not easy task. So if you need refresh a desktop in run-time, you can execute a next procedure: SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, NULL, NULL); This code will refresh a desktop image and re-read the icons for files with registered extentions. PS: you can do a same if you press a right mouse button on desktop and select Update item. #76: How can I change a button caption in Open/SaveDialog? Today I found a nice tip about changing the captions in standard dialogs (TOpendialog or TSaveDialog). By default the TOpendialog have the two buttons: Open and Cancel. You can change this default value: procedure TForm1.Opendialog1Show(Sender: TObject); begin SetDlgItemText(GetParent(Opendialog1.Handle), IDOK, PChar('New &Open')); SetDlgItemText(GetParent(Opendialog1.Handle), IDCANCEL, PChar('New &Cancel')); end;

#64: How can I draw a chart on own canvas? Sometimes you need draw the chart on the own canvas. For example, you want to print a chart or include the chart in own bitmap. You can make it so: 1. yourChart.DrawToMetaCanvas(ACanvas, ARect); or 2. var intChartWidth, intChartHeight: Integer; Meta: TMetaFile; begin Meta := yourChart.TeeCreateMetafile(False, Rect(0, 0, intChartWidth, intChartHeight)); try

204

ACanvas.StretchDraw(ARect, Meta); finally Meta.Free; end; end; , where - yourChart is a "source" chart component - ARect is a rect in which you want to place a chart image, - ACanvas is a "target" canvas

In the SMReport Designer I used the first procedure for chart outputing on the report band. #61: How can I read the vertical refresh rate of the display? If you need retrieve the value of the vertical refresh rate of the your monitor, you can call the GetDeviceCaps API's function with VREFRESH parameter. This feature are available on Windows NT platform only, so before using you must check the Windows version. For example, var ov: TOSVersionInfo; vr: Integer; begin ov.dwOSVersionInfoSize := SizeOf(ov); GetVersionEx(ov); if OV.dwPlatformID = VER_PLATFORM_WIN32_NT then begin vr := GetDeviceCaps(Form1.Canvas.Handle, VREFRESH); Label.Caption := 'Frequence: ' + IntToStr(vr) + ' Hz'; end; end;

#97: How can I hide/show the Start button from Windows TaskBar? If you needs to hide/show the Start button from Windows Taskbar, you can use the next procedure: procedure HideShowStartButton(boolVisible: Boolean); var Tray, Child: hWnd; C: array[0..127] of Char; S: string; begin Tray := FindWindow('Shell_TrayWnd', nil); Child := GetWindow(Tray, GW_CHILD); while Child <> 0 do begin if GetClassName(Child, C, SizeOf(C)) > 0 then begin S := StrPas(C); if UpperCase(S) = 'BUTTON' then begin startbutton_handle := child; ShowWindow(Child, Integer(boolVisible)) end; end; Child := GetWindow(Child, GW_HWNDNEXT); end; end;

205

How to Make a Windows Screen Saver in Delphi by Mark R. Johnson From time to time, I see questions asked about how to make a Windows screen saver in Delphi that can be selected in the Control Panel Desktop. After seeing a few general responses that only partially answered the question, I decided to give it a try myself. The code you will see here is the result: a simple Windows screen saver. The complete Delphi source code for this screen saver is available for FTP as spheres.zip (4K). Before getting into the details of the code, however, I would like to thank Thomas W. Wolf for the general screen saver tips he submitted to comp.lang.pascal, which I found helpful in writing this article.

Background A Windows screen saver is basically just a standard Windows executable that has been renamed to have a .SCR filename extension. In order to interface properly with the Control Panel Desktop, however, certain requirements must be met. In general, the program must: · maintain optional settings · provide a description of itself · distinguish between active mode and configuration mode · disallow multiple copies of itself to run · exit when the user presses a key or moves the mouse In the following description, I will try to show how each of these requirements can be met using Delphi.

Getting Started The screen saver we are going to create will blank the screen and begin drawing shaded spheres at random locations on the screen, periodically erasing and starting over. The user will be able to specify the maximum number spheres to draw before erasing, as well as the size and speed with which to draw them. To begin, start a new, blank project by selecting New Project from the Delphi File menu. (Indicate "Blank project" if the Browse Gallery appears.)

Configuration Form The first thing most people see of a screen saver is its setup dialog. This is where the user specifies values for options specific to the screen saver. To create such a form, change the properties of Form1 (created automatically when the new project was begun) as follows:

BorderIcons [biSystemMenu] biSystemMenu True biMinimize False biMaximize False BorderStyle bsDialog Caption Configuration Height 162 Name CfgFrm Position poScreenCenter Visible False Width 266

We want to be able to configure the maximum number of spheres drawn on the screen, the size of the spheres, and the speed with which they are drawn. To do this, add the following three Labels (Standard palette) and SpinEdits (Samples palette): (Note: You can select the following text, copy it to the clipboard, and paste it onto the configuration form to create the components.) object Label1: TLabel Left = 16 Top = 19 Width = 58 Height = 16 Alignment = taRightJustify

206

Caption = 'Spheres:' end object Label2: TLabel Left = 41 Top = 59 Width = 33 Height = 16 Alignment = taRightJustify Caption = 'Size:' end object Label3: TLabel Left = 29 Top = 99 Width = 45 Height = 16 Alignment = taRightJustify Caption = 'Speed:' end object spnSpheres: TSpinEdit Left = 84 Top = 15 Width = 53 Height = 26 MaxValue = 500 MinValue = 1 TabOrder = 0 Value = 50 end object spnSize: TSpinEdit Left = 84 Top = 55 Width = 53 Height = 26 MaxValue = 250 MinValue = 50 TabOrder = 1 Value = 100 end object spnSpeed: TSpinEdit Left = 84 Top = 95 Width = 53 Height = 26 MaxValue = 10 MinValue = 1 TabOrder = 2 Value = 10 end

Finally, we need three buttons -- OK, Cancel, and Test. The Test button is not standard for screen saver setup dialogs, but it is convenient and easy to implement. Add the following three buttons using the BitBtn buttons of the "Additional" palette: object btnOK: TBitBtn Left = 153 Top = 11 Width = 89 Height = 34 TabOrder = 3 Kind = bkOK end object btnCancel: TBitBtn Left = 153 Top = 51 Width = 89 Height = 34 TabOrder = 4 Kind = bkCancel

207

end object btnTest: TBitBtn Left = 153 Top = 91 Width = 89 Height = 34 Caption = 'Test...' TabOrder = 5 Kind = bkIgnore end

Once we have the form layout, we need to add some code to make it work. First, we need to be able to load and save the current configuration. To do this, we should place the Spheres, Size, and Speed values into an initialization file (*.INI) in the user's Windows directory. Delphi's TIniFile object is just the thing for this. Switch to the code view for the Setup form, and add the following uses clause to the implementation section of the configuration form's unit: uses IniFiles;

Then, add the following procedure declarations to the private section of the TCfgFrm declaration: procedure LoadConfig; procedure SaveConfig;

Now add the following procedure definitions after the uses clause in the implementation section: const CfgFile = 'SPHERES.INI'; procedure TCfgFrm.LoadConfig; var inifile : TIniFile; begin inifile := TIniFile.Create(CfgFile); try with inifile do begin spnSpheres.Value := ReadInteger('Config', 'Spheres', 50); spnSize.Value := ReadInteger('Config', 'Size', 100); spnSpeed.Value := ReadInteger('Config', 'Speed', 10); end; finally inifile.Free; end; end; {TCfgFrm.LoadConfig} procedure TCfgFrm.SaveConfig; var inifile : TIniFile; begin inifile := TIniFile.Create(CfgFile); try with inifile do begin WriteInteger('Config', 'Spheres', spnSpheres.Value); WriteInteger('Config', 'Size', spnSize.Value); WriteInteger('Config', 'Speed', spnSpeed.Value); end; finally inifile.Free; end; end; {TCfgFrm.SaveConfig}

All that remains for the configuration form is to respond to a few events to properly load and save the configuration. First, we need to load the configuration automatically whenever the program starts up. We can use the setup form's OnCreate event to do this. Double- click the OnCreate field in the events section of the Object Inspector and enter the following code:

procedure TCfgFrm.FormCreate(Sender: TObject); begin LoadConfig; end; {TCfgFrm.FormCreate}

208

Next, double-click the OK button. We need to save the current configuration and close the window whenever OK is pressed, so add the following code: procedure TCfgFrm.btnOKClick(Sender: TObject); begin SaveConfig; Close; end; {TCfgFrm.btnOKClick}

In order to simply close the form (without saving) when the Cancel button is pressed, double-click on the Cancel button and add: procedure TCfgFrm.btnCancelClick(Sender: TObject); begin Close; end; {TCfgFrm.btnCancelClick}

Finally, to test the screen saver, we will need to show the screen saver form (which we haven't yet created). Go ahead and double-click on the Test button and add the following code: procedure TCfgFrm.btnTestClick(Sender: TObject); begin ScrnFrm.Show; end; {TCfgFrm.btnTestClick}

Then add "Scrn" to the uses clause in the implementation section. Scrn refers to the screen saver form unit that we will create in the next step. In the meantime, save this form unit as "Cfg" by selecting Save File as from the File menu.

Screen Saver Form The screen saver itself will simply be a large, black, captionless form that covers the entire screen, upon which the graphics are drawn. To create the second form, select New Form from the File menu and indicate a "Blank form" if prompted by the Browse Gallery. BorderIcons [] biSystemMenu False biMinimize False biMaximize False BorderStyle bsNone Color clBlack FormStyle fsStayOnTop Name ScrnFrm Visible False

To this form, add a single component -- a timer from the System category of the Delphi component palette. Set its properties accordingly: object tmrTick: TTimer Enabled = False OnTimer = tmrTickTimer Left = 199 Top = 122 end

No other components will be required for this form. However, we will need to add some code to handle drawing the shaded spheres. Switch to the code window accompanying the ScrnFrm form. In the TScrnFrm private section, add the following procedure declaration: procedure DrawSphere(x, y, size : integer; color : TColor);

Now, in the implementation section of the unit, add the code for this procedure: procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor); var i, dw : integer; cx, cy : integer; xy1, xy2 : integer; r, g, b : byte; begin with Canvas do begin {Fill in the pen & brush settings.} Pen.Style := psClear; Brush.Style := bsSolid; Brush.Color := color; {Prepare colors for sphere.}

209

r := GetRValue(color); g := GetGValue(color); b := GetBValue(color); {Draw the sphere.} dw := size div 16; for i := 0 to 15 do begin xy1 := (i * dw) div 2; xy2 := size - xy1; Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255), Min(b + (i * 8), 255)); Ellipse(x + xy1, y + xy1, x + xy2, y + xy2); end; end; end; {TScrnFrm.DrawSphere}

As you can see from the code, we are given the (x,y) coordinates of the top, left corner of the sphere, as well as its diameter and base color. Then, to draw the sphere, we step through brushes of increasingly bright color, starting with the given base color. With each new brush, we draw a smaller filled circle concentric with the previous ones. You will also notice, however, that the function refers to another function, Min(). This is not a standard Delphi function, so we must add it to the unit, above the declaration for DrawSphere(). function Min(a, b : integer) : integer; begin if b < a then Result := b else Result := a; end; {Min}

In order to periodically call the DrawSphere() function, we must respond to the OnTimer event of the Timer component we added to the ScrnFrm. Double-click the Timer component on the form and fill in the automatically created procedure with the following code: procedure TScrnFrm.tmrTickTimer(Sender: TObject); const sphcount : integer = 0; var x, y : integer; size : integer; r, g, b : byte; color : TColor; begin if sphcount > CfgFrm.spnSpheres.Value then begin Refresh; sphcount := 0; end; Inc(sphcount); x := Random(ClientWidth); y := Random(ClientHeight); size := CfgFrm.spnSize.Value + Random(50) - 25; x := x - size div 2; y := y - size div 2; r := Random($80); g := Random($80); b := Random($80); DrawSphere(x, y, size, RGB(r, g, b)); end; {TScrnFrm.tmrTickTimer}

This procedure keeps track of the number of spheres that have been drawn in sphcount, and refreshes (erases) the screen when we have reached the maximum number. In the meantime, it calculates the random position, size, and color for the next sphere to be drawn. (Note: The color range is limited to only the first half of the brightness spectrum in order to provide greater depth to the shading.) As you may have noticed, the tmrTickTimer() procedure references the CfgFrm form to retrieve the configuration options. In order for this reference to be recognized, add the following uses clause to the implementation section of the unit: uses Cfg;

210

Next, we will need a way to deactivate the screen saver when a key is pressed, the mouse is moved, or the screen saver form looses focus. One way to do this is to create an handler for the Application.OnMessage event that looks for the necessary conditions to terminate the screen saver. First, add the following variable declaration to the implementation section of the unit: var crs : TPoint;

This variable will be used to store the original position of the mouse cursor for later comparison. Now, add the following declaration to the private section of TScrnFrm: procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);

Add the corresponding code to the implementation section of the unit:

procedure TScrnFrm.DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean); var done : boolean; begin if Msg.message = WM_MOUSEMOVE then done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or (Abs(HIWORD(Msg.lParam) - crs.y) > 5) else done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_ACTIVATE) or (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_NCACTIVATE); if done then Close; end; {TScrnFrm.DeactivateScrnSaver}

When a WM_MOUSEMOVE window message is received, we compare the new coordinates of the mouse to the original location. If it has moved more than our threshold (5 pixels in any direction), then we close the screen saver. Otherwise, if a key is pressed or another window or dialog box takes the focus, the screen saver closes. In order for this procedure to go into effect, however, we need to set the Application.OnMessage property and get the original position of the mouse cursor. A good place to do this is in the form's OnShow event handler: procedure TScrnFrm.FormShow(Sender: TObject); begin GetCursorPos(crs); tmrTick.Interval := 1000 - CfgFrm.spnSpeed.Value * 90; tmrTick.Enabled := true; Application.OnMessage := DeactivateScrnSaver; ShowCursor(false); end; {TScrnFrm.FormShow}

Here we also specify the timer's interval and activate it, as well as hiding the mouse cursor. Most of these things should be undone, however, in the form's OnHide event handler:

procedure TScrnFrm.FormHide(Sender: TObject); begin Application.OnMessage := nil; tmrTick.Enabled := false; ShowCursor(true); end; {TScrnFrm.FormHide}

Finally, we need to make sure that the screen saver form fills the entire screen when it is shown. To do this add the following code to the form's OnActivate event handler: procedure TScrnFrm.FormActivate(Sender: TObject); begin WindowState := wsMaximized; end; {TScrnFrm.FormActivate}

Take this opportunity to save the ScrnFrm form unit as "SCRN.PAS" by selecting Save File from the File menu.

The Screen Saver Description You can define the text that will appear in the Control Panel Desktop list of screen savers by adding a {$D text} directive to the project source file. The $D directive inserts the given text into the module description entry of the executable file. For the Control Panel to recognize the text you must start with the term "SCRNSAVE", followed by your description. 211

Select Project Source from the Delphi View menu so you can edit the source file. Beneath the directive "{$R *.RES}", add the following line: {$D SCRNSAVE Spheres Screen Saver}

The text "Spheres Screen Saver" will appear in the Control Panel list of available screen savers when we complete the project.

Active Versus Configuration Mode Windows launches the screen saver program under two possible conditions: 1) when the screen saver is activated, and 2) when the screen saver is to be configured. In both cases, Windows runs the same program. It distinguishes between the two modes by adding a command line parameter -- "/s" for active mode and "/c" for configuration mode. For our screen saver to function properly with the Control Panel, it must check the command line for these switches.

Active Mode When the screen saver enters active mode (/s), we need to create and show the screen saver form. We also need create the configuration form, since it contains all of the configuration options. When the screen saver form closes, the entire program should then terminate. This fits the definition of a Delphi Main Form -- a form that starts when the program starts and signals the end of the application when the form closes.

Configuration Mode When the screen saver enters configuration mode (/c), we need to create and show the configuration form. We should also create the screen saver form, in case the user wishes to test configuration options. However, when the configuration form closes, the entire program should then terminate. In this case, the configuration form fits the definition of a Main Form.

Defining the Main Form Ideally, we would like to identify ScrnFrm as the Main Form when a /s appears on the command line, and CfgFrm as the Main Form in all other cases. To do this requires knowledge of an undocumented feature of the TApplication VCL object: The Main Form is simply the first form created with a call to Application.CreateForm(). Thus, to define different Main Forms according to our run-time conditions, modify the project source as follows: begin if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin {ScrnFrm needs to be the Main Form.} Application.CreateForm(TScrnFrm, ScrnFrm); Application.CreateForm(TCfgFrm, CfgFrm); end else begin {CfgFrm needs to be the Main Form.} Application.CreateForm(TCfgFrm, CfgFrm); Application.CreateForm(TScrnFrm, ScrnFrm); end; Application.Run; end.

Just by changing the order of creation, we have automatically set the Main Form for that instance. In addition, the Main Form will automatically be shown, despite the fact that we have set the Visible properties to False for both forms. as a result, we achieve the desired effect with only minimal code. (Note: for the if statement to function as shown above, the "Complete boolean eval" option should be unchecked in the Options | Project | Compiler settings. Otherwise, an error will occur if the program is invoked with no command line parameters.) In order to use the UpperCase() Delphi function, SysUtils must be included in the project file's uses clause to give something like: uses Forms, SysUtils, Scrn in 'SCRN.PAS' {ScrnFrm}, Cfg in 'CFG.PAS' {CfgFrm};

212

Blocking Multiple Instances One difficulty with Windows screen savers is that they must prevent multiple instances from being run. Otherwise, Windows will continue to launch a screen saver as the given time period ellapses, even when an instance is already active. To block multiple instances of our screen saver, modify the project source file to add the outer if statement shown below: begin {Only one instance is allowed at a time.} if hPrevInst = 0 then begin if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin ... end; Application.Run; end; end;

The hPrevInst variable is a global variable defined by Delphi to point to previous instances of the current program. It will be zero if there are no previous instances still running. Now save the project file as "SPHERES.DPR" and compile the program. With that, you should be able to run the screen saver on its own. Without any command line parameters, the program should default to configuration mode. By giving "/s" as the first command line parameter, you can also test the active mode. (See Run | Parameters...)

Installing the Screen Saver Once you've tested and debugged your screen saver, you are ready to install it. To do so, simply copy the executable file (SPHERES.EXE) to the Windows directory, changing its filename extension to .SCR in the process (SPHERES.SCR). Then, launch the Control Panel, double-click on Desktop, and select Screen Saver | Name. You should see "Spheres Screen Saver" in the list of possible screen savers. Select it and set it up

213

sscanf in delphi? From: [email protected] (Barry) A kind soul sent me the following unit a while ago. I have found it quite useful, but there may be a problem with the %s tag since its use has generated errors on occasion. unit Scanf; interface uses SysUtils; type EFormatError = class(ExCeption); function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; implementation { Sscanf parses an input string. The parameters ... s - input string to parse fmt - 'C' scanf-like format string to control parsing %d - convert a Long Integer %f - convert an Extended Float %s - convert a string (delimited by spaces) other char - increment s pointer past "other char" space - does nothing Pointers - array of pointers to have values assigned result - number of variables actually assigned for example with ... Sscanf('Name. Bill Time. 7:32.77 Age. 8', '. %s . %d:%f . %d', [@Name, @hrs, @min, @age]); You get ... Name = Bill hrs = 7 min = 32.77 age = 8

}

function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; var i,j,n,m : integer; s1 : string; L : LongInt; X : Extended; function GetInt : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetFloat : Integer; begin s1 := '';

214

while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetString : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] <> ' ') and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function ScanStr(c : Char) : Boolean; begin while (s[n] <> c) and (Length(s) > n) do inc(n); inc(n); If (n <= Length(s)) then Result := True else Result := False; end; function GetFmt : Integer; begin Result := -1; while (TRUE) do begin while (fmt[m] = ' ') and (Length(fmt) > m) do inc(m); if (m >= Length(fmt)) then break; if (fmt[m] = '%') then begin inc(m); case fmt[m] of 'd': Result := vtInteger; 'f': Result := vtExtended; 's': Result := vtString; end; inc(m); break; end; if (ScanStr(fmt[m]) = False) then break; inc(m); end; end; begin n := 1; m := 1; Result := 0; for i := 0 to High(Pointers) do begin j := GetFmt; case j of vtInteger : begin if GetInt > 0 then begin L := StrToInt(s1);

215

Move(L, Pointers[i]^, SizeOf(LongInt)); inc(Result); end else break; end; vtExtended : begin if GetFloat > 0 then begin X := StrToFloat(s1); Move(X, Pointers[i]^, SizeOf(Extended)); inc(Result); end else break; end; vtString : begin if GetString > 0 then begin Move(s1, Pointers[i]^, Length(s1)+1); inc(Result); end else break; end; else break; end; end; end; end.

Supporting Cut Copy Paste From: "Shejchenko Andrij" I use following procedures. Call them when clicking correspondent menu items. This will work with all editable controls. But you should specially handle EDIT messages for trees. procedure TMainForm.EditUndo(Sender: TObject); var Mes:TWMUndo; begin Mes.Msg:=WM_UNDO; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCut(Sender: TObject); var Mes:TWMCut; begin Mes.Msg:=WM_CUT; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCopy(Sender: TObject); var Mes:TWMCopy; begin Mes.Msg:=WM_COPY; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditPaste(Sender: TObject); var Mes:TWMPaste; begin Mes.Msg:=WM_PASTE;

216

Screen.ActiveControl.Dispatch(Mes); end;

217

From: [email protected] (Frantzcy Paisible) Subject: Re: [delphi] Adding to Program Manager Date: Mon, 26 Jun 1995 15:05:16 -0400 >Anybody know how to add my application to Program Manager? This application >needs to be placed into the Startup group. I also need to restart windows >after the setup program runs. Any ideas? Here is what's left from what I got from borland some time ago. The DDEClient is a component you drop on the form (System, DdeClientItem). Var Macro : String; Var Cmd: array[0..255] of Char; NewPrg,Desc : String; Begin { Create the group, does nothing if it existst } Name := 'StartUp'; Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10; StrPCopy (Cmd, Macro); DDEClient.OpenLink; if not DDEClient.ExecuteMacro(Cmd, False) then MessageDlg(, mtInformation, [mbOK], 0); { Then you add you program } NewPrg := 'C:\HELLO.EXE'; {Full path of the program you} Desc := 'Say Hello'; {Description that appears under the icon| Macro := '[AddItem('+NewPrg+','+Desc+')]'+ #13#10; StrPCopy (Cmd, Macro); if not f1_.DDEClient.ExecuteMacro(Cmd, False) then MessageDlg(,mtInformation, [mbOK], 0); { To make sure the group is saved } StrPCopy (Cmd,'[ShowGroup(nonexist,1)]'); DDEClient.ExecuteMacro(Cmd, False); { Now... this part doesn't work and I don't know why } { Anybody who knows why is welcome } StrPCopy (Cmd,'[reload()]'); DDEClient.ExecuteMacro(Cmd, False); { and close the link } DDEClient.CloseLink; End; Good Luck! ................................................................... Frantzcy Paisible . Fax: (514) 527-4066 Internet Montreal . E-mail: [email protected] 218

Tel: (514) 393-1014

.

URL:

http://mtl.net

------------------------------------------------------------------------------From: [email protected] Subject: RE: [delphi] DDE with Program Manager Date: Wed, 28 Jun 1995 19:20:30 -0600 A procedure to get all groups from the program manager using a DDEclientconv: {This example needs a listbox called AllGroups} procedure GetGroups(Sender: TObject); var Thedata: pchar; {pchar that holds the groups} dat: char; {used to process each group} charcount: word; Theitem,theline:string; begin {get allgroups items} charcount:=0; TheData:= DDEClientConv2.RequestData('Groups'); theline:=''; repeat application.processmessages; dat:=Thedata[charcount];{get character from the Thedata} if (dat=chr(10)) {or (dat=chr(13))} then begin while Pos(char(10), Theline) > 0 do delete(Theline,pos(char(10),Theline),1); while Pos(char(13), Theline) > 0 do delete(Theline,pos(char(13),Theline),1); If theline='' then continue; allgroups.items.add(theline); {Allgroups is a LISTBOX} theline:=''; end; Theline:=theline+dat; inc(charcount); until charcount>=strlen(Thedata); strdispose(Thedata); end; {This procedure will save you hours of brain waves!} -Michael Caracena

219

Use desktop as canvas!! function windowsDesktopCanvas: TCanvas; var DC: HDc; begin DC := getWindowDC ( GetDeskTopWindow ); result := TCanvas.Create; result.Handle := DC; end;

220

!**************************************

! for :Dll,Exe,Dat,Drv File Scanner(Priit Serk)

!************************************** Programmed by Priit Serk !************************************** ! Name: Dll,Exe,Dat,Drv File Scanner(Priit Serk) ! Description:This code enables you to view all procedures and functions what DLL,DAT,EXE,DRV file has. It displays them to your screen and later you can use this file with Delphi. ! By: ! ! ! Inputs:None ! ! Returns:Code returns all procedures and functions what DLL,EXE,DAT,DRV file has. ! !Assumes:None ! !Side Effects:None !This code is copyrighted and has limited warranties. !Please see http://www.Planet-SourceCode.com/xq/ASP/txtCodeId.380/lngWId.7/qx/vb/scripts/ShowCode.htm !for details. !************************************** procedure GetFunctionNamesFromDLL(DLLName: string; List: TStrings); type chararr = array[0..$FFFFFF] of char; var h: THandle; i, fc: integer; st: string; arr: pointer; ImageDebugInformation: PImageDebugInformation; begin List.Clear; DLLName := ExpandFileName(DLLName); if not FileExists(DLLName) then Exit; h := CreateFile(PChar(DLLName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if h = -1 then Exit; ImageDebugInformation := MapDebugInformation(h, PChar(DLLName), nil, 0); if ImageDebugInformation = nil then Exit; arr := ImageDebugInformation^.ExportedNames; fc := 0; for i := 0 to ImageDebugInformation^.ExportedNamesSize - 1 do begin if chararr(arr^)[i] = #0 then begin st := PChar(@chararr(arr^)[fc]); if length(st) > 0 then List.Add(st); if (i > 0) and (chararr(arr^)[i - 1] = #0) then Break; fc := i + 1; end; end; 221

UnmapDebugInformation(ImageDebugInformation); CloseHandle(h); end;

222

a

Duvar kagidi degistirme

Kapat

Programinizin calismasi esnasinda, arzu ettiginiz bir duvar kagidinin kullanilmasini ister misiniz? Iste bunu halletmenin yolu… procedure TForm1.FormCreate(Sender: TObject); var Reg: TRegIniFile; begin Reg := TRegIniFile.Create('Control Panel'); Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp'); Reg.WriteString('desktop', 'TileWallpaper', '1'); Reg.Free; SystemParametersInfo(SPI_SETDESKWALLPAPER,0, nil, SPIF_SENDWININICHANGE); end;

223

Office 2000'de oldugu gibi ToolBar üzerinde Kayan Menü

Kapat

type TForm1 = class(TForm) AnaMenu : TMainMenu; ControlBar : TControlBar; MenuCubugu : TToolBar; procedure FormCreate(Sender: TObject); private public end; var Form1 : TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var MenuNo,MenuGenisligi : Integer; MenuElemani : TToolButton; begin MenuGenisligi:=0; for MenuNo:=AnaMenu.Items.Count-1 downto 0 do begin MenuElemani:=TToolButton.Create(MenuCubugu); MenuElemani.Parent:=MenuCubugu; MenuElemani.AutoSize:=True; MenuElemani.Grouped:=True; MenuElemani.Caption:=AnaMenu.Items[MenuNo].Caption; MenuElemani.MenuItem:=AnaMenu.Items[MenuNo]; Inc(MenuGenisligi,MenuElemani.Width); end; MenuCubugu.Width:=MenuGenisligi; Menu:=nil; end; // // ToolBar'in Flat özelligini True yapin. // // Kolay Gelsin. // // Hakan HAMURCU // [email protected] //

224

Ipucu penceresinin özellestirilmesi

Kapat

Standart ipucu penceresi, kismen de olsa özellestirilebilir. Iste örnegi. type TMyHintWindow = class (THintWindow) constructor Create (AOwner: TComponent); override; end; var Form1: TForm1; implementation constructor TMyHintWindow.Create (AOwner: TComponent); begin inherited Create (AOwner); canvas.brush.color:=clwhite; Canvas.Font.Name := 'Courier New'; Canvas.Font.Size := 72; end; procedure TForm1.FormCreate(Sender: TObject); begin Application.ShowHint := false; HintWindowClass := TMyHintWindow; Application.ShowHint := True; end;

225

Ag da tanimli kullanicilar kimler? Component Kodu

Kapat

Ag ortamindayken, ayni aga giris yapmaya yetkili kullanicilarin (bilgisayarlarin), isimlerini bulup getiren bir bilesene ait unit asagidadir. Kullanilabilmesi icin, sisteme bilesen olarak tanimlanmasi gereklidir. Bunun icin, Components | Install components menüsü kullanilir. unit NetUsers; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TNetUsers = class(TComponent) private { Private declarations } fServer : string; protected { Protected declarations } procedure SetServer(Server : string); public { Public declarations } UserList: TStringList; constructor Create(Owner:TComponent); override; destructor Destroy; override; function Execute : Boolean; published { Published declarations } property Server :string read fServer write SetServer; end; PnetResourceArr = ^TNetResource; procedure register; implementation procedure TNetUsers.SetServer(Server : string); begin if fServer <> Server then fServer := Server; end; constructor TNetUsers.Create(Owner:TComponent); begin inherited Create(Owner); if not ( csDesigning in ComponentState ) then begin UserList := TStringList.Create; UserList.Sorted := True; end; end; destructor TNetUsers.Destroy; begin if not( csDesigning in ComponentState ) then UserList.Destroy; inherited Destroy; end; function TNetUsers.Execute : Boolean; var NetResource: TNetResource; Buf:Pointer; Count, BufSize, Res: DWORD; i : Integer; lphEnum: THandle; p : PnetResourceArr; begin Execute := False; UserList.Clear;

226

UserList.Clear; GetMem(Buf, 8192); try FillChar(NetResource, SizeOf(NetResource), 0); NetResource.lpRemoteName := PChar(fServer); NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER; NetResource.dwUsage := RESOURCEUSAGE_CONTAINER; NetResource.dwScope := RESOURCETYPE_DISK; Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum); if Res <> 0 then Exit; while true do begin Count := -1; BufSize := 8192; Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); if Res = ERROR_NO_MORE_ITEMS then Exit; if (Res <> 0) then Exit; p := PNetResourceArr(Buf); for i := 0 to Count - 1 do begin { Agdaki kullanici isimlerini Userlist listesine ekle} UserList.Add(p^.lpRemoteName + 2); Inc(p); end; end; Res := WNetCloseEnum(lphEnum); if Res <> 0 then raise Exception(Res); finally FreeMem(Buf); Execute := True; end; end; procedure register; begin RegisterComponents('Sil', [TNetUsers]); end; end. //kullanimi { procedure TForm1.Button1Click(Sender: TObject); begin NETUSERS1.EXECUTE; listbox1.items.assign(netusers1.userlist) end;}

227

XOR Sifreleme mantiginin kirilmasi

Kapat

procedure TForm1.Button1Click(Sender: TObject); var i,j:longword; thistime,lasttime:longword; buffer:array[0..7]of byte; b:array[0..1]of longword absolute buffer[0]; plaintext:array[0..7]of byte; p:array[0..1]of longword absolute plaintext[0]; key:array[0..7]of byte; k:array[0..1]of longword absolute key[0]; begin lasttime:=gettickcount; randomize; if length(edit1.text)<8 then exit; for i:=0 to 7 do begin plaintext[i]:=byte(edit1.text[i+1]); buffer[i]:=plaintext[i] xor random(256);//encrypt end; i:=0; repeat for j:=0 to 1000000 do //loop is unrolled by compiler begin randseed:=i; key[0]:=random(256); key[1]:=random(256); key[2]:=random(256); key[3]:=random(256); key[4]:=random(256); key[5]:=random(256); key[6]:=random(256); key[7]:=random(256); if b[0] xor k[0]=p[0] then //test key in blocks of 4 if b[1] xor k[1]=p[1] then begin thistime:=gettickcount; caption:='The key is: '+inttostr(i)+' ('+inttostr((thistime- lasttime)div 1000)+'sec)'; Exit; end; inc(i,1); end; caption:=inttostr(i); application.processmessages; until i>longword(MaxInt); end; bLaCkSnOw [email protected]

228

OEM LOGO Nasıl değişirmiş?

OEMIFO.INI ve OEMLOGO.BMP dosyaları c:\winnt\system32 dizini içerisine oluşturulur. OEMINFO.INI dosyasında; [general] Manufacturer=Tanz AnthroX Model=ver 1.1 [support information] Line1=AnthroX Software Line2=www.AnthroX.com [email protected] Line4= Line5= Line6= Line7= Line8= Line9= Line10= yazmaktadır. Tips from Tansu ÖZÇELEBİ

229

Start a program in a new Desktop Linux has a neat feature which allows 4 (possibly more) desktops active at once. I am not replicating this here :) However the following function will start a new program in a new desktop and wait until it has finished, this could be useful in a variety of applications including setup programs or anywhere where you don't want the user to access the standard desktop (i.e. in a cybercafe). Answer: function StartProcessInNewDeskTopAndWait(const FileName, Params: string; DeskTop: string = 'NewDeskTop'): boolean; var StartInfo: TStartupInfo; ProcInfo: TProcessInformation; CmdLine: string; hDeskTop: HDESK; begin (* Ensure the file Exists *) if not FileExists(FileName) then raise Exception.Create(FileName + #13'Does Not Exist!!'); (* Quote the filename incase it contains spaces, tag on the parameters *) CmdLine := AnsiQuotedStr(Filename, '"') + ' ' + Params; (* Create a new desktop *) hDeskTop := CreateDesktop(PChar(DeskTop), nil, nil, DF_ALLOWOTHERACCOUNTHOOK, MAXIMUM_ALLOWED, nil); try (* clear out the CreateProcess params and refill with valid data *) FillChar(StartInfo, SizeOf(StartInfo), 0); with StartInfo do begin cb := SizeOf(StartUpInfo); dwFlags := STARTF_USESHOWWINDOW; wShowWindow := SW_SHOW; lpDesktop := PChar(DeskTop); end; (* Start the program *) Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, PChar(ExtractFilePath(Filename)), StartInfo, ProcInfo); if Result then begin (* Switch to the newly created desktop *) SwitchDesktop(hDeskTop); (* wait for the program to finish before coming back *) WaitForSingleObject(ProcInfo.hProcess, INFINITE); (* Free the Handles *) CloseHandle(ProcInfo.hProcess); CloseHandle(ProcInfo.hThread); (* Switch back to the current desktop *) 230

SwitchDesktop(GetThreadDesktop(GetCurrentThreadID)); end; finally (* Close the desktop that we created *) CloseDesktop(hDeskTop); end; end; To call the program use something like procedure TForm1.Button1Click(Sender: TObject); begin StartProcessInNewDeskTopAndWait('d:\winnt\system32\notepad.exe', '"c:\autoexec.bat"'); end;

231

How to make the selected TreeNode Bold without owner drawing The following code uses the TVIS_BOLD constant to make the selected node bold. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls; type TForm1 = class(TForm) TreeView1: TTreeView; procedure TreeView1Change(Sender: TObject; Node: TTreeNode); procedure TreeView1Changing(Sender: TObject; Node: TTreeNode; var AllowChange: Boolean); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses Commctrl; {$R *.DFM} procedure SetNodeBold(Node: TTreeNode; MakeBold: Boolean); var Item: TTVItem; Template: Integer; begin if Assigned(Node) then begin if MakeBold then Template := -1 else Template := 0; Item.Mask := TVIF_STATE; Item.hItem := Node.ItemId; Item.StateMask := TVIS_BOLD; Item.State := Item.StateMask and Template; TreeView_SetItem(Node.TreeView.Handle, Item); end; end; procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode); begin SetNodeBold(Node, True); 232

end; procedure TForm1.TreeView1Changing(Sender: TObject; Node: TTreeNode; var AllowChange: Boolean); begin SetNodeBold(TreeView1.Selected, False) end; end.

233

Here's the code I use, the comment shows a link to my source for the technique. David procedure SendMsgToMachine( FromName, ToName, Text: String); // http://www.djernaes.dk/martin/winpopup.html var H: THandle; S: String; DW: DWord; begin H := CreateFile( PChar( '\\'+ ToName +'\mailslot\messngr'), GENERIC_WRITE, FILE_SHARE_READ, NIL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if H = INVALID_HANDLE_VALUE then raise Exception.CreateFmt( 'NetSend CreateFile failed( %d)', [GetLastError]); S := FromName +#0+ ToName +#0+ Text +#0; try if not WriteFile(H, S[ 1], Length( S), DW, nil) then raise Exception.CreateFmt( 'NetSend WriteFile failed( %d)', [GetLastError]); finally FileClose( H); end; end;

234

Question/Problem/Abstract: How can I send Messages from an application, as like NT command net send? Answer: Well here it goes. The Program uses a Function not declared in the standard units in Delphi 5 Enterprise (Update). So we have to include our own file with constant's and the function. Here it goes: unit lmmsg; // Thanks to Win2k4u for providing me with this file. (dalNet, #delphi.se) interface //uses lmglobal; const // // Values for msgi1_forward_flag. // MSGNAME_NOT_FORWARDED = 0; // Name not forwarded MSGNAME_FORWARDED_TO = $04; // Name forward to remote station MSGNAME_FORWARDED_FROM = $10; // Name forwarded from remote station type MSG_INFO_0 = record msgi0_name : PWideChar end; PMSG_INFO_0 = ^MSG_INFO_0; MSG_INFO_1 = record msgi1_name : PWideChar; msgi1_forward_flag : Integer; msgi1_forward : PWideChar end; PMSG_INFO_1 = ^MSG_INFO_1; function NetMessageNameAdd ( serverName, msgName : PWideChar) : Integer; stdcall; function NetMessageNameEnum ( serverName : PWideChar; level : Integer; var buffer : Pointer; prefMaxLen : Integer; var entriesRead, totalEntries, resumeHandle : Integer) : Integer; stdcall; function NetMessageNameGetInfo ( servername, msgname : PWideChar; level : Integer; var buffer : Pointer) : Integer; stdcall; 235

function NetMessageNameDel ( serverName, msgName : PWideChar) : Integer; stdcall; function NetMessageBufferSend ( serverName, msgName, fromName : PWideChar; buf : Pointer; bufLen : Integer) : Integer; stdcall; //NetAPIStatus == Integer implementation function NetMessageNameAdd; external 'NETAPI32.DLL'; function NetMessageNameEnum; external 'NETAPI32.DLL'; function NetMessageNameGetInfo; external 'NETAPI32.DLL'; function NetMessageNameDel; external 'NETAPI32.DLL'; function NetMessageBufferSend; external 'NETAPI32.DLL'; end. Copy above code and save it as the unit lmmsg.pas. Then place following components on your Form. * TLabel (Caption, Receiver) * TLabel (Caption, ''); * TComboBox * TButton (Caption, Send) * TMemo Woo! Half way done now.. Create an event for the Button you just created, call it Button1 and paste this code: procedure TForm1.Button1Click(Sender: TObject); var MsgBuff : pWideChar; Size, NewSize, Code : Integer; User, UName : Array[0..127] Of WideChar; begin Size := Length(Memo1.Text); StringToWideChar(ComboBox1.Text, User, SizeOf(User) div 2); StringToWideChar(UserName, UName, SizeOf(UName) div 2); NewSize := Size * 2; MsgBuff := VirtualAlloc(nil, Size, Mem_Commit, Page_ReadWrite); MultiByteToWideChar(CP_ACP, 0, PChar(Memo1.Text), Size, MsgBuff, NewSize); Code := NetMessageBufferSend('', User, UName, MsgBuff, lStrLenW(MsgBuff)* SizeOf(pWideChar)); If Code = 0 Then Label3.Caption := 'Message was sent Successfully!' Else Label3.Caption := 'Returned Error Code: ' + IntToStr(Code); End; I'm passing the logged on user's name rather then the computer, cuz often in networks, the computer names are so cryptical and make no sense. 236

The Reason I set NewSize as Size * 2 is because, this function uses UniCode as character code, and UniCode uses 2 bytes to represent every charachter. The rest is hopefully kinda self explaining. So there's all the code needed to send a Network message to someone on you network. This code can be used in many ways, but this shows the basic idea behind the use of the function, NetMessageBufferSend. oh, one last thing.. I used a TComboBox, so that I either could load all names in it every time I started the app, so I don't have to re-type them again. Or even more fancy way, enumerate all current connected computer to the network, and present them there. I was too lazy for either way :D

237

Question/Problem/Abstract: The article "Sending Messages as the Microsoft NT command, net send" by Chris Viklund prompted me to look at the Net functions a little more closely. The first problem being that trying to run on a 95/98 machine will fail at program startup complaining about the DLL which it cannot link to. My solution was to create a TNetSend class which will attempt to load the DLL at creation time, if it fails (Win 95/98) then any calls to SendMessage will simply return false and no application crash occurs. I have played around with the other functions declared by Chris, but cannot actually get them to do anything useful. ie. TFGetNameEnum = function(ServerName : PWideChar;Level : integer; var Buffer : Pointer; PrefMaxLen : integer; var EntriesRead,TotalEntries,ResumeHandle : integer) : integer; stdcall; TFNameAdd = function(ServerName,MsgName : PWideChar) : integer; stdcall; TFNameDel = function(ServerName,MsgName : PWideChar) : integer; stdcall; The class currently has 1 method function SendMessage(ToName,NetMessage : string; ServerName : string = '') : boolean; ServerName is NullStr by default (LOCAL SERVER), I have not managed to use it with any servername except '' as ADMIN privileges are required for remote servers. Example var NS : TNetSend; procedure ????? begin NS := TNetSend.Create; ... end; procedure ????? begin NS.SendMessage('mikeh','Testing Net Send'); NS.SendMessage('harryj','Home Time at 6.00'); ... end; procedure ????? begin NS.Free; ... end; I Have included the expanded version I have been playing with as well, but not having much joy in getting any results (Privileges ????), maybe someone out there can debug and expand on them. 238

Answer: // Simplified Class (single method only)unit NetSend; interface uses Windows,Classes; type // DLL Prototype declaration TFSendMessage = function(ServerName,MsgName,FromName : PWideChar; Buf : Pointer; BufLen : integer) : integer; stdcall; // TNetSend Class TNetSend = class(TObject) private FLibHandle : THandle; FSendMessage : TFSendMessage; public constructor Create; destructor Destroy; override; function SendMessage(ToName,NetMessage : string; ServerName : string = '') : boolean; end; // ----------------------------------------------------------------------------implementation // ================================================ // Supplementarty functions // ================================================ function GetLogonName : string; var Buffer : string; Retvar : string; ASize : dword; begin RetVar := ''; SetLength(Buffer,50); Asize := length(Buffer); if GetUserName(PChar(Buffer),ASize) then begin Retvar := string(PChar(Buffer)); end else Retvar := ''; Result := RetVar; end; function ComputerName : string; var Name : PChar; WName : string; Size : DWORD; begin 239

Size := MAX_COMPUTERNAME_LENGTH + 1; GetMem(Name,Size); GetComputerName(Name,Size); WName := string(Name); FreeMem(Name); Result := WName; end; // ================================================ // Dynamically attempt to load library // ================================================ constructor TNetSend.Create; begin FLibHandle := LoadLibrary('NETAPI32.DLL'); if FLibHandle <> 0 then @FSendMessage := GetProcAddress(FLibHandle,'NetMessageBufferSend'); end; destructor TNetSend.Destroy; begin inherited Destroy; if FLibHandle <> 0 then FreeLibrary(FLibHandle); end; // ============================================================ = // Send a message to a user/application name // ServerName is '' by default and equates to LOCAL COMPUTER // Admin privilige is required to send from a remote server // ============================================================ == function TNetSend.SendMessage(ToName,NetMessage : string; ServerName : string = '') : boolean; var MsgBuff : PWideChar; Size,NewSize : integer; User,MyName,SName : array [0..127] of WideChar; RetVar : boolean; begin RetVar := false; if @FSendMessage <> nil then begin Size := length(NetMessage); StringToWideChar(ServerName,SName,SizeOf(SName) div 2); StringToWideChar(ToName,User,SizeOf(User) div 2); StringToWideChar(GetLogonName+'@'+ComputerName,MyName, SizeOf(MyName) div 2); NewSize := Size * 2; MsgBuff := VirtualAlloc(nil,Size,MEM_COMMIT,PAGE_READWRITE); MultiByteToWideChar(CP_ACP,0,PChar(NetMessage),Size, MsgBuff,NewSize); RetVar := (FSendMessage(SName,User,MyName,MsgBuff, 240

lStrLenW(MsgBuff) * SizeOf(PWideChar)) = 0); VirtualFree(MsgBuff,0,MEM_RELEASE); end; Result := RetVar; end; end.

// ============================================================ ================= // Additional functionality - ANYONE HELP OR EXPAND HERE PLEASE ??? // ============================================================ ================= unit NetSend; interface uses Windows,Classes; type // DLL Prototype declarations TFSendMessage = function(ServerName,MsgName,FromName : PWideChar; Buf : Pointer; BufLen : integer) : integer; stdcall; TFGetNameEnum = function(ServerName : PWideChar;Level : integer; var Buffer : Pointer; PrefMaxLen : integer; var EntriesRead,TotalEntries,ResumeHandle : integer) : integer; stdcall; TFNameAdd = function(ServerName,MsgName : PWideChar) : integer; stdcall; TFNameDel = function(ServerName,MsgName : PWideChar) : integer; stdcall; // TNetSend Class TNetSend = class(TObject) private FLibHandle : THandle; FSendMessage : TFSendMessage; FGetNameEnum : TFGetNameEnum; FNameAdd : TFNameAdd; FNameDel : TFNameDel; public constructor Create; destructor Destroy; override; procedure DelMsgName(MsgName : string; 241

ServerName : string = ''); procedure AddMsgName(MsgName : string; ServerName : string = ''); procedure GetReceipients(ToNames : TStrings; ServerName : string = ''); function SendMessage(ToName,NetMessage : string; ServerName : string = '') : boolean; end; // ----------------------------------------------------------------------------implementation const BUF_SIZE = 10; type MSG_INFO = record MsgName : PWideChar end; // Methods constructor TNetSend.Create; begin FLibHandle := LoadLibrary('NETAPI32.DLL'); if FLibHandle <> 0 then begin @FSendMessage := GetProcAddress(FLibHandle,'NetMessageBufferSend'); @FGetNameEnum := GetProcAddress(FLibHandle,'NetMessageNameEnum'); @FNameAdd := GetProcAddress(FLibHandle,'NetMessageNameNameAdd'); @FNameDel := GetProcAddress(FLibHandle,'NetMessageNameNameDel'); end; end; destructor TNetSend.Destroy; begin inherited Destroy; if FLibHandle <> 0 then FreeLibrary(FLibHandle); end; // ============================================================ = // Send a message to a user/application name // ServerName is '' by default and equates to LOCAL COMPUTER // Admin privilige is required to send from a remote server // ============================================================ == function TNetSend.SendMessage(ToName,NetMessage : string; ServerName : string = '') : boolean; var MsgBuff : PWideChar; Size,NewSize : integer; User,MyName,SName : array [0..127] of WideChar; 242

RetVar : boolean; begin RetVar := false; if @FSendMessage <> nil then begin Size := length(NetMessage); StringToWideChar(ServerName,SName,SizeOf(SName) div 2); StringToWideChar(ToName,User,SizeOf(User) div 2); StringToWideChar(GetLogonName+'@'+ComputerName,MyName, SizeOf(MyName) div 2); NewSize := Size * 2; MsgBuff := VirtualAlloc(nil,Size,MEM_COMMIT,PAGE_READWRITE); MultiByteToWideChar(CP_ACP,0,PChar(NetMessage),Size,MsgBuff,NewSize); RetVar := (FSendMessage(SName,User,MyName,MsgBuff, lStrLenW(MsgBuff) * SizeOf(PWideChar)) = 0); VirtualFree(MsgBuff,0,MEM_RELEASE); end; Result := RetVar; end; // ============================================================ ======== // Return list of msg names (only returns myself on local computer ?) // other server names I get a blank list ?? // ============================================================ ======== procedure TNetSend.GetReceipients(ToNames : TStrings; ServerName : string = ''); const LEN = 20; var InfPtr : pointer; InfArr : array [1..BUF_SIZE] of MSG_INFO; EntriesRead,TotalEntries,ResumeHandle : integer; SName : array [0..127] of WideChar; i : integer; begin ToNames.Clear; if @FGetNameEnum <> nil then begin EntriesRead := 0; TotalEntries := 0; ResumeHandle := 0; StringToWideChar(ServerName,SName,SizeOf(SName) div 2); InfPtr := VirtualAlloc(nil,SizeOf(MSG_INFO_ARR),MEM_COMMIT,PAGE_READWRITE); FGetNameEnum(SName,0,InfPtr,LEN,EntriesRead,TotalEntries,ResumeHandle); if EntriesRead > 0 then begin move(InfPtr^,InfArr[1],SizeOf(MSG_INFO_ARR)); for i := 1 to EntriesRead do ToNames.Add(InfArr[i].MsgName); end;

243

VirtualFree(InfPtr,0,MEM_RELEASE); end; end; procedure TNetSend.AddMsgName(MsgName : string; ServerName : string = ''); var UName,SName : array [0..127] of WideChar; begin if @FNameAdd <> nil then begin StringToWideChar(MsgName,UName,SizeOf(UName) div 2); StringToWideChar(ServerName,SName,SizeOf(SName) div 2); FNameAdd(SName,UName); end; end; procedure TNetSend.DelMsgName(MsgName : string; ServerName : string = ''); var UName,SName : array [0..127] of WideChar; begin if @FNameDel <> nil then begin StringToWideChar(MsgName,UName,SizeOf(UName) div 2); StringToWideChar(ServerName,SName,SizeOf(SName) div 2); FNameDel(SName,UName); end; end; end. -----------Bunları eklemeyi unutma derleyince hata verecek. Yep, it's missing. Here is the full definition const BUF_SIZE = 10; type MSG_INFO = record MsgName : PWideChar end; MSG_INFO_ARR = array [1..BUF_SIZE] of MSG_INFO; PMSG_INFO_ARR = ^MSG_INFO_ARR; ----------------------------

244

Question/Problem/Abstract: How To Make A Great Looking Form ? Answer: //////////////////////////////////////////////////////////////////////// /////// TRIED ON WINDOWS 2000 PROFESSIONAL AND SERVER WITH DELPHI 5 /////// PLEASE DO NOT TRY TO DEFINE ANY VALUES< MAY CAUSE ERROS //////////////////////////////////////////////////////////////////////// Hi Everybody, in a late time in the evening, i started digging in this code, and here is the result, to try it and see the results your self, please do the following...... 1- Start A New Project In Delphi 5 2- Make Sure JPEG Is In Your Windows Clause 3- Add These Lines const WS_EX_LAYERED = THE-SECRET-CODE-HERE---LOOK-COMMENT; LWA_COLORKEY = 1; //1 LWA_ALPHA = 2; //2 type TSetLayeredWindowAttributes = function ( hwnd : HWND; // handle to the layered window crKey : TColor; // specifies the color key bAlpha : byte; // value for the blend function dwFlags : DWORD // action ): BOOL; stdcall;

You Saw (THE-SECRET-CODE-HERE---LOOK-COMMENT) Above A Minute Ago, In This Place Add Any Of The Following Values Const $81111 Form Caption Flipped $82222 Form Visible But Can Never Get Focused $83333 Form Caption Flipped And Never Gets Focus $80FFF Form is (bsToolWindow), Never Maximized, Never Gets Focused $FFFFF Form is (bsToolWindow), Form Flipped, Never Gets Focus, Never Maximizes $222222 Very Strange Behaviour On Form Move, Try It !! $222000 Form Looks as In Win 3.11 Applications $333333 Captionless Window, Never Moves #333000 Form Like In Win 3.11 Applications, Caption Flipped $444444 The Whole Form With Everything On It Is Flipped $444888 The Whole Form With Everything On It Is Flipped, It Is Converted To (bsToolWindow) $555555 Form And All Contents Are Flipped, But Caption Still In Place ( Not Flipped ) $555888 Form And All Contents Are Flipped, But Caption Still In Place ( Not Flipped ), It Is Converted To (bsToolWindow) 245

$666666 Form And All Contents Are Flipped, Win 3.11 GUI $666888 Form And All Contents Are Flipped, Win 3.11 GUI, (bsTooWindow) $777000 This Is Strange, Looks Like A 16bit Application, Everything Flipped, Caption In Place ***BUT***, Windows Accesses Your Form as If It Was Not A Part Of Your Application, I Mean, When Minimizing Application, You Will See One Entry In The Taskbar, When Restoring It, Every Form Will Have Its Own Entry, Well, It Makes An MDI Like Application !! $777888 The Same But The MDI Form Will Have No Icon At All. $888888 (bsToolWindows) Transparent Form $888000 Normal Transparent Form $888FFF (bsToolWindows) Transparent Form, Cant Get Focused $8F8F8F (bsToolWindows) Transparent Form, MDI Alike $999999 Transparent (bsToolWindow) Form, Caption Flipped $999000 Transparent Form, Caption Flipped $999FFF Transparent (bsToolWindow) Form, Caption Flipped, Never Focused

4- In Your FormCreate Event, Place This Code var Info: TOSVersionInfo; F: TSetLayeredWindowAttributes; begin inherited; Info.dwOSVersionInfoSize := SizeOf(Info); GetVersionEx(Info); if (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and (Info.dwMajorVersion >= 5) then begin F := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes'); if Assigned(F) then begin SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED); F(Handle, 1, Round(255 * 75 / 100), LWA_ALPHA); end; end;

And Have Fun..................

246

Question/Problem/Abstract: Want to have a unique hint window? How bout transparent? Answer: This component requires unit udcUtil, in post Create Transparent Bitmap by me. Just drop this component to your form and set enabled to true. unit udcHintEx; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, udcUtil; type TdcInternalHintEx = class(THintWindow) private FTransBitmap: TTransparentBitmap; FActivating: Boolean; protected procedure Paint; override; procedure CreateParams(var Params: TCreateParams); override; public procedure ActivateHint(Rect: TRect; const AHint: string); override; function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override; constructor Create(AOwner:TComponent); override; destructor Destroy; override; end; TdcHintEx= class(TComponent) private FFont: TFont; FTransparent: Boolean; FTransparency: Integer; FTranspColor: TColor; FShadowColor: TColor; FEnabled: Boolean; FLeftMargin: Integer; FRightMargin: Integer; FBottomMargin: Integer; FTopMargin: Integer; procedure SetEnable(const Value: Boolean); procedure SetTransparency(const Value: Integer); procedure SetFont(const Value: TFont); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Transparent: boolean read FTransparent write FTransparent; property Transparency: Integer read FTransparency write SetTransparency default 30; property TranspColor: TColor read FTranspColor write FTranspColor default clInfoBk; property ShadowColor: TColor read FShadowColor write FShadowColor default clWhite; property Enabled: Boolean read FEnabled write SetEnable; property Font: TFont read FFont write SetFont; 247

property LeftMargin: Integer read FLeftMargin write FLeftMargin default 5; property TopMargin: Integer read FTopMargin write FTopMargin default 5; property RightMargin: Integer read FRightMargin write FRightMargin default 5; property BottomMargin: Integer read FBottomMargin write FBottomMargin default 5; end; procedure Register; implementation { TdcInternalHintEx } {$R *.RES} var dcHintEx: TdcHintEx; procedure TdcInternalHintEx.ActivateHint(Rect: TRect; const AHint: string); type PRGBArray = ^TRGBArray; TRGBArray = array[0..1000000] of TRGBTriple; begin FActivating := True; try ShowWindow(Handle, SW_HIDE); Caption := AHint; Inc(Rect.Bottom, 2); Inc(Rect.Right, 2); UpdateBoundsRect(Rect); if Rect.Top + Height > Screen.DesktopHeight then Rect.Top := Screen.DesktopHeight - Height; if Rect.Left + Width > Screen.DesktopWidth then Rect.Left := Screen.DesktopWidth - Width; if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft; if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop; if dcHintEx.Transparent then FTransBitmap.CreateBitmap(Rect, dcHintEx.TranspColor, dcHintEx.Transparency); SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height, SWP_SHOWWINDOW or SWP_NOACTIVATE); Invalidate; finally FActivating := False; end; end; function TdcInternalHintEx.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; begin Result := Rect(0, 0, MaxWidth, 0); Canvas.Font := dchintEx.Font; DrawText(Canvas.Handle, PChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX or DrawTextBiDiModeFlagsReadingOnly); Inc(Result.Right, dchintEx.RightMargin+dcHintEx.LeftMargin); Inc(Result.Bottom, dcHintEx.BottomMargin+dcHintEx.TopMargin); 248

end; constructor TdcInternalHintEx.Create(AOwner: TComponent); begin inherited; FTransBitmap := TTransparentBitmap.Create; end; procedure TdcInternalHintEx.CreateParams(var Params: TCreateParams); begin inherited; Params.Style := Params.Style - WS_BORDER; end; destructor TdcInternalHintEx.Destroy; begin FTransBitmap.Free; inherited; end; procedure TdcInternalHintEx.Paint; var R: TRect; begin R := ClientRect; Canvas.Font := dcHintEx.Font; if dcHintEx.Transparent then BitBlt(Canvas.Handle, 0, 0, FTransBitmap.TransBitmap.Width, FTransBitmap.TransBitmap.Height, FTransBitmap.TransBitmap.Canvas.Handle, 0, 0, SRCCOPY); Inc(R.Left, dcHintEx.LeftMargin-1); Inc(R.Top, dcHintEx.TopMargin-1); Dec(R.Right, dcHintEx.RightMargin+1); Dec(R.Bottom, dcHintEx.BottomMargin+1); Canvas.Font.Color := dcHintEx.ShadowColor; DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); Inc(R.Left,2); Inc(R.Top,2); Inc(R.Right,2); Inc(R.Bottom,2); DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); Dec(R.Left); Dec(R.Top); Dec(R.Right); Dec(R.Left); Canvas.Font.Color := dcHintEx.Font.Color; DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); end; { TdcHintEx } 249

constructor TdcHintEx.Create(AOwner: TComponent); begin if not (AOwner.InheritsFrom(TCustomForm)) then raise Exception.Create('dcHintEx must be dropped on a form.'); inherited; FLeftMargin:= 5; FRightMargin:= 5; FTopMargin:= 5; FBottomMargin:= 5; FTransparent := True; FTransparency := 30; FTranspColor := clInfoBk; FShadowColor := clWhite; FFont := TFont.Create; FFont.Assign(TCustomForm(AOwner).Font); end; destructor TdcHintEx.Destroy; begin FFont.Free; inherited; end; procedure TdcHintEx.SetEnable(const Value: Boolean); begin if FEnabled <> Value then begin FEnabled := Value; if not (csDesigning in ComponentState) then if FEnabled then begin dcHintEx := Self; HintWindowClass := TdcInternalHintEx end else begin dcHintEx := nil; if HintWindowClass = TdcInternalHintEx then HintWindowClass := THintWindow; end; end; end; procedure TdcHintEx.SetFont(const Value: TFont); begin FFont.Assign(Value); end; procedure TdcHintEx.SetTransparency(const Value: Integer); begin if (Value < 0) or (Value > 100) then raise Exception.Create('Invalid transparency percentage value.'); FTransparency := Value; end; procedure Register; begin 250

RegisterComponents('dc Tools', [TdcHintEx]); end; end.

251

Question/Problem/Abstract: How to make a different title bar? Answer: I made it on Delphi 5, but should work on older versions. Create a new form and set the property BorderStyle to bsNone. Insert an image named image1 - it will be the close button. Insert an image named image2 - it will be the title bar. Insert an image named image3 - it will be the minimize button. Insert an lable named label1 - it will be the title. If you want your title bar to look exactly like the windows title bar, then you will have to arrange the images all on the same roll and make some nice images for them. To make the label you will have to put it exactly over the bar, make it the same size as the bar, set the autosize of lable1 to false, set the Transparent to true and that's all. Thanks to Shannon(ICQ 5488969), We have a new very short version of this article: procedure TForm1.Image4MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if button = mbleft then //checks if left mouse button is down begin ReleaseCapture; Perform(WM_SYSCommand, $f019,0); //sends a command for moving //the form. Notice that $f019 is the hexdecimal value of SC_Move //(61456), but it not the same with SC_MOVE... end; end; That's All! Put this code in the mousedown event and you are done. This is my old article (My ICQ is 57662198): ....... var mdown:boolean; pos:TPoint; procedure TForm1.Image1Click(Sender: TObject); begin application.Terminate; end; procedure TForm1.Image3Click(Sender: TObject); begin Application.Minimize; end; procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin mdown := false; //the user isn't holding down the left mouse btn end; procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin mdown := true; //the user is holding down the left mouse button GetCursorPos(pos); 252

//Get the position of the cursor at the momment when the user //clicks on the bar (the mouse hasn't made a move yet) end; procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var mouse:TPoint; A,B :integer; begin //check if the user is holding down the mouse button if mdown = true then begin //get the possible new position of the cursor GetCursorPos(mouse); //get the difference between the last mouse move and this one A := mouse.X - pos.x; B := mouse.Y - pos.y; form1.left := form1.left + A; //set the new left position form1.top := form1.top + B; //set the new top position GetCursorPos(pos); //get the mouse position end; ........

253

Question/Problem/Abstract: How do I create lines (or whatever) on the screen? Eg. TDesktopCanvas Answer: { This program demonstrates a TDesktopCanvas. I wrote this to prepare my self for using Trinitron monitors :) The code parts are gathered from different parts of the www. } program TrinitronTraining; uses Messages, Windows, Graphics, Forms; type TDesktopCanvas = class(TCanvas) private DC : hDC; function GetWidth:Integer; function GetHeight:Integer; public constructor Create; destructor Destroy; override; published property Width: Integer read GetWidth; property Height: Integer read GetHeight; end; { TDesktopCanvas object } function TDesktopCanvas.GetWidth:Integer; begin Result:=GetDeviceCaps(Handle,HORZRES); end; function TDesktopCanvas.GetHeight:Integer; begin Result:=GetDeviceCaps(Handle,VERTRES); end; constructor TDesktopCanvas.Create; begin inherited Create; DC := GetDC(0); Handle := DC; end; destructor TDesktopCanvas.Destroy; begin Handle := 0; ReleaseDC(0, DC); inherited Destroy; end;

254

Const YCount = 2; Var desktop : TDesktopCanvas; dx,dy : Integer; i : Integer; F : Array[1..YCount] of TForm; function CreateLine(Y : Integer) : TForm; begin Result := TForm.Create(Application); with Result do begin Left := 0; Top := y; Width := dx; Height := 1; BorderStyle := bsNone; FormStyle := fsStayOnTop; Visible := True; end; end; procedure ProcessMessage; var Msg : TMsg; begin if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then if Msg.Message = WM_QUIT then Application.Terminate; end; begin desktop := TDesktopCanvas.Create; try dx := desktop.Width; dy := desktop.Height div (YCount+1); finally desktop.free; end; for i:=1 to YCount do F[i]:=CreateLine(i*dy); Application.NormalizeTopMosts; ShowWindow(Application.Handle, SW_Hide); for i:=1 to YCount do SetWindowPos(F[i].Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE); { use this if you don't want to stop repeat ProcessMessage; until false; {} Sleep(15000); 255

for i:=1 to YCount do F[i].Free; end.

256

Question/Problem/Abstract: Usually, when you make a game, it's very usefull to draw transparent bitmaps (without background). And so, mix bitmaps, (one over another one). This is a simple way to do that. Answer: To see more programming examples or anything goto my personal page: http://www.mad666.net To ask anything about programming goto my personal forum: http://webserver.interar.com.ar/empleoslocalescomar/cgibin/Ultimate.cgi -----------------------------------------------------------------------------{ The following unit draws two bitmaps on a form. One is used as the background and the second one as the foreground. The foreground bitmap is displayed as a "transparent" bitmap. This shows the two bitmaps mixed, one over another, We need to use the known BitBlt API to do the job. This example is quite fast.} Unit TranspBMP; Interface Uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; Type TForm1 = Class (TForm) Procedure FormCreate (Sender : TObject); Procedure FormClose (Sender : TObject; Var Action : TCloseAction); Private { Private declarations } ImageForeGround : TImage; ImageBackGround : TImage; Public { Public declarations } End; Procedure DrawTransparentBitmap (Ahdc : HDC; Image : TImage; XStart, YStart : Word); Var Form1 : TForm1; Implementation {$R *.DFM} Procedure DrawTransparentBitmap (Ahdc : HDC; Image : TImage; XStart, YStart : Word); Var

257

TransparentColor : TColor; CColor : TColorRef; BmAndBack, BmAndObject, BmAndMem, BmSave, BmBackOld, BmObjectOld, BmMemOld, BmSaveOld : HBitmap; HdcMem, HdcBack, HdcObject, HdcTemp, HdcSave : HDC; PtSize : TPoint; Begin // Set the transparent color to be the lower left pixel of the bitmap TransparentColor := Image.Picture.Bitmap.Canvas.Pixels [0, Image.Height - 1]; TransparentColor := TransparentColor or $02000000; HdcTemp := CreateCompatibleDC (Ahdc); SelectObject (HdcTemp, Image.Picture.Bitmap.Handle); // Select the bitmap // Convert bitmap dimensions from device to logical points PtSize.X := Image.Width; PtSize.Y := Image.Height; DPtoLP (HdcTemp, PtSize, 1); // Convert from device logical points // Create some DCs to hold temporary data HdcBack := CreateCompatibleDC (Ahdc); HdcObject := CreateCompatibleDC (Ahdc); HdcMem := CreateCompatibleDC (Ahdc); HdcSave := CreateCompatibleDC (Ahdc); // Create a bitmap for each DC BmAndBack := CreateBitmap (PtSize.X, PtSize.Y, 1, 1, NIL); BmAndObject := CreateBitmap (PtSize.X, PtSize.Y, 1, 1, NIL); BmAndMem := CreateCompatibleBitmap (Ahdc, PtSize.X, PtSize.Y); BmSave := CreateCompatibleBitmap (Ahdc, PtSize.X, PtSize.Y); // Each DC must select a bitmap object to store pixel data BmBackOld := SelectObject (hdcBack, bmAndBack); BmObjectOld := SelectObject (hdcObject, bmAndObject); BmMemOld := SelectObject (hdcMem, bmAndMem); BmSaveOld := SelectObject (hdcSave, bmSave); // Set proper mapping mode SetMapMode (HdcTemp, GetMapMode (Ahdc)); // Save the bitmap sent here, because it will be overwritten BitBlt (HdcSave, 0, 0, PtSize.X, PtSize.Y, HdcTemp, 0, 0, SrcCopy); // Set the background color of the source DC to the color contained in the // parts of the bitmap that should be transparent 258

CColor := SetBkColor (HdcTemp, TransparentColor); // Create the object mask for the bitmap by performing a BitBlt() // from the source bitmap to a monochrome bitmap BitBlt (HdcObject, 0, 0, PtSize.X, PtSize.Y, HdcTemp, 0, 0, SrcCopy); // Set the background color of the source DC back to the original color SetBkColor (HdcTemp, CColor); // Create the inverse of the object mask BitBlt (HdcBack, 0, 0, PtSize.X, PtSize.Y, HdcObject, 0, 0, NotSrcCopy); // Copy the background of the main DC to the destination BitBlt (HdcMem, 0, 0, PtSize.X, PtSize.Y, Ahdc, XStart, YStart, SrcCopy); // Mask out the places where the bitmap will be placed BitBlt (HdcMem, 0, 0, PtSize.X, PtSize.Y, HdcObject, 0, 0, SrcAnd); // Mask out the transparent colored pixels on the bitmap BitBlt (HdcTemp, 0, 0, PtSize.X, PtSize.Y, hdcBack, 0, 0, SrcAnd); // Xor the bitmap with the background on the destination DC BitBlt (HdcMem, 0, 0, PtSize.X, PtSize.Y, hdcTemp, 0, 0, SrcPaint); // Copy the destination to the screen BitBlt (Ahdc, XStart, YStart, PtSize.X, PtSize.Y, HdcMem, 0, 0, SrcCopy); // Place the original bitmap back into the bitmap sent here BitBlt (HdcTemp, 0, 0, PtSize.X, PtSize.Y, HdcSave, 0, 0, SrcCopy); // Delete the memory bitmaps DeleteObject (SelectObject (HdcBack, BmBackOld)); DeleteObject (SelectObject (HdcObject, BmObjectOld)); DeleteObject (SelectObject (HdcMem, BmMemOld)); DeleteObject (SelectObject (HdcSave, BmSaveOld)); // Delete the memory DCs DeleteDC (HdcMem); DeleteDC (HdcBack); DeleteDC (HdcObject); DeleteDC (HdcSave); DeleteDC (HdcTemp);

259

End; Procedure TForm1.FormCreate (Sender : TObject); Begin // Create image controls for two bitmaps and set their parents ImageForeGround := TImage.Create (Form1); ImageForeGround.Parent := Form1; ImageBackGround := TImage.Create (Form1); ImageBackGround.Parent := Form1; // Load images ImageBackGround.Picture.LoadFromFile ('c:\mad.bmp'); ImageForeGround.Picture.LoadFromFile ('c:\utilman.bmp'); // Set background image size to its bitmap dimensions With ImageBackGround Do Begin Left := 0; Top := 0; Width := Picture.Width; Height := Picture.Height; End; // Set the foreground image size centered in the background image With ImageForeGround Do Begin Left := (ImageBackGround.Picture.Width - Picture.Width) Div 2; Top := (ImageBackGround.Picture.Height - Picture.Height) Div 2; Width := Picture.Width; Height := Picture.Height; End; // Do not show the transparent bitmap as it will be displayed BitBlt()ed // by the DrawTransparentBitmap() function ImageForeGround.Visible := False; // Draw the tranparent bitmap note how the DC of the foreground is used in // the function below DrawTransparentBitmap (ImageBackGround.Picture.Bitmap.Canvas.Handle, ImageForeGround, ImageForeGround.Left, ImageForeGround.Top); End; 260

Procedure TForm1.FormClose (Sender: TObject; Var Action : TCloseAction); Begin // Free images ImageForeGround.Free; ImageBackGround.Free; End; End.

261

Question/Problem/Abstract: How to implement Gaussian Blur algorithm in Delphi? Answer: The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much. The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.) One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution. Anyway, you can do this: unit GBlur2; interface uses Windows, Graphics; type PRGBTriple = ^TRGBTriple; TRGBTriple = packed record b: byte; {easier to type than rgbtBlue} g: byte; r: byte; end; PRow = ^TRow; TRow = array[0..1000000] of TRGBTriple; PPRows = ^TPRows; TPRows = array[0..1000000] of PRow; const MaxKernelSize = 100; type TKernelSize = 1..MaxKernelSize; TKernel = record Size: TKernelSize; Weights: array[-MaxKernelSize..MaxKernelSize] of single; end; {the idea is that when using a TKernel you ignore the Weights except for Weights in the range -Size..Size.} procedure GBlur(theBitmap: TBitmap; radius: double); implementation 262

uses SysUtils; procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double); {makes K into a gaussian kernel with standard deviation = radius. For the current application you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small Size is good because the execution time is going to be propertional to K.Size.)} var j: integer; temp, delta: double; KernelSize: TKernelSize; begin for j := Low(K.Weights) to High(K.Weights) do begin temp := j / radius; K.Weights[j] := exp(-temp * temp / 2); end; {now divide by constant so sum(Weights) = 1:} temp := 0; for j := Low(K.Weights) to High(K.Weights) do temp := temp + K.Weights[j]; for j := Low(K.Weights) to High(K.Weights) do K.Weights[j] := K.Weights[j] / temp; {now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter - this is important, otherwise a blur with a small radius will take as long as with a large radius...} KernelSize := MaxKernelSize; delta := DataGranularity / (2 * MaxData); temp := 0; while (temp < delta) and (KernelSize > 1) do begin temp := temp + 2 * K.Weights[KernelSize]; dec(KernelSize); end; K.Size := KernelSize; {now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1} temp := 0; for j := -K.Size to K.Size do temp := temp + K.Weights[j]; for j := -K.Size to K.Size do K.Weights[j] := K.Weights[j] / temp; end; function TrimInt(Lower, Upper, theInteger: integer): integer; begin if (theInteger <= Upper) and (theInteger >= Lower) then result := theInteger else if theInteger > Upper then result := Upper else result := Lower; 263

end; function TrimReal(Lower, Upper: integer; x: double): integer; begin if (x < upper) and (x >= lower) then result := trunc(x) else if x > Upper then result := Upper else result := Lower; end; procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow); var j, n: integer; tr, tg, tb: double; {tempRed, etc} w: double; begin for j := 0 to High(theRow) do begin tb := 0; tg := 0; tr := 0; for n := -K.Size to K.Size do begin w := K.Weights[n]; {the TrimInt keeps us from running off the edge of the row...} with theRow[TrimInt(0, High(theRow), j - n)] do begin tb := tb + w * b; tg := tg + w * g; tr := tr + w * r; end; end; with P[j] do begin b := TrimReal(0, 255, tb); g := TrimReal(0, 255, tg); r := TrimReal(0, 255, tr); end; end; Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple)); end; procedure GBlur(theBitmap: TBitmap; radius: double); var Row, Col: integer; theRows: PPRows; K: TKernel; ACol: PRow; P: PRow; begin if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then 264

raise exception.Create('GBlur only works for 24-bit bitmaps'); MakeGaussianKernel(K, radius, 255, 1); GetMem(theRows, theBitmap.Height * SizeOf(PRow)); GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple)); {record the location of the bitmap data:} for Row := 0 to theBitmap.Height - 1 do theRows[Row] := theBitmap.Scanline[Row]; {blur each row:} P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple)); for Row := 0 to theBitmap.Height - 1 do BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P); {now blur each column} ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple)); for Col := 0 to theBitmap.Width - 1 do begin {first read the column into a TRow:} for Row := 0 to theBitmap.Height - 1 do ACol[Row] := theRows[Row][Col]; BlurRow(Slice(ACol^, theBitmap.Height), K, P); {now put that row, um, column back into the data:} for Row := 0 to theBitmap.Height - 1 do theRows[Row][Col] := ACol[Row]; end; FreeMem(theRows); FreeMem(ACol); ReAllocMem(P, 0); end; end. Example: procedure TForm1.Button1Click(Sender: TObject); var b: TBitmap; begin if not opendialog1.Execute then exit; b:= TBitmap.Create; b.LoadFromFile(Opendialog1.Filename); b.PixelFormat:= pf24Bit; Canvas.Draw(0, 0, b); GBlur(b, StrToFloat(Edit1.text)); Canvas.Draw(b.Width, 0, b); b.Free; end; Note that displaying 24-bit bitmaps on a 256-color system requires some special tricks - if this looks funny at 256 colors it doesn't prove the blur is wrong.

265

Question/Problem/Abstract: How to Write a Screensaver in Delphi Answer: In order to write a screensaver we need to include several procedures: FormShow - hide cursor, setup message processing, start screensaver display FormHide - stop screensaver display, show cursor DeactivateScrSaver - process messages, deactivate if keys / mouse pressed Typical code for these procedures is shown below. You should ensure that your form is designed with the style fsStayOnTop. You also need to make sure only one instance of your program is running in the usual way. Finally you need to include the compiler directive {$D SCRNSAVE programname Screen Saver} in your project unit (*.dpr). Once your program is compiled then change it's filename extension to SCR and copy it to your \WINDOWS\SYSTEM folder.

var crs : TPoint; {original location of mouse cursor} procedure TScrForm.FormShow(Sender: TObject); {starts the screensaver} begin WindowState := wsMaximized; {ensure program fills screen} GetCursorPos(crs); {get current cursor position} Application.OnMessage := DeactivateScrSaver; {check for Mouse/Keys} ShowCursor(false); {hide the cursor} {start screensaver display...} // end; {procedure TScrForm.FormShow} procedure TScrForm.FormHide(Sender: TObject); {returns control to the user} begin Application.OnMessage := nil; {discard the message} {stop the screensaver...} // ShowCursor(true); {bring the cursor back} end; {procedure TScrForm.FormHide} procedure TScrForm.DeactivateScrSaver(var Msg : TMsg; var Handled : boolean); {detects Mouse movement or Keyboard use} var done : boolean; begin if Msg.message = WM_MOUSEMOVE then {mouse movement} done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or (Abs(HIWORD(Msg.lParam) - crs.y) > 5) else {key / mouse button pressed?} done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or 266

(Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN); if done then Close; end; {procedure TScrForm.DeactivateScrSaver}

267

Question/Problem/Abstract: Calling procedures and events one at a time without using breakpoints. Answer: One of a great advantages we have using RAD is buttons. We use buttons a lot to call procedures but why not use them also for emulating procedures and events. Since most programs contain lots of events and messages we can use this to debug and design code! Can you imagine procedures named createtree(), addnode(), savenode(). Now put three buttons on a form and name them after each procedure. Delphi will generate: createtreeclick(), addnodeclick(), modifynodeclick(). Lets say you have one procedure that you want to create and test, named Addnode(). First create a button with the same name that you would give the procedure. as you see below I created a button named Addnode. So I run the program, press the Addnode button if everything is OK I now have a good procedure. So far we are normal and most of us already know how to do this. But here's the trick!! After making the Addnode button visible property := false in the object inspector to hide the button, I can call the AddnodeClick procedure from another procedure or event without clicking the button! In the example below, I let Delphi create a Memo1Exit event. Now I can call the AddnodeClick procedure when an exit event occurs in Memo1. After testing, I can copy the code from the AddnodeClick procedure to to a new addnode procedure. Once I'm sure it runs ok I delete the Addnode button on the form and the AddnodeClick procedure. procedure TForm1.AddnodeClick(Sender: TObject); begin Exit; // does nothing yet end; ////filling in code and testing this procedure/////// procedure TForm1.AddnodeClick(Sender: TObject); /// this line is temporary var TreeViewIndex: LongInt; begin block := TBlock.Create; block.uID := GetUniqueNum; block.data := Memo1.Text; TreeViewIndex := StrToInt(Edit3.Text); with TreeView1 do begin if Items.Count = 0 then Items.AddObject(nil, 'Item' + block.uID, block) else if (TreeViewIndex < Items.Count) and (TreeViewIndex >= 0) then Items.AddObject(Items[TreeViewIndex], 'Item' + block.uID, block); Items[TreeViewIndex].Selected := True; LastSelNode := Selected; end; block.Free; end; ////Later on I decided to add the Memo1Exit event 268

procedure TForm1.Memo1Exit(Sender: TObject); begin AddnodeClick(Addnode); ///////// this is the magic line end; ///after testing both procedures code below is result////////// procedure TForm1.Addnode; // this line is now permanent var TreeViewIndex: LongInt; begin block := TBlock.Create; block.uID := GetUniqueNum; block.data := Memo1.Text; TreeViewIndex := StrToInt(Edit3.Text); with TreeView1 do begin if Items.Count = 0 then Items.AddObject(nil, 'Item' + block.uID, block) else if (TreeViewIndex < Items.Count) and (TreeViewIndex >= 0) then Items.AddObject(Items[TreeViewIndex], 'Item' + block.uID, block); Items[TreeViewIndex].Selected := True; LastSelNode := Selected; end; block.Free; end; procedure TForm1.Memo1Exit(Sender: TObject); begin Addnode; // this line is now permanent end; //I could replaced both procedures with one exit event but I might later // want to call some other procedure from the exit event //////////////////////////////////////////////////////// After all a program is nothing more than one procedure calling another procedure which in turn calls another. In the code above I could have created another button called Exit to emulate the Memo1Exit event. Using this technique along with a nice flowchart program makes things much easier to sort out steps in a program. Some of you might say ' got ya! my procedures have parameters'. Well do this, for each parameter place a dummy var inside the procedure block and give each one a dummy assignment just for testing. Example: instead of-> procedure hello(x,y : integer) // without using a button do this -> procedure helloclick(Sender : TObject)// with a button named hello var x,y : integer; 269

begin x := 10; y := 20; dosomething with x and y; end; Using the old technique many programmers would declare a procedure name, comment it out and go back and fill it in later. Using this technique the buttons are used instead of the dummy procedures. Remember, each button can call another button or event and so on. Someday someone will get real sharp and actually create a flowchart program with visual connectors to live buttons of differrent shapes !! I hope some of you try this technique it works great for me.

270

Question/Problem/Abstract: How do I add checkbox items to TGrids? Answer: If you have ever needed checkboxes inside a grid, and either haven't learned how to write custom components, or don't have the time to write one, here's a way to do it. Basically, what you will need to do it use the Objects property of the grid to store TCheckBox items. But you can store anything here, as long as it is a descendent of TObject. In a recent project I wrote, I needed a checkbox in the second column (index of 1) of a TStringGrid. All in all it's pretty simple, but you will have to make sure everything is handled properly behind the scenes. as stated in the Delphi documentation: "The string grid does not own the objects in the Objects array. Objects added to the Objects array still exist even if the string grid is destroyed. They must be explicitly destroyed by the application." In order to add a new checkbox (and a new row the grid), you can use code similar to the following: grdPreviousFiles.RowCount := grdPreviousFiles.RowCount + 1; RowToAdd := grdPreviousFiles.RowCount; grdPreviousFiles.Cells [0, RowToAdd] := IntToStr(RowToAdd); grdPreviousFiles.Objects[1, RowToAdd] := TCheckBox.Create(grdPreviousFiles); grdPreviousFiles.Cells [2, RowToAdd] := dlgOpenFile.FileName; grdPreviousFiles.Repaint(); This code creates a new checkbox in the new row, but does not change it's state. You will need something to tell you the dimensions of the checkmark within the box so everything looks OK. You may need to play around with the numbers until they look OK to you. Here's what I've come up with: const CHECKMARK_WIDTH = 13; CHECKMARK_HEIGHT = 13; These two constants can either be global to the form, local to the event handler, or you could even hardcode them in-line. The actual drawing of the checkboxes is handled in the OnDrawCell event handler for the grid: procedure TfrmMain.grdPreviousFilesDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var CheckBox : TCheckBox; DrawRect : TRect; DrawState : Integer; OldPenColor : TColor; OldFont : TFont; S : string; begin // Custom draw only the column that has the TCheckBox objects in it, and // only for the number of rows physically in the grid if (ACol = 1) and (ARow > 0) and (ARow < grdPreviousFiles.RowCount) then begin // Convert the object we're storing at the current location into a 271

// CheckBox CheckBox := grdPreviousFiles.Objects[ACol, ARow] as TCheckBox; // Make sure there's a checkbox created for the cell before we try to // draw it in the grid if Assigned(CheckBox) then begin // Tells us what state to draw the CheckBox in case CheckBox.State of cbChecked : DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED; cbUnchecked : DrawState := DFCS_BUTTONCHECK; else DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED; end; // Determine the area we will use to draw the check mark and the // square around it DrawRect.Left := Rect.Left + (Rect.Right - Rect.Left - CHECKMARK_WIDTH) div 2; DrawRect.Top := Rect.Top + (Rect.Bottom - Rect.Top - CHECKMARK_HEIGHT) div 2; DrawRect.Right := DrawRect.Left + CHECKMARK_WIDTH; DrawRect.Bottom := DrawRect.Top + CHECKMARK_HEIGHT; // Keeps the current pen color so we can restore it after we draw // the square around the check mark OldPenColor := grdPreviousFiles.Canvas.Pen.Color; // Use the color defined by Windows - we don't want to 'assume' what // colors the user is using grdPreviousFiles.Canvas.Pen.Color := clBtnShadow; // This draws the basic square that will hold the check mark grdPreviousFiles.Canvas.Rectangle(DrawRect); // Restore the pen color back to it's original grdPreviousFiles.Canvas.Pen.Color := OldPenColor; // Draws the check mark - the DFCS_FLAT must be used, or the 3D style // will be used DrawFrameControl(grdPreviousFiles.Canvas.Handle, DrawRect, DFC_BUTTON, DrawState or DFCS_FLAT); end; end; // other code for OnDrawCell event goes here end; To take care of setting the Checked state of the checkbox, you can perform something similar to the below in the OnDblClick event handler: procedure TfrmMain.grdPreviousFilesDblClick(Sender: TObject); var CheckBox : TCheckBox; begin

272

CheckBox := grdPreviousFiles.Objects[1, grdPreviousFiles.Row] as TCheckBox; if Assigned(CheckBox) then begin if (grdPreviousFiles.Cells[2, grdPreviousFiles.Row] <> '') and FileExists(grdPreviousFiles.Cells[2, grdPreviousFiles.Row]) then begin CheckBox.Checked := not CheckBox.Checked; grdPreviousFiles.Invalidate; end else MessageDlg('This file does not exist. It cannot be selected' + CR_LF + CR_LF + 'As a reminder, files in the list that do not exist' + CR_LF + 'are presented in boldface type', mtWarning, [mbOK], 0); end; end; The OnDrawCell event handler will take care of drawing the checkmark for you when it is called. When you are finished with the form that contains the grid with checkboxes, you should make sure you have properly disposed of them. You can do this in the OnClose event for the form: procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction); var Index : word; CheckBox : TCheckBox; begin for Index := 1 to grdPreviousFiles.RowCount do begin CheckBox := grdPreviousFiles.Objects[1, Index] as TCheckBox; CheckBox.Free(); end; end; --If you wish to get a picture of what this looks like, please visit the following page: http://www.cimba.com/abovetherim/preview/preview5.html You should be able to use as many checkboxes in as many columns as you like, you just have to remember to manage of all of them yourself.

273

Question/Problem/Abstract: Has it ever bothered you that the TTrackbar in Delphi doesn't look the way you expect? Answer: The TTrackBar in Delphi is very wide. This is unlike the trackbar you see used throughout the Windows 9X and 2000 desktops. For some reason I found this annoying. After doing some research and a bit of experimenting I discovered the reason. When Delphi creates the trackbar from the windows common controls store it specifies a style of TBS_ENABLESELRANGE (see TTrackBar.CreateParams in ComCtrls.pas). The TBS_ENABLESELRANGE style is what allows the Trackbar to display a selection range and support the three properties SelEnd, SelRange and SelStart.. This range feature is nice but under normal usage isn’t used much. In most cases all we want is a slider that we can set a min an max value and then set and track the current position (like the desktop volume control). Anyway, it turns out that if the trackbar is created without this TBS_ENABLESELRANGE style set, then it’s thickness reverts back to the skinny slider seen on the desktop. See the complete code below for ToaTrackbar. The new ToaTrackBar is very simple. It just adds a boolean SelRange property which specifies if you want to use the range features of the component. This property defaults to true so it is exactly like the current TTrackBar component. If you can live without the range feature then you can set SelRange to false which has a visible slimming effect. In the code, setting SelRange to false simply recreates the control without the TBS_ENABLESELRANGE style. To Use - Once you’ve installed the component code below into your IDE then go to the Samples tab on the component palette find the oaTrackBar and drop it on a form. Now set the new SelRange property to false, TickMarks to tmBoth and TickStyle to tsNone and presto, you have a trackbar just like the desktops volume control. -------------------------- code follows ----------------------------unit oaTrackBar; { Freeware by Alec Bergamini O&A Productions www.o2a.com Setting the SelRange to false, TickMarks to tmBoth and TickStyle tsNone gives you the same look as the desktop volume slider.} interface uses Windows, Messages, SysUtils, Classes, Controls, ComCtrls, CommCtrl; type ToaTrackBar = class(TTrackBar) private fSelRange: Boolean; procedure SetSelRange(const Value: Boolean); protected procedure CreateParams(var Params: TCreateParams); override; public constructor Create(AOwner: TComponent); override; published property SelRange :Boolean read fSelRange write SetSelRange default True; end;

274

procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [ToaTrackBar]); end; { ToaTrackBar } constructor ToaTrackBar.Create(AOwner: TComponent); begin inherited; fSelRange := True; end; procedure ToaTrackBar.CreateParams(var Params: TCreateParams); begin inherited; with Params do begin if not fSelRange then Style := Style and Not TBS_ENABLESELRANGE; end; end; procedure ToaTrackBar.SetSelRange(const Value: Boolean); begin if Value <> fSelRange then begin fSelRange := Value; RecreateWnd; end; end; end.

275

Memo which uses a bitmap as a caret - Component The following component uses a resource bitmap as a caret. Check the attachment for source/binaries. Answer: unit MemoEx; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TMemoEx = class(TMemo) private FCaret: TBitmap; FResourceName: string; procedure LoadCaret; protected procedure WMSetFocus(var Msg: TMessage); message WM_SETFOCUS; procedure Loaded; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ResourceName: string read FResourceName write FResourceName; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TMemoEx]); end; { TMemoEx } constructor TMemoEx.Create(AOwner: TComponent); begin inherited Create(AOwner); FCaret := TBitmap.Create; end; destructor TMemoEx.Destroy; begin FCaret.Free; inherited Destroy; end; procedure TMemoEx.LoadCaret; 276

begin try if ComponentState = [] then FCaret.LoadFromResourceName(Hinstance, ResourceName); except ShowMessage(Format('Could not find specified Caret (%s)', [FResourceName])); end; end; procedure TMemoEx.Loaded; begin inherited Loaded; LoadCaret; end; procedure TMemoEx.WMSetFocus(var Msg: TMessage); begin inherited; if FCaret.Handle <> 0 then if not CreateCaret(Handle, FCaret.Handle, 0, 0) then ShowMessage(SysErrorMessage(GetLastError)); ShowCaret(Handle); end; end.

277

Detect wether an application is being dubugged or not. The following function will detect if the application is being debugged or not. This function will not work on Windows 95. Behaviour of an application could be changed if run within a debugger, for instance component writers might want their unregistered components to be run in the debugger only. Answer: function DebuggerPresent: boolean; type TDebugProc = function: boolean; stdcall; var Kernel32: HMODULE; DebugProc: TDebugProc; begin Result := False; Kernel32 := GetModuleHandle('kernel32.dll'); if Kernel32 <> 0 then begin @DebugProc := GetProcAddress(Kernel32, 'IsDebuggerPresent'); if Assigned(DebugProc) then Result := DebugProc; end; end; to use a simple if test can be used if DebuggerPresent then ShowMessage('debugging') else ShowMessage('NOT debugging');

278

Question/Problem/Abstract: Bored? Like playing tricks on your coworkers? I tested it out on my bosses secretary and it was fun, so I'll share it with you. BUT its just not fun, it also contains usefull classes. Answer: [v2 Added DesktopCanvas unit to this text] Fun program to trick your friends, secretary or anyone with a computer :-). The program flips your desktop upside down until you click on it. BUT, this does have some interesting code. 1. It contains TDesktopCanvas where you can access your desktop through a TCanvas object. (Thanks to artical http://www.delphi3000.com/articles/article_782.asp by Erwin Molendijk) 2. It contains TQuickPixel which gives you high speed pixel access, btw - it caches the scan lines for even faster performance. Download the source, it is fairly easy to follow. Compile it and stick it in your friends startup folder :-) or just run it and walk away. To end the program just click the inverted screen. Now for the usefull part as far as coding: TDesktopCanvas: Please refer to artical http://www.delphi3000.com/articles/article_782.asp by Erwin Molendijk to take a look at TDesktopCanvas... [v2 update - I included it at the end of this artical] I may have modified it some, cannot remember... but you can download my useable unit. I want to make sure to give credit to Erwin. TQuickPixel: A class I made so I could have fast pixel access without fumbling with scan lines. This class caches the scan lines for faster perfomance. One drawback of this class is that it sets your Bitmap to 24bit. If you want me to build a class that supports all bit formats then please make a comment to do so and I can build one without causing a performance hit (use method pointers so there is no testing of bit format). I will also speed up the pixel setting to work without the shifts if anyone asks for the multiple format thing. as a side note I think it would be possible to include Line, arc and circle methods... but only if there is enough interest. Windows is really slow about drawing. Here is the code for TQuickPixel. You can also go to my website for working EXE and download full source. =================================== unit QuickPixel; interface uses Windows, Graphics; type TQuickPixel = class private FBitmap: TBitmap; FScanLines: array of PRGBTriple; function GetPixel(X, Y: Integer): TColor; procedure SetPixel(X, Y: Integer; const Value: TColor); 279

function GetHeight: Integer; function GetWidth: Integer; public constructor Create(const ABitmap: TBitmap); property Pixel[X, Y: Integer]: TColor read GetPixel write SetPixel; property Width: Integer read GetWidth; property Height: Integer read GetHeight; end; implementation { TQuickPixel } constructor TQuickPixel.Create(const ABitmap: TBitmap); var I: Integer; begin inherited Create; FBitmap:= ABitmap; FBitmap.PixelFormat:= pf24bit; SetLength(FScanLines, FBitmap.Height); for I:= 0 to FBitmap.Height-1 do FScanLines[I]:= FBitmap.ScanLine[I]; end; function TQuickPixel.GetHeight: Integer; begin Result:= FBitmap.Height; end; function TQuickPixel.GetPixel(X, Y: Integer): TColor; var P: PRGBTriple; begin P:= FScanLines[Y]; Inc(P, X); Result:= (P^.rgbtBlue shl 16) or (P^.rgbtGreen shl 8) or P^.rgbtRed; end; function TQuickPixel.GetWidth: Integer; begin Result:= FBitmap.Width; end; procedure TQuickPixel.SetPixel(X, Y: Integer; const Value: TColor); var P: PRGBTriple; begin P:= FScanLines[Y]; Inc(P, X); P^.rgbtBlue:= (Value and $FF0000) shr 16; P^.rgbtGreen:= (Value and $00FF00) shr 8; P^.rgbtRed:= Value and $0000FF; end;

280

end. =============================================== unit DesktopCanvas; // original aurthor is Erwin Molendijk interface uses Graphics, Windows; type TDesktopCanvas = class(TCanvas) private FDC: HDC; function GetWidth:Integer; function GetHeight:Integer; public constructor Create; destructor Destroy; override; published property Width: Integer read GetWidth; property Height: Integer read GetHeight; end; implementation { TDesktopCanvas } function TDesktopCanvas.GetWidth:Integer; begin Result:= GetDeviceCaps(Handle, HORZRES); end; function TDesktopCanvas.GetHeight:Integer; begin Result:= GetDeviceCaps(Handle, VERTRES); end; constructor TDesktopCanvas.Create; begin inherited Create; FDC:= GetDC(0); Handle:= FDC; end; destructor TDesktopCanvas.Destroy; begin Handle:= 0; ReleaseDC(0, FDC); inherited Destroy; end; end. 281

Question/Problem/Abstract: Different BIOS manufacturers have placed the serial numbers and other BIOS information in different memory locations, so the code you can usually find in the net to get this information might work with some machines but not with others... Answer: For a simple copy-protection scheme we need to know whether the machine that is executing our application is the one where it was installed. We can save the machine data in the Windows Registry when the application is installed or executed for the first time, and then every time the application gets executed we compare the machine data with the one we saved to see if they are the same or not. But, what machine data should we use and how do we get it? In a past issue we showed how to get the volume serial number of a logical disk drive, but normally this is not satisfying for a software developer since this number can be changed. A better solution could be using the BIOS serial number. BIOS stands for Basic Input/Output System and basically is a chip on the motherboard of the PC that contains the initialization program of the PC (everything until the load of the boot sector of the hard disk or other boot device) and some basic device-access routines. Unfortunately, different BIOS manufacturers have placed the serial numbers and other BIOS information in different memory locations, so the code you can usually find in the net to get this information might work with some machines but not with others. However, most (if not all) BIOS manufacturers have placed the information somewhere in the last 8 Kb of the first Mb of memory, i.e. in the address space from $000FE000 to $000FFFFF. Assuming that "s" is a string variable, the following code would store these 8 Kb in it: SetString(s, PChar(Ptr($FE000)), $2000); // $2000 = 8196 We can take the last 64 Kb to be sure we are not missing anything: SetString(s, PChar(Ptr($F0000)), $10000); // $10000 = 65536 The problem is that it's ill-advised to store "large volumes" of data in the Windows Registry. It would be better if we could restrict to 256 bytes or less using some hashing/checksum technique. For example we can use the SHA1 unit (and optionally the Base64 unit) introduced in the issue #17 of the Pascal Newsletter: http://www.latiumsoftware.com/en/pascal/0017.php3 The code could look like the following: uses SHA1, Base64; function GetHashedBiosInfo: string; var SHA1Context: TSHA1Context; SHA1Digest: TSHA1Digest; begin // Get the BIOS data SetString(Result, PChar(Ptr($F0000)), $10000); // Hash the string SHA1Init(SHA1Context); SHA1Update(SHA1Context, PChar(Result), Length(Result)); SHA1Final(SHA1Context, SHA1Digest); SetString(Result, PChar(@SHA1Digest), sizeof(SHA1Digest)); // Return the hash string encoded in printable characters Result := B64Encode(Result); 282

end; This way we get a short string that we can save in the Windows Registry without any problems. The full source code example corresponding to this article is available for download: http://www.latiumsoftware.com/download/p0020.zip The full source code example of this article is available for download: http://www.latiumsoftware.com/download/p0020.zip DISPLAYING BIOS INFORMATION --------------------------If we wanted to display the BIOS information we should parse the bytes to extract all null-terminated strings with ASCII printable characters at least 8-characters length, as it is done in the following function: function GetBiosInfoAsText: string; var p, q: pchar; begin q := nil; p := PChar(Ptr($FE000)); repeat if q <> nil then begin if not (p^ in [#10, #13, #32..#126, #169, #184]) then begin if (p^ = #0) and (p - q >= 8) then begin Result := Result + TrimRight(String(q)) + #13#10; end; q := nil; end; end else if p^ in [#33..#126, #169, #184] then q := p; inc(p); until p > PChar(Ptr($FFFFF)); Result := TrimRight(Result); end; Then we can use the return value for example to display it in a memo: procedure TForm1.FormCreate(Sender: TObject); begin Memo1.Lines.Text := GetBiosInfoAsText; end;

283

Question/Problem/Abstract: How to simulate Office XP menu look and feel Answer: This code simulate Office XP menu look and feel, without loosing any of the menu standard functionality, RightToLeft has been taking in account in the code. You can alter the code to give your own colors and fonts. Note: Make sure that OnerRedraw and ParentBidiMode properties of the menu are true. The following code is a complete form unit, with a MainMenu and ImageList. You can download/see the example project from: http://www.shagrouni.com/english/software/menu.html (New: XP Menu is a component now). To download: http://www.shagrouni.com/english/software/xpmenu.html ================= unit fMenu; interface uses Windows, SysUtils, Classes, Graphics, Controls, Forms, Menus, ImgList; type TForm1 = class(TForm) ImageList1: TImageList; MainMenu1: TMainMenu; FileMenu: TMenuItem; procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); procedure FormCreate(Sender: TObject); private procedure MenueDrawItemX(xMenu: TMenu); public end; procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin MenueDrawItemX(Menu); end; procedure TForm1.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); 284

begin MenueDrawItem(Sender, ACanvas, ARect, Selected); end; procedure TForm1.MenueDrawItemX(xMenu: TMenu); var i: integer; B: TBitmap; FMenuItem: TMenuItem; begin B := TBitmap.Create; B.Width := 1; B.Height := 1; for i := 0 to ComponentCount - 1 do if Components[i] is TMenuItem then begin FMenuItem := TMenuItem(Components[i]); FMenuItem.OnDrawItem := DrawItem; if (FMenuItem.ImageIndex = -1) and (FMenuItem.Bitmap.width = 0) and (xMenu <> nil) then if FMenuItem.GetParentComponent.Name <> xMenu.Name then FMenuItem.Bitmap.Assign(b); end; B.Free; DrawMenuBar(handle); end; procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); var txt: string; B: TBitmap; IConRect, TextRect: TRect; FBackColor, FIconBackColor, FSelectedBkColor, FFontColor, FSelectedFontColor, FDisabledFontColor, FSeparatorColor, FCheckedColor: TColor; i, X1, X2: integer; TextFormat: integer; HasImgLstBitmap: boolean; FMenuItem: TMenuItem; FMenu: TMenu; begin FMenuItem := TMenuItem(Sender); FMenu := FMenuItem.Parent.GetParentMenu; FBackColor := $00E1E1E1; FIconBackColor := $00D1D1D1; FSelectedBkColor := $00DCCFC7; 285

FFontColor := clBlack; FSelectedFontColor := clNavy; FDisabledFontColor := clGray; FSeparatorColor := $00D1D1D1; FCheckedColor := clGray; if FMenu.IsRightToLeft then begin X1 := ARect.Right - 20; X2 := ARect.Right; end else begin X1 := ARect.Left; X2 := ARect.Left + 20; end; IConRect := Rect(X1, ARect.Top, X2, ARect.Bottom); TextRect := ARect; txt := ' ' + FMenuItem.Caption; B := TBitmap.Create; B.Transparent := True; B.TransparentMode := tmAuto; HasImgLstBitmap := false; if (FMenuItem.Parent.GetParentMenu.Images <> nil) or (FMenuItem.Parent.SubMenuImages <> nil) then begin if FMenuItem.ImageIndex <> -1 then HasImgLstBitmap := true else HasImgLstBitmap := false; end; if HasImgLstBitmap then begin if FMenuItem.Parent.SubMenuImages <> nil then FMenuItem.Parent.SubMenuImages.GetBitmap(FMenuItem.ImageIndex, B) else FMenuItem.Parent.GetParentMenu.Images.GetBitmap(FMenuItem.ImageIndex, B) end else if FMenuItem.Bitmap.Width > 0 then B.Assign(TBitmap(FMenuItem.Bitmap)); if FMenu.IsRightToLeft then begin X1 := ARect.Left; X2 := ARect.Right - 20; end else begin 286

X1 := ARect.Left + 20; X2 := ARect.Right; end; TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom); ACanvas.brush.color := FBackColor; ACanvas.FillRect(TextRect); if FMenu is TMainMenu then for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do if FMenuItem.GetParentMenu.Items[i] = FMenuItem then begin ACanvas.brush.color := FIConBackColor; ACanvas.FillRect(ARect); if (FMenuItem.ImageIndex = -1) and (FMenuItem.Bitmap.width = 0) then begin TextRect := ARect; break; end; end; ACanvas.brush.color := FIconBackColor; ACanvas.FillRect(IconRect); if FMenuItem.Enabled then ACanvas.Font.Color := FFontColor else ACanvas.Font.Color := FDisabledFontColor; if Selected then begin ACanvas.brush.Style := bsSolid; ACanvas.brush.color := FSelectedBkColor; ACanvas.FillRect(TextRect); ACanvas.Pen.color := FSelectedFontColor; ACanvas.Brush.Style := bsClear; ACanvas.RoundRect(TextRect.Left, TextRect.top, TextRect.Right, TextRect.Bottom, 6, 6); if FMenuItem.Enabled then ACanvas.Font.Color := FSelectedFontColor; end; X1 := IConRect.Left + 2; if B <> nil then ACanvas.Draw(X1, IConRect.top + 1, B); if FMenuItem.Checked then begin ACanvas.Pen.color := FCheckedColor; ACanvas.Brush.Style := bsClear; ACanvas.RoundRect(IconRect.Left, IconRect.top, IconRect.Right, IconRect.Bottom, 3, 3); 287

end; if not FMenuItem.IsLine then begin SetBkMode(ACanvas.Handle, TRANSPARENT); ACanvas.Font.Name := 'Tahoma'; if FMenu.IsRightToLeft then ACanvas.Font.Charset := ARABIC_CHARSET; if FMenu.IsRightToLeft then TextFormat := DT_RIGHT + DT_RTLREADING else TextFormat := 0; if FMenuItem.Default then begin Inc(TextRect.Left, 1); Inc(TextRect.Right, 1); Inc(TextRect.Top, 1); ACanvas.Font.color := clGray; DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); Dec(TextRect.Left, 1); Dec(TextRect.Right, 1); Dec(TextRect.Top, 1); ACanvas.Font.color := FFontColor; end; DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); txt := ShortCutToText(FMenuItem.ShortCut) + ' '; if FMenu.IsRightToLeft then TextFormat := DT_LEFT else TextFormat := DT_RIGHT; DrawtextEx(ACanvas.Handle, PChar(txt), Length(txt), TextRect, TextFormat, nil); end else begin ACanvas.Pen.Color := FSeparatorColor; ACanvas.MoveTo(ARect.Left + 10, 288

TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2)); ACanvas.LineTo(ARect.Right - 2, TextRect.Top + Round((TextRect.Bottom - TextRect.Top) / 2)) end; B.free; end; end.

289

Question/Problem/Abstract: How to retrieve currently logged-in user name in Delphi from system ? (including WinNT and Novell) Answer: There are many ways to do it. Here is a list of methods to read user name. These methods handle both kinds of names: standalone system (MS Windows) and network user name. 1. Windows API You call windows API's function GetUserName. Example: ====================================== function GetSysUserName: string; const BUF_SIZE = 255; var dw:DWORD; Buffer:string; begin dw := BUF_SIZE; SetLength(Buffer,dw); result :=''; if GetUserName(@(Buffer[1]),dw) then result :=StrPas(@(Buffer[1])); end; ====================================== 2. BDE This function works, if BDE is installed. If not, it will not execute correctly, I presume. Example: ====================================== function GetBDEUserName:string; var SysConfigInfo: SYSConfig; begin try Check(DbiGetSysConfig(SysConfigInfo)); result := SysConfigInfo.szUserName; except result :=''; // empty name on error end; end; ====================================== 3. Environment This method reads environment variable set by Windows system after login in. Value returned by this function is a user name logged into system (not network). Example: ====================================== function TForm1.GetEnvirName: string; var buf:array[1..512] of char; iSize:DWORD; begin iSize := GetEnvironmentVariable('USERNAME', @buf, 512); 290

buf[iSize+1] := #0; result := StrPas(@buf); end; ====================================== 4. MS Access function named "AdvApiGetUserName". I don't know when this function doesn't work, but it can be usefull if other methods will fail. Example: ====================================== // import function from DLL function AdvApiGetUserName(ABuffer:PChar; var nSize:longint):longint; stdcall; external advapi32 name 'GetUserNameA'; // call function function TForm1.GetAccessName: string; var buf:array[1..512] of char; iSize:longint; iError:longint; begin iSize := 512; iError := AdvApiGetUserName(@buf, iSize); buf[iSize+1] := #0; result := StrPas(@buf); end; ====================================== 5. Windows network API's function "WNetGetUser". Another function of Windows API, this time specialized for network environments, but doesn't work with Novell if double log-in is applied (one log-in into Windows, second into Novell client). Example: ====================================== function TForm1.GetWNetName: string; var buf:array[1..512] of char; len:DWORD; begin len := 512; if WNetGetUser(nil, @buf, len)<>NO_ERROR then result := '' else begin result := StrPas(@buf); end; end; ====================================== 6. Novell registry value Reads currently logged-in user name from Novell client settings (registry). Example: ====================================== 291

function TForm1.GetNovRegName: string; var Reg :TRegIniFile; begin Reg := TRegIniFile.Create('Volatile Environment'); try Reg.RootKey := HKEY_CURRENT_USER; result := Reg.ReadString('','NWUSERNAME',''); finally reg.Free; end; end; ====================================== The included Delphi source codes I've developed using Delphi 3. I've also included a compiled version. Test application is using all methods mentioned above to read user name and displays results of each method on the screen.

292

Question/Problem/Abstract: How do we get all those nice blending and gradiant effects in windows. Windows 2000 and I think other versions may support it as well, now have inbuilt functions to do all the fancy stuff. The projkect source that follows demonstrates this and provides a link to my site where you can downlaod the example. (it contains bitmaps so I didn't think you would want me to past the DFM as text !) Answer: The source for this is at http://www.lummie.co.uk/delphi/APIGradiant and AlphaBlend Examples.zip First on the onpaint of the form I show how to do a gradiant from blue to white - notice you can set teh procedure TForm1.FormPaint(Sender: TObject); var udtVertex: array [0..1] of _TRIVERTEX; rectGradient: TGradientRect; begin with udtVertex[0] do begin x := 0; y := height; Red := 0; Green := 0; Blue := $ff00; Alpha := $5500; end; with udtVertex[1] do begin x := Width; y := 0; Red := $ff00; Green := $ff00; Blue := $ff00; Alpha := $5500; end; rectGradient.UpperLeft := 0; rectGradient.LowerRight := 1; GradientFill(Canvas.Handle, @udtVertex, 2, @rectGradient, 1, GRADIENT_FILL_RECT_H); end; for more information look on MSDN.microsoft.com and search for gradiantfill Button1Click shows the simple alphablending of two images. procedure TForm1.Button1Click(Sender: TObject); 293

var res : TBitmap; bf : _BLENDFUNCTION; begin res := TBitmap.create; try res.width := i1.picture.width; res.height := i1.picture.height; res.assign(i1.picture.bitmap); bf.BlendOp := AC_SRC_OVER; bf.BlendFlags := 0; bf.SourceConstantAlpha := BlendAmount.Value; bf.AlphaFormat := 0; AlphaBlend(res.canvas.handle, 0,0,res.width,res.height,i2.picture.bitmap.Canvas.handle,0,0,res.width,res.height,bf); i3.Picture.assign(res); finally res.free; end; end; Have fun......

294

Question/Problem/Abstract: I have an application and I need to show some Autocad drawings in my help files. Plant layout, Process Flow diagrams, equipment arangments, etc. The users do not know autocad, and you certainly want them to alter company documents (See my previous Article). In this example we will build an "Acad Reader" Answer: We will need several things: 1) Autodesk Whip 4.0 ActiveX. Download it from Autodesk. If you have Acad2000 it is probably allready registered on your computer. If not check out http://www3.autodesk.com/adsk/section/0,,163301-123112,00.html 2) Install it on your computer, and use Import ActiveX to make it available to delphi. You also will be able to see the Acad DWF files in Explorer or Netscape. 3) If you have Autocad14 or 2000, make 3 sample Drawing Web Files (dwf). Define some views in your files, like top view, east view, boilerhouse etc. If you do not have, borrow some files. For delphi we need a form, a TTreeview, a TSplitter and a TWhip object. Also a global pointer variable (MyRecPtr) to link the Acad dwf files to the nodes in the treeview component.

Drop a Treeview component on the form, align it to the left. Drop a splitter, align it to the left Drop a Whip component align it all client On the Form OnShow event, we will create 3 nodes. I defined the nodes: Overall Map Pumps Boilers On the OnChangeEvent of the treeview component key the following code: Whip1.StreamName := PMyRec(TreeView1.Selected.Data)^.FName

When you run the program, right clicking the draw area, will enable you to zoom, print, turn off layers, change views, etc. Good luck

295

-----------------------------------------------------------------------------unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, ComCtrls, OleCtrls, WHIPLib_TLB; type TForm1 = class(TForm) TreeView1: TTreeView; Splitter1: TSplitter; Whip1: TWhip; procedure FormShow(Sender: TObject); procedure TreeView1Change(Sender: TObject; Node: TTreeNode); private { Private declarations } public { Public declarations } end; var Form1: TForm1; type PMyRec = ^TMyRec; TMyRec = record FName: string; end; var MyRecPtr: PMyRec; //File to be loaded TreeViewIndex: LongInt; implementation {$R *.DFM} procedure TForm1.FormShow(Sender: TObject); begin New(MyRecPtr); //define first node MyRecPtr^.FName := 'D:\Articles\RefMap.dwf'; if TreeView1.Items.Count = 0 then TreeView1.Items.AddObject(nil, 'Overall Map' , MyRecPtr); //define second node TreeViewIndex := 0; New(MyRecPtr); MyRecPtr^.FName := 'D:\Articles\Moyno-Model.dwf'; with treeview1 do Items.AddObject(Items[TreeViewIndex], 'Pumps' , MyRecPtr); //define last node 296

inc(TreeViewIndex); New (MyRecPtr); MyRecPtr^.FName := 'D:\Articles\Boilers Schematic-Model.dwf'; with treeview1 do Items.AddObject(Items[TreeViewIndex], 'Boilers' , MyRecPtr); end;

procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode); begin Whip1.StreamName := PMyRec(TreeView1.Selected.Data)^.FName end; end.

297

Question/Problem/Abstract: How to use MS Word as report generator? Answer: Why not use the MS Word as report generator in your projects? We can easyly build the report and allow user to modify it using well known editor in any way he wants. The example below demonstartes how to build the report based on StringGrid contents. procedure TsiGridReporter.ShowReport; var Range: Variant; i, j: integer; begin if FGrid = nil then raise Exception.Create('No grid selected!'); try FWordApp := CreateOleObject('Word.Application'); except raise Exception.Create('Cannot start MS Word!'); end; FWordApp.Visible := True; FWordApp.Documents.Add; if FShowDate then begin Range := FWordApp.Documents.Item(1); Range := Range.Sections.Item(1); Range := Range.Headers.Item(1).Range; Range.Text := 'Date: ' + DateToStr(Date) + ' Time: ' + TimeToStr(Time); end; Range := FWordApp.Documents.Item(1); Range := Range.Sections.Item(1); Range := Range.Footers.Item(1); Range.Range.Text := 'Page:'; Range.Range.ParagraphFormat.Alignment := ord(waAlignParagraphRight); Range.PageNumbers.Add; FWordApp.Documents.Item(1).Paragraphs.Add; Range := FWordApp.Documents.Item(1).Range( FWordApp.Documents.Item(1).Paragraphs.Item(FWordApp.Documents.Item(1).Paragraphs.Count 1).Range.End, FWordApp.Documents.Item(1).Paragraphs.Item(FWordApp.Documents.Item(1).Paragraphs.Count 1).Range.End); Range.Text := FTitle; Range.Bold := fsBold in FTitleFont.Style; Range.Italic := fsItalic in FTitleFont.Style; Range.Underline := fsUnderline in FTitleFont.Style; Range.Font.StrikeThrough := fsStrikeOut in FTitleFont.Style; Range.Font.Name := FTitleFont.Name; Range.Font.Size := FTitleFont.Size; Range.Font.ColorIndex := ord(FTitleColor); Range.ParagraphFormat.Alignment := ord(FTitleAlignment); FWordApp.Documents.Item(1).Paragraphs.Add; FWordApp.Documents.Item(1).Paragraphs.Add; Range := FWordApp.Documents.Item(1).Range( FWordApp.Documents.Item(1).Paragraphs.Item(FWordApp.Documents.Item(1).Paragraphs.Count 1).Range.End, FWordApp.Documents.Item(1).Paragraphs.Item(FWordApp.Documents.Item(1).Paragraphs.Count 298

1).Range.End); FWordApp.Documents.Item(1).Tables.Add(Range, FGrid.RowCount, FGrid.ColCount); Range := FWordApp.Documents.Item(1).Tables.Item(FWordApp.Documents.Item(1).Tables.Count); for i := 1 to FGrid.RowCount do for j := 1 to FGrid.ColCount do begin Range.Cell(i, j).Range.InsertAfter(FGrid.Cells[j-1, i-1]); if (i <= FGrid.FixedRows) or (j <= FGrid.FixedCols) then begin Range.Cell(i, j).Range.Bold := True; Range.Cell(i, j).Range.Shading.BackgroundPatternColorIndex := ord(wcGray25); end else begin Range.Cell(i, j).Range.Bold := fsBold in FCellFont.Style; Range.Cell(i, j).Range.Italic := fsItalic in FCellFont.Style; Range.Cell(i, j).Range.Underline := fsUnderline in FCellFont.Style; Range.Cell(i, j).Range.Font.StrikeThrough := fsStrikeOut in FCellFont.Style; Range.Cell(i, j).Range.Font.Name := FCellFont.Name; Range.Cell(i, j).Range.Font.Size := FCellFont.Size; // Range.Cell(i, j).Range.Font.ColorIndex := ord(FCellColor); Range.Cell(i, j).Range.Shading.BackgroundPatternColorIndex := FCellColor; end; end; end; This example is just one method of component attached to this article. This component also has the PrintReport and PrintPreview methods. See attached source code for details. This component could give you just the first step for creating your own full featured report generator based on using MS Word. P.S. Component and source code are FREEWARE, so you can use it as you want.

299

Question/Problem/Abstract: register Answer: function Ini:boolean; var query:Tquery; a,b:dword; Year, Month, Day:word; s,rt,sk,tk,i:integer; ss,tp,sql1,sql2,vv:string; begin DecodeDate(date, Year, Month, Day); getvolumeinformation(pchar('c:\'),nil,0,@s,a,b,nil,0); tp:=datetostr(date+90); i:=1; while i>0 do begin i:=pos('-',tp); delete(tp,i,1); end; vv:='on'+inttohex(hiword(s),4)+inttohex(loword(s),4); ss:=vv+tp; sql1:='SELECT name FROM sysindexes WHERE substring(name,1,10) LIKE '+#39+vv+#39; sql2:='CREATE INDEX '+ss+' ON syssegments (segment)'; query:=Tquery.Create(self); query.DatabaseName:='adatabase'; query.SQL.Text:=sql1; query.Open; rt:=query.RecordCount; //if haven't create index then create it if rt<=0 then begin query.SQL.Text:=sql2; query.ExecSQL; end; //Index have been created query.Close; query.SQL.Text:=sql1; query.Open; tp:=query.FieldByName('name').asstring; delete(tp,1,10); sk:=strtoint(tp);//sk is key tp:=datetostr(date+90); //90 means user can use your program for 90 days i:=1; while i>0 do begin i:=pos('-',tp); delete(tp,i,1); end; tk:=strtoint(tp); //tk is linker if tk query.Free; end;

300

Question/Problem/Abstract: How to change authentication/authorization setting, and impersonate a user on an interface/proxy call. Answer: What we want to do ----------------------When it comes to COM and client security, and the authentication level details used on interface call, you can be sure than sooner or later you'll need to specify the authentication information at runtime, or on a specific call to an interface. Usually you set up authentication/authorization/impersonation levels using the Dcomcnfg application provided. How ever, when you require these to be altered or wish to cloak or impersonate an alternate user on calls to a proxy so the server recongnises the alternate user as the callee rather than your natural login account, or the application user account ( i.e service user account). Finding out how.. --------------------Well to find out how to do this is really not very easy.. very differcult to find examples, people asking how to do it.. people responding where to maybe find out how... msdn is definately the best resourse for information on low level security side of COM and authentication documentation on this subject, but finding full examples which work, or all the syntax/constants/data types that's required is always lacking when it comes to msdn library documentation. So for all those who have been looking for this answer. How it's done. -----------------There are a few ways to setup this information, you can set it globally to your process using the call CoInitializeSecurity(). But I am going to explain how to use the CoSetProxyBlanket() which can set this information on a specific interface (proxy) which is far more flexible. CoSetProxyBlanket is a wrapper that simply uses the IClientSecurity interface provided by the proxy and calls the SetBlanket method of the interface. I will give you a quick code example of this here and provide you with an attachment which contains all the contants, data types, and a the wrapper function to cater for all the options. Enjoy..... const RPC_C_AUTHN_WINNT = 10; RPC_C_AUTHZ_DEFAULT = $ffffffff; RPC_C_AUTHN_LEVEL_CALL = 3; RPC_C_IMP_LEVEL_IMPERSONATE = 3; EOAC_NONE = $0; type (* The Auth Identity Structure *) PCoAuthIdentity = ^TCoAuthIdentity; _CoAuthIdentity = packed record 301

User : PChar; UserLength : DWORD; Domain : PChar; DomainLength : DWORD; Password : PChar; PasswordLength : DWORD; Flags : DWORD; end; TCoAuthIdentity = _CoAuthIdentity; implementation (* Procedure to demonstrate the use of the CoSetProxyBlanket call and how to use it to impersonate another user when calling an interface. *) procedure SetUserImpersonateOnProxy( Proxy: IUnknown; //-- Interface const UserName, DomainName, Psword: String; //-- User Account AuthenicationService: DWORD = RPC_C_AUTHN_WINNT; AuthorizationService: DWORD = RPC_C_AUTHZ_DEFAULT; AuthenicationLevel: DWORD = RPC_C_AUTHN_LEVEL_CALL; ImpersonationLevel: DWORD = RPC_C_IMP_LEVEL_IMPERSONATE; CapabiltiesFlag: DWORD = EOAC_NONE ); var AuthIdent: TCoAuthIdentity; iResult: Integer; begin (* Populate an Auth Identity structure with the User Account Details *) ZeroMemory(@AuthIdent, 0); with AuthIdent do begin User := pChar(UserName); UserLength := length(UserName); Domain := pChar(DomainName); DomainLength := length(DomainName); Password := pChar(Psword); PasswordLength := length(Psword); Flags := SEC_WINNT_AUTH_IDENTITY_ANSI; end; iResult := CoSetProxyBlanket(Proxy, (* Authentication Service is the service which will be used for authentication i.e WinNT NTLM KERBEROS etc.. this rarely needs to be changed unless Delegation level of impersonation is required and this is only possible with Windows 2000 and Kerberos Authentication Service *) AuthenicationService, AuthorizationService, 0, (* Authentication level should be CALL or PKT as this is the level when authentication will take place.. On each CALL. *) AuthenicationLevel, (* Impersonation Level regards to the servers rights to impersonate as the authenticated user. *) 302

ImpersonationLevel, @AuthIdent, CapabiltiesFlag); case iResult of S_OK: (* Success *) ; E_INVALIDARG : Raise Exception.Create('Invalid Arguments.'); E_OUTOFMEMORY : Raise Exception.Create('Out of Memory'); else Raise Exception.Create('Failed to blanket proxy') end; end; ------------var Intf: IMyFooServer; begin Intf := CoMyFooServer.Create; try SetUserImpersonateOnProxy(Intf, 'AUser', 'DELPHIDOMAIN', 'FooBar'); (* Interface will authenticate the user AUser as the Callee on each call to the Server. *) Intf.CallMethodAsAUser(Blah); finally Intf := NIL; end; end; -------------You will find attached the unit shortly. Regards to all, look forward to hearing any comments.

303

Question/Problem/Abstract: Understanding what makes a key vulnerable and the pittfalls brought on by brute key searches. Answer: // source code at bottom The security of any good cryptosystem relies on the key. No matter how large a key, there will be an imposing decrease in security if it is poorly used by the software. Keys should be measured according to the bits of entropy contained within them, and simple keys should be disallowed. They should contain many different characters, and have no discernable patterns. Only when these conditions are met will a key withstand dictionary and brute force attacks. A key's entropy measures the amount of unpredictable bits. Considering users will usually only use alpha-numeric characters, you should only use the minimum number of bits possible to represent that key. Using 8 bits per character means there are 256 different characters available. An attacker knows the user will only use alpha-numeric characters (62 characters, 6 bits), and will not bother testing for the 194 other characters. A practical technique is to convert each character (1 byte) into a 6bit number, and concatenating then next to each other. You could allow only lower case letters and a few numbers and reduce each character to 5bits (32 characters). It is important to demand the user to use passwords that are larger to achieve the same key size. With this said, an 8 character key should not be considered to be 64bits, but in fact 48bits (6bits x 8 characters). Keys with low entropy pose a security threat no matter how well designed the rest of the system is designed. Short, one-word keys should not be tolerated within a cryptosystem. Even if you optimize entropy, there simply isn't enough key data in a 5 character key to withstand a brute force attack. A 30bit key (6bits x 5 characters) only allows a possibility of a few billion keys, which only takes a few hours to exhaust on a powerful computer. A key of at least 128bits should be required for sesitive data; this ensures a span of a few years before the need arises for a new and longer key. At 6bits per character this means the key should be 22 or more characters long. This may seem large, but nothing stops you from using phrases. as an example lets look at the phrase "ThE ElevatoR WaS GoinG UP", it is 25 characters long. The key is 150 bits long, but still easy to remember. All keys should be dealt with in this manner. There is no excuse for allowing a user to use an 8 character key and compromising the entire cryptosystem. A key provides better resistance against algorithmic searches when it contains many different characters. If the key is 22 characters long, but only contains 4 different characters, then it is severely weak. To keep things simple, at least half the characters in a key should be different (22 character key should have at least 11 different characters). More different characters in a key make it harder to statistically predict the next character. Although such an attack is unlikely, there is no room for error. Preventing all known types of attacks and anticipating breaches before-hand is of 304

utter-most importance no matter how insignificant a risk may seem. A risk is always a risk. It is important to encourage users to have the most different characters they can remember in each key to make algorithmic searches yield no results. Attackers love patterns, they make key searches and his life much easier. Users seem to think that keys like: "bingobingo" are more secure than those like: "bingo", but the fact is they are only slightly better. Smart attackers know all the tricks users devise to make their keys harder to guess. Using a word twice should be strongly discouraged. Oftentimes users add numbers at the end of the key, to make it less predictable. Unfortunately 80% of the time the number is 123, and the other 20% is 321. For an attacker to test these additional keys, he must also test with 123 added to each key, as well as 321. This means he has to search 3 times as many keys; this only represents a 1.5 bit increase instead of the 18bits 3 characters should offer. Testing keys for patterns can be a very complex obstacle, and will not be discussed in this paper. After obvious patterns have been disallowed it is wise to pass the key through a one-way hash function such as SHA or HAVAL. These functions take an input of data and create an out which has no solvable relationship to the input; for every possible input there is only one output. The output of these hash functions is seemingly random and will effectively disguise any discrete patterns. Eliminating patterns makes it very difficult for an attacker to search for weak keys. //***** NOTES: I originaly wrote the article above for my website. The source bellow is part of a library in progress cummulating 3 years of research. It's meant to be an example, but if you want to use it in a program, a little bit of credit would be nice. These key routines have been optimized and re-written a dozen times, I've tried to comment as best I could. The procedure structures may seem odd because I originaly wrote them in C++. The pseudo random number generator comes from an unknown source, and this implementation of haval is a [severe] modification of David Barton's haval.pas found in the DCPcrypt 1.3 component suite. I used context encapsulation so that the procedures wouldn't have to be instantiated in a multi-threaded environment (server maybe?). Description: [MutateKey] Transforms a key into another by expanding and compressing. No previous keys can be determined by the current key, but all the succeeding keys can be. This is usefull for adding entropy to a key (so that there are no shortcuts to brute searches) or for sessions which may need to use multiple session-keys. [PasswordToKey] Converts a string with 64 possible characters: 'a'-'z', 'A'-'Z', '0'-'9', '_' and '.' into a 256bit by leaving out 2 bits from every character (64 chars only need 6bits to represent each, instead of 8bits for 256 chars), and then uses MutateKey to add entropy. [AnanlyzeKey] Examines a key's entropy by searching for patterns, counting the bits needed per character, evaluation 0/1 (binary) distribution, and derives a summative rating of the key measured in bit-length. (a complete 305

example of this can be found at http://www.geocities.com/drmungkee/software/codebase.html) //******************* UNIT BEGINS HERE ************************************** unit keyfunc; interface type key256=array[0..7]of longword; Prng_CTX=record r:array[1..97]of real; x1,x2,x3:longword; end; TPrng_CTX=^Prng_CTX; Haval_CTX=record lenhi,lenlo:longword; Index:longword; hash:array[0..7]of longword; hashbuffer:array[0..127]of byte; end; THaval_CTX=^Haval_CTX; KeyStatistics=record KeyLength:longword; KeySize:longword; CharCount:byte; CharBits:byte; Patterns:longword; Differential:longword; BruteLength:longword; Rating:longword; end; TKeyStatistics=^KeyStatistics; procedure MutateKey(var key:key256); function PasswordToKey(pass:string):key256; function AnalyzePassword(pass:string):KeyStatistics; implementation const BIT_MASK:array[0..7]of byte = (1,2,4,8,16,32,64,128); HASH_SIZE=256; PrngM1:longword=259200; PrngI1:longword=7141; PrngC1:longword=54773; PrngM2:longword=134456; PrngI2:longword=8121; PrngC2:longword=28411; PrngM3:longword=243000; PrngI3:longword=4561; PrngC3:longword=51349; //*************************************************************************** 306

// Haval // // Derived from David Barton's haval.pas (DCPcrypt 1.3 component suite) // //*************************************************************************** procedure HavalCompress(ctx:THaval_CTX); function rr32(x:longword;c:longint):longword;register;assembler; asm mov ecx,edx ror eax,cl end; procedure r1(var x7,x6,x5,x4,x3,x2,x1,x0:longword;const w:longword); var t:longword; begin t:=((x2)and((x6)xor(x1))xor(x5)and(x4)xor(x0)and(x3)xor(x6)); x7:=rr32(t,7)+rr32(x7,11)+w; end; procedure r2(var x7,x6,x5,x4,x3,x2,x1,x0:longword;const w,c:longword); var t:longword; begin t:=(x3 and(x4 and(not x0)xor x1 and x2 xor x6 xor x5)xor x1 and(x4 xor x2) xor x0 and x2 xor x5); x7:=rr32(t,7)+rr32(x7,11)+w+c; end; procedure r3(var x7,x6,x5,x4,x3,x2,x1,x0:longword;const w,c:longword); var t:longword; begin t:=((x4)and((x1)and(x3)xor(x2)xor(x5))xor(x1)and(x0)xor(x3)and(x6) xor(x5)); x7:=rr32(t,7)+rr32(x7,11)+w+c; end; procedure r4(var x7,x6,x5,x4,x3,x2,x1,x0:longword;const w,c:longword); var t:longword; begin t:=(x3 and(x5 and(not x0)xor x2 and(not x1)xor x4 xor x1 xor x6)xor x2 and(x4 and x0 xor x5 xor x1)xor x0 and x1 xor x6); x7:=rr32(t,7)+rr32(x7,11)+w+c; end; procedure r5(var x7,x6,x5,x4,x3,x2,x1,x0:longword;const w,c:longword); var t:longword; begin t:=(x1 and(x3 and x4 and x6 xor(not x5))xor x3 and x0 xor x4 and x5 xor x6 and x2); x7:=rr32(t,7)+rr32(x7,11)+w+c; end; var t7,t6,t5,t4,t3,t2,t1,t0:longword; w:array[0..31] of longword; begin t0:=ctx.hash[0]; t1:=ctx.hash[1]; t2:=ctx.hash[2]; t3:=ctx.hash[3]; 307

t4:=ctx.hash[4]; t5:=ctx.hash[5]; t6:=ctx.hash[6]; t7:=ctx.hash[7]; move(ctx.hashbuffer,w,sizeof(w)); r1(t7,t6,t5,t4,t3,t2,t1,t0,w[ 0]); r1(t6,t5,t4,t3,t2,t1,t0,t7,w[ 1]); r1(t5,t4,t3,t2,t1,t0,t7,t6,w[ 2]); r1(t4,t3,t2,t1,t0,t7,t6,t5,w[ 3]); r1(t3,t2,t1,t0,t7,t6,t5,t4,w[ 4]); r1(t2,t1,t0,t7,t6,t5,t4,t3,w[ 5]); r1(t1,t0,t7,t6,t5,t4,t3,t2,w[ 6]); r1(t0,t7,t6,t5,t4,t3,t2,t1,w[ 7]); r1(t7,t6,t5,t4,t3,t2,t1,t0,w[ 8]); r1(t6,t5,t4,t3,t2,t1,t0,t7,w[ 9]); r1(t5,t4,t3,t2,t1,t0,t7,t6,w[10]); r1(t4,t3,t2,t1,t0,t7,t6,t5,w[11]); r1(t3,t2,t1,t0,t7,t6,t5,t4,w[12]); r1(t2,t1,t0,t7,t6,t5,t4,t3,w[13]); r1(t1,t0,t7,t6,t5,t4,t3,t2,w[14]); r1(t0,t7,t6,t5,t4,t3,t2,t1,w[15]); r1(t7,t6,t5,t4,t3,t2,t1,t0,w[16]); r1(t6,t5,t4,t3,t2,t1,t0,t7,w[17]); r1(t5,t4,t3,t2,t1,t0,t7,t6,w[18]); r1(t4,t3,t2,t1,t0,t7,t6,t5,w[19]); r1(t3,t2,t1,t0,t7,t6,t5,t4,w[20]); r1(t2,t1,t0,t7,t6,t5,t4,t3,w[21]); r1(t1,t0,t7,t6,t5,t4,t3,t2,w[22]); r1(t0,t7,t6,t5,t4,t3,t2,t1,w[23]); r1(t7,t6,t5,t4,t3,t2,t1,t0,w[24]); r1(t6,t5,t4,t3,t2,t1,t0,t7,w[25]); r1(t5,t4,t3,t2,t1,t0,t7,t6,w[26]); r1(t4,t3,t2,t1,t0,t7,t6,t5,w[27]); r1(t3,t2,t1,t0,t7,t6,t5,t4,w[28]); r1(t2,t1,t0,t7,t6,t5,t4,t3,w[29]); r1(t1,t0,t7,t6,t5,t4,t3,t2,w[30]); r1(t0,t7,t6,t5,t4,t3,t2,t1,w[31]); r2(t7,t6,t5,t4,t3,t2,t1,t0,w[ 5],$452821E6); r2(t6,t5,t4,t3,t2,t1,t0,t7,w[14],$38D01377); r2(t5,t4,t3,t2,t1,t0,t7,t6,w[26],$BE5466CF); r2(t4,t3,t2,t1,t0,t7,t6,t5,w[18],$34E90C6C); r2(t3,t2,t1,t0,t7,t6,t5,t4,w[11],$C0AC29B7); r2(t2,t1,t0,t7,t6,t5,t4,t3,w[28],$C97C50DD); r2(t1,t0,t7,t6,t5,t4,t3,t2,w[ 7],$3F84D5B5); r2(t0,t7,t6,t5,t4,t3,t2,t1,w[16],$B5470917); r2(t7,t6,t5,t4,t3,t2,t1,t0,w[ 0],$9216D5D9); r2(t6,t5,t4,t3,t2,t1,t0,t7,w[23],$8979FB1B); r2(t5,t4,t3,t2,t1,t0,t7,t6,w[20],$D1310BA6); r2(t4,t3,t2,t1,t0,t7,t6,t5,w[22],$98DFB5AC); r2(t3,t2,t1,t0,t7,t6,t5,t4,w[ 1],$2FFD72DB); r2(t2,t1,t0,t7,t6,t5,t4,t3,w[10],$D01ADFB7); r2(t1,t0,t7,t6,t5,t4,t3,t2,w[ 4],$B8E1AFED); r2(t0,t7,t6,t5,t4,t3,t2,t1,w[ 8],$6A267E96); r2(t7,t6,t5,t4,t3,t2,t1,t0,w[30],$BA7C9045); r2(t6,t5,t4,t3,t2,t1,t0,t7,w[ 3],$F12C7F99); 308

r2(t5,t4,t3,t2,t1,t0,t7,t6,w[21],$24A19947); r2(t4,t3,t2,t1,t0,t7,t6,t5,w[ 9],$B3916CF7); r2(t3,t2,t1,t0,t7,t6,t5,t4,w[17],$0801F2E2); r2(t2,t1,t0,t7,t6,t5,t4,t3,w[24],$858EFC16); r2(t1,t0,t7,t6,t5,t4,t3,t2,w[29],$636920D8); r2(t0,t7,t6,t5,t4,t3,t2,t1,w[ 6],$71574E69); r2(t7,t6,t5,t4,t3,t2,t1,t0,w[19],$A458FEA3); r2(t6,t5,t4,t3,t2,t1,t0,t7,w[12],$F4933D7E); r2(t5,t4,t3,t2,t1,t0,t7,t6,w[15],$0D95748F); r2(t4,t3,t2,t1,t0,t7,t6,t5,w[13],$728EB658); r2(t3,t2,t1,t0,t7,t6,t5,t4,w[ 2],$718BCD58); r2(t2,t1,t0,t7,t6,t5,t4,t3,w[25],$82154AEE); r2(t1,t0,t7,t6,t5,t4,t3,t2,w[31],$7B54A41D); r2(t0,t7,t6,t5,t4,t3,t2,t1,w[27],$C25A59B5); r3(t7,t6,t5,t4,t3,t2,t1,t0,w[19],$9C30D539); r3(t6,t5,t4,t3,t2,t1,t0,t7,w[ 9],$2AF26013); r3(t5,t4,t3,t2,t1,t0,t7,t6,w[ 4],$C5D1B023); r3(t4,t3,t2,t1,t0,t7,t6,t5,w[20],$286085F0); r3(t3,t2,t1,t0,t7,t6,t5,t4,w[28],$CA417918); r3(t2,t1,t0,t7,t6,t5,t4,t3,w[17],$B8DB38EF); r3(t1,t0,t7,t6,t5,t4,t3,t2,w[ 8],$8E79DCB0); r3(t0,t7,t6,t5,t4,t3,t2,t1,w[22],$603A180E); r3(t7,t6,t5,t4,t3,t2,t1,t0,w[29],$6C9E0E8B); r3(t6,t5,t4,t3,t2,t1,t0,t7,w[14],$B01E8A3E); r3(t5,t4,t3,t2,t1,t0,t7,t6,w[25],$D71577C1); r3(t4,t3,t2,t1,t0,t7,t6,t5,w[12],$BD314B27); r3(t3,t2,t1,t0,t7,t6,t5,t4,w[24],$78AF2FDA); r3(t2,t1,t0,t7,t6,t5,t4,t3,w[30],$55605C60); r3(t1,t0,t7,t6,t5,t4,t3,t2,w[16],$E65525F3); r3(t0,t7,t6,t5,t4,t3,t2,t1,w[26],$AA55AB94); r3(t7,t6,t5,t4,t3,t2,t1,t0,w[31],$57489862); r3(t6,t5,t4,t3,t2,t1,t0,t7,w[15],$63E81440); r3(t5,t4,t3,t2,t1,t0,t7,t6,w[ 7],$55CA396A); r3(t4,t3,t2,t1,t0,t7,t6,t5,w[ 3],$2AAB10B6); r3(t3,t2,t1,t0,t7,t6,t5,t4,w[ 1],$B4CC5C34); r3(t2,t1,t0,t7,t6,t5,t4,t3,w[ 0],$1141E8CE); r3(t1,t0,t7,t6,t5,t4,t3,t2,w[18],$A15486AF); r3(t0,t7,t6,t5,t4,t3,t2,t1,w[27],$7C72E993); r3(t7,t6,t5,t4,t3,t2,t1,t0,w[13],$B3EE1411); r3(t6,t5,t4,t3,t2,t1,t0,t7,w[ 6],$636FBC2A); r3(t5,t4,t3,t2,t1,t0,t7,t6,w[21],$2BA9C55D); r3(t4,t3,t2,t1,t0,t7,t6,t5,w[10],$741831F6); r3(t3,t2,t1,t0,t7,t6,t5,t4,w[23],$CE5C3E16); r3(t2,t1,t0,t7,t6,t5,t4,t3,w[11],$9B87931E); r3(t1,t0,t7,t6,t5,t4,t3,t2,w[ 5],$AFD6BA33); r3(t0,t7,t6,t5,t4,t3,t2,t1,w[ 2],$6C24CF5C); r4(t7,t6,t5,t4,t3,t2,t1,t0,w[24],$7A325381); r4(t6,t5,t4,t3,t2,t1,t0,t7,w[ 4],$28958677); r4(t5,t4,t3,t2,t1,t0,t7,t6,w[ 0],$3B8F4898); r4(t4,t3,t2,t1,t0,t7,t6,t5,w[14],$6B4BB9AF); r4(t3,t2,t1,t0,t7,t6,t5,t4,w[ 2],$C4BFE81B); r4(t2,t1,t0,t7,t6,t5,t4,t3,w[ 7],$66282193); r4(t1,t0,t7,t6,t5,t4,t3,t2,w[28],$61D809CC); r4(t0,t7,t6,t5,t4,t3,t2,t1,w[23],$FB21A991); r4(t7,t6,t5,t4,t3,t2,t1,t0,w[26],$487CAC60); 309

r4(t6,t5,t4,t3,t2,t1,t0,t7,w[ 6],$5DEC8032); r4(t5,t4,t3,t2,t1,t0,t7,t6,w[30],$EF845D5D); r4(t4,t3,t2,t1,t0,t7,t6,t5,w[20],$E98575B1); r4(t3,t2,t1,t0,t7,t6,t5,t4,w[18],$DC262302); r4(t2,t1,t0,t7,t6,t5,t4,t3,w[25],$EB651B88); r4(t1,t0,t7,t6,t5,t4,t3,t2,w[19],$23893E81); r4(t0,t7,t6,t5,t4,t3,t2,t1,w[ 3],$D396ACC5); r4(t7,t6,t5,t4,t3,t2,t1,t0,w[22],$0F6D6FF3); r4(t6,t5,t4,t3,t2,t1,t0,t7,w[11],$83F44239); r4(t5,t4,t3,t2,t1,t0,t7,t6,w[31],$2E0B4482); r4(t4,t3,t2,t1,t0,t7,t6,t5,w[21],$A4842004); r4(t3,t2,t1,t0,t7,t6,t5,t4,w[ 8],$69C8F04A); r4(t2,t1,t0,t7,t6,t5,t4,t3,w[27],$9E1F9B5E); r4(t1,t0,t7,t6,t5,t4,t3,t2,w[12],$21C66842); r4(t0,t7,t6,t5,t4,t3,t2,t1,w[ 9],$F6E96C9A); r4(t7,t6,t5,t4,t3,t2,t1,t0,w[ 1],$670C9C61); r4(t6,t5,t4,t3,t2,t1,t0,t7,w[29],$ABD388F0); r4(t5,t4,t3,t2,t1,t0,t7,t6,w[ 5],$6A51A0D2); r4(t4,t3,t2,t1,t0,t7,t6,t5,w[15],$D8542F68); r4(t3,t2,t1,t0,t7,t6,t5,t4,w[17],$960FA728); r4(t2,t1,t0,t7,t6,t5,t4,t3,w[10],$AB5133A3); r4(t1,t0,t7,t6,t5,t4,t3,t2,w[16],$6EEF0B6C); r4(t0,t7,t6,t5,t4,t3,t2,t1,w[13],$137A3BE4); r5(t7,t6,t5,t4,t3,t2,t1,t0,w[27],$BA3BF050); r5(t6,t5,t4,t3,t2,t1,t0,t7,w[ 3],$7EFB2A98); r5(t5,t4,t3,t2,t1,t0,t7,t6,w[21],$A1F1651D); r5(t4,t3,t2,t1,t0,t7,t6,t5,w[26],$39AF0176); r5(t3,t2,t1,t0,t7,t6,t5,t4,w[17],$66CA593E); r5(t2,t1,t0,t7,t6,t5,t4,t3,w[11],$82430E88); r5(t1,t0,t7,t6,t5,t4,t3,t2,w[20],$8CEE8619); r5(t0,t7,t6,t5,t4,t3,t2,t1,w[29],$456F9FB4); r5(t7,t6,t5,t4,t3,t2,t1,t0,w[19],$7D84A5C3); r5(t6,t5,t4,t3,t2,t1,t0,t7,w[ 0],$3B8B5EBE); r5(t5,t4,t3,t2,t1,t0,t7,t6,w[12],$E06F75D8); r5(t4,t3,t2,t1,t0,t7,t6,t5,w[ 7],$85C12073); r5(t3,t2,t1,t0,t7,t6,t5,t4,w[13],$401A449F); r5(t2,t1,t0,t7,t6,t5,t4,t3,w[ 8],$56C16AA6); r5(t1,t0,t7,t6,t5,t4,t3,t2,w[31],$4ED3AA62); r5(t0,t7,t6,t5,t4,t3,t2,t1,w[10],$363F7706); r5(t7,t6,t5,t4,t3,t2,t1,t0,w[ 5],$1BFEDF72); r5(t6,t5,t4,t3,t2,t1,t0,t7,w[ 9],$429B023D); r5(t5,t4,t3,t2,t1,t0,t7,t6,w[14],$37D0D724); r5(t4,t3,t2,t1,t0,t7,t6,t5,w[30],$D00A1248); r5(t3,t2,t1,t0,t7,t6,t5,t4,w[18],$DB0FEAD3); r5(t2,t1,t0,t7,t6,t5,t4,t3,w[ 6],$49F1C09B); r5(t1,t0,t7,t6,t5,t4,t3,t2,w[28],$075372C9); r5(t0,t7,t6,t5,t4,t3,t2,t1,w[24],$80991B7B); r5(t7,t6,t5,t4,t3,t2,t1,t0,w[ 2],$25D479D8); r5(t6,t5,t4,t3,t2,t1,t0,t7,w[23],$F6E8DEF7); r5(t5,t4,t3,t2,t1,t0,t7,t6,w[16],$E3FE501A); r5(t4,t3,t2,t1,t0,t7,t6,t5,w[22],$B6794C3B); r5(t3,t2,t1,t0,t7,t6,t5,t4,w[ 4],$976CE0BD); r5(t2,t1,t0,t7,t6,t5,t4,t3,w[ 1],$04C006BA); r5(t1,t0,t7,t6,t5,t4,t3,t2,w[25],$C1A94FB6); r5(t0,t7,t6,t5,t4,t3,t2,t1,w[15],$409F60C4); 310

inc(ctx.hash[0],t0); inc(ctx.hash[1],t1); inc(ctx.hash[2],t2); inc(ctx.hash[3],t3); inc(ctx.hash[4],t4); inc(ctx.hash[5],t5); inc(ctx.hash[6],t6); inc(ctx.hash[7],t7); fillchar(w,sizeof(w),0); ctx.index:=0; fillchar(ctx.hashbuffer,sizeof(ctx.hashbuffer),0); end; procedure HavalUpdateLen(ctx:THaval_CTX;len:longword); begin inc(ctx.lenlo,(len shl 3)); if ctx.lenlo<(len shl 3)then inc(ctx.lenhi); inc(ctx.lenhi,len shr 29); end; procedure HavalFlush(ctx:THaval_CTX); begin ctx.lenhi:=0; ctx.lenlo:=0; ctx.index:=0; fillchar(ctx.hashbuffer,sizeof(ctx.hashbuffer),0); fillchar(ctx.hash,sizeof(ctx.hash),0); end; procedure HavalInit(ctx:THaval_CTX); begin HavalFlush(ctx); ctx.hash[0]:=$243F6A88; ctx.hash[1]:=$85A308D3; ctx.hash[2]:=$13198A2E; ctx.hash[3]:=$03707344; ctx.hash[4]:=$A4093822; ctx.hash[5]:=$299F31D0; ctx.hash[6]:=$082EFA98; ctx.hash[7]:=$EC4E6C89; end; procedure HavalUpdate(ctx:THaval_CTX;const Buffer; Size: longint); var p:^byte; begin HavalUpdateLen(ctx,size); p:=@buffer; while size>0 do begin if(sizeof(ctx.hashbuffer)-ctx.index)<=longword(size)then begin move(p^,ctx.hashbuffer[ctx.index],sizeof(ctx.hashbuffer)-ctx.index); dec(size,sizeof(ctx.hashbuffer)-ctx.index); inc(p,sizeof(ctx.hashbuffer)-ctx.index); HavalCompress(ctx); 311

end else begin move(p^,ctx.hashbuffer[ctx.index],size); inc(ctx.index,size); size:=0; end; end; end; procedure HavalFinal(ctx:THaval_CTX;var digest); begin ctx.hashbuffer[ctx.index]:=$80; if ctx.index>118 then HavalCompress(ctx); ctx.hashbuffer[118]:=((HASH_SIZE and 3)shl 6)or(5 shl 3)or 1; ctx.hashbuffer[119]:=(HASH_SIZE shr 2)and $FF; move(ctx.lenlo,ctx.hashbuffer[120],sizeof(ctx.lenlo)); move(ctx.lenhi,ctx.hashbuffer[124],sizeof(ctx.lenhi)); HavalCompress(ctx); move(ctx.hash,digest,HASH_SIZE div 8); HavalFlush(ctx); end; //**************************************************************************** // PRNG //**************************************************************************** procedure PrngInit(ctx:TPrng_CTX;seed:longword); var i:byte; begin ctx.x1:=(seed+PrngC1)mod PrngM1; ctx.x1:=(ctx.x1*PrngI1+PrngC1)mod PrngM1; ctx.x2:=ctx.x1 mod PrngM2; ctx.x1:=(ctx.x1*PrngI1+PrngC1)mod PrngM1; ctx.x3:=ctx.x1 mod PrngM3; for i:=1 to 97 do begin ctx.x1:=(ctx.x1*PrngI1+PrngC1)mod PrngM1; ctx.x2:=(ctx.x2*PrngI2+PrngC2)mod PrngM2; ctx.r[i]:=(ctx.x1+ctx.x2/PrngM2)/PrngM1; end; end; function Prng(ctx:TPrng_CTX):longword; var i:longword; begin ctx.x1:=(ctx.x1*PrngI1+PrngC1)mod PrngM1; ctx.x2:=(ctx.x2*PrngI2+PrngC2)mod PrngM2; ctx.x3:=(ctx.x3*PrngI3+PrngC3)mod PrngM3; i:=1+(97*ctx.x3)div PrngM3; Prng:=trunc($FFFFFFFF*ctx.r[i]); ctx.r[i]:=(ctx.x1+ctx.x2/PrngM2)/PrngM1; end; procedure PrngFlush(ctx:TPrng_CTX); var i:byte; 312

begin ctx.x1:=0; ctx.x2:=0; ctx.x3:=0; for i:=1 to 97 do ctx.r[i]:=0; end; //**************************************************************************** // Key Routines //**************************************************************************** procedure MutateKey(var key:key256); var i:byte; exp_key:array[0..1,0..7]of longword; ran_ctx:Prng_CTX; hash_ctx:Haval_CTX; temp_key:key256; begin // *** [1]feed key as 8 seeds into PRNG to generate 16 longs for i:=0 to 7 do begin PrngInit(@ran_ctx,key[i]); //use key as seed data exp_key[0,i]:=Prng(@ran_ctx); //expand key exp_key[1,i]:=not Prng(@ran_ctx); //negate to reduce PRNG relationship end; // *** [2]feed [1] as 64 bytes into Haval for i:=0 to 7 do temp_key[i]:=key[i]; HavalInit(@hash_ctx); HavalUpdate(@hash_ctx,exp_key[0][0],64); //feed expanded key as data HavalFinal(@hash_ctx,key); // *** [3]xor(^) [2] and [1] to produce the final key for i:=0 to 7 do key[i]:=key[i]xor temp_key[i]; //reduce HASH relationship end; function PasswordToKey(pass:string):key256; var i,j:integer; temp_chars:array[0..42]of byte; key_size:byte; temp_key:array[0..31]of byte; temp_pos:byte; bit_pos:byte; begin // *** [1]convert 8bit Chars to 6bit bytes for i:=1 to length(pass)do case byte(pass[i]) of 97..122:temp_chars[i]:=byte(pass[i])-97; //if a..z assign 0-25 65..90 :temp_chars[i]:=byte(pass[i])-39; //if A..Z assign 26-51 48..57 :temp_chars[i]:=byte(pass[i])+4; //if 0..9 assign 52-61 byte('.'):temp_chars[i]:=62; //if . assign 62 byte('_'):temp_chars[i]:=63; //if _ assign 63 313

end; key_size:=(length(pass)*6)div 8; //keysize with 6bit chars // *** [2]append 6bit Chars to each other temp_pos:=0; //temp buffer position bit_pos:=0; //bit position for i:=0 to key_size-1 do //concatonate 6bit chars together begin temp_key[i]:=0; for j:=0 to 7 do begin inc(temp_key[i], ((temp_chars[temp_pos] and BIT_MASK[bit_pos]) shr bit_pos) shl j); inc(bit_pos,1); if bit_pos=6 then begin bit_pos:=0; inc(temp_pos,1); end; end; end; // *** [3]make full 256bit key //[EDITED 04/25/01] Sorry about the bug. This was originaly done to the //passphrase, but I moved it to the process the key instead and forgot to //adjust the length from 43 to 32 bytes. Just change the lines of step [3]. //Again, sorry. if key_size<32 then begin j:=0; for i:=key_size-1 to 31 do //fill in empty bytes begin temp_key[i]:=temp_key[j]xor i; inc(j,1); end; end; // *** [4]eliminate english language redundancy MutateKey(key256(temp_key)); PasswordToKey:=key256(temp_key); end; function AnalyzePassword(pass:string):KeyStatistics; var i,j:longword; key:array[0..1023]of byte; chars:array[0..255] of byte; pat_pos,pat_len:longword; ones,zeros:longword; stat:KeyStatistics; begin // *** [1]count keylenght 314

stat.KeyLength:=length(pass); // *** [2]copy key to buffer for i:=0 to stat.KeyLength-1 do key[i]:=byte(pass[i]); // *** [3]count char repetition for i:=0 to 255 do chars[i]:=0; for i:=0 to stat.KeyLength-1 do inc(chars[key[i]],1); // *** [4]count different characters stat.CharCount:=0; for i:=0 to 255 do if chars[i]<>0 then inc(stat.CharCount,1); // *** [5]count charbits stat.CharBits:=0; for i:=0 to 7 do if stat.CharCount > BIT_MASK[i] then inc(stat.CharBits,1); // *** [6]count patterns pat_pos:=0; pat_len:=0; repeat i:=pat_pos; repeat if (key[i]=key[pat_pos])and(i<>pat_pos)then //if match is found repeat inc(pat_len,1); //increment pattern size inc(i,1); //move to next char inc(pat_pos,1); //next char in pattern until (key[i]<>key[pat_pos])or(i=stat.KeyLength); //until pattern ends inc(i,1); until (i>stat.KeyLength-1); //until finished searching for this pattern inc(pat_pos,1); //start new pattern with the next char until pat_pos>stat.KeyLength; //until all patterns have been searched if pat_len=0 then stat.Patterns:=0 else stat.Patterns:=(pat_len*100)div stat.KeyLength; // *** [7]count bit-differential ones:=0; zeros:=0; for i:=0 to stat.KeyLength-1 do for j:=0 to 7 do if (key[i] and BIT_MASK[j])=0 then inc(zeros,1) else inc(ones,1); stat.Differential:=(longword(abs(ones-zeros))*100)div(stat.KeyLength*8); // *** [8]count brutelength stat.BruteLength:=stat.CharBits*stat.KeyLength; // *** [9]count keysize stat.KeySize:=stat.KeyLength*8; // *** [10]count rating := BL - ((((pat+dif) /2) /100) *BL) stat.Rating:=stat.BruteLength((((stat.Patterns+stat.Differential)div 2)*stat.BruteLength)div 100); 315

AnalyzePassword:=stat; end; end. (C)Copyright DrMungkee, 2000 (www.drmungkee.com, [email protected])

316

Question/Problem/Abstract: Ever seen Win2K pop balloons over tray icons? When connecting through the Dial-Up Networking, for example... Windows pops a balloon over the connection icon that states speed and connection type. This is how to produce those cool balloons in your code. Answer: Please note: The author assumes you are familiar with simple operations of inserting and removing your icons to / from the "Tray". If you are not, I suggest studying either, or both, of the following: 1. How to create a TrayIcon ! (ID 1567) by Bernhard Angerer 2. In the end of this article, I provide my own functions for these tasks. Now, back to the balloons. I found out that the format of the NotifyIconData structure used to operate icons in the Tray (which, by the way, is called by Microsoft "The Taskbar Notification Area" :) changed significantly in Windows 2000. Those changes are NOT reflected in ShellAPI.pas unit of Delphi 5. Therefore I got the original SHELLAPI.H and translated the required declarations. Here they are: uses Windows; type NotifyIconData_50 = record // defined in shellapi.h cbSize: DWORD; Wnd: HWND; uID: UINT; uFlags: UINT; uCallbackMessage: UINT; hIcon: HICON; szTip: array[0..MAXCHAR] of AnsiChar; dwState: DWORD; dwStateMask: DWORD; szInfo: array[0..MAXBYTE] of AnsiChar; uTimeout: UINT; // union with uVersion: UINT; szInfoTitle: array[0..63] of AnsiChar; dwInfoFlags: DWORD; end{record}; const NIF_INFO = $00000010; NIIF_NONE = $00000000; NIIF_INFO = $00000001; NIIF_WARNING = $00000002; NIIF_ERROR = $00000003; Here is a couple of types I think to be helpful: type TBalloonTimeout = 10..30{seconds}; TBalloonIconType = (bitNone, // no icon bitInfo, // information icon (blue) bitWarning, // exclamation icon (yellow) bitError); // error icon (red) Now we're ready to BALLOON!

317

This is the function I use: uses SysUtils, Windows, ShellAPI; function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: String; const BalloonIconType: TBalloonIconType): Boolean; const aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR); var NID_50 : NotifyIconData_50; begin FillChar(NID_50, SizeOf(NotifyIconData_50), 0); with NID_50 do begin cbSize := SizeOf(NotifyIconData_50); Wnd := Window; uID := IconID; uFlags := NIF_INFO; StrPCopy(szInfo, BalloonText); uTimeout := Timeout * 1000; StrPCopy(szInfoTitle, BalloonTitle); dwInfoFlags := aBalloonIconTypes[BalloonIconType]; end{with}; Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50); end; And this is how to employ it: DZBalloonTrayIcon(Form1.Handle, 1, 10, 'this is the balloon text', 'title', bitWarning); The icon has to be already added, of course, with the same window handle and IconID (in this example, Form1.Handle and 1). Try all three types of the inside-the-balloon-icons, they are cool! ======THE END OF THE BALLOON ARTICLE====== P.S. Now the functions I promised for adding/removing tray icons: uses SysUtils, Windows, ShellAPI; {just adds an icon} function DZAddTrayIcon(const Window: HWND; const IconID: Byte; const Icon: HICON; const Hint: String = ''): Boolean; var NID : NotifyIconData; begin FillChar(NID, SizeOf(NotifyIconData), 0); with NID do begin cbSize := SizeOf(NotifyIconData); Wnd := Window; uID := IconID; if Hint = '' then begin uFlags := NIF_ICON; 318

end{if} else begin uFlags := NIF_ICON or NIF_TIP; StrPCopy(szTip, Hint); end{else}; hIcon := Icon; end{with}; Result := Shell_NotifyIcon(NIM_ADD, @NID); end; {adds an icon with a call-back message} function DZAddTrayIconMsg(const Window: HWND; const IconID: Byte; const Icon: HICON; const Msg: Cardinal; const Hint: String = ''): Boolean; var NID : NotifyIconData; begin FillChar(NID, SizeOf(NotifyIconData), 0); with NID do begin cbSize := SizeOf(NotifyIconData); Wnd := Window; uID := IconID; if Hint = '' then begin uFlags := NIF_ICON or NIF_MESSAGE; end{if} else begin uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; StrPCopy(szTip, Hint); end{else}; uCallbackMessage := Msg; hIcon := Icon; end{with}; Result := Shell_NotifyIcon(NIM_ADD, @NID); end; {removes an icon} function DZRemoveTrayIcon(const Window: HWND; const IconID: Byte): Boolean; var NID : NotifyIconData; begin FillChar(NID, SizeOf(NotifyIconData), 0); with NID do begin cbSize := SizeOf(NotifyIconData); Wnd := Window; uID := IconID; end{with}; Result := Shell_NotifyIcon(NIM_DELETE, @NID); end; A few final notes: 1. There's absolutely no need to use the larger ver.5.0 structure NotifyIconData_50 to add or remove icons, the old smaller structure NotifyIconData is perfect for that, even if you want to balloon them. 2. For the callback message, I suggest using WM_APP + something. 3. Using different IconIDs, it is easy to add many different icons to tray from a single parent window and operate them by their IconIDs.

319

Question/Problem/Abstract: How to pop a dialog box where you can choose a computer on the network neighborhood ? Answer: {** Compile fine with D3, Should be OK with other version **} function BrowseForComputer(const winhandle : THANDLE; const title : string) : string; WinHandle : window handle (Form1.Handle) or 0. Title : title of the dialog box result : selected computer, or emptystring if Cancel. Based on some code find in newsgroup. uses shlobj; {...} function BrowseForComputer(const winhandle : THANDLE; const title : string) : string; //Pop up the standard 'Browse for computer' dialog box var BrowseInfo: TBrowseInfo; IDRoot: PItemIDList; Path: array[0..MAX_PATH] of Char; begin // Get the Item ID for Network Neighborhood SHGetSpecialFolderLocation(winHandle, CSIDL_NETWORK, IDRoot); ZeroMemory(@BrowseInfo, SizeOf(TBrowseInfo)); ZeroMemory(@path, MAX_PATH); BrowseInfo.hwndOwner := winhandle; BrowseInfo.pidlRoot := IDRoot; BrowseInfo.lpszTitle := PChar(title); BrowseInfo.pszDisplayName := @path; // Include this flag to show computer only BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;// or BIF_RETURNONLYFSDIRS ; // Show the browse dialog, get the Item ID for the selected item and convert it to a path SHBrowseForFolder(BrowseInfo); // SHGetPathFromIDList(IDList, Path); result := path; end;

320

Question/Problem/Abstract: I like the balloons that pops up in the Window 2000 tray area. How do I get them in my programs? Answer: This behavior can be accomplished by using the Shell_NotifyIcon with the proper flags. A good example is the Daniel Zakharov's article. As Daniel indicated in his article there is another article from Bernhard Angerer showing an interesting (and simple) component to manage tray icons. My task here is to join the informations from both articles to get a working component ready for Windows 2000 and ballooning. First of all I suggest to remove the line added by Bernhard in the constructor of its component: when used at design-time the Application.Handle seems to refer to Delphi main window (at least in version 5.0). This lead the entire IDE to behave in a quite strange way. A possible solution to this problem is to modify the constructor in this way: if not (csDesigning in ComponentState) then SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); This change add the WS_EX_TOOLWINDOW style to the main window at run-time only. And now for the fleshy part! Step 1: Add the new flag and messages needed for ballooning. const WM_TOOLTRAYICON = WM_USER+1; WM_RESETTOOLTIP = WM_USER+2; NIF_INFO = $00000010; NIIF_NONE = $00000000; NIIF_INFO = $00000001; NIIF_WARNING = $00000002; NIIF_ERROR = $00000003;

Step 2: Add a new version for the TNotifyIconData structure. I call this structure TNotifyIconData50 TNotifyIconData50 = record cbSize: DWORD; Wnd: HWND; uID: UINT; uFlags: UINT; uCallbackMessage: UINT; hIcon: HICON; szTip: array[0..127] of AnsiChar; dwState: DWORD; dwStateMask: DWORD; szInfo: array[0..255] of AnsiChar; uTimeout: UINT; // union with uVersion: UINT; szInfoTitle: array[0..63] of AnsiChar; dwInfoFlags: DWORD; 321

end{record}; Step 3: Add some new helper types (used later). TBalloonTimeout = 10..30; {seconds} TBalloonIconType = (bitNone, // no icon bitInfo, // information icon (blue) bitWarning, // exclamation icon (yellow) bitError); // error icon (red) Step 4: Replace the references to TNOTIFYICONDATA with TNotifyIconData50. In the component there are just two This is the first one... ... TTrayIcon = class(TComponent) private { Field Variables } IconData: TNotifyIconData50; fIcon : TIcon; ... This is the second one... ... procedure TTrayIcon.FillDataStructure; begin with IconData do begin cbSize := SizeOf(TNotifyIconData50); wnd := FWindowHandle; uID := 0; // is not passed in with message so make it 0 uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; hIcon := fIcon.Handle; StrPCopy(szTip,fToolTip); uCallbackMessage := WM_TOOLTRAYICON; end; end; Step 5: Add the Balloon() method to the public section of the class and to the body of source: ... public constructor create(aOwner : TComponent); override; destructor destroy; override; function Balloon(Title: String; Text: string; IconType: TBalloonIconType; Timeout: TBalloonTimeout): Boolean; ... ... function TTrayIcon.Balloon(Title: String; Text: string; IconType: TBalloonIconType; Timeout: TBalloonTimeout): Boolean; 322

const aBalloonIconTypes: array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR); begin if fActive then begin //Removes old balloon FillDataStructure; with IconData do begin uFlags := uFlags or NIF_INFO; StrPCopy(szInfo, ''); end{with}; Shell_NotifyIcon(NIM_MODIFY, @IconData); //Shows new balloon FillDataStructure; with IconData do begin uFlags := uFlags or NIF_INFO; StrPCopy(szInfo, Text); uTimeout := Timeout * 1000; StrPCopy(szInfoTitle, Title); dwInfoFlags := aBalloonIconTypes[IconType]; end{with}; Result := Shell_NotifyIcon(NIM_MODIFY, @IconData) end else result := True; end; ... Enjoy!

323

Question/Problem/Abstract: I was asked how to implement the MinimizeAll feature of the new Win2K shell. Answer: I found that if you import the Microsoft Shell Controls & Automation Type Library, you have this functionality in a component. Select Project..Import Type Library... from the menu Select Microsoft Shell Controls & Automation (version 1.0). Click Install... There will be several components placed on the ActiveX palette tab. Drop a TShell Component on your form or DM and you canMinimize all just by doing this: Shell1.MinimizeAll; /********************************************************************* There are many really cool shell tricks available when you use the TShell Control. *********************************************************************/ procedure TForm1.Shell(sMethod: Integer); begin case sMethod of 0: //Minimizes all windows on the desktop begin Shell1.MinimizeAll; Button1.Tag := Button1.Tag + 1; end; 1: //Displays the Run dialog begin Shell1.FileRun; Button1.Tag := Button1.Tag + 1; end; 2: //Displays the Shut Down Windows dialog begin Shell1.ShutdownWindows; Button1.Tag := Button1.Tag + 1; end; 3: //Displays the Find dialog begin Shell1.FindFiles; Button1.Tag := Button1.Tag + 1; end; 4: //Displays the Date/Time dialog begin Shell1.SetTime; Button1.Tag := Button1.Tag + 1; end; 324

5: //Displays the Internet Properties dialog begin Shell1.ControlPanelItem('INETCPL.cpl'); Button1.Tag := Button1.Tag + 1; end; 6: //Enables user to select folder from Program Files begin Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files'); Button1.Tag := Button1.Tag + 1; end; 7: //Displays the Taskbar Properties dialog begin Shell1.TrayProperties; Button1.Tag := Button1.Tag + 1; end; 8: //Un-Minimizes all windows on the desktop begin Shell1.UndoMinimizeAll; Button1.Tag := 0; end; end; {case} end; procedure TForm1.Button1Click(Sender: TObject); begin Shell(Button1.Tag); end;

325

Question/Problem/Abstract: How can I format a drive under Win32? Answer: You can use the ShellAPI funciton ShFormatDrive. Example: const SHFMT_DRV_A = 0; const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end;

326

327

Question/Problem/Abstract: How to mount a networkdrive or work witht he UNC path ! Answer: The functions 'WNetAddConnection2' mounts a networkdrive. Is 'aDriveLetter' empty, there will be no driveletter found and the windows explorer doesn't show the connection. In this case you have to work with the UNC path. function ConnectDrive(aUser,aPwd,aUncPath,aDriveLetter: string; var aErrorCode: integer): boolean; var ANetResource: TNetResource; PW,UN: array[0..200] of char; Error: word; begin aUser := aUser + #0; aPwd := aPwd + #0; aUncPath := aUncPath + #0; with ANetResource do begin dwType:=RESOURCETYPE_DISK; lpLocalName := PChar(aDriveLetter); lpRemoteName := PChar(aUncPath); lpProvider:=nil; end; StrCopy(PW,@aPwd[1]); StrCopy(UN,@aUser[1]); Error := WNetAddConnection2(ANetResource, @PW, @UN, 0); aErrorCode := Error; Result := (Error = 0); end; How can I disconnect a networkdrive. RE: How to disconnect? var fForce: boolean; fForget: integer; begin { fForce := true; // to force disconnect even with open files, otherwise false fForget := CONNECT_UPDATE_PROFILE; // (const defined in windows.pas) to ensure that even persistent connections are cancelled in future, otherwise set fForget := 0 // aResource can be the local resource name (e.g. F:, LPT1) or the remote UNC path } result := WNetCancelConnection2(PChar(aResource), fForget, fForce); end;

328

Question/Problem/Abstract: How to implement an event... Answer: You can communicate with components via properties, methods and events. Here is a small example how to add an event to DBGrid when the user clicks the right mouse button: type TExtDBGrid = class(TDBGrid) private FOnRightClick : TNotifyEvent; procedure WMRButtonDown(var Message : TWMRButtonDown); message WM_RBUTTONDOWN; protected public published property OnRightClick: TNotifyEvent read FOnRightClick write FOnRightClick; end; procedure TExtDBGrid.WMRButtonDown(var Message: TWMRButtonDown); begin if Assigned(FOnRightClick) then FOnRightClick(Self); end; It's always the same procedure. We need to add a property for the event (in the published section when the event should appear under events in the object-inspector - otherwise in the public section) from the type that defines the parameters of the event. In the above example we used TNotifyEvent type TNotifyEvent = procedure (Sender: TObject) of object; which is defined in the unit Classes and therefore always available! When you want to fire the event you must be sure that the main-program did assign a procedure (assign statement) - then you can call it useing FOnEventName(Self, Params...); In this example we want to react on the right mouse button - this works with the reserved word message and the windows constant for this event: WM_RBUTTONDOWN Of course we can also define custom-events with various parameters. One thing to mention is that you can also use VAR-Parameters, so that the component can get input from the main program. For example: type TMyEvent = procedure (Sender: TObject; VAR aAbort: boolean) of object; procedure TMyComp.AnyFunc; var abort: boolean; begin while (...) do begin if Assigned(FMyEvent) then FMyEvent(Self, abort); if abort then exit; end; 329

end; In this case the event would be fired on every step through the loop and the main program could interrupt assigning aAbort to false !

330

Question/Problem/Abstract: How to create the PING functionality from ICMP.DLL Answer: A Little PING application. Once a received a email from a VB developer asking how we can ping a host from a delphi application. But Whats´s PING ? Ping is a protocol for testing whether a particular computer is connected to the Internet by sending a packet to its Internet Protocol (IP) address and waiting for a response. We build a little application that implements the ping funcionality. To do that we use the ICMP protocol implemented on ICMP.DLL. ICMP - Internet Control Message Protocol. The ICMP delivers error and control messages from hosts to the requesters. An ICMP test can determine whether a destination is reachable and responding. 1. open Delphi; 2. On a new project, Add a Tbutton, a Tedit and a Tmemo in your form; 3. Insert the “winsock” in the uses clausule; 4. Declare a record constant to put the IP head: type IPINFO = record Ttl :char; Tos :char; IPFlags :char; OptSize :char; Options :^char; end; 5. Declare a record constant to put the ICMP package: type ICMPECHO = record Source :longint; Status :longint; RTTime :longint; DataSize:Shortint; Reserved:Shortint; pData :^variant; i_ipinfo:IPINFO; end; 6. Declare the functions/procedures that you wiil call from ICMP.DLL TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF} TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF} TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF} 7. In the Tbutton´s Onclick event insert this code:: procedure TForm1.Button1Click(Sender: TObject); var wsadt : wsadata; 331

icmp :icmpecho; HNDicmp : integer; hndFile :integer; Host :PHostEnt; Destino :in_addr; Endereco :^DWORD; IP : ipinfo; Retorno :integer; dwRetorno :DWORD; x :integer; IcmpCreateFile : TIcmpCreateFile; IcmpCloseHandle : TIcmpCloseHandle; IcmpSendEcho : TIcmpSendEcho; begin if (edit1.Text = '') then begin Application.MessageBox('Enter a HostName ro a IP Adress', 'Error', MB_OK); exit; end; HNDicmp := LoadLibrary('ICMP.DLL'); if (HNDicmp <> 0) then begin @IcmpCreateFile := GetProcAddress(HNDicmp,'IcmpCreateFile'); @IcmpCloseHandle := GetProcAddress(HNDicmp,'IcmpCloseHandle'); @IcmpSendEcho := GetProcAddress(HNDicmp,'IcmpSendEcho'); if (@IcmpCreateFile=nil) or (@IcmpCloseHandle=nil) or (@IcmpSendEcho=nil) then begin Application.MessageBox('Error getting ICMP Adress’,'Error', MB_OK); FreeLibrary(HNDicmp); end; end; Retorno := WSAStartup($0101,wsadt); if (Retorno <> 0) then begin Application.MessageBox('Can´t Load WinSockets','WSAStartup', MB_OK); WSACleanup(); FreeLibrary(HNDicmp); end; Destino.S_addr := inet_addr(Pchar(Edit1.text)); if (Destino.S_addr = 0) then begin Host := GetHostbyName(PChar(Edit1.text)); end else begin Host := GetHostbyAddr(@Destino,sizeof(in_addr), AF_INET); end; if (host = nil) then begin Application.MessageBox('Host not found','Error', MB_OK); WSACleanup(); FreeLibrary(HNDicmp); exit; end; memo1.Lines.Add('Pinging ' + Edit1.text);

332

Endereco := @Host.h_addr_list; HNDFile := IcmpCreateFile(); for x:= 0 to 4 do begin Ip.Ttl := char(255); Ip.Tos := char(0); Ip.IPFlags := char(0); Ip.OptSize := char(0); Ip.Options := nil; dwRetorno := IcmpSendEcho( HNDFile, Endereco^, null, 0, Ip, Icmp, sizeof(Icmp), DWORD(5000)); Destino.S_addr := icmp.source; Memo1.Lines.Add('Ping ' + Edit1.text); end; IcmpCLoseHandle(HNDFile); FreeLibrary(HNDicmp); WSACleanup(); end; This code is not complete functional, sometimes it´s doesn´t work with Hostnames, only with IP adresses. For NT users don´t use the IcmpCloseHandle function. If you have some idea to make this code work better, mail me. That´s All….. Now, the complete unit ´s code: ---------------------------------unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, winsock, StdCtrls; type IPINFO = record Ttl :char; Tos :char; IPFlags :char; OptSize :char; Options :^char; end;

333

type ICMPECHO = record Source :longint; Status :longint; RTTime :longint; DataSize:Shortint; Reserved:Shortint; pData :^variant; i_ipinfo:IPINFO; end; TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF} TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF} TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF} type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Edit1: TEdit; Memo1: TMemo; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var wsadt : wsadata; icmp :icmpecho; HNDicmp : integer; hndFile :integer; Host :PHostEnt; Destino :in_addr; Endereco :^DWORD; IP : ipinfo; Retorno :integer; dwRetorno :DWORD; x :integer; IcmpCreateFile : TIcmpCreateFile; IcmpCloseHandle : TIcmpCloseHandle; 334

IcmpSendEcho : TIcmpSendEcho; begin if (edit1.Text = '') then begin Application.MessageBox('Digite um HostName ou um End. IP', 'Error', MB_OK); exit; end; HNDicmp := LoadLibrary('ICMP.DLL'); if (HNDicmp <> 0) then begin @IcmpCreateFile := GetProcAddress(HNDicmp,'IcmpCreateFile'); @IcmpCloseHandle := GetProcAddress(HNDicmp,'IcmpCloseHandle'); @IcmpSendEcho := GetProcAddress(HNDicmp,'IcmpSendEcho'); if (@IcmpCreateFile=nil) or (@IcmpCloseHandle=nil) or (@IcmpSendEcho=nil) then begin Application.MessageBox('Erro pegando endereços ICMP','Error', MB_OK); FreeLibrary(HNDicmp); end; end; Retorno := WSAStartup($0101,wsadt); if (Retorno <> 0) then begin Application.MessageBox('Não foi possível carregar WinSockets','WSAStartup', MB_OK); WSACleanup(); FreeLibrary(HNDicmp); end; Destino.S_addr := inet_addr(Pchar(Edit1.text)); if (Destino.S_addr = 0) then begin Host := GetHostbyName(PChar(Edit1.text)); end else begin Host := GetHostbyAddr(@Destino,sizeof(in_addr), AF_INET); end; if (host = nil) then begin Application.MessageBox('Host não encontrado','Error', MB_OK); WSACleanup(); FreeLibrary(HNDicmp); exit; end; memo1.Lines.Add('Pinging ' + Edit1.text); Endereco := @Host.h_addr_list; HNDFile := IcmpCreateFile(); for x:= 0 to 4 do begin Ip.Ttl := char(255); Ip.Tos := char(0); Ip.IPFlags := char(0); Ip.OptSize := char(0); Ip.Options := nil; dwRetorno := IcmpSendEcho( HNDFile, Endereco^, 335

null, 0, Ip, Icmp, sizeof(Icmp), DWORD(5000)); Destino.S_addr := icmp.source; Memo1.Lines.Add('Pingou ' + Edit1.text); end; IcmpCLoseHandle(HNDFile); FreeLibrary(HNDicmp); WSACleanup(); end; end.

336

Question/Problem/Abstract: How do I get the local internet machine name and IP address? Answer: Getting the local machine name and IP address is a straight forward process that is most easily accomplished using the TCP component. Simply drop a TCP component from the internet page of the component palette on to a form, and access the following members of the TCP component: Memo1.Lines.Add(TCP1.LocalHostName); Memo1.Lines.Add(TCP1.LocalIp); If you prefer not to use the TCP component, here is an example that interfaces directly with your winsock layer: uses Winsock; procedure TForm1.FormCreate(Sender: TObject); var wVersionRequested : WORD; wsaData : TWSAData; begin {Start up WinSock} wVersionRequested := MAKEWORD(1, 1); WSAStartup(wVersionRequested, wsaData); end; procedure TForm1.Button1Click(Sender: TObject); var p : PHostEnt; s : array[0..128] of char; p2 : pchar; begin {Get the computer name} GetHostName(@s, 128); p := GetHostByName(@s); Memo1.Lines.Add(p^.h_Name); {Get the IpAddress} p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^); Memo1.Lines.Add(p2); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Shut down WinSock} WSACleanup; end;

337

Question/Problem/Abstract: This article presents a code snipet which shows how to get the current user and the computer name. Answer: Obviously this is not a complete program, but you can use the Windows API calls GetUserName and GetComputerName as shown below. uses windows ... var u: array[0..127] of Char; c: array[0..127] of Char; user: string; computer: string; sz: dword; begin sz := SizeOf(u); GetUserName(u, sz); sz := SizeOf(c); GetComputerName(c, sz); user := u; computer := c; end;

338

Question/Problem/Abstract:

How can I send raw IP Packets?

This example just showes how to send an UDP packet with customized (spoofed) source ip+port. >>> You can only SEND raw-packets! <<< >>> Please don't ask me why. rtfm. <<< Answer: { ---------------------------------------------------------------------Raw Packet Sender using: Delphi + Winsock 2 Copyright (c) 2000 by E.J.Molendijk ([email protected]) Description: Using raw sockets you can SEND raw packets over the internet containing whatever you like. Keep in mind: 1. This only works under Window 2000. 2. You can SEND raw packets. You can NOT RECEIVE raw packets. 3. You must be Administrator to run this. 4. This unit requires a form containing a button and a memo.

Usage: 1. Before you run your program, you must change the SrcIP+SrcPort+ DestIP+DestPort to suitable values! 2. If you don't understand what this source does: Don't use it. ---------------------------------------------------------------------} unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, OleCtrls, Registry; Const SrcIP = '123.123.123.1'; SrcPort = 1234; DestIP = '123.123.123.2'; DestPort = 4321;

339

Max_Message = 4068; Max_Packet = 4096; type TPacketBuffer = Array[0..Max_Packet-1] of byte; TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure SendIt; end; // IP Header type T_IP_Header = record ip_verlen : Byte; ip_tos : Byte; ip_totallength : Word; ip_id : Word; ip_offset : Word; ip_ttl : Byte; ip_protocol : Byte; ip_checksum : Word; ip_srcaddr : LongWord; ip_destaddr : LongWord; end; // UDP Header Type T_UDP_Header = record src_portno : Word; dst_portno : Word; udp_length : Word; udp_checksum : Word; end; // Some Winsock 2 type declarations u_char = Char; u_short = Word; u_int = Integer; u_long = Longint; SunB = packed record s_b1, s_b2, s_b3, s_b4: u_char; end; SunW = packed record s_w1, s_w2: u_short; end; in_addr = record 340

case integer of 0: (S_un_b: SunB); 1: (S_un_w: SunW); 2: (S_addr: u_long); end; TInAddr = in_addr; Sockaddr_in = record case Integer of 0: (sin_family: u_short; sin_port: u_short; sin_addr: TInAddr; sin_zero: array[0..7] of Char); 1: (sa_family: u_short; sa_data: array[0..13] of Char) end; TSockAddr = Sockaddr_in; TSocket = u_int; const WSADESCRIPTION_LEN = 256; WSASYS_STATUS_LEN = 128; type PWSAData = ^TWSAData; WSAData = record // !!! also WSDATA wVersion: Word; wHighVersion: Word; szDescription: array[0..WSADESCRIPTION_LEN] of Char; szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; iMaxSockets: Word; iMaxUdpDg: Word; lpVendorInfo: PChar; end; TWSAData = WSAData; // Define some winsock 2 functions function closesocket(s: TSocket): Integer; stdcall; function socket(af, Struct, protocol: Integer): TSocket; stdcall; function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr; tolen: Integer): Integer; stdcall;{} function setsockopt(s: TSocket; level, optname: Integer; optval: PChar; optlen: Integer): Integer; stdcall; function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr } function htons(hostshort: u_short): u_short; stdcall; function WSAGetLastError: Integer; stdcall; function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall; function WSACleanup: Integer; stdcall; const AF_INET = 2; // internetwork: UDP, TCP, etc. IP_HDRINCL = 2; // IP Header Include SOCK_RAW = 3; // raw-protocol interface

341

IPPROTO_IP = 0; // dummy for IP IPPROTO_TCP = 6; // tcp IPPROTO_UDP = 17; // user datagram protocol IPPROTO_RAW = 255; // raw IP packet INVALID_SOCKET = TSocket(NOT(0)); SOCKET_ERROR = -1; var Form1: TForm1; implementation // Import Winsock 2 functions const WinSocket = 'WS2_32.DLL'; function closesocket; external winsocket name 'closesocket'; function socket; external winsocket name 'socket'; function sendto; external winsocket name 'sendto'; function setsockopt; external winsocket name 'setsockopt'; function inet_addr; external winsocket name 'inet_addr'; function htons; external winsocket name 'htons'; function WSAGetLastError; external winsocket name 'WSAGetLastError'; function WSAStartup; external winsocket name 'WSAStartup'; function WSACleanup; external winsocket name 'WSACleanup'; {$R *.DFM} // // Function: checksum // // Description: // This function calculates the 16-bit one's complement sum // for the supplied buffer // function CheckSum(Var Buffer; Size : integer) : Word; type TWordArray = Array[0..1] of Word; var ChkSum : LongWord; i : Integer; begin ChkSum := 0; i := 0; While Size > 1 do begin ChkSum := ChkSum + TWordArray(Buffer)[i]; inc(i); Size := Size - SizeOf(Word); end; if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]); ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF); ChkSum := ChkSum + (Chksum shr 16); 342

Result := Word(ChkSum); end; procedure BuildHeaders( FromIP : String; iFromPort : Word; ToIP : String; iToPort : Word; StrMessage : String; Var Buf : TPacketBuffer; Var remote : TSockAddr; Var iTotalSize : Word ); Var dwFromIP : LongWord; dwToIP : LongWord; iIPVersion : Word; iIPSize : Word; ipHdr : T_IP_Header; udpHdr : T_UDP_Header; iUdpSize : Word; iUdpChecksumSize : Word; cksum : Word; Ptr : ^Byte; procedure IncPtr(Value : Integer); begin ptr := pointer(integer(ptr) + Value); end; begin // Convert ip address'ss dwFromIP := inet_Addr(PChar(FromIP)); dwToIP := inet_Addr(PChar(ToIP)); // Initalize the IP header // iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage); iIPVersion := 4; iIPSize := sizeof(ipHdr) div sizeof(LongWord); // // IP version goes in the high order 4 bits of ip_verlen. The // IP header length (in 32-bit words) goes in the lower 4 bits. // ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize; ipHdr.ip_tos := 0; // IP type of service ipHdr.ip_totallength := htons(iTotalSize); // Total packet len ipHdr.ip_id := 0; // Unique identifier: set to 0 343

ipHdr.ip_offset := 0; // Fragment offset field ipHdr.ip_ttl := 128; // Time to live ipHdr.ip_protocol := $11; // Protocol(UDP) ipHdr.ip_checksum := 0 ; // IP checksum ipHdr.ip_srcaddr := dwFromIP; // Source address ipHdr.ip_destaddr := dwToIP; // Destination address // // Initalize the UDP header // iUdpSize := sizeof(udpHdr) + length(strMessage); udpHdr.src_portno := htons(iFromPort) ; udpHdr.dst_portno := htons(iToPort) ; udpHdr.udp_length := htons(iUdpSize) ; udpHdr.udp_checksum := 0 ; // // Build the UDP pseudo-header for calculating the UDP checksum. // The pseudo-header consists of the 32-bit source IP address, // the 32-bit destination IP address, a zero byte, the 8-bit // IP protocol field, the 16-bit UDP length, and the UDP // header itself along with its data (padded with a 0 if // the data is odd length). // iUdpChecksumSize := 0; ptr := @buf[0]; FillChar(Buf, SizeOf(Buf), 0); Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr)); IncPtr(SizeOf(ipHdr.ip_srcaddr)); iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr); Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr)); IncPtr(SizeOf(ipHdr.ip_destaddr)); iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr); IncPtr(1); Inc(iUdpChecksumSize); Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol)); IncPtr(sizeof(ipHdr.ip_protocol)); iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol); Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length)); IncPtr(sizeof(udpHdr.udp_length)); iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length); move(udpHdr, ptr^, sizeof(udpHdr)); IncPtr(sizeof(udpHdr)); iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr); Move(StrMessage[1], ptr^, Length(strMessage)); 344

IncPtr(Length(StrMessage)); iUdpChecksumSize := iUdpChecksumSize + length(strMessage); cksum := checksum(buf, iUdpChecksumSize); udpHdr.udp_checksum := cksum; // // Now assemble the IP and UDP headers along with the data // so we can send it // FillChar(Buf, SizeOf(Buf), 0); Ptr := @Buf[0]; Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr)); Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr)); Move(StrMessage[1], ptr^, length(StrMessage)); // Apparently, this SOCKADDR_IN structure makes no difference. // Whatever we put as the destination IP addr in the IP header // is what goes. Specifying a different destination in remote // will be ignored. // remote.sin_family := AF_INET; remote.sin_port := htons(iToPort); remote.sin_addr.s_addr := dwToIP; end; procedure TForm1.SendIt; Var sh : TSocket; bOpt : Integer; ret : Integer; Buf : TPacketBuffer; Remote : TSockAddr; Local : TSockAddr; iTotalSize : Word; wsdata : TWSAdata; begin // Startup Winsock 2 ret := WSAStartup($0002, wsdata); if ret<>0 then begin memo1.lines.add('WSA Startup failed.'); exit; end; with memo1.lines do begin add('WSA Startup:'); add('Desc.: '+wsData.szDescription); add('Status: '+wsData.szSystemStatus); end; try // Create socket sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP); 345

if (sh = INVALID_SOCKET) then begin memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError)); exit; end; Memo1.lines.add('Socket Handle = '+IntToStr(sh)); // Option: Header Include bOpt := 1; ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt)); if ret = SOCKET_ERROR then begin Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError)); exit; end; // Build the packet BuildHeaders( SrcIP, SrcPort, DestIP, DestPort, 'THIS IS A TEST PACKET', Buf, Remote, iTotalSize ); // Send the packet ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote)); if ret = SOCKET_ERROR then Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError)) else Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.'); // Close socket CloseSocket(sh); finally // Close Winsock 2 WSACleanup; end; end; procedure TForm1.Button1Click(Sender: TObject); begin SendIt; end; end.

346

Carlos,

The code below shows how to read/write binary data from the system registry

{-------------------------------------------------------Shows how to read and write different data types from the registry including binary and currency types. -------------------------------------------------------} procedure TfrmMain.mnuReadWritecurrencyandbinarydata1Click( Sender: TObject); { This record is used to demo read/write operations to the registry } type TSomeData = record Top, Left, Width, Height : Integer ; Caption : WideString ; end; { Key beneath HKEY_CURRENT_USER to work with } const BaseKey = 'a_test' ; var Reg : TRegistry ; MyCurrency: Currency ; FSomeData : TSomeData ; begin if not ListBox1.Visible then ListBox1.Visible := True ; ListBox1.Clear ; { Assign a values to store into the registry } FSomeData.Top := Top ; FSomeData.Left := Left ; FSomeData.Width := Width ; FSomeData.Height := Height ; FSomeData.Caption := Caption ; MyCurrency := 1000000.90 ; { Create an object to access the system registry } Reg := TRegistry.Create ; try Reg.RootKey := HKEY_CURRENT_USER ; if not Reg.CreateKey(BaseKey) then begin ShowMessage('Failed to make it new entry for "' + BaseKey + '"'); exit ; end ; Reg.OpenKey(BaseKey,False) ; 347

{ Write our data to the registry } Reg.WriteCurrency('Currency Example',MyCurrency) ; Reg.WriteBinaryData('BinaryData Example',FSomeData,SizeOf(TSomeData)) ; { Now read back the data for currency } ListBox1.Items.Add(Format('Currency Example = %m', [Reg.ReadCurrency('Currency Example')])) ; ListBox1.Refresh ; { Nullify the record to insure we get back the data } FSomeData.Top := -1 ; FSomeData.Left := -1 ; FSomeData.Width := -1 ; FSomeData.Height := -1 ; FSomeData.Caption := '' ; { Screw a bit with the form, later we restore it with the registry data } Top := Top - 100 ; Left := Left - 100 ; Caption := 'Just demoing...' ; { Timely pause for reflection } Sleep(2000) ; { Okay let's get the data back } Reg.ReadBinaryData('BinaryData Example',FSomeData,SizeOf(TSomeData)) ; { Show the returned members retrieved from the registery } ListBox1.Items.Add('Top = ' + IntToStr(FSomeData.Top)) ; ListBox1.Items.Add('Left = ' + IntToStr(FSomeData.Left)) ; ListBox1.Items.Add('Width = ' + IntToStr(FSomeData.Width)) ; ListBox1.Items.Add('Height = ' + IntToStr(FSomeData.Height)) ; ListBox1.Items.Add('Caption = ' + FSomeData.Caption) ; ListBox1.Refresh ; { Using registry data restore the forms position } Top := FSomeData.Top ; Left := FSomeData.Left ; Caption := FSomeData.Caption ; { Close the current key } Reg.CloseKey ; { Remove it since we are done with it } Reg.DeleteKey(BaseKey) ; finally Reg.CloseKey ; Reg.Free ; end ; end; 348

EXAMPLE 2 {-------------------------------------------------------This example shows how to 1) Determine a data values type using GetDataType 2) Read a binary value with GetDataSize and ReadBinaryData. NOTE: This code makes use of dynamic arrays introduced in version 4 of Delphi. In other words, you need D4 or higher to work this code. -------------------------------------------------------} procedure TfrmMain.mnuExistingBinaryValueClick(Sender: TObject); {$IFDEF DELPHI_4_UP} const Key : String = 'Enum\Network\NWLINK\0000' ; Val : String = 'Capabilities' ; var Data : Array of Byte ; S : String ; sz : Word ; I : Word ; Reg : TRegistry ; {$ENDIF} begin {$IFDEF DELPHI_4_UP} Reg := TRegistry.Create ; with Reg do begin RootKey := HKEY_LOCAL_MACHINE ; if OpenKey(Key, False) then begin { Making assumtions that the value is here and simply checking it's data type. } if GetDataType(Val) = rdBinary then begin sz := GetDataSize(Val) ; if sz > 0 then begin SetLength(Data, sz) ; ReadBinaryData(Val, Data[0], sz) ; S := Val + ' = ' ; for I := 0 to sz - 1 do begin S := S + Format('%2x',[Data[I]]) ; end; ShowMessage(Key + #92 + S) ; end ; end ; end else ErrorMsg('HKEY_LOCAL_MACHINE\' + Key + ' not found') ; Free ; end ; {$ELSE} ErrorMsg('This code requires Delphi 4 or higher to execute') ; {$ENDIF} end; 349

EXAMPLE 3 {-------------------------------------------------------This function reads a binary value from the registry and returns this value as a TDateTime. --------------------------------------------------------} function GetWinFirstInstallDateTime:TDateTime ; var i : LongInt ; begin Result := Now ; with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE ; if OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion', False) then try ReadBinaryData('FirstInstallDateTime',i, SizeOf(i)) ; Result := FileDateToDateTime(i) ; finally CloseKey ; end else Exception.Create('FirstInstallDateTime failed') ; finally Free ; end ; end; EXAMPLE 4 unit WinInformation; interface uses Windows,Registry,SysUtils ; type TMyWindowsSettings = Record ProductKey:String ; ProdcutID:String ; ProductName:String ; FirstInstallDate:TDateTime ; end ; function kg_GetWinInfo:TMyWindowsSettings ; implementation function kg_GetWinInfo:TMyWindowsSettings ; var I: Integer ; begin with TRegistry.Create do try 350

RootKey := HKEY_LOCAL_MACHINE ; if OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion', False) then try ReadBinaryData('FirstInstallDateTime',i, SizeOf(i)) ; Result.FirstInstallDate := FileDateToDateTime(i) ; Result.ProductKey := ReadString('ProductKey') ; Result.ProdcutID := ReadString('ProductID') ; Result.ProductName := ReadString('ProductName') ; finally CloseKey ; end else Exception.Create('failed to get Windows information') ; finally Free ; end ; end; end.

351

!************************************** ! for :Stealth !************************************** If you Like it then vote. If you dont like it then tell me how to make it better! !************************************** ! Name: Stealth

! Description:Hide your porgams in the task manager, and from process lists. No one will ever know its there!

! By: Dave Bayliss ! ! ! Inputs:None ! ! Returns:None ! !Assumes:This control does not work under Windows 2000 as the tasking is different, I use it on win 95, 98, ME systems and it works great! ! !Side Effects:None !This code is copyrighted and has limited warranties. !Please see http://www.Planet-SourceCode.com/xq/ASP/txtCodeId.420/lngWId.7/qx/vb/scripts/ShowCode.htm !for details. !************************************** {Created By David Bayliss http://www.dbayliss.com} unit Stealth; interface uses WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages; type TDuplicateComponent = class(Exception); TFormNotOwner = class(Exception); TStealth = class(TComponent) private FHideForm: Boolean; fHideApp: Boolean; OldWndProc: TFarProc; NewWndProc: Pointer; function IsIt: Boolean; procedure SetIt (Value: Boolean); procedure SetHideApp(Value: Boolean); procedure HookParent; procedure UnhookParent; procedure HookWndProc(var Message: TMessage); protected { Protected declarations } procedure HideApplication; procedure ShowApplication; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; 352

procedure Loaded; override; procedure ProcessEnabled; published { Published declarations } property HideForm: Boolean read IsIt write SetIt stored true default true; property HideApp: Boolean read fHideApp write SetHideApp; end; function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; procedure Register; implementation destructor TStealth.Destroy; begin ShowApplication; UnhookParent; inherited destroy; end; constructor TStealth.Create(AOwner: TComponent); var i: Word; CompCount: Byte; begin inherited Create(AOwner); fHideform := true; NewWndProc := nil; OldWndProc := nil; CompCount := 0; if (csDesigning in ComponentState) then if (AOwner is TForm) then with (AOwner as TForm) do begin for i := 0 to ComponentCount - 1 do if Components[i] is TStealth then Inc(CompCount); if CompCount > 1 then raise TDuplicateComponent.Create('There is already a TStealth component on this Form'); end else raise TFormNotOwner.Create('The owner of TStealth Component is not a TForm'); HookParent; end; procedure TStealth.SetHideApp(Value: Boolean); begin fHideApp := Value; if Value then HideApplication else ShowApplication; end; procedure TStealth.HideApplication; begin if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 1); end; procedure TStealth.ShowApplication; begin 353

if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 0); end; procedure TStealth.Loaded; begin inherited Loaded; { Always call inherited Loaded method } if not (csDesigning in ComponentState) then ProcessEnabled; end; procedure TStealth.ProcessEnabled; begin if not (csDesigning in ComponentState) then if fHideform then ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE) else ShowWindow(FindWindow(nil, @Application.Title[1]), SW_RESTORE); end; function TStealth.IsIt: Boolean; begin Result := fHideform; end; procedure TStealth.SetIt(Value: Boolean); begin fHideform := value; ProcessEnabled; end; procedure TStealth.HookParent; begin if owner = nil then exit; OldWndProc := TFarProc(GetWindowLong((owner as TForm).Handle, GWL_WNDPROC)); NewWndProc := MakeObjectInstance(HookWndProc); SetWindowLong((owner as TForm).Handle, GWL_WNDPROC, LongInt(NewWndProc)); end; procedure TStealth.UnhookParent; begin if (owner <> NIL) and Assigned(OldWndProc) then SetWindowLong((owner as TForm).Handle, GWL_WNDPROC, LongInt(OldWndProc)); if Assigned(NewWndProc) then FreeObjectInstance(NewWndProc); NewWndProc := NIL; OldWndProc := NIL; end; procedure Register; begin RegisterComponents('Dbayliss', [TStealth]); end; procedure TStealth.HookWndProc(var Message: TMessage); begin if owner = NIL then exit; if (Message.Msg = WM_SHOWWINDOW) then if (Message.wParam <> 0) then ProcessEnabled; Message.Result := CallWindowProc(OldWndProc, (owner as TForm).Handle, Message.Msg, Message.wParam, Message.lParam); end; 354

end.

355

ISAPI/CGI Tabanlı Web Uygulamaları

0

30 Oca 2001 00:00 Eklendi

Bu konu aslinda bir seferde anlatilacak kadar basit degil. Ama 5000 karakteri gecmeden dilimin dondugu kadar anlatmaya calisacagim.Bolumleri takip etmenizi tavsiye ederim. Konuyu anlatirken sizin en azindan ortalama bir bilgiye sahip delphi kullanicisi oldugunuzu varsayiyorum. Zamani geldiginde anlattiklarimi ornekleyecegim. CGI/ISAPI'YE GIRIS : Aranizda bir cogunuz HTML sayfasi hazirlamissinizdir yada bunun nasil bir sey oldugunu en azindan burada goruyorsunuz. Web HTML) sayfalari aslinda duragan yani statik sayfalardir. Bu sayfalara dinanizm katmanin pek cok yolu bulunmaktadir. Biz delphi programcisi oldugumuzu gore bu dinanizmi web sayfalarina nasil katabiliriz. Soruya verebilecegimiz 4 cevap bulunmaktadir. Bunlar ASP (Active Server Page), ISAPI (INTERNET SERVER APPLICATION PROGRAMING INTERFACE), CGI (COMMON GATEWAY INTERFACE) uygulamalaridir. ISAPI/CGI VE DIGER DELPHI UYGULAMALARI ARASINDAKI ARASINDAKI FARK NEDIR? ISAPI bir DLL uygulamasidir. CGI ise bir konsol (Windows icin konusursak penceresi olmayan ciktisini bir tarayiciya ornegin IE. yonlendiren) bir EXE uygulamasidir. Delphinin diger uygulama standartlari ile bu iki tur uygulamayi birbirinden ayiran yegane fark, tum delphi uygulamalarinda kullanici bir windows OS penceresi uzerindeki denetimler ile calisirken, ISAPI ve CGI uygulamalarinda HTML uzerindeki denetimlerle calisilmasidir. ISAPI DLL olmasindan oturu calistirildiginda ozel olarak serbest birakilmadigi surece bellege bir kez yuklenir ve her sefer cagrilisinda ayni bellek adresinden kosar. CGI ise bir exe olmasindan dolayi her cagrilisinda bellege yeniden yuklenir ve isi bitince ISAPI nin aksine sonlanir. Tahmin edebileceginiz gibi ISAPI CGI uygulamalarina nazaran cok daha hizli calisir, ancak herhangi bir istisna (EXCEPT) ciktiginda calistigi ana bilgisayari dolayisiyla tum sistemi cokertebilir. CGI icin bu konuda soylenecek bir sey kalmiyor sanirim. PEKI BIR ISAPI/CGI UYGULAMASI NASIL YAZILIR. Buda ikinci bolumun konusu.Siteyi izlemeye devam edin lutfen.

ISAPI/CGI Tabanlı Web Uygulamaları [2]

0

30 Oca 2001 00:00 Eklendi

ISAPI/CGI UYGULAMALARI NASIL YAZILIR: ISAPI VE CGI araasindaki farki ogrendigimize gore bu tur uygulamalarin nasil yazilacagi konusuna bir giris yapabiliriz. Asagidaki islem basamaklarini sirasiyla izleyin. (Uzgunum ama burdan pencerelerin resmini yayimlayamiyorum :-) ) 1- Delphi ana menuden New secin. 2- New Items penceresinin en altinda bulunan Web server application item'i secin 3- Karsiniza gelecek pencerede 3 adet secenek var. 1 ve ikiyi 1.bolumde anlattim 3 ncu secenek CGI uygulamalarinin veri iletimi icin Windows Ini sistemine benzer bir sistemi kullaniyor. Bu su an cok onemli degil. NOT : ISAPI ve CGI uygulamalarinin genel yapisi ve kullandiklari bilesenler aynidir. Daha sonrada 356

NOT : ISAPI ve CGI uygulamalarinin genel yapisi ve kullandiklari bilesenler aynidir. Daha sonrada gorecegimiz gibi bir ISAPI uygulamasini proje kaynak dosyasindaki Bir kac satiri silip library ifadesi yerine program yazarak veya tersini yaparak bir turden digerine gecebiliriz. 4- ISAPI ile baslamanizi tavsiye ederim. Iste karsinizda bir WEBMODULE ve buna ait unit. WebModule icin help'e giderseniz TDataModule sinifindan tureyen bir nesne oldugunu gorursunuz. Sanirim en azindan bir programinizda DataModule kullanmissinizdir. Iste tipki datamodule nesnesinde oldugu gibi WEBMODULE nesneside TDataset (TQuery, TDataBase,TTable vs.) bilesenlerine konteynirlik gorevini ustlenmektedir. Ama DataModuleden farkli olarak HTML sayfalari ile iletisim kurabilen cok onemli bir ozelligi bulunmaktadir. (Aslinda bir DataModule uzerine bir WebDispatcher:TWebDispatcher bileseni koyarsaniz Datamodule nesnenizi Webmodule olarak kullanabilirsiniz). Bir Webmodule'un en onemli ozelligi uzerine cift tikladiginizda veya sag tiklayarak actiginizda acilan WebActionItem.Editor ile duzenleyebildiginiz Action lardir. WebActionItem lar 3 ncu bolumun konusudur. Bir webmodule HTML ile ilgili iki islem yapar. 1- Talepleri almak (Request:TWebRequest) 2- Talepleri HTML'ye gondermek (Response : TWebResponse) Yeri gelince bu iki islemin nasil yapilacagini anlatacagim. Ancak HTML konusunda bilmeniz gereken bir kac noktaya burada deginmek istiyorum. Bunlar ; 1- HTML dosyalari Statiktir 2- HTML dosyalari tarayiciya yuklenirken ilk satirdaki Taglardan baslayip, satir satir tarama yapilarak sayfa yuklenir 3- Bir HTML'nin bir ISAPI/CGI uygulamasina talep/data gondermesi icin FORM tagi kullanilir.

NOT : HTML taglarinin nasil yazildigi konusunda bilginiz oldugunu varsayiyorum. Aksi takdirde bana e-posta atin Web dersleriyle ilgili bir kac dosya gondereyim. Yukaridaki ornekte bir web sayfasi icine adi bilgial.DLL olan ve tam yol ismi (Adresi) verilen ISAPI uygulamasina adi ve soyadi alanlarinin degerleri gonderilmektedir. NOT : Bilmeyenler icin; HTML'de veri gonderirken en cok kullanilan iki method vardir. POST ve GET yontemleri. POST methodunu kullandiginizda veri boyu bilgisayarinizin kapasitesi ile dogru orantilidir, gonderdiginiz bilgide kullanici tarafindan gorulmez. GET yontemi ile veri gondermek post methoduna gore oldukca hizlidir, ancak gonderebileceginiz max. veri yanlis hatirliyorsam duzeltin 250 karakter (Byte hesabini size birakiyorum) dir ve gonderilen veri tarayicinizin adres alaninda kullanici tarfindan gorulebilir. (Ben daha cok Post methodunu tercih ediyorum.) Tabii ki Delphiden gonderilen bilgiye erismek icin POST ve GET yontemlerinden kullanilan methoda uygun Delphi yontemini kullanmaniz gerekmektedir. FORM taginin kullanilmasina gelecek bolumlerde PATHINFO ozelliginden bahsederken tekrar deginecegim. Bir sonraki bolumde (3 ncu bolum) WebActionItem kullanimini, ve HTML uzerinden gelen verileri nasil alabilecegimizi, tarayiciya verileri nasil gonderebilecegimizi anlatacagim. 357

gelen verileri nasil alabilecegimizi, tarayiciya verileri nasil gonderebilecegimizi anlatacagim. Webmaster dan ricam makaleler bolumunde 5000 karakter sinirini cikarabilecegi maximum seviyeye cikarmasi ve mumkunse makaleler icinde Hit gostergesi koymasidir. 3 ncu bolumde gorusmek uzere hepinizi kolay gelsin.... ISAPI/CGI Tabanlı Web Uygulamaları [3]

0

23 Mar 2001 00:00 Eklendi

Bir html sayfasi ile bir isapi/cgi uygulamasinin etkilesimde bulunabilmesi icin
html taginin kullanildigini onceki bolumde anlatmistim. Hatirlatmak acisindan ; DELPHI ISAPI-CGI UYGULAMALARI Adiniz : Soyadiniz :
Yukardaki satilari aciklamadan once izin verirseniz uygulama tarafina donup, burda yaptigimiz islemleri anlatmak istiyorum. Bir Webmodule:TWebModule nesnesinin en onemli ozelliginin WebActionItem:TWebActionItem ozelligi oldugunu daha once belirtmistim. TObject-->TPersistent-->TCollectionItem-->TWebActionItem Bir WebActionItem olusturmak icin ya webmodule uzerinde cift tiklayarak yada kisayol menusu ile (mouse sag tusa tiklayip) Action Editor penceresini acin ve Add secenegini kullanin. Bir webmodule bir yada daha fazla sayida WebActionItem ekleyebilir ve bunlarin ozellik ve OnAction olayini object inspector ile ayarlayabilirsiniz. Iste bu ozelliklerden onemli olanlarin ve tek olayin (ONACTION) detaylari ; Ozellik/Olay Aciklama -----------------------------------------------------------Default ilgili WebActionItem in bir pathinfo kullanilmadan HTML sayfalarindan gelen/gonderilen talep veya degerlerin varsayilan yanitlama olayi olarak ayarlanmasi. Yukaridaki ornekte bir pathinfo belirtilmemistir.Dolayisiyla Webmodule default ozelligi true olan WebActionItem'in onAction olayi ile talebe tepki verecektir. -----------------------------------------------------------Methodtype HTML uzerinden gonderilen veri/talebin gonderilme bicimi. Varsayilan degeri mtAny. Bir html sayfasi form tagi ile isapi/cgi uygulamaya deger gonderirken 4 yontemden birini kullanir. Bunlardan en cok kullanilan GET ve POST yontemlerini onceki bolumlerde anlattim ama yeri gelince tekrar deginecegim. ------------------------------------------------------------ Pathinfo Yukarida belirttigim gibi bir Webmodule ait birden fazla WebActionItem olabilir. Eger birden fazla WebActionItem kullanirsaniz, html sayfalarin-dan bu WebActionItem lara ulasmak icin spesifik birer isim vermeniz ve Form tagina bunu eklemeniz gerekir.
Adiniz : Soyadiniz :
358

------------------------------------------------------------Producer Herhangi WebActionItem'a bir Pageproducer veya bunun turevlerini atamak icin kullanilir. Bir WebActionItem bir producer atarsaniz talebin yanitlan-masi ile ilgili sonuc ciktisi bu producer ile gosterdiginiz kaynak tarafindan yapilir. Simdilik kafanizin karismamasi icin bu konunun detaylarina girmiyorum. ------------------------------------------------------------OnAction (Olay) Bir html sayfasi ile etkilesim kuran webmodule bunu WebActionItem OnAction olayi ile degerlendirir.Degerlendirmeden kastim, gelen talebi alir, yazdiginiz kod dogrultusunda isler (Bir veri tabani kayit islemi yapmak gibi), ve yine bu olaydaki kodlar dogrultusunda uretilen html ciktisini talebi gonderen bilgisayarin Webbrowserina geri gonderir. Tum bu bilgiler isiginda bir html sayfasi ile bir isapi/cgi uygulamasi arasindaki trafigi asagidaki bicimde ozetleyebiliriz. HTML SAYFASI : Form tagini kullanarak uygulamadan (isapi/cgi) talepte bulunur. (Bu talep herhangi bir sey olabilir. Ornegin delphiturk bir isapi/cgi tabanli bir site olsaydi Componentler bolumunde internet componentlerinin ilgili veritabani icindeki tum componentler arasinda suzulerek/filitrelenerek listelenmesi istenebilirdi.)
Component Turu :
ISAPI/CGI uygulamasi : Html sayfasindan gelen/gonderilen talep/veriyi kabul eder. OnAction olayi ile isler ve istenirse geriye talep veya isleminv sonuclarini dondurur. Talebi kabul ederken Form taginda gosterilen Form Action="http://www.delphiturk.com/login/bilgial.DLL/componentsuz" satirinda gosterilen pathinfo yu dikkate alir. (Örnekte pathinfo=componentsuz) Bu Pathinfoya ait WebActionItemin ONAction olayinda yazilan kodlar isletilir. OnAction olayi ile ilgili ayrintili bilgiyi konunun biraz daha derinlemesine girerek ileriki bolumde anlatacagim. Bizden ayrilmayin.

359

Programcilikta, hepimizin önem verdigi seylerden biri de ticari amaclarla yazdigimiz programlarin bir bilgisayardan digerine cekilmesini engellemektir. Bunun icin sayisiz yol vardir. Bunlardan biride eger Windows tabanli calisiyorsaniz sudur: Sistem.Dbf diye bir Database dosyasini programin installationinda yaratin ve bu Sistem.dbf dosyasina programin kuruldugu bilgisayarin Biosunun Seri Numarasi, Tarihi, Modeli gibi bilgileri kaydedin. Daha sonra program her calistiginda o anki biosun seri numarasiyla Sistem.Dbf'teki Biosun seri numarasini karsilastirsin, tutmazsa programin calistigi bilgisayar degismis demektir. Sistem.Dbf dosyasini sifreli table yapmaniz daha saglikli olacatir. Biosun üretim tarihi ve Biosla ilgili diger bilgileri su sekilde elde edebilirsiniz: unit biosbilgi; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Registry, StdCtrls; const DBRoot = HKEY_LOCAL_MACHINE; type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; Label2: TLabel; Label3: TLabel; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; BRegistry: TRegistry; Biosdate:string; Biosname:string; Biosver:string; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin BRegistry := TRegistry.Create; BRegistry.RootKey := DBRoot; BRegistry.LazyWrite := false; BRegistry.OpenKey('Enum\Root\*PNP0C01\0000', False); BiosDate := BRegistry.ReadString('BIOSDate'); BiosName := BRegistry.ReadString('BIOSName'); BiosVer := BRegistry.ReadString('BIOSVersion'); BRegistry.CloseKey; Label1.Caption:=BiosDate; Label2.Caption:=BiosName; Label3.Caption:=Biosver; end; 360

end.

361

Delphi formlarini Web sayfasinda yayinlama

0

12 Eyl 2000 00:00 Eklendi

Delphi Microsoft Activex teknolojisini kendi yarattiginiz formlar üzerinde kullanmaniza , kendi formlarinizi Activex nesneleri haline getirmenize olanak tanir. bir Activex formu olusturmak; oldukca kolay bir kac islemi gerektirir. bu formlarin farkli bir özelligi, olusturdugunuz formu otomatik olarak Ocx tabanli bir component te cevirebilir ve diger gelistirme ortamlari veya makro dillerinden cagirabilirsiniz. yapmak istedigim ornek bir Activex Formu yaratmak ve bu formu hem component haline getirmek ( Ocx seklinde ) hemde Web sayfasinda yayinlamak. iste adim adim bir Activex formunun olusturulmasi : 1- kendinize uygulamanizi ve dosyalarinizi kayit edeceginiz bos bir dizin olusturun 2- Delphi de ki acik tüm projeleri kapatin File/Close all 3- File -New sayfasindan Activex sekmesinde ActiveForm simgesine tiklayin 4- karsiniza gelen ActiveForm Wizard ekraninda olusturmak istediginiz projeye bir isim verin ( Name adi verirken bosluk birakmayin ) 5- Ok butonuna tikladigizda Delphi sizin icin otomatik olarak bos bir Delphi Formu olusturur. Bu formun diger Delphi formlarindan farkli, bir kac ozelligi vardir. formun unit kisminda oldukca uzun bir kod vardir; bu kadar uzun olmasi ( bos bir form icin yaklasik 350 satir) aslinda bu teknolojinin ne kadar siradan ve hantal oldugunu gosterir. 6 - olusturdugunuz delphi projesi Delphi ye ozel bir Dll dir. ( Delphi icesinden dll mantiginda calisan ama uzantisi Dll olmayan dosyalar vardir Ornegin Package (paket) component dosyalari ) 7 - Delphi olusturulan bu formun bütün harici ifadelerini kendisi otomatik olarak doldurur; ben bu formun uzerine tiklandigi zaman ekrana bir mesaj gosteren buton ekledim 8 - Programi kayit edit bir kez derlediginiz zaman varsayilan dizinde ( ActiveFormProj1.ocx ) adinda bir dosya olusturur. (ben proje ismini degistirmedim ) 9- sira geldi bu formun Web sayfasina cevrilmesine iste siradaki adimlar 10 - Project - Web Deployment Options menusunden acilan ekrandan Target dir secenegine Formunuzu web sayfasi olarak kayit edeceginiz dizini secin 11- Target url ve Html dir seceneklerine de ayni yolu yazmaniz gerekir ( sadece birer nokta koymaniz yeterli tekrar yazmaniza gerek yok ) 12 - Use Cap file Compression secenegi bu formun Cab dosyasi olarak web de tasinabilmesi icin ben bos biraktim 13 - Ok dugmesine basarak bu ekrani kapatin 14 - Project - Web Deploy menusune tiklayarak Html dosyasini olusturun hepsi bu kadar artik kayit ettiginiz dizinde ilgili Htm sayfasini acabilirsiniz. ( Active formlar yalnizca windows veya Activex i destekleyen islemtim sistemlerinde acilir Linux veya degisik türevlerinde bu sayfalari acamassiniz ) ayni dizinde bir de Ocx dosyasi var bunu Delphi den yuklemek icin Component - import activex control seceneklerini girebilirsiniz acilan ekrandan 362

Component - import activex control seceneklerini girebilirsiniz acilan ekrandan Add dugmesine tiklayin ve Ocx dosyasini yukleyin Artik Delphi formunuz bir component. hepinize kolay gelsin...

363

Delphi & Object Inheritance

0


Delphi tam anlamiyla OOP teknigini maksimum seviyede kullanmanizi saglayan bir dildir. Class tanimi yaparken ekleyecegimiz kucuk bir ayrinti yeni yarattigimiz class'in base class'tan turemesini saglayacak. Ornegin: ******************************** TFigure = class private X, Y: Integer; protected procedure Draw; virtual; public constructor Create(InitX, InitY: Integer); procedure Show; end; procedure TFigure.Draw; begin // kod yok cunku TFigure seklin ne oldugunu bilmiyor end; procedure TFigure.Show; begin Draw; end; constructor TFigure.Create(InitX, InitY: Integer); begin X := InitX; Y := InitY; end; ******************************** ******************************** TRectangle = class(TFigure) protected procedure Draw; override; end; procedure TRectangle.Draw; begin // ekrana cizme islemi end; ******************************** var AFigure: TFigure; UserResponse: Integer; begin GetUserResponse(UserResponse); case userResponse of 364

case userResponse of urRectangle: AFigure := TRectangle.Create(10, 10); urCircle: AFigure := TCircle.Create(5, 7); ... ... end; AFigure.Show; end; Yukardaki kodu incelediginizde her bir figür icin ortak ozellikte olanlarin TFigure, her bir figuru farklilastiran ozelliklerin ise o figure ait nesneye eklendigini goreceksiniz. Ornegin her figur icin X, Y ortaktir ancak daire icin ayni zamanda yaricap, dikdortgen icin boy ve en gibi ozellikler gereklidir. Ikinci bolum ise cok daha ilginc. Burda dikkat etmenizi istedigim konu kullanicidan alinan bilgiye gore AFigure nesnesinin olusturulmasi, daha acik anlatimiyla compile zamaninda AFigure nesnesinin ne oldugunun bilinmemesi, Rintime'da belli olmasi. Ikinci bolumde ise suna dikkat edin. AFigure.Show sadece TFigure Class'inin bir metodu ancak programda eger AFigure nesnesi dikdortgen olarak olusturulduysa ekrana dikdortgen, daire olarak olusturulduysa daire cizmeli. Burda anahtar kelime virtual ve override. TFigure class'inda Draw virtual (sanal) bir metoddur. Eger kendisini base class olarak alan ve o metodu override eden bir class turetilmis ise artik bir anlamda base class'da tanimlanan virtual metod gorunmez olur, yeni yazilan yeni metodla replace edilir. Onceki virtual metodu yeni yazilan virtual metod icinde kullanmak icin "inherited Draw" demeniz yeterli. Bu durumda cagrilacak olan base class'in Draw metodudur. Virtual ve override Object Inheritance kavraminda onemli bir yer tutar. Bu kullanimda esas amacimiz base class'da tanimlanmis olan metodu kullanabilmek ve ona baska ozellikler ekleyebilmek. Virtual yaninda abstract metodlar da tanimlayabiliriz. Virtual ile Abstract arasindaki fark, virtual metodlar override edilmek zorunda degildir, Abstract metodlari ise override etme zorunlulugu vardir.

365

Wave dosyasi nasil calinir, nasil Exe icine gomulur ?

0

26 Eki 2000 00:00 Eklendi

Merhaba, Bir cok program kucuk wave dosyalarini dagitmaktansa dogrudan programin icinden calmaktadir. Bu islemi Delphi'den yapmak icin: 1. Project|Resources komutu verin. 2. Gelen pencerede sag tiklayip New|User Data komutu verin. 3. Resource Type olarak "WAVE" girin. 4. Istediginiz wav uzantili dosyayi secin. 5. Delphi varsayilan olarak WAVE_1 ismini verecektir. Bunu herhangi bir sayiyla degistirin. (Uzerinde sag tiklaip ReName komutu vererek) Örnegin: 1 Asagida benim kullandigim procedure'lari veriyorum: ************************************* function PlayWavFromResource(ResID: Integer): Boolean; begin Result := PlaySound(PChar('#' + IntToStr(ResID)), HInstance, SND_RESOURCE or SND_ASYNC); end; function PlayWavFile(const FileName: string): Boolean; begin Result := PlaySound(PChar(FileName), 0, SND_ASYNC); end; procedure StopWav; var buffer: array[0..2] of char; begin buffer[0] := #0; PlaySound(Buffer, 0, SND_PURGE); end; ************************************* PlayWavFromResource procedure'i programin icerisinde gomulu olan wave dosyasini calacaktir. Parametre olark gonderdiginiz deger yukarda ismini degistirdiginiz (WAVE_1 -> 1) degerdir. Ornegin: ************************************* procedure TForm1.Button1Click(Sender: TObject); begin StopWav; PlayWavFromResource(1); end; ************************************* Notlar: - Resource Type olarak sadece WAVE girmeniz gereklidir. - Cok buyuk Wave dosyalarini exe'nin icine gommek yerine ayri dosya olarak dagitin. Disardaki bir wave dosyasini calmak icin PlayWavFile isimli procedure'i kullanabilirsiniz. - StopWav isimli procedure o anda sistemde calinan bir ses dosyasi varsa calmayi durduracaktir. 366

- StopWav isimli procedure o anda sistemde calinan bir ses dosyasi varsa calmayi durduracaktir. - PlayWavFromResource ve PlayWavFile isimli procedure'lar calma islemini arka planda yapacaktir. Yani programiniz ses dosyasi calarken calismaya devam edebilir. Kolay gelsin.

367

Delphi Formlari 2

0


File / New form veya File / New ve gelen ekrandan New sekmesinde Form komutunu verdiginiz takdirde Delphi sizin icin otomatik bir form olusturur; bir form ayni zamanda bir kac dosyaninda birlikte olusturulmasini da saglar Unit1.pas yaratilan formun kod dosyasi , Unit1.dfm yine ayni formun metinsel tanimlarini icerisinde bulundurur ve buna herhangi bir metin editörü veya form üzerinde sag tusa basip View as Text seceneðine tiklayarak görebilirsiniz. Delphi icerisinden yeni olusturulan her form project / Options kisminda Forms sekmesinde yer alir. eger bir formu projeden iptal ederseniz. bu penceredeki listede göremessiniz. ayni zamanda bu ekranda formlarin yaratilma sirasini da görülebilir. eger Auto -Create listesinde ki bir formu > tusuna basarak Available form kismina alirsaniz. bu form baslangicta otomatik olarak olusturulmaz ve Project source kismindan silinir. calisma aninda yeni bir form yaratmak oldukca basittir. birazcik deneyim ile tüm formlarinizi calisma aninda yaratabilirsiniz. iste size bir örnek. ben formun adinin myform oldugunu ve Project - options - forms sayfasinda, formun ( Available form ) kismina alindigini varsayiyorum. baska bir formdan bu formu cagirmak icin procedure Tform1.button1click(sender : Tobject); Begin if MyForm= nil then MyForm := TMyform.Create(Application); MyForm.ShowModal ; Myform.Free ; MyForm := nil ; end; yukaridaki birkac satirda bir önceden tanimli bir formu yeniden yarattim, daha sonra onu Showmodal fonksiyonu ile ekrana getirdim isim bittikten sonra Free komutu ile yok ettim ve nil ederek hafizadan tamamen attim. Delphi formlari 4

0


Delphi de formlarin ekranin hangi koordinatta cikacagini belirlemek her ne kadar kolay görünse de biraz karisik olabilir cünkü, örnegin ekranin sag üst kösenini bulmak cok kolaydýr formun left ve top özelliklerini 0 verirsiniz halledersiniz. fakat tam tersi posizyonu düsünün. formlarinizin farkli ekran cözünürliklerinde farkli acilarda cikmasini engellemek istiyorsaniz veya formunuzun ekranin belirli bir bölümünde cikmasini istiyorsaniz iste size bir örnek procedure TForm1.FormShow(Sender: TObject); begin Left := GetSystemMetrics(SM_CXFullScreen)-Width-2; Top := GetSystemMetrics(SM_CYMaximized)-Height-10; end; yukaridaki kodu formunuzun OnShow olayina yazin GetSystemMetrics windows api si system konfigirasyonuna ait ayarlari kontrol eder. forms unitinde 368

GetSystemMetrics windows api si system konfigirasyonuna ait ayarlari kontrol eder. forms unitinde bu fonksiyonun kullanimi hakkinda daha genis örnek görebilirsiniz.

369

implementation function RegisterserviceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external 'KERNEL32.DLL'; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin // sakla RegisterserviceProcess(GetCurrentProcessID,1); end; procedure TForm1.Button2Click(Sender: TObject); begin // tekrar göster RegisterserviceProcess(GetCurrentProcessID,0); end;

370

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,shellapi, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; ListBox1: TListBox; Button3: TButton; Button4: TButton; Button5: TButton; mcd: TPanel; Timer1: TTimer; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Button4Click(Sender: TObject); procedure Button5Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} {1--------------BURDAN BAŞLAYIP----------------------------------------------------------------------------} function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external 'KERNEL32.DLL' procedure TForm1.Button1Click(Sender: TObject); begin RegisterServiceProcess(GetCurrentProcessID,1); end; procedure TForm1.Button2Click(Sender: TObject); begin RegisterServiceProcess(GetCurrentProcessID,0); end; {1-----------------BURADA BİTER---------------------------------------------------------------------} //Tüm gizli ve görünür uygulamalary listele {2--------------BURDAN BAŞLAYIP----------------------------------------------------------------------------} function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean; Export; {$ifdef Win32} StdCall; {$endif} var Buffer : Array[0..99] of char; begin GetWindowText(Wnd,Buffer,100); if StrLen(Buffer) <> 0 then Form1.ListBox1.Items.Add(StrPas(Buffer));

371

Result := True; end; procedure TForm1.Button3Click(Sender: TObject); begin listbox1.Clear; //Tüm gizli ve görünür uygulamalary listele EnumWindows(@EnumWindowsProc,LongInt(Self)); end; {2--------------BURDAN BAŞLAYIP----------------------------------------------------------------------------} {3--------------BURDAN BAŞLAYIP----------------------------------------------------------------------------} procedure TForm1.Button4Click(Sender: TObject); begin //DESKTOPDAKİ İCONLARI GİZLE ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE); end; procedure TForm1.Button5Click(Sender: TObject); begin //DESKTOPDAKİ İCONLARI GÖSTER ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW); end;

procedure TForm1.Timer1Timer(Sender: TObject); var Muda : Boolean; begin {RENKLİLİK OLUR DİYE PANELLİ RENKLENDİRDİM )} With mcd do begin Muda := Color = clWhite; if muda then begin Font.Color := clWhite; Color := clOlive; end else begin Font.Color := clBlack; Color := clWhite; end; end; end; {3--------------BURDAN BAŞLAYIP----------------------------------------------------------------------------} {4-----------------BURADAN BAŞLAR------------------------------------------------------------------} procedure TForm1.FormCreate(Sender: TObject); begin //BU KOD İLE PROGRAM TASKBARDAN SAKLANIR SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); showmessage('BU PROGRAM CTR+ALT+DEL TUŞLARINA BASINCA PROGRAMI GÖSTERMEME '#13'DESKTOPDAKİ ICONLARI SAKLAMA'#13'TÜM ÇALIŞAN GİZLİ DOSYALARI GÖSTERME'#13'PROGRAMI TASKBARDA SAKLAMA') 372

end; {SON-----------------------------BURADA BİTER-------------------------------------------------------------} end.

373

Try the following: function TForm1.PortIn(IOport:word):byte; assembler; asm mov dx,ax in al,dx end; function TForm1.PortInW(IOport:word):word; assembler; asm mov dx,ax in ax,dx end; procedure TForm1.PortOutW(IOport:word; Value:word); assembler; asm xchg ax,dx out dx,ax end; procedure TForm1.PortOut(IOport:word; Value:byte); assembler; asm xchg ax,dx out dx,al end;

PortOut(888, 128); 888 is port address in decimal and 128 is data, or X := PortIn(889) Let me know if it helps or you need more info

374

how to hide the internet connection status from system tray uses shellapi; procedure tform1.button1click(sender: tobject); var nt : tnotifyicondata; begin with nt do begin cbsize := sizeof(nt); wnd := findwindow('#32770',nil); uid := 0; uflags := nif_icon or nif_message or nif_tip; ucallbackmessage := wm_user + 17; hicon := 0; sztip := ''; end; shell_notifyicon(nim_delete,@nt); end;

from www.swissdelphicenter.ch developers knowledge base { -thierry bodin http://www.ephemeride.com

375

tip title - control capslock, scrolllock, numlock {this code will allow you to control caps lock, scroll lock, and num} procedure tform1.button2click(sender: tobject); var keystate: tkeyboardstate; begin getkeyboardstate(keystate); if (keystate[vk_numlock] = 0) then keystate[vk_numlock] := 1 else keystate[vk_numlock] := 0; if (keystate[vk_scroll] = 0) then keystate[vk_scroll] := 1 else keystate[vk_scroll] := 0; if (keystate[vk_capital] = 0) then keystate[vk_capital] := 1 else keystate[vk_capital] := 0; setkeyboardstate(keystate); end;

376

Tip Title - Converting Windows Messages to strings FUNCTION MSGTOSTR( WM : WORD ) : STRING; BEGIN CASE WM OF WM_ACTIVATE : RESULT:= 'WM_ACTIVATE '; WM_ACTIVATEAPP : RESULT:= 'WM_ACTIVATEAPP '; WM_ASKCBFORMATNAME : RESULT:= 'WM_ASKCBFORMATNAME '; WM_CANCELMODE : RESULT:= 'WM_CANCELMODE '; WM_CHANGECBCHAIN : RESULT:= 'WM_CHANGECBCHAIN '; WM_CHAR : RESULT:= 'WM_CHAR '; WM_CHARTOITEM : RESULT:= 'WM_CHARTOITEM '; WM_CHILDACTIVATE : RESULT:= 'WM_CHILDACTIVATE '; WM_CLEAR : RESULT:= 'WM_CLEAR '; WM_CLOSE : RESULT:= 'WM_CLOSE '; WM_COMMAND : RESULT:= 'WM_COMMAND '; WM_COMMNOTIFY : RESULT:= 'WM_COMMNOTIFY '; WM_COMPACTING : RESULT:= 'WM_COMPACTING '; WM_COMPAREITEM : RESULT:= 'WM_COMPAREITEM '; WM_COPY : RESULT:= 'WM_COPY '; WM_CREATE : RESULT:= 'WM_CREATE '; WM_CTLCOLOR : RESULT:= 'WM_CTLCOLOR '; WM_CUT : RESULT:= 'WM_CUT '; WM_DDE_ACK : RESULT:= 'WM_DDE_ACK '; WM_DDE_ADVISE : RESULT:= 'WM_DDE_ADVISE '; WM_DDE_DATA : RESULT:= 'WM_DDE_DATA '; WM_DDE_EXECUTE : RESULT:= 'WM_DDE_EXECUTE '; WM_DDE_INITIATE : RESULT:= 'WM_DDE_INITIATE '; WM_DDE_POKE : RESULT:= 'WM_DDE_POKE '; WM_DDE_REQUEST : RESULT:= 'WM_DDE_REQUEST '; WM_DDE_TERMINATE : RESULT:= 'WM_DDE_TERMINATE '; WM_DDE_UNADVISE : RESULT:= 'WM_DDE_UNADVISE '; WM_DEADCHAR : RESULT:= 'WM_DEADCHAR '; WM_DELETEITEM : RESULT:= 'WM_DELETEITEM '; WM_DESTROY : RESULT:= 'WM_DESTROY '; WM_DESTROYCLIPBOARD : RESULT:= 'WM_DESTROYCLIPBOARD '; WM_DEVMODECHANGE : RESULT:= 'WM_DEVMODECHANGE '; WM_DRAWCLIPBOARD : RESULT:= 'WM_DRAWCLIPBOARD '; WM_DRAWITEM : RESULT:= 'WM_DRAWITEM '; WM_DROPFILES : RESULT:= 'WM_DROPFILES '; WM_ENABLE : RESULT:= 'WM_ENABLE '; WM_ENDSESSION : RESULT:= 'WM_ENDSESSION '; WM_ENTERIDLE : RESULT:= 'WM_ENTERIDLE '; WM_ERASEBKGND : RESULT:= 'WM_ERASEBKGND '; WM_FONTCHANGE : RESULT:= 'WM_FONTCHANGE '; WM_GETDLGCODE : RESULT:= 'WM_GETDLGCODE '; WM_GETFONT : RESULT:= 'WM_GETFONT '; WM_GETMINMAXINFO : RESULT:= 'WM_GETMINMAXINFO '; WM_GETTEXT : RESULT:= 'WM_GETTEXT '; WM_GETTEXTLENGTH : RESULT:= 'WM_GETTEXTLENGTH '; WM_HSCROLL : RESULT:= 'WM_HSCROLL '; WM_HSCROLLCLIPBOARD : RESULT:= 'WM_HSCROLLCLIPBOARD '; WM_ICONERASEBKGND : RESULT:= 'WM_ICONERASEBKGND '; WM_INITDIALOG : RESULT:= 'WM_INITDIALOG '; WM_INITMENU : RESULT:= 'WM_INITMENU '; WM_INITMENUPOPUP : RESULT:= 'WM_INITMENUPOPUP '; 377

WM_KEYDOWN : RESULT:= 'WM_KEYDOWN '; WM_KEYUP : RESULT:= 'WM_KEYUP '; WM_KILLFOCUS : RESULT:= 'WM_KILLFOCUS '; WM_LBUTTONDBLCLK : RESULT:= 'WM_LBUTTONDBLCLK '; WM_LBUTTONDOWN : RESULT:= 'WM_LBUTTONDOWN '; WM_LBUTTONUP : RESULT:= 'WM_LBUTTONUP '; WM_MBUTTONDBLCLK : RESULT:= 'WM_MBUTTONDBLCLK '; WM_MBUTTONDOWN : RESULT:= 'WM_MBUTTONDOWN '; WM_MBUTTONUP : RESULT:= 'WM_MBUTTONUP '; WM_MDIACTIVATE : RESULT:= 'WM_MDIACTIVATE '; WM_MDICASCADE : RESULT:= 'WM_MDICASCADE '; WM_MDICREATE : RESULT:= 'WM_MDICREATE '; WM_MDIDESTROY : RESULT:= 'WM_MDIDESTROY '; WM_MDIGETACTIVE : RESULT:= 'WM_MDIGETACTIVE '; WM_MDIICONARRANGE : RESULT:= 'WM_MDIICONARRANGE '; WM_MDIMAXIMIZE : RESULT:= 'WM_MDIMAXIMIZE '; WM_MDINEXT : RESULT:= 'WM_MDINEXT '; WM_MDIRESTORE : RESULT:= 'WM_MDIRESTORE '; WM_MDISETMENU : RESULT:= 'WM_MDISETMENU '; WM_MDITILE : RESULT:= 'WM_MDITILE '; WM_MEASUREITEM : RESULT:= 'WM_MEASUREITEM '; WM_MENUCHAR : RESULT:= 'WM_MENUCHAR '; WM_MENUSELECT : RESULT:= 'WM_MENUSELECT '; WM_MOUSEACTIVATE : RESULT:= 'WM_MOUSEACTIVATE '; WM_MOUSEMOVE : RESULT:= 'WM_MOUSEMOVE '; WM_MOVE : RESULT:= 'WM_MOVE '; WM_NCACTIVATE : RESULT:= 'WM_NCACTIVATE '; WM_NCCALCSIZE : RESULT:= 'WM_NCCALCSIZE '; WM_NCCREATE : RESULT:= 'WM_NCCREATE '; WM_NCDESTROY : RESULT:= 'WM_NCDESTROY '; WM_NCHITTEST : RESULT:= 'WM_NCHITTEST '; WM_NCLBUTTONDBLCLK : RESULT:= 'WM_NCLBUTTONDBLCLK '; WM_NCLBUTTONDOWN : RESULT:= 'WM_NCLBUTTONDOWN '; WM_NCLBUTTONUP : RESULT:= 'WM_NCLBUTTONUP '; WM_NCMBUTTONDBLCLK : RESULT:= 'WM_NCMBUTTONDBLCLK '; WM_NCMBUTTONDOWN : RESULT:= 'WM_NCMBUTTONDOWN '; WM_NCMBUTTONUP : RESULT:= 'WM_NCMBUTTONUP '; WM_NCMOUSEMOVE : RESULT:= 'WM_NCMOUSEMOVE '; WM_NCPAINT : RESULT:= 'WM_NCPAINT '; WM_NCRBUTTONDBLCLK : RESULT:= 'WM_NCRBUTTONDBLCLK '; WM_NCRBUTTONDOWN : RESULT:= 'WM_NCRBUTTONDOWN '; WM_NCRBUTTONUP : RESULT:= 'WM_NCRBUTTONUP '; WM_NEXTDLGCTL : RESULT:= 'WM_NEXTDLGCTL '; WM_PAINT : RESULT:= 'WM_PAINT '; WM_PAINTCLIPBOARD : RESULT:= 'WM_PAINTCLIPBOARD '; WM_PALETTECHANGED : RESULT:= 'WM_PALETTECHANGED '; WM_PALETTEISCHANGING : RESULT:= 'WM_PALETTEISCHANGING '; WM_PARENTNOTIFY : RESULT:= 'WM_PARENTNOTIFY '; WM_PASTE : RESULT:= 'WM_PASTE '; WM_POWER : RESULT:= 'WM_POWER '; WM_QUERYDRAGICON : RESULT:= 'WM_QUERYDRAGICON '; WM_QUERYENDSESSION : RESULT:= 'WM_QUERYENDSESSION '; WM_QUERYNEWPALETTE : RESULT:= 'WM_QUERYNEWPALETTE '; WM_QUERYOPEN : RESULT:= 'WM_QUERYOPEN '; WM_QUEUESYNC : RESULT:= 'WM_QUEUESYNC '; 378

WM_QUIT : RESULT:= 'WM_QUIT '; WM_RBUTTONDBLCLK : RESULT:= 'WM_RBUTTONDBLCLK '; WM_RBUTTONDOWN : RESULT:= 'WM_RBUTTONDOWN '; WM_RBUTTONUP : RESULT:= 'WM_RBUTTONUP '; WM_RENDERALLFORMATS : RESULT:= 'WM_RENDERALLFORMATS '; WM_RENDERFORMAT : RESULT:= 'WM_RENDERFORMAT '; WM_SETCURSOR : RESULT:= 'WM_SETCURSOR '; WM_SETFOCUS : RESULT:= 'WM_SETFOCUS '; WM_SETFONT : RESULT:= 'WM_SETFONT '; WM_SETREDRAW : RESULT:= 'WM_SETREDRAW '; WM_SETTEXT : RESULT:= 'WM_SETTEXT '; WM_SHOWWINDOW : RESULT:= 'WM_SHOWWINDOW '; WM_SIZE : RESULT:= 'WM_SIZE '; WM_SIZECLIPBOARD : RESULT:= 'WM_SIZECLIPBOARD '; WM_SPOOLERSTATUS : RESULT:= 'WM_SPOOLERSTATUS '; WM_SYSCHAR : RESULT:= 'WM_SYSCHAR '; WM_SYSCOLORCHANGE : RESULT:= 'WM_SYSCOLORCHANGE '; WM_SYSCOMMAND : RESULT:= 'WM_SYSCOMMAND '; WM_SYSDEADCHAR : RESULT:= 'WM_SYSDEADCHAR '; WM_SYSKEYDOWN : RESULT:= 'WM_SYSKEYDOWN '; WM_SYSKEYUP : RESULT:= 'WM_SYSKEYUP '; WM_SYSTEMERROR : RESULT:= 'WM_SYSTEMERROR '; WM_TIMECHANGE : RESULT:= 'WM_TIMECHANGE '; WM_TIMER : RESULT:= 'WM_TIMER '; WM_UNDO : RESULT:= 'WM_UNDO '; WM_USER : RESULT:= 'WM_USER '; WM_VKEYTOITEM : RESULT:= 'WM_VKEYTOITEM '; WM_VSCROLL : RESULT:= 'WM_VSCROLL '; WM_VSCROLLCLIPBOARD : RESULT:= 'WM_VSCROLLCLIPBOARD '; WM_WINDOWPOSCHANGED : RESULT:= 'WM_WINDOWPOSCHANGED '; WM_WINDOWPOSCHANGING : RESULT:= 'WM_WINDOWPOSCHANGING '; WM_WININICHANGE : RESULT:= 'WM_WININICHANGE '; ELSE RESULT:= 'UNKNOWN: '+INTTOSTR(WM); END; END; ADD THIS TO THE PRIVATE SECTION : PROCEDURE APPONMESSAGE(VAR MSG: TMSG; VAR HANDLED: BOOLEAN); FUNCTION MSGTOSTR( WM : WORD ) : STRING; THIS PROCEDURE GETS THE WINDOWS MESSAGES : PROCEDURE TFORM1.APPONMESSAGE(VAR MSG: TMSG; VAR HANDLED: BOOLEAN); BEGIN // GET THE MESSAGES AND PASS THEM TO THE // MSGTOSTR FUNCTION STATUSBAR1.SIMPLETEXT := MSGTOSTR(MSG.MESSAGE); END; IN FROMCREATE ADD: PROCEDURE TFORM1.FORMCREATE(SENDER: TOBJECT); BEGIN // WE DO THIS SO THAT ANY MESSAGES // THAT THE APPLICATION RECIEVES GOES 379

// TO THE APPONMESSAGES PROCEDURE APPLICATION.ONMESSAGE := APPONMESSAGE; END;

380

hide form from taskbar, task manager and visibility // this example code stealths a program hiding it from the windows taskbar, the // system task manager (aka task switcher) and from sight // the example uses tform1 for the main form type tregisterserviceprocess = function (dwprocessid, dwtype:dword) : dword; stdcall; // form create procedure made from tform1 procedure tform1.formcreate(sender: tobject); var tm : string; i : integer; pc, oldname, newname : pchar; hndl :thandle; registerserviceprocess: tregisterserviceprocess; begin hndl := loadlibrary('kernel32.dll'); registerserviceprocess := getprocaddress(hndl, 'registerserviceprocess'); registerserviceprocess(getcurrentprocessid, 1); freelibrary(hndl); setwindowlong(application.handle, gwl_exstyle, getwindowlong(application.handle, gwl_exstyle) or ws_ex_toolwindow and not ws_ex_appwindow); end; // you must enter this line of code in the main program unit or the form will not hide showmainform := false; [email protected] { tip posted from: tram-law corps

381

tip title - hooking keyboard - send key routine library sendkey; {this code taken with permission from "delphi developer's guide" by xavier pacheco and steve teixeira.} uses sysutils, wintypes, winprocs, messages, classes, keydefs; type { error codes } tsendkeyerror = (sk_none, sk_failsethook, sk_invalidtoken, sk_unknownerror); { exceptions } esendkeyerror = class(exception); esethookerror = class(esendkeyerror); einvalidtoken = class(esendkeyerror); { a tlist descendant that know how to dispose of its contents } tmessagelist = class(tlist) public destructor destroy; override; end; destructor tmessagelist.destroy; var i: longint; begin { deallocate all the message records before discarding the list } for i := 0 to count - 1 do dispose(peventmsg(items[i])); inherited destroy; end; var { variables global to the dll } msgcount: word; messagebuffer: teventmsg; hookhandle: hhook; playing: boolean; messagelist: tmessagelist; altpressed, controlpressed, shiftpressed: boolean; nextspecialkey: tkeystring; function makeword(l, h: byte): word; { macro creates a word from low and high bytes } inline( $5a/ { pop dx } $58/ { pop ax } $8a/$e2); { mov ah, dl } procedure stopplayback; { unhook the hook, and clean up } begin { if hook is currently active, then unplug it } if playing then 382

unhookwindowshookex(hookhandle); messagelist.free; playing := false; end; function play(code: integer; wparam: word; lparam: longint): longint; export; { this is the journalplayback callback function. it is called by windows } { when windows polls for hardware events. the code parameter indicates what } { to do. } begin case code of hc_skip: begin { hc_skip means to pull the next message out of our list. if we } { are at the end of the list, it's okay to unhook the journalplayback } { hook from here. } { increment message counter } inc(msgcount); { check to see if all messages have been played } if msgcount >= messagelist.count then stopplayback else { copy next message from list into buffer } messagebuffer := teventmsg(messagelist.items[msgcount]^); result := 0; end; hc_getnext: begin { hc_getnext means to fill the wparam and lparam with the proper } { values so that the message can be played back. do not unhook } { hook from within here. return value indicates how much time until } { windows should playback message. we'll return 0 so that it's } { processed right away. } { move message in buffer to message queue } peventmsg(lparam)^ := messagebuffer; result := 0 { process immediately } end else { if code isn't hc_skip or hc_getnext, then call next hook in chain } result := callnexthookex(hookhandle, code, wparam, lparam); end; end; procedure startplayback; { initializes globals and sets the hook } begin { grab first message from list and place in buffer in case we } { get a hc_getnext before and hc_skip } messagebuffer := teventmsg(messagelist.items[0]^); { initialize message count and play indicator } msgcount := 0; { initialize alt, control, and shift key flags } altpressed := false; controlpressed := false; 383

shiftpressed := false; { set the hook! } hookhandle := setwindowshookex(wh_journalplayback, play, hinstance, 0); if hookhandle = 0 then raise esethookerror.create('couldn''t set hook') else playing := true; end; procedure makemessage(vkey: byte; m: word); { procedure builds a teventmsg record that emulates a keystroke and } { adds it to message list } var e: peventmsg; begin new(e); { allocate a message record } with e^ do begin message := m; { set message field } { high byte of paraml is the vk code, low byte is the scan code } paraml := makeword(vkey, mapvirtualkey(vkey, 0)); paramh := 1; { repeat count is 1 } time := gettickcount; { set time } end; messagelist.add(e); end; procedure keydown(vkey: byte); { generates keydownmessage } begin { don't generate a "sys" key if the control key is pressed (windows quirk) } if (altpressed and (not controlpressed) and (vkey in [ord('a')..ord('z')])) or (vkey = vk_menu) then makemessage(vkey, wm_syskeydown) else makemessage(vkey, wm_keydown); end; procedure keyup(vkey: byte); { generates keyup message } begin { don't generate a "sys" key if the control key is pressed (windows quirk) } if altpressed and (not controlpressed) and (vkey in [ord('a')..ord('z')]) then makemessage(vkey, wm_syskeyup) else makemessage(vkey, wm_keyup); end; procedure simkeypresses(vkeycode: word); { this function simulates keypresses for the given key, taking into } { account the current state of alt, control, and shift keys } begin { press alt key if flag has been set } if altpressed then keydown(vk_menu); 384

{ press control key if flag has been set } if controlpressed then keydown(vk_control); { if shift is pressed, or shifted key and control is not pressed... } if (((hi(vkeycode) and 1) <> 0) and (not controlpressed)) or shiftpressed then keydown(vk_shift); { ...press shift } keydown(lo(vkeycode)); { press key down } keyup(lo(vkeycode)); { release key } { if shift is pressed, or shifted key and control is not pressed... } if (((hi(vkeycode) and 1) <> 0) and (not controlpressed)) or shiftpressed then keyup(vk_shift); { ...release shift } { if shift flag is set, reset flag } if shiftpressed then begin shiftpressed := false; end; { release control key if flag has been set, reset flag } if controlpressed then begin keyup(vk_control); controlpressed := false; end; { release alt key if flag has been set, reset flag } if altpressed then begin keyup(vk_menu); altpressed := false; end; end; procedure processkey(s: string); { this function parses each character in the string to create the message list } var keycode: word; key: byte; index: integer; token: tkeystring; begin index := 1; repeat case s[index] of keygroupopen : begin { it's the beginning of a special token! } token := ''; inc(index); while s[index] <> keygroupclose do begin { add to token until the end token symbol is encountered } token := token + s[index]; inc(index); { check to make sure the token's not too long } if (length(token) = 7) and (s[index] <> keygroupclose) then raise einvalidtoken.create('no closing brace'); end; { look for token in array, key parameter will } { contain vk code if successful } if not findkeyinarray(token, key) then raise einvalidtoken.create('invalid token'); 385

{ simulate keypress sequence } simkeypresses(makeword(key, 0)); end; altkey : begin { set alt flag } altpressed := true; end; controlkey : begin { set control flag } controlpressed := true; end; shiftkey : begin { set shift flag } shiftpressed := true; end; else begin { a normal character was pressed } { convert character into a word where the high byte contains } { the shift state and the low byte contains the vk code } keycode := vkkeyscan(makeword(byte(s[index]), 0)); { simulate keypress sequence } simkeypresses(keycode); end; end; inc(index); until index > length(s); end; function sendkeys(s: string): tsendkeyerror; export; { this is the one entry point. based on the string passed in the s } { parameter, this function creates a list of keyup/keydown messages, } { sets a journalplayback hook, and replays the keystroke messages. } var i: byte; begin try result := sk_none; { assume success } messagelist := tmessagelist.create; { create list of messages } processkey(s); { create messages from string } startplayback; { set hook and play back messages } except { if an exception occurs, return an error code, and clean up } on e:esendkeyerror do begin messagelist.free; if e is esethookerror then result := sk_failsethook else if e is einvalidtoken then result := sk_invalidtoken; end else 386

{ catch-all exception handler ensures than an exception } { doesn't walk up into application stack } result := sk_unknownerror; end; end; exports sendkeys index 1; begin end

387

tip title - file upload usage: var reqcontent:trwrequestcontent; begin reqcontent:= trwrequestcontent.create(request); try reqcontent.field['username_fromform'].content; reqcontent.field['uploadedfile_fromform'].contenttype; reqcontent.field['uploadedfile_fromform'].filename; end;

unit parserequest; { copyright © 2000 winwright inc. (canada) all rights reserved. this unit may be freely used and distributed by anyone for use in any application commercial or otherwise as long as these comments including copyright are kept intact. this unit can be used to parse out data returned from html forms with enctype="multipart/form-data" and method=post do not use on any other encoding. reason for unit is the twebrequest class in delphi does not provide correct handling for multipart data. these helper classes provide this handling. description: create an instance of trwrequestcontent passing to the constructor either the complete content from a twebrequest object or the twebrequest instance itself. in the latter case trwrequestcontent will take care of making sure all content has been retrieved from the client. trwrequestcontent will first parse the boundary string used to delimit each form item, then use that to parse the content of all the individual fields. for each field parsed, that specific content is passed to the constructor of a trwrequestitem which then parses it further to pull out the individual elements. for most fields this simply consists of name and content. for multi-select listbozes, the content will contain the choices separated by semi-colons (;). for images, the filename and contenttype properties will also be provided. the content will be the actual image data and can be directly saved to file as the appropriate type (e.g. .jpg or .gif). once created, you can iterate the list of names using the fieldname property, individual trwrequestitems using the field property, or get the entire tstringlist containing the names and trwrequestitem objects via the fields property. fieldcount and contentlength are also available. 388

freeing the trwrequestcontent object will free all the trwrequestitem objects. } interface uses classes, sysutils, httpapp; type { trwrequestitem: - contains data about a single item returned from an html form. - there's no need to create these manually, they are created for you by calling the constructor of the trwrequestcontent class. } trwrequestitem = class private fname: string; fcontenttype: string; ffilename: string; fcontent: string; fcontentlength: integer; public constructor create(const acontent: string); procedure addvalue(const acontent: string); property name: string read fname; property contenttype: string read fcontenttype; property filename: string read ffilename; property content: string read fcontent; property contentlength: integer read fcontentlength; end; { trwrequestcontent: - passed either the content property of a twebrequest class, or an instance of a twebrequest class, will parse out the individual fields. } trwrequestcontent = class private flist: tstrings; fboundary: string; fcontentlength: cardinal; fcontent: string; procedure clearlist; procedure parsefields(const data: string); function getfieldcount: integer; function getfield(const index: string): trwrequestitem; function getname(index: integer): string; function getnames: tstrings; public constructor create(req: twebrequest); overload; constructor create(const adata: string); overload; destructor destroy; override; property contentlength: cardinal read fcontentlength; property content: string read fcontent; 389

property fieldcount: integer read getfieldcount; property field[const index: string]: trwrequestitem read getfield; property fieldname[index: integer]: string read getname; property fieldnames: tstrings read getnames; end; implementation const crlf = #13#10; sboundary = 'boundary='; sfilename = 'filename="'; sname = 'name="'; scontenttype = 'content-type: '; { trwcontentitem } constructor trwrequestitem.create(const acontent: string); // must be passed the data for a single item from the twebrequest // content. trailing boundary must be removed. var i, e: integer; begin i := pos(sname, acontent); if i <= 0 then raise exception.create('trwcontentitem: no name found'); e := pos('"', pchar(@acontent[i + length(sname)])); fname := copy(acontent, i + length(sname), e-1); i := pos(sfilename, acontent); if i > 0 then begin e := pos('"', pchar(@acontent[i + length(sfilename)])); ffilename := copy(acontent, i + length(sfilename), e-1); end; i := pos(scontenttype, acontent); if i > 0 then begin e := pos(#13, pchar(@acontent[i + length(scontenttype)])); fcontenttype := copy(acontent, i + length(scontenttype), e-1); end; i := pos(crlf + crlf, acontent) + 4; fcontentlength := length(acontent) - i + 1; if fcontentlength > 0 then setstring(fcontent, pchar(@acontent[i]), fcontentlength) else fcontent := ''; end; procedure trwrequestitem.addvalue(const acontent: string); // this allows additional values to be added to an existing // content value for the case of multi-select listboxes. begin fcontent := fcontent + ';' + acontent; 390

end; { trwrequestcontent } constructor trwrequestcontent.create(req: twebrequest); // calling this constructor will check to see if all // data has been retrieved from the client and, if not, // will download it. it will then parse that data. var p: pchar; i: integer; len: cardinal; ms: tmemorystream; begin flist := tstringlist.create; // get currently retrieved data fcontentlength := req.contentlength; setstring(fcontent, pchar(req.content), length(req.content)); setlength(fcontent, fcontentlength); len := length(req.content); p := pchar(fcontent) + len; // get the entire request while len < fcontentlength do begin i := req.readclient(p^, fcontentlength - len); inc(len, i); inc(p, i); end; try ms := tmemorystream.create; try p := pchar(fcontent); ms.write(p^, len); ms.savetofile('c:\temp\content.txt'); except ms.write('problem', 7); ms.savetofile('c:\temp\content.txt'); end; finally ms.free; end; parsefields(fcontent); end; constructor trwrequestcontent.create(const adata: string); // this constructor assumes you've already correctly // downloaded the entire content from the client. it // simply attempts to parse the passed content begin flist := tstringlist.create; parsefields(adata); end; procedure trwrequestcontent.parsefields(const data: string); // this method scans the content and parses out the individual 391

// item blocks (delimited by a boundary string which is the // first parseable item). each parsed block is passed to the // constructor of the trwrequestitem class which is added to // the list of items var i, e, idx: integer; item: trwrequestitem; s: string; begin // get the boundary string i := pos(crlf, data); fboundary := copy(data, 1, i - 1); inc(i, 2); // parse the request setstring(s, pchar(@data[i]), length(data) - i); e := pos(crlf + fboundary, s); while e > 0 do begin item := trwrequestitem.create(copy(data, i, e - 1)); // need to check for same name in case of multi-select listboxes idx := flist.indexof(item.name); if idx < 0 then // new item (common case) flist.addobject(item.fname, item) else begin // additional item value trwrequestitem(flist.objects[idx]).addvalue(item.content); item.free; end; inc(i, e + length(fboundary)); setstring(s, pchar(@data[i]), length(data) - i); e := pos(crlf + fboundary, s); end; end; destructor trwrequestcontent.destroy; begin clearlist; flist.free; inherited; end; procedure trwrequestcontent.clearlist; var i: integer; begin for i := 0 to flist.count - 1 do flist.objects[i].free; end; function trwrequestcontent.getfieldcount: integer; begin result := flist.count; end; function trwrequestcontent.getfield(const index: string): trwrequestitem; // it's assumed you know what fields you are expecting to find 392

// therefore this property is indexed by the name of the field var i: integer; begin i := flist.indexof(index); result := trwrequestitem(flist.objects[i]) end; function trwrequestcontent.getname(index: integer): string; // but if you don't know what names you are expecting, // you can iterate them by number here. begin result := flist[index] end; function trwrequestcontent.getnames: tstrings; // this allows access to the tstringlist that contains // the field names and trwrequestitem instances begin result := flist; end; end.

393

Belli satıra gitmak için bunu kullan : {Not: Etkiyi gormek icin SpeedBtn kullaniniz} procedure TForm1.SpeedButton1Click(Sender: TObject); begin // en alta Memo1.Selstart := Length (Memo1.Text); Memo1.Perform(EM_SCROLLCARET, 0, 0); end; procedure TForm1.SpeedButton2Click(Sender: TObject); begin // en üste Memo1.SelStart := 0; Memo1.Perform(EM_SCROLLCARET, 0, 0); end; procedure TForm1.SpeedButton3Click(Sender: TObject); begin // satir 6 ya git(0 dan baslar) with Memo1 do SelStart := Perform(EM_LINEINDEX, 5, 0); Memo1.Perform(EM_SCROLLCARET, 0, 0); end; -------------------------------------------imlecin nerde olduğunu bulmk için bunu kullan var LineNum:logint; CharsBeforeLine:logint; begin LineNum:=SendMessage(Memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0); CharsBeforeLine:=SendMessage(Memo1.Handle,EM_LINEINDEX,LineNum,0); Label1.Caption:='Satır'+IntToStr(LineNum+1); Label2.Caption:='Kolon'+IntToStr((Memo1.SelStart-CharsBeforeLine)+1);

394

Tip Title - SHGetSpecialFolderLocation VAR I : INTEGER; SFOLDER : PITEMIDLIST; SPECIALPATH : ARRAY[0..MAX_PATH] OF CHAR; BEGIN SHGETSPECIALFOLDERLOCATION(FORM1.HANDLE, CSIDL_RECENT, SFOLDER); SHGETPATHFROMIDLIST(SFOLDER, SPECIALPATH); LABEL1.CAPTION := STRPAS(SPECIALPATH); // MAKE SURE YOU ADD SHLOBJ TO YOUR USES CLAUSE OTHER FOLDERS : CSIDL_BITBUCKET CSIDL_CONTROLS CSIDL_DESKTOP CSIDL_DESKTOPDIRECTORY CSIDL_DRIVES CSIDL_FONTS CSIDL_NETHOOD CSIDL_NETWORK CSIDL_PERSONAL CSIDL_PRINTERS CSIDL_PROGRAMS CSIDL_RECENT CSIDL_SENDTO CSIDL_STARTMENU CSIDL_STARTUP CSIDL_TEMPLATES

395

function getstartupfolderpath: string; var iidlist: pitemidlist; buffer: array [0..max_path-1] of char; begin iidlist:= nil; olecheck(shgetspecialfolderlocation(application.handle, csidl_startup {or csidl_common_startup},iidlist)); if not shgetpathfromidlist(iidlist, buffer) then raise exception.create(''could not get startup folder.''); result:= strpas(buffer); end; tip title - get special folders function getspecialfolder(folderid : longint) : string; var path : pchar; idlist : pitemidlist; begin getmem(path, max_path); shgetspecialfolderlocation(0, folderid, idlist); shgetpathfromidlist(idlist, path); result := string(path); freemem(path); end; //i then created other functions to wrap the previous function and they are these function gettmpinternetdir: string; begin result := addslash(getspecialfolder(csidl_internet_cache)); end; function getcookiesdir: string; begin result := addslash(getspecialfolder(csidl_cookies)); end; function gethistorydir: string; begin result := addslash(getspecialfolder(csidl_history)); end; function getdesktop: string; begin result := addslash(getspecialfolder(csidl_desktop)); end; function getdesktopdir: string; begin result := addslash(getspecialfolder(csidl_desktopdirectory)); end; function getprogdir: string; begin result := addslash(getspecialfolder(csidl_programs)); 396

end; function getmydocdir: string; begin result := addslash(getspecialfolder(csidl_personal)); end; function getfavdir: string; begin result := addslash(getspecialfolder(csidl_favorites)); end; function getstartupdir: string; begin result := addslash(getspecialfolder(csidl_startup)); end; function getrecentdir: string; begin result := addslash(getspecialfolder(csidl_recent)); end; function getsendtodir: string; begin result := addslash(getspecialfolder(csidl_sendto)); end; function getstartmenudir: string; begin result := addslash(getspecialfolder(csidl_startmenu)); end; function getnethooddir: string; begin result := addslash(getspecialfolder(csidl_nethood)); end; function getfontsdir: string; begin result := addslash(getspecialfolder(csidl_fonts)); end; function gettemplatedir: string; begin result := addslash(getspecialfolder(csidl_templates)); end; function getappdatadir: string; begin result := addslash(getspecialfolder(csidl_appdata)); end; function getprinthooddir: string; begin result := addslash(getspecialfolder(csidl_printhood)); 397

end; { directories that don't work on win 9x/me but do on nt/w2k csidl_common_startmenu csidl_common_programs csidl_common_startup csidl_common_desktopdirectory csidl_altstartup csidl_common_altstartup csidl_common_favorites } //make sure shlobj is in your uses clause or the csidl constants won't map correctly. //so with this code you just call getmydocdir and it will return a string with //the my documents path in it. i think the others are very simple to figure out tip title - get special directories const cshellappdata = 'appdata'; cshellcache = 'cache'; cshellcookies = 'cookies'; cshelldesktop = 'desktop'; cshellfavorites = 'favorites'; cshellfonts = 'fonts'; cshellhistory = 'history'; cshelllocalapp = 'local appdata'; cshellnethood = 'nethood'; cshellpersonal = 'personal'; cshellprinthood = 'printhood'; cshellprograms = 'programs'; cshellrecent = 'recent'; cshellsendto = 'sendto'; cshellstartmenu = 'start menu'; cshellstartup = 'startup'; cshelltemplates = 'templates'; function getshellfolder (const folder: string):string; const cwin32 = 'software\microsoft\windows\currentversion'; cshellprefix = '\explorer\shell folders'; var r: tregistry; begin result:= ''; r:= tregistry.create; try r.rootkey:=hkey_current_user; // make no difference between nt and 95/98! if r.openkey (cwin32 + cshellprefix, false) then result:= r.readstring (folder) + '\'; finally r.free; end; end;

398

tip title - file association procedure tform1.button1click(sender: tobject); var myreg: tregistry; begin myreg := tregistry.create; myreg.rootkey := hkey_classes_root; myreg.lazywrite := false; {open or create key} myreg.openkey('.xyz\shell\open\command', true); {specify the program} myreg.writestring('', 'c:\windows\notepad.exe %1'); {specify the icon} myreg.closekey; myreg.openkey('.xyz\defaulticon', true); {use the first icon in the relevant .exe} myreg.writestring('', 'c:\windows\notepad.exe,0'); myreg.closekey; myreg.free; end; raone

399

Detecting Softice in W9x and NT (W2K - dunno) Note: Click Title to view in Edit Box for easier copying. The Cracker can still defeat this protection by using FrogIce, nothing can stop SoftIce hehe. Anyway here is sum code you just instert into your Applcation. //SoftIce in W9x Function IsSoftIce95Loaded: boolean; Var hFile: Thandle; Begin result := false; hFile := CreateFileA('\.SICE', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if( hFile <> INVALID_HANDLE_VALUE ) then begin CloseHandle(hFile); result := TRUE; end; End; // SoftIce in NT OS Function IsSoftIceNTLoaded: boolean; Var hFile: Thandle; Begin result := false; hFile := CreateFileA('\.NTICE', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if( hFile <> INVALID_HANDLE_VALUE ) then begin CloseHandle(hFile); result := TRUE; end; End; //to detect it if IsSoftIce95Loaded or IsSoftIceNTLoaded then Application.Terminate {if you insert a "Nag" (Message telling him he uses SoftIce) then a amatuer cracker w'll find this protection in notime} //bestway of using this thing is in "project Unit" By: H3X3D1T , any probz mail me

400

Macromedia Flash Resizing - May 21, 2001 - Technical Articles Related Links Removing the popup menu in Macromedia Flash .OCX Displaying Macromedia Flash .SWF files in your Delphi Application! A few things that are easily accomplished using a browser are a little bit more tricky in Delphi. 1. How to get the flash ocx to resize properly. After hours and hours of researching and testing I came up with 2 methods from the Internet, and both may work in some versions of Delphi, but in other versions like Delphi 4 Standard did not. 1st Method: Make the object Visible:=False and then Visible:=True. 2nd Method: Change the objects parent to nil and then back again. This method seems to work except that it stops any streaming mp3's currently being played. After 7 hours of researching Delphis help files and testing I came up with this.... Correct Method: ShockwaveFlash1.DoObjectVerb(-1); Using DoObjectVerb(-3) works also, but that is meant to make it hide. 2. How to get the flash ocx to resize to the proper width and height of the swf movie. There doesn't seem to be any way to do this with the ocx, so the only way i could think of was getting the info out of the actual file. Below is some code which shows how to do this (and it works!! wohooo!). This is where I could really do with some help. Im a real newbie and haven't even got around to reading anything on coding Delphi (I've been learning by reading others code). So this code could probably be improved, reading the swf sdk might help (if you can find the code that reads in a rectangle tag... I couldn't :) So feel free to contact me at the email below. 3. Stopping the flicker when resizing. There's two ways to do this. 1st Method: To use the windows message WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND; and returning false. 2nd Method: Set the doublebuffered for the form to true. The 1st method seems quicker than the 2nd method, but the 1st method can cause weird results when the movie is not taking up the whole form. 401

4. Here are the 22 properties that can be accessed with GetProperty.. 1. 2. 3. 4. 5. 6. 7. 8.

= x position = y position = xscale = yscale = currentframe = totalframes = alpha = visible - Although visible will return the string 'TRUE' or 'FALSE', it is Set with a 0 for False and 1 for True 9. = width 10. = height 11. = rotation 12. = target 13. = framesloaded 14. = name 15. = droptarget 16. = url 17. = highquality 18. = focusrect 19. = soundbuftime 20. = quality 21. = xmouse 22. = ymouse For more information on these properties (such as which can be changed) look in the help file that comes with Flash. Contact Info If you can help improve the code, or just have some questions feel free to contact me at... [email protected]

Source Code: unit Unit1; interface // Please note that some comments in this file // are objectional. I hardly ever understand // all that crap in sdk's and API stuff :) // // Also if you want to better understand what's // going on in the width/height routines your // going to have to read the Macromedia SWF // sdk.... you poor bugger ;) The file I read // was 'Flash_Uncovered.doc' uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, OleCtrls, ShockwaveFlashObjects_TLB, AppEvents, StdCtrls; 402

type TForm1 = class(TForm) ShockwaveFlash1: TShockwaveFlash; procedure FormResize(Sender: TObject); procedure FormCreate(Sender: TObject); private procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND; Function LoadHeader( const filename: String ): String; function IsBitSet(const val: byte; const TheBit: byte): boolean; function BitOn(const val: Integer; const TheBit: byte): Integer; function BitOff(const val: byte; const TheBit: byte): byte; function MovieWidth(const HeaderS: String ): Integer; function MovieHeight(const HeaderS: String ): Integer; function BitLenth(headers: string):byte; function BitInString(const HeaderS: String; const TheBit: byte): boolean; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormResize(Sender: TObject); begin // DoObjectVerb(-1) tells the Flash OCX to Show, // this has the effect of making the Flash OCX // rerender its self according to its current // properties (width, height) ShockwaveFlash1.DoObjectVerb(-1); end; // This stops windoze from eraseing the background // of the form, which eliminates the flicker when // resizing it. Stopping the flicker can also be // achieved by setting DoubleBuffered for the form to True. // procedure TForm1.FormCreate(Sender: TObject); // begin // Form1.DoubleBuffered:=True; // end; // DoubleBuffered is probally better when the movie doesn't // take up the whole form. procedure TForm1.WMEraseBkgnd(var M: TWMEraseBkgnd); begin // M.Result := LRESULT(False); // not having anything in here is the same as returning False end; 403

// Returns the piece of header in a swf movie // (that contains the width and height) // called 'filename' as a string Function TForm1.LoadHeader( const filename: String ): String; Var fs: TFileStream; Begin fs:= TFilestream.Create( filename, fmOpenRead or fmShareDenyWrite ); try SetLength(Result, 17); fs.Seek(8, soFromBeginning); fs.Readbuffer( Result[1], Length( result )); finally fs.free end; End; procedure TForm1.FormCreate(Sender: TObject); var HString: String; begin // Load the header into HString and resize the form according // to the width and height of the swf movie, tell the flash ocx // what movie to load and finally tell it to play the movie HString:=LoadHeader('C:\WINDOWS\Desktop\test.swf'); Form1.ClientWidth:=MovieWidth(Hstring); Form1.ClientHeight:=MovieHeight(HString); ShockwaveFlash1.Movie:='C:\WINDOWS\Desktop\test.swf'; ShockwaveFlash1.Play; end; // This returns the width of a swf movie as an integer. // 'HeaderS' is a string that holds the piece of the header // which was loaded earlier with LoadHeader function TForm1.MovieWidth(const HeaderS: String ): Integer; var i,a,b: byte; begin result:=0; a:=BitLenth(HeaderS); b:=4 + a shl 1; for I := 4+a to b do begin if BitInString(HeaderS,I) then result:=BitOn(result,a); dec(a); end; // The width and height are actually stored as TWIPS and // need to be divided by 20 to know what they are in pixels result:=result div 20; end; // This returns the height of a swf movie as an integer. 404

// 'HeaderS' is a string that holds the piece of the header // which was loaded earlier with LoadHeader function TForm1.MovieHeight(const HeaderS: String ): Integer; var i,a,b: byte; begin result:=0; a:=BitLenth(HeaderS); b:=4 + a shl 2; for I := 4 + a * 3 to b do begin if BitInString(HeaderS,I) then result:=BitOn(result,a); dec(a); end; // The width and height are actually stored as TWIPS and // need to be divided by 20 to know what they are in pixels result:=result div 20; end; // This returns True if bit 'TheBit' in string 'HeaderS' // is a 1 function TForm1.BitInString(const HeaderS: String; const TheBit: byte): boolean; var a,b,c: byte; begin a:=TheBit shr 3; b:=a shl 3; inc(a); c:=TheBit-b; result:=IsBitSet(ord(HeaderS[a]),7-c); end; // Checks to see if bit 'TheBit' in 'val' is a 1 // returns True if so function TForm1.IsBitSet(const val: byte; const TheBit: byte): boolean; begin result := (val and (1 shl TheBit)) <> 0; end; // Turn bit 'TheBit' in 'val' to a 1 function TForm1.BitOn(const val: Integer; const TheBit: byte): Integer; begin result := val or (1 shl TheBit); end; // This returns how many bits long each width and // height record is function TForm1.BitLenth(headers: string):byte; begin result := ord(HeaderS[1]) shr 3; end; 405

// Never actually used. Left here incase I needed it later... // Turn bit 'TheBit' in 'val' to a 0 function TForm1.BitOff(const val: byte; const TheBit: byte): byte; begin result := val and ((1 shl TheBit) xor $FF); end; end.

406

Displaying Macromedia Flash .SWF files in your Delphi Application! - Jun 5, 2001 Technical Articles Related Links Removing the popup menu in Macromedia Flash .OCX Macromedia Flash Resizing Macromedia Method descriptions for ActiveX Control If you have considered using your Macromedia Flash files to help add some flavor to your Delphi applications, but never knew how, this article is for you. Download demo project First of all you must find the file titled "SWFLASH.OCX" usually in the C:\Windows\System\Macromed\Flash directory. You can then in Delphi click on the menu Component --> Import ActiveX Control. Choose the SWFlash.OCX file and import it. Once you install it, you will then have the TShockWaveFlash component to drag onto your form. PROBLEM: The important thing to remember is that if deploy your application then they must have this OCX file or it will not run. SOLUTION: To keep your program simple and only have 1 file to distribute, I would suggest to create a resource file of the OCX and include in your .EXE. Extract the file if needed and register it. I have included some sample code on how to do this. CREATING RESOURCE FILE: (Skip this section if you already understand it). Create a new Text File in Notepad. Type the following line: Flash RCDATA "SWFLASH.OCX" Make sure the text file is saved as Filename.rc, I saved mine as FlashOCX.rc. You must also have the .rc file in the same directory as the SWFLASH.OCX file in order for this to work. Open your command prompt (DOS window) and find the brcc32.exe file in your bin directory wherever you installed Delphi. Type this and execute it in DOS: Brcc32 DirofFile\FlashOCX.rc Example: Brcc32 c:\windows\system\flashocx.rc It should now have created a file titled "FLASHOCX.RES". You can now include this into your application. {$R *.RES} {$R FLASHOCX.RES} The R Directive tells your program to include that Resource File. HOW TO EXTRACT AND REGISTER: First off we need to check to see if we can play the Flash File or not. Click on Project --> View Source (in Delphi 5) and pull up the project source code. We want to check for the 407

EOleSysError Message when creating the first form. If we encounter the error, then we know we must register the OCX on that particular machine. uses comobj begin Application.Initialize; try Application.CreateForm(TForm1, Form1); except On EOleSysError Do begin //Register OCX File because not found. end; end; Application.Run; end. This next bit of source code that I will display will give you what is needed to extract the resource file and place into the Windows System Directory. uses windows, classes, sysutils var aSystemDirZ : array[0..2047] of Char; fSystemDir : String; ... GetSystemDirectory ( aSystemDirZ, 2047 ); fSystemDir := aSystemDirZ; ResStream := TResourceStream.Create(0, 'Flash', RT_RCDATA); try FileStream := TFileStream.Create(fSystemDir+'SWFLASH.OCX', fmCreate); try FileStream.CopyFrom(ResStream, 0); finally FileStream.Free; end; finally ResStream.Free; end; ENTIRE CODE: You must still register the OCX file, and I will now display the entire code so you can see how it would all fit together. program FlashPlayer; uses Forms, Dialogs, comobj, windows, classes, sysutils, 408

uMain in 'uMain.pas' {Form1}; {$R *.RES} {$R FLASHOCX.RES} type TRegFunc = function : HResult; stdcall; function WinExecAndWait32( FileName: String; Visibility : Integer ) : Cardinal; var { by Pat Ritchey } zAppName : array[0..512] of char; zCurDir : array[0..255] of char; WorkDir : String; StartupInfo : TStartupInfo; ProcessInfo : TProcessInformation; begin StrPCopy( zAppName, FileName ); GetDir ( 0, WorkDir ); StrPCopy( zCurDir, WorkDir ); FillChar( StartupInfo, Sizeof( StartupInfo ), #0 ); StartupInfo.cb := Sizeof( StartupInfo ); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := Visibility; if ( not CreateProcess( nil, zAppName, { pointer to command line string } nil, { pointer to process security attributes } nil, { pointer to thread security attributes } false, { handle inheritance flag } CREATE_NEW_CONSOLE or { creation flags } NORMAL_PRIORITY_CLASS, nil, { pointer to new environment block } zCurDir, { pointer to current directory name } StartupInfo, { pointer to STARTUPINFO } ProcessInfo ) ) then begin Result := $FFFFFFFF; { pointer to PROCESS_INF } MessageBox( Application.Handle, PChar( SysErrorMessage( GetLastError ) ), 'Yipes!', 0 ); end else begin WaitforSingleObject( ProcessInfo.hProcess, INFINITE ); GetExitCodeProcess ( ProcessInfo.hProcess, Result ); CloseHandle ( ProcessInfo.hProcess ); CloseHandle ( ProcessInfo.hThread ); end; end; var aSystemDirZ : array[0..2047] of Char; aShortPath : array[0..2047] of Char; fSystemDir : String; 409

aCommand : String; aHandle : Cardinal; aFunc : TRegFunc; ResStream : TResourceStream; FileStream : TFileStream; begin GetSystemDirectory ( aSystemDirZ, 2047 ); fSystemDir := aSystemDirZ; Application.Initialize; try Application.CreateForm(TForm1, Form1); except On EOleSysError Do begin ResStream := TResourceStream.Create(0, 'Flash', RT_RCDATA); try FileStream := TFileStream.Create(fSystemDir+'SWFLASH.OCX', fmCreate); try FileStream.CopyFrom(ResStream, 0); finally FileStream.Free; end; finally ResStream.Free; end; try {Register the OCX File} aHandle := LoadLibrary( PChar( fSystemDir+'SWFLASH.OCX' ) ); if ( aHandle >= 32 ) then begin aFunc := GetProcAddress( aHandle, 'DllRegisterServer' ); if ( Assigned( aFunc ) = TRUE ) then begin GetShortPathName( PChar( fSystemDir+'SWFLASH.OCX' ), aShortPath, 2047 ); aCommand := Format( '%s egsvr32.exe /s %s', [fSystemDir, aShortPath] ); WinExecAndWait32( aCommand, SW_HIDE ); end; FreeLibrary( aHandle ); end; //Try Creating the Form Again try Application.CreateForm(TForm1, Form1); except ShowMessage('Unable to find Macromedia Shockwave Flash.'); end; except ShowMessage('Unable to register Macromedia Shockwave Flash.'); end; {End of Registering the OCX File} 410

end; end; Application.Run; end. END OF PROJECT SOURCE HOW TO USE ACTIVEX CONTROL: Properties ReadyState (get only) - 0=Loading, 1=Uninitialized, 2=Loaded, 3=Interactive, 4=Complete. TotalFrames (get only) - Returns the total number of frames in the movie. This is not available until the movie has loaded. Wait for ReadyState = 4. FrameNum (get or set) - The currently displayed frame of the movie. Setting this will advance or rewind the movie. Playing (get or set) - True if the movie is currently playing, false if it is paused. Quality (get or set) - The current rendering quality (0=Low, 1=High, 2=AutoLow, 3=AutoHigh). This is the same as the QUALITY parameter. ScaleMode (get or set) - Scale mode (0=ShowAll, 1= NoBorder, 2 = ExactFit). This is the same as the SCALE parameter. AlignMode (get or set) - The align mode consists of bit flags. (Left=+1, Right=+2, Top=+4, Bottom=+8). This is the same as the SALIGN parameter. BackgroundColor (get or set) - Override the background color of a movie. An integer of the form red*65536+green*256+blue use -1 for the default movie color. Loop (get or set) - True if the animation loops, false to play once. Same as the MOVIE parameter. Movie (get or set) - The URL source for the Flash Player movie file. Setting this will load a new movie into the control. Same as the MOVIE parameter. Methods Play() - Start playing the animation. Stop() - Stop playing the animation. Back() - Go to the previous frame. Forward() - Go to the next frame. Rewind() - Go to the first frame. SetZoomRect(int left, int top, int right, int bottom) - Zoom in on a rectangular area of the movie. Note that the units of the coordinates are in twips (1440 units per inch). To calculate a rectangle in Flash, set the ruler units to Points and multiply the coordinates by 20 to get TWIPS. Zoom(int percent) - Zoom the view by a relative scale factor. Zoom(50) will double the size of the 411

objects in the view. Zoom(200) will reduce the size of objects in the view by one half. Pan(int x, int y, int mode) - Pan a zoomed in movie. The mode can be: 0 = pixels, 1 = % of window. Events OnProgress(int percent) - Generated as the Flash Player movie is downloading. OnReadyStateChange(int state) - Generated when the ready state of the control changes. The possible states are 0=Loading, 1=Uninitialized, 2=Loaded, 3=Interactive, 4=Complete. FSCommand(string command, string args) - This event is generated when a GetURL action is performed in the movie with a URL and the URL starts with "FSCommand:". The portion of the URL after the : is provided in command and the target is provided in args. This can be used to create a response to a frame or button action in the Shockwave Flash movie. For further information see the Macromedia Flash Website In order to include your Flash files into your Delphi Application, just type in the directory of the .SWF file, then make "Embed Movie" = True, and it will be included in your file and not look at the Movie parameter any longer Removing the popup menu in Macromedia Flash .OCX Note: Click Title to view in Edit Box for easier copying. Related Links Displaying Macromedia Flash .SWF files in your Delphi Application! Macromedia Flash Resizing In Delphi 5, place an "Application Events" component onto the form. On the "OnMessage" Event place the following code: procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean); begin if Msg.message = WM_RBUTTONDOWN then Handled := True; end; If by chance you wanted to place your own popupmenu, then do the following: procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean); begin if Msg.message = WM_RBUTTONDOWN then begin popupmenu1.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y); Handled := True; end; end; Hope that helps someone that wanted to know how to do this.

412

Formdaki tum enter tuslarini tab olarak yorumlar; butonlarinki haric!!! formun private kismina yazilacak: Procedure CMDialogKey(Var Msg:TWMKey); message CM_DIALOGKEY; formun implementation kismina yazilacak: Procedure TForm1.CMDialogKey(Var Msg: TWMKey); Begin If NOT (ActiveControl Is TButton) Then If Msg.Charcode = 13 Then Msg.Charcode := 9; inherited; End; *bu kodla her kontrole OnKeyPressed yazmaktan kurtulursun *kodun hizli calismasini saglamak icin formun keypreview'ini kapat *ornege bakarak butondan baska kontrolleride haric tutabilirsin

413

Hint'leriniz ekranda daha uzun süre kalsın Formunuzun OnCreate olayina asagidaki kodu yazin. Buradaki deger milisaniye cinsindendir. 1 saniye=1000 milisaniye. Application.HintHidePause := 4000; {buradaki deger milisaniye cinsindendir

ICO Dosyalarını BMP ye Çevirme ico'dan bmp'ye çevirme; var Icon : TIcon; Bitmap : TBitmap; begin Icon := TIcon.Create; Bitmap := TBitmap.Create; Icon.LoadFromFile('c:\picture.ico'); Bitmap.Width := Icon.Width; Bitmap.Height := Icon.Height; Bitmap.Canvas.Draw(0, 0, Icon ); Bitmap.SaveToFile('c:\picture.bmp'); Icon.Free; Bitmap.Free; end;

IDE için ipuçları ? Panel üzerindeki bilesenleri fare ile tiklayip sürükleyerek seçmek için Ctrl tusuna basili tutun. ? Nesnelerin iki tür özelligi olabilir:design-time ve run-time. Tasarim aninda degistirilebilen tüm özellikler çalisma aninda da degistirilebilir. ? Bilesenleri View->Alignment Palette veya sag tus->Alignment veya Edit->Align ile hizalayabiliriz. ? Compile menüsünden Syntax Check ile çok hizli bir sekilde (programi derlemeye göre) yazmis oldugunuz kodda imla kontrolü yapar. ? Bilesen paletinde çok fazla sayfaniz oldugunda bir bilesene ulasmak için bunlari kaydirmaniz gerekir. Bu durumda sayfalari daha kisa adlarla isimlendirin, böylece tüm sayfalar ekrana sigar. ? Delphi projenin tüm kod dosyalarini, son derlemeden bu yana degisip degismedigini kontrol eder ve sadece degisen dosyalari derler. Projedeki tüm dosyalari degisiklige ugrayip ugramadigina bakmadan derlemek için Project->Build All. ? Project->Information ile yapmis oldugunuz en son derleme hakkinda bazi bilgileri görebilirsiniz. ? Delphi'de hemen hemen her bilesende SpeedMenu ismi verilen menüler vardir. Bu menüyü görmek için bilesene sag tiklayin. Bazi islemleri çok kolay bir sekilde yapabilirsiniz. Bence buna alisin ve her bilesenin SpeedMenu'sünü kontrol edin. Mesela QuickReport gibi bir bilesen ile çalisirken SpeedMenu çok isinize yarayacaktir. ? Bir form üzerindeki birden fazla bileseni seçmek için Shift tusunu kullanabilirsiniz. Seçmek istediginiz bilesenlerden birine tiklayin, sonra Shift tusuna basarak seçmek istediginiz diger bilesenlere tiklayin. Shift tusuna basarken seçili bir bilesene tiklarsaniz seçim iptal edilir. Bu arada Object Inspector seçtiginiz bilesenlerin ortak özelliklerini gösterecek sekilde degisir. Bu seçme islemini fare ile de yapabilirsiniz. Fareyi tiklayin ve fareyi sürükleyerek seçmek istediginiz bilesenleri içine alin ve birakin. Bu islem bazen çok faydali olur. Mesela bir form üzerindeki tüm Edit kontrollerinin rengini degistirmek gibi. 414

Hepsiyle tek tek ugrasmazsiniz. ? Bir bileseni seçtikten sonra Ctrl tusuna basarak yerini ayarlayabilirsiniz. Ctrl tusuna basarak sag oka basarsaniz bilesen saga dogru kayar. Ayni sekilde Ctrl tusu basili iken sol ok tusuna basarsaniz sola, üst ok tusuna basarsaniz üste ve alt ok tusuna basarsaniz alta dogru kayar. Böylece bilesenlerin form üzerindeki yerini ince ayarlarla yapabilirsiniz. Shift + Ctrl + Ok tuslarina basarsaniz bilesen grid araliklari boyunca ilerler. Grid form üzerinde görünen noktalardir. ? Koda yorum veya açiklama eklemek için //, { }, (* *) kullanabilirsiniz. // tek satir için kullanilir. { } ve (* *) arasina yazdiginiz her sey yorum olarak kabul edilir. ? Bilesenlerin form üzerindeki yerini yanlislikla degistirilmesini engellemek için Edit menüsü altindan Lock Controls komutunu kullanabilirsiniz. Bu form tasarimini bitirdiginiz zaman örnegin bir bileseni çift tiklayip kod yazmak isterken yerini degisitrmenizi önleyecektir. ? Iki dosyayi karsilastirmak için View menüsünden New Edit Windows komutunu verin. Yeni bir editör penceresi açilacaktir. ? Proje içindeki tüm dosyalarda arama yapmak için Search menüsü altindan Find in Files komutunu kullanabilirsiniz. ? Menü çubuguna direk olarak bir komut eklemeyin. Kullanicilar buna pek alisik degildir. Ancak herhangi bir nedenle bir komutu menü çubuguna koymak istiyorsaniz bu durumda kullanilan standart ünlem isaretini de komut sonuna ekleyin. Mesela Çikis! gibi. ? Bir bileseni seçtikten sonra klavyeden ESC tusuna basarsaniz, seçili bilesenin ebeveyni (parent) olan bilesen seçilir. Bunu üzerine panel vb. bilesenler oldugu için seçemediginiz formlari seçmek için kullanabilirsiniz. Formun üzerindeki panele tiklayin ve ESC tusuna basin. Form seçilecektir. ? Kodunuzu düzenlerken bir kod parçasini blok halinde saga kaydirmak için kodu seçin ve CTRL+SHIFT+I tuslarina basin. Sola kaydirmak için CTRL+SHIFT+U tuslarina basin. ? Klavyede olmayan bazi özel karaktereri programinizda kullanmak isteyebilirsiniz. Mesela © gibi. Bu karakteri yazmak için klavyeden ALT tusuna basarak 0169'u tuslayin. Yalniz 0169'u harflerin üstünde olan rakamlardan degil, klavyenin sag tarafinda yer alan rakamlardan yazmalisiniz. Diger karakterlerin karsiliklarini ögrenmek için Windows'un Character Map programini kullanabilirsiniz.

Imleci (cursor) gizleyip, tekrar gösterme ShowCursor(False) //imleci gizler ShowCursor(True) //imleci tekrardan gösterir. İki Durumlu Düğme Oluşturma ve Düğme Animasyonu Aşağıdaki kodlar uygun yordamlara yazılır. Bitbtn.Glyph.LoadFromFile('door01.bmp'); Bitbtn.Glyph.LoadFromFile('door02.bmp'); door01.bmp ve door02.bmp dosyaları geçerli dizinde olmalı yada gösterilen dosya yolunda olmalıdır.

Düğme animasyonu için Yeteri kadar düğme resmi oluşturun (w1.bmp,w2.bmp, ...) 415

Timer nesnesine aşağıdaki kodu yazın bitbtn1.Glyph(LoadFromFile('w'+inttostr(say)+'.bmp')); say:=(count mod 16)+1;

İmlecin Ekranın Neresinde Olduğunu Öğrenme procedure TForm1.Button1Click(Sender: TObject); var Yer:TPoint; begin if Assigned(ActiveControl) then begin Yer:=Point(0,0); { burda 0,0 imleç'in ekrandaki yeri oluyor } ActiveControl.ClientToScreen(Yer); SetCursorPos(Yer.X,Yer.Y); end; end;

Kaydırma Çubuklar İle Nesne Kontroll ScrollBox in taklit edilmesini sağlar image1.left:=-[(image1.width-).(scrollBar1.pozition)] div scrollbar1.max image1.top:=-[(image1.Height-).(scrollBar1.pozition)] div scrollbar1.max

sayı=0 alınırsa bir pencere (Panel yada form) boş görüntü oluşur bunu engellemek için sayı1:=panel1.Wiidth alınabilir.

Klasöre Gözat diyalogunu kullanarak bir klasörü seçme uses kismina 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 416

SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); end; end; Kod Şablonu Yazma Sık kullandığınız kodları bir şablona dönüştürerek hız kazanabilirsiniz;

Tools menüsünden Environtment Optionsu açıp Code Insight sekmesine kayın Add düğmesi ile yeni bir şablon oluşturmaya başlayın Çıkan iletinin ShortcutName kısmına kodu görüntüleyecek karekterleri yazın (ör speed) Description kısmına kodu tanımlayacak cümleyi yazabilirsiniz (Kısa olması tasiye edilir ör: 'Button durum kodu') Ok dedikten sonra Code kısmına şablonunuzu yazabilirsiniz. Onaylayıp çıktığınızda kod şablonu kullanıma hazırdır. Şablonu Unit de kuıllanmak için Ctrl+J ye basın ve speed yazın (ilk bir iki harf yeterli olabilir) şablonunuzu görüp aktif yaptıktan sonnra entere basın şablonunuz Unitinize eklenecektir.

Komut Tuşalarını Kontrol Etmek if (ssctrl in shift) then... if (ssshiftl in shift) then... if (ssaltl in shift) then...

String Kopyalama s:='Kopyalama' s:=copy(s,2,4); Dönen değer:opya veya s:=copy('Kopyalama',2,4); Dönen değer:opya s nin 2. karekterinden itibaren 4 karekterini al

ListBox (Vaya ComboBox) seçili öge(leri) seçilmemis hale getirme ListBox1.ItemIndex:=-1; Combobox1.ItemIndex:=-1;

Listbox, Combobox ve Memo'ya bir seferde ekleme yapmak; Listbox1.items.SetText('aaa'#13'bbb'#13'ccc'); Memo1.Lines.SetText('aaa'#13'bbb'#13'ccc'); 417

Listbox'a yatay kaydırma çubuğu eklemek Formunuzun OnCreate olayina asagidaki kodu ekleyin. SendMessage(Listbox1.Handle, LB_SetHorizontalExtent, 1000, Longint(0)); Listbox'ta kaydırma çubuğunu kod ile aşağı çekme

Listbox'ta 11. ögeyi listenin en basina getirmek için için asagidaki kodu yazin. SendMessage(ListBox1.Handle,lb_SetTopIndex,10,0); Eger 25. ögeyi liste basi yapmak istiyorsaniz SendMessage(ListBox1.Handle,lb_SetTopIndex,24,0);

Listedeki Seçili Öğenin Seçimini İptal Etmek Listbox veya Combobox'ta seçili bir veya birden fazla öğeyi seçilmemiş duruma getirmek için; Listbox1.itemindex:=-1; Locate Metodu İle Bir Kayda Ulaşma table1.locate('AD',, :text1.text, 'Ahmet' vs : lopartilakey : Aranan kayda en yakın kaydı bul locaseInsenstine: : Büyük-küçük harf ayrımı yapma

Map Network Drive diyalogunu açma WNetConnectionDialog ( 0, RESOURCETYPE_DISK );

Master-Detay (İlişkili) Tablolar Table1, Table2. DataSource1, DataSource2 yi forma yerleştir (Tablolar indeksli olmalı) Table2 de MasterSource yi DataSource1 yap (İlişki kurulacak sütün) AvailableIndexes de indekseleri seç ve Add yap

Mause yi aktif nesne üzerine taşımak procedure Tform1.Button1Enter(Sender: TObject); var Control : TControl; //control sınıfı oluşturuluyor xMerkez, yMerkez : Integer; Merkez : TPoint; //mause için ekran koordinat tipi tanımlanıyor 418

begin Control := TControl( Sender ); xMerkez := Control.Width div 2; yMerkez := Control.Height div 2; //aktif nesnenin (sender) merkezi bulunuyor Merkez := Point(xMerkez, yMerkez); //değerler point tipine çevriliyor Merkez := Control.ClienttoScreen(Merkez); kontrolün ekrandaki yeri tespit edilliyor SetCursorPos(Merkez.X, Merkez.Y); //mause taşınıyor end;

Memo içinde imlecin hangi satir ve kolonda oldugunu bulma var LineNum:logint; CharsBeforeLine:logint; begin LineNum:=SendMessage(Memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0); CharsBeforeLine:=SendMessage(Memo1.Handle,EM_LINEINDEX,LineNum,0); Label1.Caption:='Satir'+IntToStr(LineNum+1); Label2.Caption:='Kolon'+IntToStr((Memo1.SelStart-CharsBeforeLine)+1);

Menü Öğelerini Aktif/Pasif Yapmak Bir menü öğesinin enabled özelliğini false yapmak; mainmenu1.items[0].items[1].enabled:=False;

Mesaj Kutuları a)Show Message; Showmessage('Mesaj metni');

b)MessageBox; Application.MesssageBox('Mesaj metni','Başlık', ) (Butonlar) 0 Ok 1 Tamam, İptal 2 Durdur, Yeniden Dene, Yoksay 3 Evet, Hayır, İptal 4 Evet, Hayır 5 Yeniden Dene, İptal 8 İptal, Yardım İşaretler 419

16 Kritik x 32 Soru ? 64 Bilgi İ 48 Dikkat ! sayı=3+64 ise Evet, Hayır, İptal düğmeleri ile Bilgi işareti bulunur

Mouse'un yerini değiştirmek randomize; SetCursorPos(random(100),random(100));

Num Lock, Scroll Lock, Caps Lock Işıklarını Açmak ve Kapamak procedure TForm1.Button1Click(Sender: TObject); Var KeyState : TKeyboardState; begin GetKeyboardState(KeyState); if (KeyState[VK_CAPITAL] = 0) then KeyState[VK_CAPITAL] := 1 else KeyState[VK_CAPITAL] := 0; SetKeyboardState(KeyState); end;

VK_CAPITAL (CapsLock) :20 ScrollLock :145 VK_NUMLOCK (NumLock) :144

On FilterRecord İle Filtre Koymak OnFilterRecord yordamına aşağıdaki kod yazılır

Table1.fltered:=false olmalı

if Table1['SINIF']=edit1.text then accept:=True; else accept:=False (<,> ile belli bir aralık alınabilir) Çalıştırma; Table1.Filtered:=True; Table1.OnFilterRecord:=Table1FilterRecord

Filtreyi iptal etmek; Table1.OnFilterRecord:=NIL; 420

Otomatik Açılan Cd Yapma (Autorun) [Autorun] open=\prog.exe icon=\prog.exe metin belgesini "autorun.inf" olarak CD nin ana dizinine kopyala

Park Eedilebilir Nesneler ve Formlar Oluşturmak Park kabül edecek nesne için DoctSite ----> True Park edilece nesne için... DragKind ---> dkDock DragMode---> dnAutomatic AutoSize ---> True olmalı Dosya Kopyalama Birinci Yol -------------------------------------------------------------------------------Kalıp : BOOL CopyFile( LPCTSTR lpExistingFileName, // Kaynak Dosya LPCTSTR lpNewFileName, //Hedef Dosya BOOL bFailIfExists // Dosyanın Var olup Olmadığı ve ne yapması Gerektiği True/False ); Ör : Result:=CopyFile(PChar(SrcTableName),PChar(DestName),True); Bu Kopyalama işlemi Çok hızlı olup Dosyanın aktif veya pasif olması önemli değil kopyalar. İkinci Yol -------------------------------------------------------------------------------Bu işlem Windows'un standart Kopya işlemini yapar. SehellApi Dosyasında Detaylı bir şekilde görebilirsiniz. Kalıp : TSHFileOpStructW = packed record Wnd: HWND; //Aktif Window Handle wFunc: UINT; // Yapılacak İşlem Koya,Silme vs.. pFrom: PWideChar; // Kaynak Dosya pTo: PWideChar; // Hedef Dosya fFlags: FILEOP_FLAGS; // Default 0 fAnyOperationsAborted: BOOL; // Olayı İptal Etmek yada Etmemek hNameMappings: Pointer; lpszProgressTitle: PWideChar; //Pencere Başlığı 421

end; Ör : Var FO : TSHFileOpStruct; Aborted : Boolean; With Fo Do Begin Wnd:=Handle; WFunc:=FO_COPY; PFrom:=pchar(St1.Cells[0,F]); pTo:=pchar(St1.Cells[1,F]); FFlags:=0; fAnyOperationsAborted:=Aborted; End; try SHFileOperation(FO); finally end;

Klasik Pascal Dosya Kopyalaması -------------------------------------------------------------------------------AssignFile(FromF, OpenDialog1.FileName); Reset(FromF, 1); { Record size = 1 } if SaveDialog1.Execute then { Display Save dialog box} begin AssignFile(ToF, SaveDialog1.FileName); { Open output file } Rewrite(ToF, 1); { Record size = 1 } Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF)) + ' bytes...'); repeat BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten); until (NumRead = 0) or (NumWritten NumRead); CloseFile(FromF); CloseFile(ToF); end; end;

*** Dosya aktifse kopyalama olmaz ! Duvar Kağıdını Değiştirmek var s: string; begin s := 'c:\windows\athena.bmp'; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(s),0); Edit İçine Sadece Rakam Yazdırmak 422

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if not (key in ['0'..'9',#8]) then key:=#0 end;

Edit'e Girilen Metnin İlk Harfini Büyük Harf Yapma Form'a bir Edit componenti yerleştirin ve OnKeyPress olayına aşağıdaki kodu ekleyin. with Sender as TEdit do if (SelStart = 0) or (Text[SelStart] = ' ') then if Key in ['a'..'z'] then Key := UpCase(Key); Ekran Çözünürlüğünü Öğrenme Screen.Width //yatay çözünürlük Screen.Height //dikey çözünürlük MessageDlg('Su anda ' + IntToStr( Screen.Width ) +' x '+ IntToStr( Screen.Height )+' çözünürlükte çalisiyorsunuz', mtInformation, [mbOk], 0 ); Ekran Görüntüsünü Aktarma

Belirttiğiniz sınırlar dahilinde ekranın belli bir alanını formunuzun üzerine koymak isterseniz. Formunuza image1 adlı bir resim objesi ekleyin ve daha sonra formunuzun create olayına şu kodu yazın.

procedure TForm1.FormCreate(Sender: TObject); var DCDesk: HDC; begin DCDesk:=GetWindowDC(GetDesktopWindow); BitBlt(Image1.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,DCDesk, 0, 0,SRCCOPY); ReleaseDC(GetDesktopWindow, DCDesk); end;

Ekran Koruyucuyu Çalışyıtma //kapatmak için SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 423

0); //açmak için SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0); Ekran çözünürlüğünü değiştirme Form üzerine Button1 adlı bir buton koyun. Button1'in OnClick Event'ine aşağıdaki kodu yazın. procedure TForm1.Button1Click(Sender: TObject); var dev1:TDeviceModea; begin enumdisplaysettings(nil,0,dev1); dev1.dmpelswidth := 720; dev1.dmpelsheight := 576; dev1.dmFields := DM_PELSWIDTH + DM_PELSHEIGHT; changedisplaysettings(dev1,0); end;

Ekran görüntüsünün alınması 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: Yukaridaki kod ekran görünütüsünü form üstüne alir. Image bileseni içine ekran görüntüsünü almak için form üzerine bir image bileseni yerlestirin ve Form1.Canvas.Handle yerine Image1.Canvas.Handle yazin.

Eliptik Form Oluşturma var parametre:hrgn; begin parametre:=createellipticrgn(0,0,width,height); setwindowrgn(form1.handle,parametre,true); //(x koordinatı, y koordinatı, genişliği, yüksekliği) end;

Enter Tuşuna Basılmış Gibi Gösterme Windows programlarında bir alttaki alana geçmek için TAB tuşu kullanılır.Ancak DOS programlarından gelen alışkanlıkla kullanıcılar hep Enter ile alt alana geçmek ister ve bu bir tik olmuştur. Delphide Enter tuşu ile bir alt alana geçmek için bir yöntem; Formun Keypreview olayını True yapılır. 424

Form üzerinde herhangiki tüm bileşenlere Default false yaplır. formun onKeypres olayına aşağıdaki function ilave edilir. procedure TAdresformu.FormKeyPress(Sender: TObject; var Key: Char); begin if Key = #13 then begin Key := #0; if (Sender is TDBGrid) then TDBGrid(Sender).Perform(WM_KeyDown,VK_Tab,0) else Perform(Wm_NextDlgCtl,0,0); end;

Enter tusuna basıldığında bir sonraki kontrole geçme Enter tusuna bastiginizda Windows'un bir sonraki kontrole geçmesi için (Tab tusuna basilmis gibi) Formunuzun KeyPreview özelligini True yapin ve formun OnKeyPress olayina asagidaki kodu yazin. procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if (Key = #13) then begin Key := #0; Perform(WM_NEXTDLGCTL, 0, 0); end; end

Fareyi mesgul sekilde göstermek

Bir islem yaparken makinenin mesgul oldugunu göstermek için fareyi kum saati seklinde gösterip sonra eski haline getirmek için asagidaki gibi bir kod kullanabilirsiniz. try Screen.Cursor := crHourGlass; {buraya kodunuzu yazin...} finally Screen.Cursor := crDefault; end; Application.ProcessMessages

425

Form hakkında kısa bilgi Form1.Show; {Formu göster} Form1.Showmodal { Formu showmodal olarak göster (Showmodal iken başka hiçbir forma ulaşılamaz) } myForm.Hide; {Formmu gizle } myForm.Free; {Formu sil }

Formu şeffaf hale getirilmesi OnCreate olayına Brush.Style:=bsClear; yazmanız yeterli.

Form üzerinde nesneleri taşıma MauseDown yordamına aşağıdaki kod yazılır const say=$F012; begin ReleaseCapture; .Perform(WM_SYSCOMMAND, say, 0); end;

Format Karekter Katarı (Biçimlendirme) Format(' Abuzittin %d denemesinde, %d puan aldı',[2,165] Çıktı: Abuzittin 2 denemesinde 165 puan aldı

Format(' Abuzittin %s denemesinde, %s puan aldı',['A', '165'] Çıktı: Abuzittin A denemesinde 165 puan aldı

d: ondalık h: onaltılık hane p: işaretçi s: karekter e: üstel f: kayan nokta g: genel n: sayı m: para Formun Kapatılmsını Engelleme 426

OnClose yada BeforeClose yordamına CanClose:=false; yazılır Formun minimizeye ya da maksimizeye dönüşmesini anlama public/private kısmına ; procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; yazılır ... ve implementation dan sonra procedure TForm1.WMSysCommand; begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0); //bu örnek için beep sesi var DefaultHandler(Msg); end;

yazılır

Form'un Arka Kısmına Bir Resmi Döşemek Bitmap: TBitmap; procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP'); end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end; end; 427

Geçerli Sürücünün Disk Boşluğunu Öğrenme O anki sürücünün kapasitesini ve sürücüdeki boş yer miktarını bulmak; DiskFree(0) //o anki sürücüdeki boş yer miktarını byte cinsinden döndürür. DiskSize(0) //o anki sürücünün kapasitesini byte cinsinden döndürür. DiskSize(0) div 1024 //o anki sürücünün kapasitesini KB cinsinden döndürür.

Geometrik Formlar Oluşturma Formumuzun OnShow Eventine aşşağıdaki kodu yazıyoruz. procedure TForm1.FormShow(Sender: TObject); var regionhandle:integer; area:array[0..2] of tpoint; begin area[0].x := 0; area[0].y := 0; area[1].x := 400; area[1].y := 0; area[2].x := 200; area[2].y := 200; regionhandle:=CreatePolygonRgn(area,3,ALTERNATE); // 3 polygonda kaç tane nokta olduğunu belirtir // area ise polygon koordinatlarının bulunduğu dizi. setwindowrgn(form1.handle,RegionHandle,true); end;

Area dizisinde verilen x,y koordinatlarına göre polgon hesaplanır. Hesaplanan Handle ile herhangi bir form'a bu polyon şekli verilebilir. Polgon dışında kalan grafikler yarım veya hiç gözükmez.

Güç koruma modunda ç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);

Hard Diskin Seri numarasını Öğrenmek procedure TForm1.Button1Click(Sender: TObject); var VolumeSerialNumber : DWORD; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; SerialNumber : string; begin GetVolumeInformation('C:\', nil, 0, @VolumeSerialNumber, MaximumComponentLength, FileSystemFlags, 428

nil, 0); SerialNumber := IntToHex(HiWord(VolumeSerialNumber), 4) + '-' + IntToHex(LoWord(VolumeSerialNumber), 4); Memo1.Lines.Add(SerialNumber); end; Hareketli İmleç (Animated Cursor) leri Kullanma procedure TForm1.Button1Click(Sender:TObject); var h : THandle; begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; Hareketli cursör yapmak procedure TForm1.Button1Click(Sender:TObject); var h : THandle; begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; Hata Yakalama procedure TForm1.Button1Click(Sender: TObject); begin try

(1) ilk çalışacak blok 429

Burda hata meydana gelirse program excepten itibaren devap eder.

Except (2) ilk blokta (1) hata oluşursa çalışacak blok (1) de hata oluşmazsa burası çalışmaz.

end Alt+F4 tus kombinasyonuyla programin kapanmamasi için Formun OnCreate olayina; KeyPreview := true; Formun OnKeyDown olayina; if ((ssAlt in Shift) and (Key = VK_F4)) then Key := 0;

Alt+Tab Ve Ctrl+Esc Tuslarini Kullanilmaz Hale Getirmek ar OldVal : LongInt; begin SystemParametersInfo (97, Word (True), @OldVal, 0) //Word(False) ile kullanirsaniz tuslari tekrar kullanabilirsiniz. Baslat butonunu gizlemek veya kullanilmaz hale getirmek procedure TForm1.Button1Click(Sender: TObject); var Rgn : hRgn; begin // Baslat 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 Baslat butonunu eski haline döndürmek için SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0, true); 430

end; procedure TForm1.Button3Click(Sender: TObject); begin //Baslat butonunu kullanilmaz yap EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); end; procedure TForm1.Button4Click(Sender: TObject); begin //Kullanilmaz yapilan Baslat butonunu eski haline getirmek için EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); end;

Belgeler Mönüsünü Temizleme uses kismina ShlOBJ unitini ekleyin; SHAddToRecentDocs(SHARD_PATH, nil);

Bir DataBase deki Alanlara Ulasma Table1.FieldByName('ADI').assitring; veya; datasource1.dataset.fields[].asstring veya table1.FieldsValues['ADI'] vaya; (Tavsiye edilen) table1['AD']

Bir Denetim Masasi uygulamasini çalistirmak Control Panel uygulamalari Windows\System klasörü altinda bulunur. *.CPL uzantili dosyalardir. Bu uygulamalari Control.Exe programi ile çalistirabilirsiniz. Bazi Control Panel uygulamalari Windows\System klasöründe bulunmaz. Bunlarin ismini vererek çalistirabilirsiniz. Winexec('Control.exe timedate sw_shownormal); WinExec('C:\Windows\control.exe. mouse', sw_ShowNormal); WinExec('C:\Windows\control.exe printers', sw_ShowNormal);

431

Bir Klasörü ve Onun Altindaki Tüm Dosyalari ve Klasörleri Silme Ancak salt okunur (read only) özelligi olan ve kullanimda olan dosyalar silinmez. procedure TForm1.Button1Click(Sender: TObject); var DirInfo: TSearchRec; r : Integer; begin r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo); while r = 0 do begin if ((DirInfo.Attr and FaDirectory <> FaDirectory) and (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name)) = false then ShowMessage('C:\Download\test\'+DirInfo.Name+' silinemiyor!!!'); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); if RemoveDirectory('C:\Download\Test') = false then ShowMessage('C:\Download\test klasörü silinemiyor!!!'); end;

Bir Menüye Resim (BMP) Eklemek

procedure TForm1.FormCreate(Sender: TObject); var Bmp1 : TPicture; begin Bmp1 := TPicture.Create; Bmp1.LoadFromFile('c:\deneme\turkey.bmp'); SetMenuItemBitmaps( deneme1.Handle, 0, MF_BYPOSITION, Bmp1.Bitmap.Handle, Bmp1.Bitmap.Handle); end; Bir Popup menüyü kod ile gösterme PopupMenu1.Popup(Form1.Left+60,Form1.Top+140); Bir Programi Çalistirmak

WinExec('c:\windows\calc.exe',sw_show); WinExec('pchar(FileListBox1.FileName),SwShow); Sadece exe, bat, ini, com uzantili dosyalari çalistirir.

432

Bir programi bagli oldugu uygulama (word, excel, P. brush vs.) ile çalistirmak Uses kismina "ShellApi" yazilir Unit "Shellexecute" eklenmeli Bu dosya geçerli dizinde \Source\RTL\WIN\ShellExecute dir ShellExecute(0,'Open','C:\Manzara.bmp','','',sw_show);

Bir dosyanin boyutunu bulmak procedure TForm1.Button1Click(Sender: TObject); var srFileSR: TSearchRec; sFileName, sFileSize: string; begin sFileName := 'c:\test\2.avi'; FindFirst(sFileName,faAnyFile,srFileSR); sFileSize := IntToStr(srFileSR.Size); Showmessage(sFileSize); end;

Bir doyayi geri dönüsüm kutusuna (recyle bin) atmak uses kismina shellapi unitini ekleyin. procedure TForm1.Button1Click(Sender: TObject); var T : TSHFileOpStruct; begin FillChar(T,SizeOf(TSHFileOpStruct),#0); with T do begin Wnd:=0; wFunc:=FO_DELETE; pFrom:=Pchar('c:\test\2.avi'); fFlags:=FOF_ALLOWUNDO; end; SHFileOperation(T); end;

Bir form üzerindeki tüm bilesenleri read only(salt okunur) yapma uses kismina typinfo unitini ekleyin. procedure TForm1.SetReadOnly( Value : boolean ) ; var PropInfo : PPropInfo ; Component : TComponent ; i : integer ; begin for i := 0 to ComponentCount - 1 do begin Component := Components[ i ] ; if Component is TControl then begin 433

PropInfo := GetPropInfo( Component.ClassInfo, 'ReadOnly' ) ; if Assigned( PropInfo ) and ( PropInfo^.PropType^.Kind = tkEnumeration ) then SetOrdProp( Component, PropInfo, integer( Value ) ) ; end ; end ; end ; procedure TForm1.Button1Click(Sender: TObject); begin SetReadOnly( true ) ; end;

Bir klasörün boyutunu ögrenmek Bir klasördeki dosyalarin kaç byte yer kapladigini ögrenmek için function TForm1.GetDirectorySize(const ADirectory: string): Integer; var Dir: TSearchRec; Ret: integer; Path: string; begin Result := 0; Path := ExtractFilePath(ADirectory); Ret := Sysutils.FindFirst(ADirectory, faAnyFile, Dir); if Ret <> NO_ERROR then exit; try while ret=NO_ERROR do begin inc(Result, Dir.Size); if (Dir.Attr in [faDirectory]) and (Dir.Name[1] <> '.') then Inc(Result, GetDirectorySize(Path + Dir.Name + '\*.*')); Ret := Sysutils.FindNext(Dir); end; finally Sysutils.FindClose(Dir); end; end; procedure TForm1.Button1Click(Sender: TObject); begin Showmessage(intToStr(getdirectorysize('C:\windows'))); end;

Bir menü ögesine resim ekleme 434

procedure TForm1.FormCreate(Sender: TObject); var Bmp1 : TPicture; begin Bmp1 := TPicture.Create; Bmp1.LoadFromFile('c:\deneme\turkey.bmp'); SetMenuItemBitmaps( deneme1.Handle, 0, MF_BYPOSITION, Bmp1.Bitmap.Handle, Bmp1.Bitmap.Handle); end;

Bir menü ögesini kullanilamaz hale getirmek MainMenu1.Items[0].Items[1].Enabled:=False; //ilk menünün, ikinci elemani Bir string'in basindaki ve sonundaki bosluklari atmak için Trim(string) TrimLeft (string) //stringin sadece basindaki bosluklari atmak için TrimRight (string) //stringin sadece sonundaki bosluklari atmak için

Bir web adresini açma uses kismina Shellapi unitini ekleyin; ShellExecute(Handle, 'open', 'http://www.geocities.com/siliconvalley/campus/4958/', nil, nil, sw_ShowMaximized);

Bmp dosyasini JPEG'e dönüstürme uses kismina jpeg unitini ekleyin. procedure TForm1.Button1Click(Sender: TObject); var MyJPEG : TJPEGImage; MyBMP : TBitmap; begin MyBMP := TBitmap.Create; with MyBMP do try LoadFromFile('c:\winnt\ACD Wallpaper.bmp'); MyJPEG := TJPEGImage.Create; with MyJPEG do begin Assign(MyBMP); SaveToFile('c:\winnt\ACD Wallpaper.JPEG'); Free; end; finally Free; 435

end; end;

Büyük Bir Nesneyi Küçük Bir Nesne İçeridinde Görüntüleme Nesneden (panel,form vs) büyük nesneyi (image, memo vs) nesne içinde görüntüleme;

image1.left:= - (image1.Width-panel1.Width)*scrollbar1.position div scrollbar1.Max; image1.top:= - (image1.Height-panel1.Height)*scrollbar2.position div scrollbar1.Max; panel1.Width ve panel1.Height degerleri 0 alinirsa nesne boyu (yada eni) büyüklügünde bir alan bos görülür.

CD Rom Sürücüsünü Açip Kapamak mciSendString('Set cdaudio door open wait', nil, 0, handle); // açmak için mciSendString('Set cdaudio door closed wait', nil, 0, handle); // kapatmak için veya açmak, mcisendString('Set cdaudio door open',nil,0,handle); kapamak mcisendString('Set cdaudio door closed',nil,0,handle);

Caps lock tusu açik mi, kapali mi? if (GetKeyState(VK_CAPITAL) and $01)<>0 then Showmessage ('caps lock açik'); ComboBox İçine Resim Yerlestirmek

VCL de saglanilan OwnerDraw sitilini kullanarak Tcombobox nesnesine resim yerlestirebiliriz. İki farkli sitil özelligi bizi ilgilendiriyor. bunlar: csOwnerDrawFixed Bütün resimlerin hepsi ayni boyutta ise csOwnerDrawVariable resimler farkli boyutlarda ise Önce onDrawItem olayini kullanmaliyiz. Bu olay, uygulama ne zaman isterse combobox'i tekrar çizilmesine yariyor. Tanimlamasi: procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState) Control Item'e sahip olan kontrol Index Gösterilecek aktüel itemin indeksi Rect İtemlerin gösterilmesi gerekilen liste kutusundaki dikdörtgen 436

State Bu itemin seçildigi gösterildigi yada odaklandigini gösterir (odSelected, OdDisabled, OdFocused) csOwnerDrawFixed sitilli combobox için ondrawItem olayinda bir bitmap yada metin çizen yordam yazarak hersey hallolur. csOwnerDrawVairable stilli combobox için bir az daha fazla is yapmamiz gerekiyor.Bu bölüm OnMeasureItem olayina olay handler'i yazmak olacak. Bu olay Drawitemden önce çagirilir böylece gerçekte nasil olmasi gerektigini tanitabiliriz. Tanimlamasi: procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); Control itemleri bulunduran kontroldür. Index gösterilecek olan aktüel itemin indeksidir. Height indekslenmis itemlerin dogru boyuta degistirebilceginiz degeri Adim adim uygulayin: yeni bir uygulama baslatin forma bir imagelist ve bir combobox yerlestirin Object Inspector'dan asagidaki özellikleri yerlestirin. Öge Özellik Deger Neden ComboBox1 Style csOwnerDrawFixed İtemlerin nasil çizildigini kontrol edebiliriz. ComboBox1 Items Add whatever strings you want here to be displayed alongside the bitmaps. Grafikal gösterimden daha iyisi bir metinsel gösterim saglar. ImageList1 ImageList Editorü kullan Ayni boyutta ve ayni kuralda istediginiz gibi göründügünden emin oldugunuz bit eslemleri ekleyin Eger transparent renk istiyorsaniz tanimlayin. Combobox'da kullanilmasini istediginiz resimler. En son olarak OnDrawItem olayina su kodu yazin: procedure TForm1.ComboBox1D rawItem(Control: TWinControl; Index:Integer; Rect: TRect; State: TOwnerDrawState); begin (* kullanilan dogru highlite rengi barindirir *) combobox1.canvas.fillrect(rect); (* Aktüel resmi çizer *) imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,Index); (* resimden sonra metini girern satirdir.*) combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top, combobox1.items[index]); end;

Combobox'in listesini kod ile açip kapatma SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0); {listeyi açar} SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0); {listeyi kapatir ComboBox'in asagiya listelemesinin farkli bir yolu (DropComboBox) 437

SendMessage(ComboBox1.handle , 1039, 1, 0); Çok Satirli İpucu Olusturmak procedure TForm1.FormCreate(Sender: TObject); begin SpeedButton1.Hint:='Çok satirli ipucunu '+chr(13)+ 'mutlaka denemelisiniz '+chr(13)+ 'çok güzel'; end;

Dikdörtgen olmayan Edit'ler olusturmak Degisik sekilde bir edit elde etmek için formun OnCreate olayina asagidaki kodu yazin. SetWindowRgn(Edit1.handle, CreateRoundRectRgn(2,2,Edit1.Width-2,Edit1.Height-2,15,15), True); Pencerenin kapatma düğmesini etkisiz hale getirme Pencerenin baslik çubugunda bulunan kapatma dügmesini (X) etkisiz hale getirebilirsiniz. Ayni zamanda sistem menüsündeki Kapat(Close) seçenegide kaybolur. Bunun için asagidaki gibi bir kod yazmalisiniz. procedure TForm1.Button1Click(Sender: TObject); var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Form1'); //Form1 pencerenin basligini göstermektedir. if (hwndHandle <> 0) then begin //Burayi uygulamaniza göre degistirin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end

Programa Özel Kursör Aşağıdaki kodu kullanarak programınızda kullandığınız kursör'leri değiştirebilirsiniz. procedure TForm1.FormCreate(Sender: TObject); const crMyCursor = 5; //Burdaki 5 değeri yerine mevcut kursör değerleriyle çakışmayacak herhangi bir değerde verilebilir var Dosya:String; begin Dosya:=ExtractFileDir(Application.ExeName)+'\Kursor\'; Screen.Cursors[crMyCursor]:= LoadCursor(HInstance, Pchar(Dosya+'dinosaur.ani')); Cursor := crMyCursor; Screen.Cursors[crHourglass] := LoadCursorfROMfILE(Pchar(Dosya+'horse.ani')); Screen.Cursors[crNone] := LoadCursorfROMfILE(Pchar(Dosya+'drum.ani'+#0)); Screen.Cursors[crDefault] := LoadCursorfROMfILE(Pchar(Dosya+'fillitup.ani'+#0)); Screen.Cursors[crSize] := LoadCursorfROMfILE(Pchar(Dosya+'hand.ani'+#0)); 438

Screen.Cursors[crSizeNESW] := LoadCursorfROMfILE(Pchar(Dosya+'metronom.ani'+#0)); Screen.Cursors[crSizeNS] := LoadCursorfROMfILE(Pchar(Dosya+'3dgns.cur'+#0)); Screen.Cursors[crSizeNWSE] := LoadCursorfROMfILE(Pchar(Dosya+'dinosau2.ani'+#0)); Screen.Cursors[crSizeWE]:= LoadCursorfROMfILE(Pchar(Dosya+'banana.ani'+#0)); Screen.Cursors[crNoDrop]:= LoadCursorfROMfILE(Pchar(Dosya+'handNo.ani'+#0)); Screen.Cursors[crSQLWait]:= LoadCursorfROMfILE(Pchar(Dosya+'barber.ani'+#0)); Screen.Cursors[crDrag]:= LoadCursorfROMfILE(Pchar(Dosya+'Droppage.Cur'+#0)); end;

Programınızı kaydettiğiniz dizinin altına "Kursor" isimli bir dizin açmayı ve yukarıda adı geçen ve uzantısı .ani veya .cur olan dosyaları bu dizinin altına kopyalamayı unutmayın. Programın çalıştırılmasını bekletmek (Sleep) Bazi islemlerden sonra diger bir islemi çalistirmadan önce bir süre beklemek istersiniz. Bu gibi durumlarda Sleep komutunu kullanabilirsiniz. Burada verilen deger milisaniye cinsindendir. (1 saniye=1000 milisaniye) Sleep(10000) //10 saniye bekler Programın sadece bir kez çalıştırılmasını sağlama Normalde kullanici programinizi istedigi kadar çalistirabilir veya bazi sabirsiz kullanicilar program simgesine ard arda birkaç defa tiklayip birden fazla program penceresi açabilirler. Yani ayni anda 7-8 tane programi açabilir. Eger bunun böyle olmasini istemiyorsaniz: Formun OnCreate olayina asagidaki kodu ekleyin: if GlobalFindAtom('PROGRAM_RUNNING') = 0 then atom := GlobalAddAtom('PROGRAM_RUNNING') else begin MessageDlg('Program zaten çalisiyor!', mtWarning, [mbOK], 0); Halt; end; ve formun OnDestroy olayina da asagidaki kodu ekleyin. Hepsi bu kadar. GlobalDeleteAtom(atom); Sayilari virgüllerle yazmak 1) Bu is için FormatFloat fonksiyonunu kullanabilirsiniz. Sayi windows'unuz ayarina göre 12.345.678 veya 12,345,678 seklinde gösterilir. procedure TForm1.Button1Click(Sender: TObject); var i : integer; begin i := 12345678; Memo1.Lines.Add(FormatFloat('#,', i)) 2) Eğer işlemlerde kullanılmayacak, sadece görüntü güzelliği için kullanılacaksa ... procedure TForm1.Button1Click(Sender: TObject); var 439

a,i:integer; s:string; begin s:=Edit1.Text; i:=length(s); if pos(',',s) <>0 then exit; for a:=1 to i-1 do if (a mod 3)=0 then insert(',',s,i-a+1); Edit1.text:=s; end; 3) Delpi ile program yazarken özellikle para işlemlerinde rakamları virgüllerle ayırarak (örneğin:525,000,000)şeklinde yazdırmak istediğinizde Delphinin size sunduğu Format fonksiyonunu kullanabilirsiniz.Bu fonksiyonun kullanılışı şu şekildedir; Edit1.Text:=FormatFloat('###,###,###',x). Fakat bu fonksiyonu kullandığınızda Delphi bilgisayarınızın ayarına göre virgül yerine nokta ile ayırarak sayıları yazabilir.Bunun yerine sizde kendiniz bir function yazarak bu işlemi yaptırabilirsiniz. Örnek bir function yazılımı: function virgul(gelen:real):string; var x,y:integer; giden:string; begin Str(gelen:0:0,giden,x); x:Length(giden); y:=x-2; while y>1 do begin insert(',',giden,b); b:=b-3; end; virgul:=giden; end; Yukarıdaki functionu programınıza ekler ve yezdırmak istediğiniz sayıları yazdırırken kullanırsanız(örneğin:Edit1.Text:=virgul(sonuc);)sayıları virgullerle ayırarak yazdırmış olursunuz...

SetRange İle Filtre Koymak Table1.SetRangeStart Table1['AD']='Ahmet' Table1.SetRangeEnd; Table1.['AD']='Hakan' Table1.ApplyRange İptal Etmek İçin

Table1.SetRangeStart 440

Table1.SetRangeEnd; Table1.ApplyRange Sıcak Nokta (Hot Point) Öğesi Oluşturmak Çoğu web sitesinde bir yada birden fazla sıcak noktası-yeri olan ve bunların tıklanmasıyla bazı işlevleri yerine getiren grafiksel resimler görürsünüz. Bu sıcak noktalar birbirinden ayrı resimlerden ve onların bağlantılarından başka bir şey değildir. Bununla birlikte bazı resimler farenin kendi bölgelerinden geçmesiyle bir hint gösterirler yada tıklandığınızda bir müzik çalarlar. Genellikle web tasarımcıları bu tip etkileri yaratmak için Java programlama dilini kullanırlar. Bu yazıda,Size şeffaf delphi sıcak nokta öğelerini nasıl yaratacağınızı göstereceğim. Bu öğeyi bir formda bir image yada shape öğesinin istediğiniz bir bölgesinin üzerine yerleştirebilirsiniz;böylece bu nesne bir hint gösterebilir, farenin tıklanması yada sürükle bırak hareketi gibi fare hareketleri ile bazı işlevler yerine getirebilir.

Sıcak Noktadan İstenilen Başlamadan önce, sıcak nokta öğemizin hangi davranışları sergileyeceğine karar verelim. Öncelikle biz öğemizin şeffaf olmasını istiyoruz. Sonra; eğer visible özelliği false durumda ise arkasında görünen herhangi bir image yada shape'in o bölgesini işlevsizleştirecek bir öğe istiyoruz Ayrıca fare hareketlerine cevap vermek için bir öğe istiyoruz, Fakat bir pencere kontrol öğesi yaratmak istemiyoruz çünkü sistem kaynaklarını çok fazla tüketmektedir. Eğer başka pencereli öğeler içeren formda bazı sıcak noktalar yaratacaksak, bu dikkat edilmesi gereken bir konudur. Bu gereksinimler,TpaintBox ve TLabel öğe sınıflarında sağlanmıştır. Aslında Paintbox öğesi için OnPaint olay handler'i yaratmazsanız yada caption'suz bir label yaratırsanız ve transparent özelliğini True yaparsanız aynı şeffaf etkiyi yapabilirsiniz. Ne yazık ki bu öğe sınıflarının tümü bizim gerçekten istemediğimiz yada ihtiyacımız olmayan davranışları da gösterir.Bu öğelerin temel sınıfı olan TGraphicControl sınıfını deneyebilirsiniz. Öğemizi geliştirirken ilgilendiğimiz bütün özelliklerinin tanımlarını bulacaksınız. Fakat bunları Property editörde yayınlamaz.Buna göre TGraphicControl'den yeni bir sınıf ile istediğimiz gibi tam bir öğe yaratabiliriz ve yayımlanmamış özellikleri yayımlanmış gibi tekrar tanımlayabiliriz. Tanımlamalar Şimdi sıcak nokta öğemizi yaratalım. Önce Component Expert menüsünden THotspot adlı bir nesne yaratalım ve bunu öğe paletinde Birliksoft sayfasına yerleştirelim. Yeni öğe sınıfı için kaynak kod göründüğünde Aşağıda çizgiler ile ayrılmış kodu girin. Eğer bunu Delphi 2.0 ve üstü için 441

kullanacaksanız OnStartDrag özelliğini aktif hale getirin. unit Sicaknokta; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TSicaknokta = class(TGraphicControl) private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } property Align; property ShowHint; property Visible; property Enabled; property OnClick; property OnDblClick; property OnMouseDown; property OnMouseUp; property OnMouseMove; property OnDragDrop; property OnEndDrag; {property OnStartDrag; //Delphi 2.0 ve üstü için sadece! } end; procedure Register; implementation procedure Register; begin RegisterComponents('Y² Sınıfları', [TSicaknokta]); end; end.

--------------------------------------------------------------------------------

Kod girmeyi tamamladığınızda HOTSPOT.PAS olarak kaydedin ve bir öğe kütüphanesinin içine kurun. Ardından boş bir form yaratın ve formun üstüne bir image öğesi yerleştirin. Image öğesine çift tıklayın ve IMAGES\SPLASH\256COLOR dizinindeki SHIPPING.BMP dosyasını yükleyin. HotSpot öğesini biteşlemin sağ alt köşesine yerleştirin ve geminin 442

pruvasını kaplayana kadar genişletin. Sonra Hotspot öğesinin Hint özelliğini Geminin pruvası olarak değiştirin. Ana formun ShowHint özeliğini True yaparak bu hint'i enable yapın. HotSpot öğesinin Cursor özelliğini crUpArrow olarak değiştirin. En son olarak bir OnClick olay handlerini yaratmak için hotspot öğesinin üzerini çift tıklayın ve aşşağıdaki şekilde değiştirin:

procedure TForm1.HotSpot1Click(Sender: TObject); begin ShowMessage('Pruvayı tıkladınız...'); end;

Bu uygulamayı derleyip çalıştırdığınızda,dikkat ederseniz; sıcak nokta bölgesi üzerinde hareket ettiğinde imleç yüzeyi bir yukarı oka dönüşüyor ve Şekil A da görüldüğü gibi hint penceresi görünüyor. Sıcak noktayı tıkladığınızda. Şekil B de görüldüğü gibi bir diyalog kutusu ve bir mesaj görüntüleniyor.

Sıralama Algoritması

s.array(1..15) of integer ..... for x:= 1 to 15 do for y:=1 to 14 do if s[y]>s[y+1] then begin ;//sonraki küçükse yer değiştir z:=s[y]; s[y]:=s[y+1]; s[y+1]:=z; end; end; end; veya -----------------------------------------------------------------------------------------------; procedure kucuktenbuyuge; var a,b,say:integer; begin for a:=1 to 14 do for b:=a+1 to 15 do if sayi[a]>sayi[b] then begin say:=sayi[a];sayi[a]:=sayi[b];sayi[b]:=say; end; end; 443

En Büyüğünü-En Küçüğünü Bulma s:array[0..9] pf integer =(1,5,7,2,90,3,3 ,4,7,8,7) ... k=s[0] for a:=1 to 9 do if s[a]>s[a+1] then k=s[a+1]

Sistem Tarihini ve Saatini Değiştirmek Sistemin tarihini ve saatini değiştirmek için SetLocalTime fonksiyonunu kullanabilirsiniz. var t:TSystemTime; begin t.wYear:=1998; t.wMonth:=5; t.wDay:=23; t.wHour:=12; t.wMinute:=34; SetLocalTime(t); end; Sistemdeki Cd Rom Sürücüleri Bulma procedure TForm1.Button1Click(Sender: TObject); var Surucu_araligi: set of 0..25; //sürücü sıra noları Suruculer,Surucu_no :integer; Surucu_harfi: string; begin listbox1.Clear; Suruculer := GetLogicalDrives; // yüklü sürücüler if Suruculer <> 0 then // eğer yüklü bir sürüc varsa ... begin integer(Surucu_araligi) := Suruculer; //sürücüleri numaralara ata for Surucu_no := 0 to 25 do begin if (Surucu_no in Surucu_araligi) then 1,2,... nolu sürücü varsa ... begin Surucu_harfi := char(Surucu_no+Ord('A'))+':'; if GetDriveType(PChar(Surucu_harfi)) = DRIVE_CDROM then listbox1.items.Add(Surucu_harfi); end; end; end;

Not : CD - ROM sürücünün ismini öğrenme chr(DRIVE_CDROM)+Ord('A')) ord('A')=65

444

Cd rom sürücüde cd olup olmadığı aşağıdaki kodla tesbit edebilir function cdvarmi(surucu : char) : bool; var surucu_yolu : string; max_bilesen_uz : DWORD; dosya_sys_bayraklari : DWORD; surucu_adi : string; begin Result := false; surucu_yolu := surucu + ':\'; if GetDriveType(PChar(surucu_yolu)) <> DRIVE_CDROM then exit; SetLength(surucu_adi, 64); GetVolumeInformation(PChar(surucu_yolu),PChar(surucu_adi),Length(surucu_adi), nil, max_bilesen_uz,dosya_sys_bayraklari,nil,0); if lStrCmp(PChar(surucu_adi),'') <> 0 then result:= true; end; procedure TForm1.Button2Click(Sender: TObject); var cdvar:boolean; begin cdvar:=cdvarmi('E'); if cdvar then ShowMessage(' Cd var... '); end; cd rom yolu şöylede öğrenilebilir (CD ROM un son sürücü olduğu varsayılıyor) a:=(drivecombobox1.Items[drivecombobox1.items.count-1]); activemovie1.filename:=a[1]+':\dosya01\dosya02\dosya.avi'

Sistemi Ctrl+Alt+Del e Kapatmak ve Açmak sistemi Ctrl+Alt+Del' e kapamak için var s : integer; begin SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @s, 0); end

sistemi Ctrl+Alt+Del' e açmak için var s : integer; begin SystemParametersInfo( SPI_SCREENSAVERRUNNING, 0, @s, 0); 445

end

Splash (Başlangoç) Formu Oluşturma F7 ye bas ve DPR dosyasını aç Application.CreateForm(TSplashfrm.Splashfrm); satırını kullanılmaz yap Yeni bir form oluştur Name: splashfrm olmalı Aşağıdakileri yaz SplashForm.Show; SplashFrm.Update

(... ApplicationCreateForm ...Ana form oluşturulsun)

SplashFrm.Hide Gizle SplashFrm.Free Sistem kaynaklarını serbest bırak

Sürücünün kapasitesini ve sürücüdeki bos yer miktarini bulmak DiskFree(0) //o anki sürücüdeki bos yer miktarini byte cinsinden döndürür. DiskSize(0) //o anki sürücünün kapasitesini byte cinsinden döndürür. DiskSize(0) div 1024 //o anki sürücünün kapasitesini KB cinsinden döndürür

Şifreli Bir Table nin Şifresini Unutturmak Şifreli bir table için programın şifre istememesi için; Table'ın Active özelliğini False yapın ve Form'un OnCreate olayına aşağıdaki kodu ekleyin Session.AddPassword('şifre'); Table1.Active:=True; Taskbar'in (Görev çubugu) AutoHide özelliği açık mı, kapalı mı? uses kismina 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 özelligi açik'); end;

Temp klasörünü bulma procedure TForm1.Button1Click(Sender: TObject); 446

var temp_klasor: array[0..MAX_PATH] of char; begin GetTempPath(SizeOf(temp_klasor), @temp_klasor); ShowMessage(temp_klasor); end;

Transparan Form Oluşturma form create yordamına aşağıdaki kod yazılır Brush.Style:=bsClear;

Türkçe Mesajlar Delphinin Professional ve Client/Server versiyonlarina sahipseniz, uygulamanizin verdigi mesajlari Türkçelestirebilirsiniz. Mesela MessageDlg fonksiyonuyla gösterdiginiz mesajlarin basliklarini ve dügmelerin basliklarini degistirebilirsiniz. Sonra "Invalid Date" gibi bir hata mesaji yerine "Geçersiz tarih, lütfen girdiginiz tarihi kontrol edin!" gibi mesaj verdirebilirsiniz. Bunun için Delphi'nin Source kodunda yer alan consts.pas (...\Delphi\Source\Vcl\) ve sysconst.pas (...\Delphi\Source\Rtl\Sys) dosyalarini Delphi ile açin ve mesajlari Türkçelestirin. Sonra bu dosyalari derleyin. Yalniz biraz dikkatli olmalisiniz ve orjinal dosyalarin mutlaka yedegini alin. Derleme sonucunda olusan consts.dcu ve sysconst.dcu dosyalarini Lib (...\Delphi\Lib) ve Slib (...\Delphi\Slib) klasörlerine kopyalayin. Yine orjinal dosyalarin birer yedegini almaniz menfaatiniz icabidir. Artik mesajlarin degistirdiginiz sekilde çikmasi gerekir.

Uygulamam Windows her açıldığında otomatik çalışsın uses kismina 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('Software\Microsoft\Windows\CurrentVersion\Run',false); reg.WriteString('Uygulamam', uygulamanizin_yolu_ve_adi); reg.CloseKey; reg.free; end;

Uygulamanızın Görev Çubuğundaki Butonunu Gizleme 447

Uygulamanızın Görev Çubuğundaki butonunu gizlemek için programınızın ana formunun OnCreate olayına aşağıdaki kodu yazın; SetWindowLong(Application.Handle,GWL_EXSTYLE, WS_EX_TOOLWINDOW);

Windows Gezginini istediginiz bir klasörle açma uses kismina ShellApi unitini ekleyin. ShellExecute(0, 'explore', 'C:\WINDOWS', //buraya açmak istediginiz klasörü yazin. nil, nil, SW_SHOWNORMAL);

Windows Tarih/Saat Özellikleri (Date/Time Properties) iletisim kutusunu açma Winexec('Control.exe Date/Time',sw_shownormal); na

Windows ekranına çizim yapma procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end;

Windows'a çizgi çizmenin farklı bir yolu procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var dc:hdc; begin dc:=getdc(0); Windows.LineTo(dc,x,y); end; end.

Windows lisans bilgilerinin (isim ve sirket) bulunması uses kismina Registry unitini ekleyin; procedure TForm1.Button1Click(Sender:TObject); var reg: TRegIniFile; begin reg := TRegIniFile.create('SOFTWARE\MICROSOFT\MS SETUP (ACME)\'); Memo1.Lines.Add(reg.ReadString('USER INFO', 'DefName', 448

'Mustafa SIMSEK')); Memo1.Lines.Add(reg.ReadString('USER INFO', 'DefCompany', 'Bilgisayar Bilimleri Müh.')); reg.free; 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'u kapatmak veya yeniden baslatmak(reboot) ExitWindowsEx(EWX_SHUTDOWN,0); //yeniden baslatmak için EWX_REBOOT

Windows'un diyalog penceresini bir klasörle açma Windows'ta Baslat->Bul->Dosyalar ve Klasörler ile açtiginiz Bul diyalog penceresini Delphi içerisinden hem de istediginiz yolu vererek çalistirabilirsiniz. uses kismina 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çildiginda konum kisminda CloseLink; //olmasini istediginiz klasör. Free; end; end;

1. Registryden kayıt okuma... procedure TForm1.FormCreate(Sender: TObject); Var Registry: TRegistry; Listan:TStringList; begin Listan := TStringList.create; Registry := TRegistry.Create; 449

try Registry.RootKey := HKey_Classes_Root; Registry.OpenKey('',False); Registry.GetKeynames(Listan); ComboBox1.Items := Listan; finally Registry.Free; end; end;

2. Porttan bilgi oku... function ReadPortB( wPort : Word ) : Byte; begin asm mov dx, wPort in al, dx mov result, al end; end;

3. Porta bilgi gönder... procedure WritePortB( wPort : Word; bValue : Byte ); begin asm mov dx, wPort mov al, bValue out dx, al end; end.

4.Uygulamanız Desktop'ta kısayol oluştursun.. procedure desktopShortcut(ffilename:string; fcaption: widestring); var IObject : IUnknown; ISLink : IShellLink; IPFile : IPersistFile; PIDL : PItemIDList; InFolder : array[0..MAX_PATH] of Char; TargetName : String; LinkName : WideString; FLinkName : String; begin TargetName := ffilename; IObject := CreateComObject(CLSID_ShellLink); ISLink := IObject as IShellLink; IPFile := IObject as IPersistFile; with ISLink do begin SetPath(pChar(TargetName)); SetWorkingDirectory (pChar(ExtractFilePath(TargetName))); 450

end; SHGetSpecialFolderLocation (0, CSIDL_DESKTOPDIRECTORY, PIDL); SHGetPathFromIDList (PIDL, InFolder); FlinkName := '\'+ FCaption + '.lnk'; LinkName := InFolder + FlinkName; IPFile.Save(PWChar(LinkName), false); end; Kullanımı: DesktopShortcut('C:/windows/notepad.exe','Notepad');

451

1. 3D Yazı yazmak.. procedure imgPaintCanvas(TheCanvas : TCanvas; TheString : String; TheFontSize, UCorner, LCorner : Integer); Begin TheCanvas.Brush.Style := bsClear; TheCanvas.Font.Style := [fsBold]; TheCanvas.Font.Name := 'MS Sans Serif'; TheCanvas.Font.Size := TheFontSize; TheCanvas.Font.Color := clBlack; TheCanvas.TextOut(UCorner, LCorner, TheString); TheCanvas.Font.Color := clGray; TheCanvas.TextOut(UCorner - 1, LCorner - 1, TheString); TheCanvas.Font.Color := clSilver; TheCanvas.TextOut(UCorner - 2, LCorner - 2, TheString); TheCanvas.Font.Color := clBlack; TheCanvas.TextOut(UCorner - 3, LCorner - 3, TheString); End; //Şöyle Çalışıyor imgPaintCanvas(Image3.Canvas, '0', 10, 6, 4);

2. Form da MetaFile çizmek... implementation {$R *.DFM} type TMetafileCanvas = class(TCanvas) private FClipboardHandle: THandle; FMetafileHandle: HMetafile; FRect: TRect; protected procedure CreateHandle; override; function GetMetafileHandle: HMetafile; public constructor Create; destructor Destroy; override; property Rect: TRect read FRect write FRect; property MetafileHandle: HMetafile read GetMetafileHandle; end; constructor TMetafileCanvas.Create; begin inherited Create; FClipboardHandle := GlobalAlloc( GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict)); end; destructor TMetafileCanvas.Destroy; begin DeleteMetafile(CloseMetafile(Handle)); if Bool(FClipboardHandle) then GlobalFree(FClipboardHandle); if Bool(FMetafileHandle) then DeleteMetafile(FMetafileHandle); inherited Destroy; end; 452

procedure TMetafileCanvas.CreateHandle; var MetafileDC: HDC; begin MetafileDC := CreateMetaFile(nil); if Bool(MetafileDC) then begin with FRect do SetWindowOrg(MetafileDC, Left - 10, Top - 10); with FRect do SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20); if Bool(FMetafileHandle) then begin PlayMetafile(MetafileDC, FMetafileHandle); end; end; Handle := MetafileDC; end; function TMetafileCanvas.GetMetafileHandle: HMetafile; var MetafilePict: PMetafilePict; IC: HDC; ExtRect: TRect; begin if Bool(FMetafileHandle) then DeleteMetafile(FMetafileHandle); FMetafileHandle := CloseMetafile(Handle); Handle := 0; MetafilePict := GlobalLock(FClipboardHandle); MetafilePict^.mm := mm_AnIsoTropic; IC := CreateIC('DISPLAY', nil, nil, nil); SetMapMode(IC, mm_HiMetric); ExtRect := FRect; DPtoLP(IC, ExtRect, 2); DeleteDC(IC); MetafilePict^.xExt := ExtRect.Right - ExtRect.Left; MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom; MetafilePict^.HMF := FMetafileHandle; GlobalUnlock(FClipboardHandle); Result := FClipboardHandle; end; procedure TForm1.BitBtn1Click(Sender: TObject); var MetafileCanvas : TMetafileCanvas; begin MetafileCanvas := TMetafileCanvas.Create; MetafileCanvas.Rect := Rect(0,0,500,500); MetafileCanvas.Ellipse(10,10,400,400); Image1.Picture.Metafile.LoadFromClipboardFormat(cf_MetafilePict, MetafileCanvas.MetafileHandle, 0); MetafileCanvas.Free; end; end.

3. Forma Bitmap kaplanması... var 453

Form1: TForm1; Bitmap: TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\hasir.bmp'); end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end; end; end.

4.Transparan Bitmap nasıl yapılır... procedure DrawTrans(DestCanvas: TCanvas; X,Y: smallint; SrcBitmap: TBitmap; AColor, BackColor: TColor); var ANDBitmap, ORBitmap: TBitmap; CM: TCopyMode; Src: TRect; begin ANDBitmap:= NIL; ORBitmap:= NIL; try ANDBitmap:= TBitmap.Create; ORBitmap:= TBitmap.Create; Src := Bounds(0,0, SrcBitmap.Width, SrcBitmap.Height); with ORBitmap do begin Width:= SrcBitmap.Width; Height:= SrcBitmap.Height; Canvas.Brush.Color := clBlack; Canvas.CopyMode := cmSrcCopy; Canvas.BrushCopy(Src, SrcBitmap, Src, AColor); end; with ANDBitmap do begin 454

Width:= SrcBitmap.Width; Height:= SrcBitmap.Height; Canvas.Brush.Color := BackColor; Canvas.CopyMode := cmSrcInvert; Canvas.BrushCopy(Src, SrcBitmap, Src, AColor); end; with DestCanvas do begin CM := CopyMode; CopyMode := cmSrcAnd; Draw(X,Y, ANDBitmap); CopyMode := cmSrcPaint; Draw(X,Y, ORBitmap); CopyMode := CM; end; finally ANDBitmap.Free; ORBitmap.Free; end; end; Kullanımı : DrawTrans(Image2.Canvas, 0,0, 'C:\Windows\deepblue.bmp', clBlack, clSilver);

Windows'un dial-up bağlantısının çağrılması //modem yüklü olmalı winexec(PChar('rundll32.exe rnaui.dll,RnaDial '+Edit1.Text),sw_show);

2.Programına Animasyonlu Cursor Ekle const cnCursorID1 = 1; begin Screen.Cursors[ cnCursorID1 ] := LoadCursorFromFile( 'c:\winnt\cursors\piano.ani' ); Cursor := cnCursorID1; end;

3.Programa E-mail linki eklemek procedure email; var x: string; begin x:='mailto:'+FEmailTo+'?Subject='+FEmailSubject+'&cc='+FEmailCC; ShellExecute(0, nil, PChar(x), nil, nil, SW_SHOWDEFAULT); end;

455

4.Registry'den Bilgi okumak var RegIni : TRegIniFile; begin RegIni := TRegIniFile.Create(''); with RegIni do begin RootKey := HKEY_LOCAL_MACHINE; LazyWrite := True; OpenKey('\Software\Microsoft\Windows\',False); ShowMessage(ReadString('CurrentVersion', 'RegisteredOrganization', 'not assigned')); Free; end; end;

5.Açık bütün pencereleri listeleme function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean; Export; {$ifdef Win32} StdCall; {$endif} var Buffer : Array[0..99] of char; begin GetWindowText(Wnd,Buffer,100); if StrLen(Buffer) <> 0 then Form.ListBox1.Items.Add(StrPas(Buffer)); Result := True; end; procedure TForm1.Button1Click(Sender: TObject); begin EnumWindows(@EnumWindowsProc,LongInt(Self)); end;

CD-ROM Drive'ı kontrol etmek... function IsCDROM(DriveNum: Integer): Boolean; assembler; asm MOV AX,1500h { MSCDEX 'e bakıyor} XOR BX,BX INT 2fh OR BX,BX JZ @Finish MOV AX,150Bh { CD driver ın kullanılırlığına bakıyor} MOV CX,DriveNum INT 2fh OR AX,AX @Finish: end; // Win32 kontrolörlü A: Function IsCdRom(DriveNum : Word) : Boolean; Var 456

F : WordBool; Begin asm mov ax, 1500h xor bx, bx int 2fh mov ax, bx or ax, ax jz @no_mscdex mov ax, 150bh mov cx, DriveNum int 2fh @no_mscdex: mov f,ax end; Result := F; End;

2. Disk veya Disket yerinde mi ? function DiskInDrive(Drive: Char): Boolean; var ErrorMode: word; begin if Drive in ['a'..'z'] then Dec(Drive, $20); if not (Drive in ['A'..'Z']) then raise EConvertError.Create('Not a valid drive ID'); ErrorMode := SetErrorMode(SEM_FailCriticalErrors); try { sürücü 1 = a, 2 = b, 3 = c, etc. } if DiskSize(Ord(Drive) - $40) = -1 then Result := False else Result := True; finally { error moduna geri dön } SetErrorMode(ErrorMode); end; end;

3. Sistem Tarih ve Saatini değiştirme... procedure SetDate(Year, Month, Day: Word); assembler; asm MOV CX,Year MOV DH,BYTE PTR Month MOV DL,BYTE PTR Day MOV AH,2BH INT 21H end; procedure SetTime(Hour, Minute, Second, Sec100: Word); assembler; asm MOV CH,BYTE PTR Hour MOV CL,BYTE PTR Minute 457

MOV DH,BYTE PTR Second MOV DL,BYTE PTR Sec100 MOV AH,2DH INT 21H end; function SetSystemDateTime(Year, Month, Day, Hour, Minute, Second: word): integer;export; begin SetDate(Year, Month, Day); SetTime(Hour, Minute + 1, Second, 0); result := 1; end

458

Forma Zoom efekti : type TZHar = (syKapat, syAc); procedure ZEfek(OForm: TForm; islem: TZHar); var SStart: TRect; SEnd: TRect; STray: TRect; wndTray : hWnd; wndChild: hWnd; begin wndTray := FindWindow('Shell_TrayWnd', nil); wndChild := FindWindowEx(wndTray, 0, 'TrayNotifyWnd', nil); GetWindowRect(wndChild, STray); if islem = syKapat then begin SStart := OForm.BoundsRect; SEnd := STray; end else begin SEnd := OForm.BoundsRect; SStart := STray; end; //sihir burda gerçekleşiyor DrawAnimatedRects(OForm.Handle, IDANI_CAPTION, SStart, SEnd) end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin ZEfek(Self,syKapat); end; procedure TfrmTest.FormShow(Sender: TObject); begin ZEfek(Self, syAc); end; Elastic Panel : unit Elastic; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type 459

TElasticPanel = class( TPanel ) private FHorz, FVert: boolean; nOldWidth, nOldHeight: integer; bResized: boolean; protected procedure WMSize( var message: TWMSize ); message WM_SIZE; public nCount: integer; constructor Create( AOwner: TComponent ); override; published property ElasticHorizontal: boolean read FHorz write FHorz default TRUE; property ElasticVertical: boolean read FVert write FVert default TRUE; end; procedure Register; implementation constructor TElasticPanel.Create( AOwner: TComponent ); begin inherited Create( AOwner ); FHorz := TRUE; FVert := TRUE; nOldWidth := Width; nOldHeight := Height; bResized := FALSE; end; procedure TElasticPanel.WMSize( var message: TWMSize ); var bResize: boolean; xRatio: real; i: integer; ctl: TWinControl; begin Inc( nCount ); if Align = alNone then bResize := TRUE else bResize := bResized; if not ( csDesigning in ComponentState ) and bResize then begin if FHorz then begin xRatio := Width / nOldWidth; for i := 0 to ControlCount - 1 do begin ctl := TWinControl( Controls[i] ); ctl.Left := Round( ctl.Left * xRatio ); ctl.Width := Round( ctl.Width * xRatio ); end; end; if FVert then begin 460

xRatio := Height / nOldHeight; for i := 0 to ControlCount - 1 do begin ctl := TWinControl( Controls[i] ); ctl.Top := Round( ctl.Top * xRatio ); ctl.Height := Round( ctl.Height * xRatio ); end; end; end else begin nOldWidth := Width; nOldHeight := Height; end; bResized := TRUE; nOldWidth := Width; nOldHeight := Height; end; procedure Register; begin RegisterComponents('Additional', [TElasticPanel]); end; end.

Hint Fontunun değiştirilmesi : implementation {$R *.DFM} Type THintConFont = Class (THintWindow) Constructor Create (AOwner: TComponent); override; end; Constructor THintConFont.Create (AOwner: TComponent); begin Inherited Create (Aowner); Canvas.Font.Name := 'Times New Roman'; Canvas.Font.Size := 18; end;

Logon Olan Kullanıcı Administrator mu? const SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)); SECURITY_BUILTIN_DOMAIN_RID = $00000020; DOMAIN_ALIAS_RID_ADMINS = $00000220; function IsAdmin: Boolean; var 461

hAccessToken: THandle; ptgGroups: PTokenGroups; dwInfoBufferSize: DWORD; psidAdministrators: PSID; x: Integer; bSuccess: BOOL; begin Result := False; bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken); if not bSuccess then begin if GetLastError = ERROR_NO_TOKEN then bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken); end; if bSuccess then begin GetMem(ptgGroups, 1024); bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize); CloseHandle(hAccessToken); if bSuccess then begin AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators); {$R-} for x := 0 to ptgGroups.GroupCount - 1 do if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then begin Result := True; Break; end; {$R+} FreeSid(psidAdministrators); end; FreeMem(ptgGroups); end; end; procedure TForm1.Button1Click(Sender: TObject); begin if isAdmin then begin ShowMessage('Logged in as Administrator'); end; end;

462

Çapraz, dikey gibi değişik açılarda yazılar nasıl yazılır?

Bu örneğimizde Form1 adlı bir formumuz ve bunun üzerinde Button1 adlı bir butonumuz var. Button1'in OnClick event'ine aşağıdaki procedure'ü girip programı çalıştırdıktan sonra butona her bastığınızda form'un rastgele bir bölgesinde LogFont.Escapement ile verilen açı mertebesinde (1/10 derece) döndürülmüş bir yazı ekrana gösteriyor. Aşağıdaki değerlerle oynayarak ilginç sonuçlar elde edebileceğiniz gibi, işin asıl sırrı olan CreateFontIndirect Windows API fonksiyonunu inceleyerek ufkunuzu daha da genişletebilirsiniz. procedure TForm1.Button1Click(Sender: TObject); var HFont : THandle; LogFont : TLogFont; Font : THandle; begin LogFont.lfHeight := -24; { font büyüklüğü } LogFont.lfWidth := 20; { genişlik? } LogFont.lfWeight := FW_NORMAL; { Kalın, İnce vs } LogFont.lfEscapement := 450; { Açı, burada 45 derece } LogFont.lfcharset := TURKISH_CHARSET; { türkçe! } LogFont.lfOutPrecision := OUT_TT_PRECIS; { f.kriteri } LogFont.lfQuality := PROOF_QUALITY; { kalite } LogFont.lfPitchandFamily := FF_Modern; { font ailesi } LogFont.lfFaceName := 'Arial'; { font adı } Font := CreateFontIndirect(LogFont); { yukarıda oluşturduğumuz font nesnesini form'a ata } SelectObject(Form1.Canvas.Handle, Font); SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 200)); SetBKmode(Form1.Canvas.Handle, Transparent); Canvas.Textout(Random(Width),Random(Height), 'Çapraz Yazı!'); DeleteObject(Font); { harcadığımız hafızayı boşalt } end; Çeşitli açılarda ve fontlarda yazılar yazdırma

Programın çalışması sırasında kod ile yeni Component'lar oluşturma

Normalde formlarınızda kullanacağınız component'leri Delphi'nin dizayn ekranında oluşturursunuz. Bazı durumlarda çalışma sırasında da aktif olarak component oluşturmanız gerekebilir. Mesela formunuzda bir dizin içerisindeki dosya sayısı kadar button oluşturmak istiyorsunuz. Dizayn sırasında kullanıcının makinasındaki tüm dosyaların sayısını bilemeyeceğinize göre bunları çalışma sırasında dinamik olarak oluşturmalısınız. Neyse bu örneğimizde kolay anlaşılması açısından bir button'a her basılışta yeni bir buton oluşturuyoruz. Her oluşturulan button'da dizayn ekranında oluşturduğumuz ilk button nesnesi button1 gibi kendisine basıldığında yeni bir buton oluşturuyor. Bu kod bu şekilde aynı zamanda Event Handler'ların çalışma sırasında nasıl atanabileceğinin de bir örneği. 463

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var B : TButton; begin B := TButton.Create(Self); { Yeni TButton oluştur } B.Parent := Self; { Kimin alt component'i? } B.OnClick := Button1Click; { OnClick Handler'ı ata } B.Left := Random(ClientWidth - Button1.Width); B.Top := Random(ClientHeight - Button1.Height); B.Caption := 'Button'; end; end. Çalışma sırasında istenildiği kadar rastgele buton oluşturma

464

Low-level formatting of floppy Something to get you started, but its a lot simpler to use the SHFormatDrive function.

type TDiocRegisters = record EBX, EDX, ECX, EAX, EDI, ESI, Flags: DWORD; end; TVWin32CtlCode = (ccNone, ccVWin32IntIoctl, ccVWin32Int26, ccVWin32Int25, ccVWin32Int13); TBiosParamBlock = packed record BytesPerSector: Word; SectorsPerCluster: Byte; ReservedSectors: Word; NumFats: Byte; NumRootEntries: Word; NumSectors: Word; MediaID: Byte; SectorsPerFat: Word; SectorsPerTrack: Word; NumHeads: Word; HiddenSectors: Word; Dummy1: Word; TotalSectors: LongInt; Dummy2: array[0..5] of Byte; end; TDeviceParamBlock = packed record Special: Byte; DeviceType: Byte; DeviceAttr: Word; NumCylinders: Word; MediaType: Byte; BiosParamBlock: TBiosParamBlock; end; TFormatParamBlock = packed record Reserved: Byte; Head: Word; Cylinder: Word; end; function VWin32(CtlCode: TVWin32CtlCode; var Regs: TDiocRegisters): Boolean; var hDevice: THandle; Count: DWORD; begin hDevice := CreateFile('\\.\VWIN32', 0, 0, nil, 0, FILE_FLAG_DELETE_ON_CLOSE, 0); Result := DeviceIoControl(hDevice, Ord(CtlCode), @Regs, SizeOf(Regs), @Regs, SizeOf(Regs), Count, nil); 465

CloseHandle(hDevice); end; function GetDeviceParamBlock(Drive: Char; var ParamBlock: TDeviceParamBlock): Word; var Regs: TDiocRegisters; begin with Regs do begin EAX := $440D; EBX := Ord(UpCase(Drive)) - Ord('@'); ECX := $0860; EDX := LongInt(@ParamBlock); VWin32(ccVWin32IntIoctl, Regs); if (Flags and 1) 0 then Result := LoWord(EAX) else Result := 0; end; end; function SetDeviceParamBlock(Drive: Char; var ParamBlock: TDeviceParamBlock): Word; var Regs: TDiocRegisters; begin with Regs do begin EAX := $440D; EBX := Ord(UpCase(Drive)) - Ord('@'); ECX := $0840; EDX := LongInt(@ParamBlock); VWin32(ccVWin32IntIoctl, Regs); if (Flags and 1) 0 then Result := LoWord(EAX) else Result := 0; end; end; function FormatTrack(Drive: Char; var ParamBlock: TFormatParamBlock): Word; var Regs: TDiocRegisters; begin with Regs do begin EAX := $440D; EBX := Ord(UpCase(Drive)) - Ord('@'); ECX := $0842; EDX := LongInt(@ParamBlock); VWin32(ccVWin32IntIoctl, Regs); if (Flags and 1) 0 then 466

Result := LoWord(EAX) else Result := 0; end; end;

467

Open/Close CD tray. Uses: NMStrm Code for Open: mciSendString('Set cdaudio door open wait', nil, 0, handle); Code for Closed:mciSendString('Set cdaudio door closed wait', nil, 0, handle); Exit/Reboot Windows: Uses: Windows Force Windows to reboot: ExitWindowsEx(EWX_REBOOT + EWX_FORCE,0); Force Windows to shut down: ExitWindowsEx(EWX_SHUTDOWN + EWX_FORCE,0); Set monitor on standby: Uses: MMSystem or ShellAPI or Messages (I think Messages most Monitor standby on: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); Monitor Standby off: SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); Disable/Enable/Open Start menu Uses: ShellApi or Windows or Messages (I think Messages most) Disable start menu: EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0, 'Button', nil),false); Enable Start menu: EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),true); Open start menu: Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_TASKLIST,0); ****************** !************************************** ! Name: Show/Hide Find Menu ! Description:Show/Hide Find Menu ! By: Kelvin Galván ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.374/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** //Add Registry to USES uses Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; procedure TForm1.Button1Click(Sender: TObject); var fBuffer : array [0..3] of byte; MyRegistry : TRegistry; begin //Hide Find Menu fBuffer[0]:=1; fBuffer[1]:=0; fBuffer[2]:=0; fBuffer[3]:=0; ////Show Find Menu //fBuffer[0]:=0; //fBuffer[1]:=0; //fBuffer[2]:=0; //fBuffer[3]:=0; MyRegistry:=TRegistry.Create; 468

MyRegistry.RootKey:=HKEY_CURRENT_USER; MyRegistry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',True ); MyRegistry.WriteBinaryData('NoFind',fBuffer,4); MyRegistry.CloseKey; MyRegistry.Free; //You Need Restart Windows end;

469

!************************************** ! Name: Show/Hide Shut Down Menu ! Description:Show/Hide Shut Down Menu ! By: Kelvin Galván ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.372/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** //Add Registry to USES uses Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; procedure TForm1.Button1Click(Sender: TObject); var fBuffer : array [0..3] of byte; MyRegistry : TRegistry; begin //Hide Shut Down Menu fBuffer[0]:=1; fBuffer[1]:=0; fBuffer[2]:=0; fBuffer[3]:=0; //Show Shut Down Menu //fBuffer[0]:=0; //fBuffer[1]:=0; //fBuffer[2]:=0; //fBuffer[3]:=0; MyRegistry:=TRegistry.Create; MyRegistry.RootKey:=HKEY_CURRENT_USER; MyRegistry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',True ); MyRegistry.WriteBinaryData('NoClose',fBuffer,4); MyRegistry.CloseKey; MyRegistry.Free; //You Need Restart Windows end;

470

!************************************** ! Name: Clear Recent Docs On Exit ! Description:Clear Recent Docs On Exit ! Windows ! By: Kelvin Galván ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.373/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** //Add Registry to USES uses Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; procedure TForm1.Button1Click(Sender: TObject); var fBuffer : array [0..3] of byte; MyRegistry : TRegistry; begin //Clear Recent Docs On Exit fBuffer[0]:=1; fBuffer[1]:=0; fBuffer[2]:=0; fBuffer[3]:=0; ////No Clear Recent Docs On Exit //fBuffer[0]:=0; //fBuffer[1]:=0; //fBuffer[2]:=0; //fBuffer[3]:=0; MyRegistry:=TRegistry.Create; MyRegistry.RootKey:=HKEY_CURRENT_USER; MyRegistry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',True ); MyRegistry.WriteBinaryData('ClearRecentDocsOnExit',fBuffer,4); MyRegistry.CloseKey; MyRegistry.Free; //You Need Restart Windows end;

This code will show you your tasks running. ================================================== procedure Form1.TasksListRecieve; var I : String; begin ListBox1.Clear; EnumWindows( @EnumWindowsProc, integer( ListBox1)); I := ''; I := ListBox1.Items.Text; 471

end;

472

!************************************** ! Name: Stealth ! Description:Hide your porgams in the t ! ask manager, and from process lists. No one will ever know its there! ! By: Dave Bayliss ! ! Assumes:This control does not work und ! er Windows 2000 as the tasking is differ ! ent, I use it on win 95, 98, ME systems ! and it works great! ! !This code is copyrighted and has ! limited warranties.Please see http://w ! ww.Planet-Source-Code.com/xq/ASP/txtCode ! Id.420/lngWId.7/qx/vb/scripts/ShowCode.h ! tm !for details. !************************************** {Created By David Bayliss http://www.dbayliss.com} unit Stealth; interface uses WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages; type TDuplicateComponent = class(Exception); TFormNotOwner = class(Exception); TStealth = class(TComponent) private FHideForm: Boolean; fHideApp: Boolean; OldWndProc: TFarProc; NewWndProc: Pointer; function IsIt: Boolean; procedure SetIt (Value: Boolean); procedure SetHideApp(Value: Boolean); procedure HookParent; procedure UnhookParent; procedure HookWndProc(var Message: TMessage); protected { Protected declarations } procedure HideApplication; procedure ShowApplication; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Loaded; override; procedure ProcessEnabled; published { Published declarations } property HideForm: Boolean read IsIt write SetIt stored true default true; property HideApp: Boolean read fHideApp write SetHideApp; 473

end; function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL'; procedure Register; implementation destructor TStealth.Destroy; begin ShowApplication; UnhookParent; inherited destroy; end; constructor TStealth.Create(AOwner: TComponent); var i: Word; CompCount: Byte; begin inherited Create(AOwner); fHideform := true; NewWndProc := nil; OldWndProc := nil; CompCount := 0; if (csDesigning in ComponentState) then if (AOwner is TForm) then with (AOwner as TForm) do begin for i := 0 to ComponentCount - 1 do if Components[i] is TStealth then Inc(CompCount); if CompCount > 1 then raise TDuplicateComponent.Create('There is already a TStealth component on this Form'); end else raise TFormNotOwner.Create('The owner of TStealth Component is not a TForm'); HookParent; end; procedure TStealth.SetHideApp(Value: Boolean); begin fHideApp := Value; if Value then HideApplication else ShowApplication; end; procedure TStealth.HideApplication; begin if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 1); end; procedure TStealth.ShowApplication; begin if not (csDesigning in ComponentState) then RegisterServiceProcess(GetCurrentProcessID, 0); end; procedure TStealth.Loaded; begin 474

inherited Loaded; { Always call inherited Loaded method } if not (csDesigning in ComponentState) then ProcessEnabled; end; procedure TStealth.ProcessEnabled; begin if not (csDesigning in ComponentState) then if fHideform then ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE) else ShowWindow(FindWindow(nil, @Application.Title[1]), SW_RESTORE); end; function TStealth.IsIt: Boolean; begin Result := fHideform; end; procedure TStealth.SetIt(Value: Boolean); begin fHideform := value; ProcessEnabled; end; procedure TStealth.HookParent; begin if owner = nil then exit; OldWndProc := TFarProc(GetWindowLong((owner as TForm).Handle, GWL_WNDPROC)); NewWndProc := MakeObjectInstance(HookWndProc); SetWindowLong((owner as TForm).Handle, GWL_WNDPROC, LongInt(NewWndProc)); end; procedure TStealth.UnhookParent; begin if (owner <> NIL) and Assigned(OldWndProc) then SetWindowLong((owner as TForm).Handle, GWL_WNDPROC, LongInt(OldWndProc)); if Assigned(NewWndProc) then FreeObjectInstance(NewWndProc); NewWndProc := NIL; OldWndProc := NIL; end; procedure Register; begin RegisterComponents('Dbayliss', [TStealth]); end; procedure TStealth.HookWndProc(var Message: TMessage); begin if owner = NIL then exit; if (Message.Msg = WM_SHOWWINDOW) then if (Message.wParam <> 0) then ProcessEnabled; Message.Result := CallWindowProc(OldWndProc, (owner as TForm).Handle, Message.Msg, Message.wParam, Message.lParam); end; end. 475

{ Article: Screen Shuffling with Delphi http://delphi.about.com/library/weekly/aa082801a.htm Delphi code that divides the current desktop into blocks and then swaps the blocks. It includes an option that lets you adjust the shuffling speed, and the size of the blocks. Great intro to sliding puzzle game or to screen saver development. For the .zip file of this project click here. } unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TShuffler = class(TForm) Image1: TImage; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } end; var Shuffler: TShuffler; DesktopBitmap : TBitmap; gx, gy : Integer; redRect : TBitmap; rW, rH

: Integer; //witdh and height of the shuffling rectangle

const DELTA = 4; //shoul be 2^n -> makes the Screen to be matrix DELTA x DELTA implementation {$R *.DFM} procedure InitScreen; var i,j:integer; begin DesktopBitmap := TBitmap.Create; with DesktopBitmap do begin Width := Screen.Width; 476

Height := Screen.Height; end; BitBlt(DesktopBitmap.Canvas.Handle,0,0,Screen.Width,Screen.Height, GetDC(GetDesktopWindow),0,0,SrcCopy); Shuffler.Image1.Picture.Bitmap := DesktopBitmap; Randomize; gx := Trunc(Random * DELTA); gy := Trunc(Random * DELTA); Shuffler.Image1.Canvas.CopyRect(Rect(rW * gx, rH * gy, rW * gx + rW, rH * gy + rH),redRect.Canvas,Rect(0,0,rW,rH)); //draw matrix for i:=0 to DELTA-1 do begin Shuffler.Image1.Canvas.MoveTo(rW * i,0); Shuffler.Image1.Canvas.LineTo(rW * i,Screen.Height); Shuffler.Image1.Canvas.MoveTo(0, rH * i); Shuffler.Image1.Canvas.LineTo(Screen.Width, rH * i); end; { **add cell numbers (row; column)** Shuffler.Image1.Canvas.Font.Size:=30; for i := 0 to DELTA-1 do begin for j := 0 to DELTA-1 do begin Shuffler.Image1.Canvas.TextOut(rw * i, rh * j, IntToStr(i+1)+';'+ IntToStr(j+1)); end; //for j end; //for i } end; procedure DrawScreen; var r1,r2:TRect; Direction:integer; begin r1:=Rect(rW * gx , rH * gy, rW * gx + rW , rH * gy + rH); Direction := Trunc(Random*4); case Direction of 0: gx := Abs((gx + 1) MOD DELTA); //right 1: gx := Abs((gx - 1) MOD DELTA); //left 2: gy := Abs((gy + 1) MOD DELTA); //down 3: gy := Abs((gy - 1) MOD DELTA); //up end; //case r2 := Rect(rW * gx , rH * gy, rW * gx + rW , rH * gy + rH); with Shuffler.Image1.Canvas do begin CopyRect(r1, Shuffler.Image1.Canvas, r2); CopyRect(r2, redRect.Canvas, redRect.Canvas.ClipRect); 477

end; end; procedure TShuffler.FormCreate(Sender: TObject); begin rW := Screen.Width div DELTA; rH := Screen.Height div DELTA; redRect:=TBitmap.Create; with redRect do begin Width := rW; Height := rH; Canvas.Brush.Color := clRed; Canvas.Brush.Style := bssolid; Canvas.Rectangle(0,0,rW,rH); Canvas.Font.Color := clNavy; Canvas.Font.Style := Canvas.Font.Style + [fsBold]; Canvas.TextOut(2,2,'About'); Canvas.Font.Style := Canvas.Font.Style - [fsBold]; Canvas.TextOut(2,17,'Delphi'); Canvas.TextOut(2,32,'Programming'); end; Timer1.Enabled := False; image1.Align := alClient; Visible := False; BorderStyle := bsNone; Top := 0; Left := 0; Width := Screen.Width; Height := Screen.Height; InitScreen; // SetWindowPos(Handle,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE + SWP_NOMOVE); Visible := True; Timer1.Interval := 10; // smaller := faster Timer1.Enabled := True; // start calling DrawScreen end; procedure TShuffler.Timer1Timer(Sender: TObject); begin DrawScreen; end; procedure TShuffler.FormDestroy(Sender: TObject); begin DesktopBitmap.Free; redRect.Free; end; end.

UNIT1.DFM 478

object Shuffler: TShuffler Left = 368 Top = 331 Width = 209 Height = 123 Caption = 'Shuffler' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Image1: TImage Left = 48 Top = 16 Width = 113 Height = 65 end object Timer1: TTimer OnTimer = Timer1Timer Left = 8 Top = 8 end end

{ ******************************************** Zarko Gajic About.com Guide to Delphi Programming http://delphi.about.com email: [email protected] free newsletter: http://delphi.about.com/library/blnewsletter.htm forum: http://forums.about.com/ab-delphi/start/ ******************************************** }

479

From: http://www.scalabium.com/faq/dct0049.htm SHELLEXECUTE ------------------var pCh: PChar; begin pCh := 'mailto:[email protected]?subject=your_subject&body=your_body&file="c: \autoexec.bat"'; ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL); end; -----------------OLE AUTOMATION W/ OUTLOOK ----------------------------------------const olMailItem = 0; var Outlook, MailItem: OLEVariant; begin try Outlook := GetActiveOleObject('Outlook.Application'); except Outlook := CreateOleObject('Outlook.Application'); end; MailItem := Outlook.CreateItem(olMailItem); MailItem.Recipients.Add('[email protected]'); MailItem.Subject := 'your subject'; MailItem.Body := 'Welcome to my homepage: http://www.scalabium.com'; MailItem.Attachments.Add('C:\Windows\Win.ini'); MailItem.Send; Outlook := Unassigned; end; --------------------Here's some code using the TNMSMTP component in Delphi... --------------------------------------------------------------procedure TfrmMain.SendErrorEmailNotification(const Content: string; const SendFile : boolean); var Smtp : TNMSmtp; tmpList : TStringList; begin Smtp := TNMSmtp.Create (nil); tmpList := TStringList.Create; try GetErrorEmailAddresses (tmpList); // Home-grown INI file lookup function for email notification Smtp.Host := 'myserver.mydomain.com'; Smtp.Connect; 480

Smtp.PostMessage.FromAddress := 'Automated'; Smtp.PostMessage.FromName := 'Report Creator'; Smtp.PostMessage.ToAddress.Assign (tmpList); Smtp.PostMessage.Subject := 'Report Creator Error Notification'; Smtp.PostMessage.Body.Add (Content); if SendFile then Smtp.PostMessage.Attachments.Add (ExtractFilePath (ParamStr(0)) + 'Errorfile.txt'); // Send the message Smtp.SendMail; finally Smtp.Disconnect; Smtp.Free; tmpList.Free; end; end;

481

NET SEND --------------------------------function NetSend(dest, source, msg: string): longint; type TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar; buf: PWideChar; buflen: Cardinal): longint; stdcall; var NetMessageBufferSend: TNetMessageBufferSendFunction; SourceWideChar : PWideChar; DestWideChar : PWideChar; MessagetextWideChar: PWideChar; Handle begin

: THandle;

Handle := LoadLibrary('NETAPI32.DLL'); if Handle = 0 then begin Result := GetLastError; exit; end; @NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend'); if @NetMessageBufferSend = nil then begin Result := GetLastError; exit; end; MessagetextWideChar := nil; SourceWideChar := nil; DestWideChar := nil; try GetMem(MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1); GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1); StringToWideChar(msg, MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1); StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1); if source = '' then result := NetMessageBufferSend(nil, DestWideChar, nil, MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1) else begin GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1); StringToWideChar(source, SourceWideChar, 20 * SizeOf(WideChar) + 1); result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar, MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1); freemem(SourceWideChar); end; finally FreeMem(MessagetextWideChar); FreeLibrary(Handle); 482

end; end; ---------------------------------

483

Packing tables To pack (remove phisically all deleted records) from a Paradox table you must use this code procedure ParadoxPack(Table : TTable); var TBDesc : CRTblDesc; hDb: hDbiDb; TablePath: array[0..dbiMaxPathLen] of char; begin FillChar(TBDesc,Sizeof(TBDesc),0); with TBDesc do begin StrPCopy(szTblName,Table.TableName); StrPCopy(szTblType,szParadox); bPack := True; end; hDb := nil; Check(DbiGetDirectory(Table.DBHandle, True, TablePath)); Table.Close; Check(DbiOpenDatabase(nil, 'STANDARD', dbiReadWrite, dbiOpenExcl,nil,0, nil, nil, hDb)); Check(DbiSetDirectory(hDb, TablePath)); Check(DBIDoRestructure(hDb,1,@TBDesc,nil,nil,nil,False)); Table.Open; end; To pack Dbase tables use this command DBIPackTable(Table1.DBHandle,Table1.Handle,nil,nil,True);

Making Enter key act as Tab To make the Enter key act as Tab key is a 3 step procedure: 1) Set the form's KeyPreview property to True 2) Set all form's buttons property Default to False 3) Create an OnKeyPress event for the form like this: procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if Key = #13 then begin Key := #0; Perform(Wm_NextDlgCtl,0,0); end; end;

484

{ DELETE CAPTION BAR } SetWindowLong(frmFTPBrowse.Handle, GWL_STYLE, GetWindowLong(frmFTPBrowse.handle,GWL_STYLE) and not WS_CAPTION); frmFTPBrowse.height := clientheight; { / DELETE CAPTION BAR }

> We can stop and delete current printing job from "Printer manager". > Can I do it in my code? I want to STOP all "print jobs" and Delete them in > my program. Try the PurgeJobsOnCurrentPrinter procedure given below. Not tested! Uses Winspool, printers; {-- GetCurrentPrinterHandle -------------------------------------------} {: Retrieves the handle of the current printer @Returns an API printer handle for the current printer @Desc Uses WinSpool.OpenPrinter to get a printer handle. The caller takes ownership of the handle and must call ClosePrinter on it once the handle is no longer needed. Failing to do that creates a serious resource leak!
Requires Printers and WinSpool in the Uses clause. @Raises EWin32Error if the OpenPrinter call fails. }{ Created 30.9.2000 by P. Below -----------------------------------------------------------------------} Function GetCurrentPrinterHandle: THandle; Const Defaults: TPrinterDefaults = ( pDatatype : nil; pDevMode : nil; DesiredAccess : PRINTER_ACCESS_USE or PRINTER_ACCESS_ADMINISTER ); Var Device, Driver, Port : array[0..255] of char; hDeviceMode: THandle; Begin { GetCurrentPrinterHandle } Printer.GetPrinter(Device, Driver, Port, hDeviceMode); If not OpenPrinter(@Device, Result, @Defaults) Then RaiseLastWin32Error; End; { GetCurrentPrinterHandle } {: Kill all pending jobs on the current printer } Procedure PurgeJobsOnCurrentPrinter; Var hPrinter: THandle; Begin hPrinter:= GetCurrentPrinterHandle; try If not WinSpool.SetPrinter( hPrinter, 0, nil, PRINTER_CONTROL_PURGE ) Then RaiseLastWin32Error; finally ClosePrinter( hPrinter ); 485

end; End; { PurgeJobsOnCurrentPrinter }

486

NT User Groups from member... Use this function ---------------------------------function NetUserGetGroups(const servername : WideString; username : WideString; level : DWORD; var bufptr : pointer; prefmaxlen : DWORD; var entriesread : DWORD; var totalentries : DWORD ) : integer; stdcall; external 'NetApi32.dll'; -------------------------Here follows o code sample of this function tha althougth doesn't do what exactly you want to , As i believe it would be help full for you if you have any question please send an e-mail at case i don't see the forum again. -----------------------------------------------

function TUserManager.UserBelongsInGlobalGroup(const UserName, GroupName: WideString): Integer; type T_inf_buf = array[0..0] of _GROUP_USERS_INFO_0; pT_inf_buf = ^T_inf_buf; var pBuffer : pT_inf_buf; res,i : integer; PreMaxLen, TotalEntries, EntriesRead :DWORD; Group_Name : WideString; begin PreMaxLen := 1024; EntriesRead := 0; TotalEntries := 0; result :=-1; Group_Name := StringToOleStr(GroupName); NetApiBufferAllocate(PreMaxLen,pointer(pBuffer)); fillChar(pbuffer^,premaxlen,0); res := NetUserGetGroups('',StringToOleStr(UserName),0,pointer(pBuffer),PreMaxLen,En triesRead,TotalEntries);

if res = 0 then begin for i:=0 to EntriesRead - 1 do begin if AnsiCompareText(pBuffer[i].grui0_name,Group_Name)=0 then result := 0; end end 487

else result := res; NetApiBufferFree(pBuffer); end;

488

Re: Call external app from Service app The second URL you mention contains an example of CreateProcess (and not ShellExecute). You can't use ShellExecute to do the same, but you should use ShellExecuteEx, e.g. uses ShellAPI; var Info: TShellExecuteInfo; begin Info.cbSize := SizeOf(Info); Info.fMask := SEE_MASK_NOCLOSEPROCESS; Info.Wnd := Application.Handle; Info.lpVerb := 'open'; Info.lpFile := 'c:\windows\notepad.exe'; Info.lpParameters := 'c:\autoexec.bat'; Info.lpDirectory := nil; Info.nShow := SW_SHOWNORMAL; if not ShellExecuteEx(@Info) then RaiseLastWin32Error; try if WaitForSingleObject(Info.hProcess, INFINITE) <> WAIT_OBJECT_0 then RaiseLastWin32Error; finally CloseHandle(Info.hProcess); end; end;

489

It won't be the same thing, but check out the Alfa File Protector, www.alfasp.com/alfa_file_protector.exe There is a freeware component inside that package that helps work with security descriptors, directly with ACLs and ACEs. Also, the help files contain API samples on how to do this. The help files only can be downloaded from: http://www.alfasp.com/help/alfa_file_protector_help.zip Regards, Dejan. andrew wrote: > Anyone care to have a crack at converting the following C++ method to > Delphi - it would be much appreciated as Security descripters and ACL's seem > to be out of my league. > > STDMETHODIMP CQueueSecurity::CreateFullAccess(BSTR PathName) >{ > SECURITY_DESCRIPTOR sd; // Security descriptor > structure > EXPLICIT_ACCESS ea; // Explicit access structure > ACL* pdacl = 0; // Access control list pointer > > // Initialize a security descriptor > if (!InitializeSecurityDescriptor(&sd, SECURITY_DESCRIPTOR_REVISION)) > throw 0; > > // Give explicit full access to the world (Everyone) > BuildExplicitAccessWithName(&ea, _T("EVERYONE"), > MQSEC_QUEUE_GENERIC_ALL, > GRANT_ACCESS, > NO_INHERITANCE); > > // Add the explicit access to the access control list (ACL) > if (SetEntriesInAcl(1, &ea, 0, &pdacl) != ERROR_SUCCESS) > throw 0; > > // Add the access control list (ACL) to the security descriptor > if (!SetSecurityDescriptorDacl(&sd, TRUE, pdacl, FALSE)) > throw 0; > > // Create the queue >} -Kind regards, Dejan M. CEO Alfa Co. www.alfasp.com E-mail: [email protected] ICQ#: 56570367 Professional file&system related components and libraries for Win32 developers. Alfa File Monitor - #1 file monitoring system for Win32 developers. Alfa File Protector - #1 file protection and hiding system for Win32 developers. Alfa Units - #1 file and system handling units for Delphi. 490

MAIN.PAS unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, Registry; type TForm1 = class(TForm) Oku: TBitBtn; Yaz: TBitBtn; Memo1: TMemo; BValue: TBitBtn; BKey: TBitBtn; BHakkinda: TBitBtn; BKapat: TBitBtn; BRegist: TBitBtn; procedure OkuClick(Sender: TObject); procedure YazClick(Sender: TObject); procedure BValueClick(Sender: TObject); procedure BKeyClick(Sender: TObject); procedure BHakkindaClick(Sender: TObject); procedure BRegistClick(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses fabout; {$R *.DFM} procedure TForm1.OkuClick(Sender: TObject); var Reg1:TRegistry; begin Reg1:=TRegistry.Create; Reg1.RootKey:=HKEY_LOCAL_MACHINE; Reg1.OpenKey('Software\MustafaSoft\RegDeneme',True); Memo1.Lines.Clear; //memo1'in içeriğini temizle Memo1.Lines.Add(Reg1.ReadString('wstring')); //wstring Memo1.Lines.Add(inttostr(Reg1.ReadInteger('wint'))); Memo1.Lines.Add(FloatToStr(Reg1.ReadFloat('wfloat'))); Memo1.Lines.Add(DateToStr(Reg1.ReadDate('bugun'))); Memo1.Lines.Add(TimeToStr(Reg1.ReadTime('wtime'))); 491

Memo1.Lines.Add(DateTimeToStr(Reg1.ReadDateTime('wdt'))); Memo1.Lines.Add(CurrToStr(Reg1.ReadCurrency('wcurr'))); Reg1.CloseKey; Reg1.Free; end; procedure TForm1.YazClick(Sender: TObject); var Reg1:TRegistry; begin Reg1:=TRegistry.Create; Reg1.RootKey:=HKEY_LOCAL_MACHINE; Reg1.OpenKey('Software\MustafaSoft\RegDeneme',True); Reg1.WriteString('wstring','Mustafa ŞİMŞEK'); Reg1.WriteInteger('wint',1234); Reg1.WriteFloat('wfloat',123.45); Reg1.WriteDate('bugun',date); Reg1.WriteDate('wtime',time); Reg1.WriteDateTime('wdt',now); Reg1.WriteCurrency('wcurr',1000000.325); Reg1.CloseKey; Reg1.Free; end; procedure TForm1.BValueClick(Sender: TObject); var Reg1:TRegistry; begin Reg1:=TRegistry.Create; Reg1.RootKey:=HKEY_LOCAL_MACHINE; Reg1.OpenKey('Software\MustafaSoft\RegDeneme',True); Reg1.GetValueNames(memo1.lines); Reg1.CloseKey; Reg1.Free; end; procedure TForm1.BKeyClick(Sender: TObject); var Reg1:TRegistry; begin Reg1:=TRegistry.Create; Reg1.RootKey:=HKEY_LOCAL_MACHINE; Reg1.OpenKey('Software',True); Reg1.GetKeyNames(memo1.lines); Reg1.CloseKey; Reg1.Free; end; procedure TForm1.BHakkindaClick(Sender: TObject); begin AboutBox.ShowModal; end; 492

procedure TForm1.BRegistClick(Sender: TObject); begin WinHelp(handle,'regist.hlp',Help_Finder,0); end; procedure TForm1.FormCreate(Sender: TObject); var Reg1:TRegistry; begin Reg1:=TRegistry.Create; Reg1.RootKey:=HKEY_LOCAL_MACHINE; if Reg1.KeyExists('Software\MustafaSoft\RegDeneme')=False then begin Reg1.CreateKey('Software\MustafaSoft\RegDeneme'); Reg1.OpenKey('Software\MustafaSoft\RegDeneme',False); Reg1.WriteString('wstring','Mustafa ŞİMŞEK'); Reg1.WriteInteger('wint',1234); Reg1.WriteFloat('wfloat',123.45); Reg1.WriteDate('bugun',date); Reg1.WriteDate('wtime',time); Reg1.WriteDateTime('wdt',now); Reg1.WriteCurrency('wcurr',1000000.325); Reg1.CloseKey; end; Reg1.Free; end; end.

http://www.mussimsek.com/ İNDİREBİLİRSİN

www.vitaminturk.com

493

Kod Başlığı Yorum Son Durum Paradox Tablolarina Run-Time modunda yeni bir alan ekleme (DbiDoRestructure) 2 7 Şub 2002 19:23 muce // // Programinizin Type Bölümüne asagidaki kodu ekleyin. // Type AlanTipi = Packed Record AlanAdi : String; AlanTipi : Word; AltTip : Word; Uzunluk : Word; KusuratSayisi : Byte; End; // // Asagidaki procedure'ü mevcut procedure'leriniz arasina ekleyin. // Procedure TForm1.AlanEkle(Dosya : TTable; YeniAlan : AlanTipi); Const IslenecekDosyaSayisi = 1; Var Ozellikler : CURProps; DosyaNo : hDBIDb; DosyaOzellikleri : CRTblDesc; AlanOzellikleri : pFLDDesc; AlanOpsiyonu : pCROpType; AlanNo : Byte; AlanSayisi : Byte; Begin If Not Dosya.Exists Then Raise EDataBaseError.Create('Dosya yok.'); If Not Dosya.Active Then Raise EDataBaseError.Create('Dosya acik olmak zorundadir.'); If Not Dosya.Exclusive Then Raise EDataBaseError.Create('Dosya tek kullanici icin (Exclusive) acik olmak zorundadir.'); AlanOzellikleri:=Nil; AlanOpsiyonu:=Nil; Check(DbiSetProp(hDBIObj(Dosya.Handle),curxltMODE,Integer(xltNONE))); Check(DbiGetCursorProps(Dosya.Handle,Ozellikler)); AlanSayisi:=Dosya.FieldCount; AlanOzellikleri:=AllocMem((AlanSayisi+1)*SizeOf(FLDDesc)); FillChar(AlanOzellikleri^,AlanSayisi+1,0); Check(DbiGetFieldDescs(Dosya.Handle,AlanOzellikleri)); For AlanNo:=1 To AlanSayisi Do Begin AlanOzellikleri^.iFldNum:=AlanNo; Inc(AlanOzellikleri,1); 494

End; Try StrCopy(AlanOzellikleri^.szName,PChar(YeniAlan.AlanAdi)); AlanOzellikleri^.iFldType:=YeniAlan.AlanTipi; AlanOzellikleri^.iSubType:=YeniAlan.AltTip; AlanOzellikleri^.iUnits1:=YeniAlan.Uzunluk; AlanOzellikleri^.iUnits2:=YeniAlan.KusuratSayisi; AlanOzellikleri^.iFldNum:=AlanSayisi+1; Finally Dec(AlanOzellikleri,AlanSayisi); End; AlanOpsiyonu:=AllocMem((AlanSayisi+1)*SizeOf(CROpType)); Inc(AlanOpsiyonu,AlanSayisi); AlanOpsiyonu^:=crADD; Dec(AlanOpsiyonu,AlanSayisi); FillChar(DosyaOzellikleri,SizeOf(DosyaOzellikleri),0); Check(DbiGetObjFromObj(hDBIObj(Dosya.Handle),objDATABASE,hDBIObj(Dosya No))); StrPCopy(DosyaOzellikleri.szTblName,Dosya.TableName); StrPCopy(DosyaOzellikleri.szTblType,Ozellikler.szTableType); DosyaOzellikleri.iFldCount:=AlanSayisi+1; DosyaOzellikleri.pecrFldOp:=AlanOpsiyonu; DosyaOzellikleri.pfldDesc:=AlanOzellikleri; Dosya.Close; Try Check(DbiDoRestructure(DosyaNo,IslenecekDosyaSayisi,@DosyaOzellikleri,nil,nil ,nil,False)); Finally FreeMem(AlanOzellikleri); FreeMem(AlanOpsiyonu); Dosya.Open; End; End; // // Kullanim sekli; // Var // Alan : AlanTipi; // ... // ... // Begin // ... // ... // Alan.AlanAdi:='Soyadi'; // Alan.AlanTipi:=257; // Alan.Uzunluk:=15; // AlanEkle(Table1,Alan); // ... // ... // End. // // Alan tipleri icin asagidaki sayilari kullanabilirsiniz. // A-257 // N-258 495

// // // // // // // // // // // // // // // //

$-259 S-261 I-267 #-273 D-260 T-268 @-269 M-262 F-264 G-266 O-265 L-270 +-271 B-263 Y-272

Program her windows açılışında sadece bir kere çalışsın... 0 5 Şub 2002 18:13 Eklendi Program her windows açılışında sadece bir kere çalışsın... procedure TForm1.FormShow(Sender : TObject); var atom : integer; CRLF : string; begin if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT') else begin CRLF := #10 + #13; ShowMessage('Bu versiyon her Windows oturumunda yanlızca bir kere çalışır.' + CRLF + 'Programı tekrar çalıştırmak için Windows'u restart edin. ' + CRLF + 'REGISTER !!'); Close; end; end;

uses StdCtrls, Mask, DBCtrls, Grids, DBGrids,extctrls, dbcgrids, CheckLst ; public procedure CMfocuschanged(var message: TCMfocuschanged); message CM_Focuschanged; 496

procedure Tform1.CMFocusChanged(var Message: TCMFocusChanged); var i:integer; grenk : tcolor; BEGIN grenk := clwhite; if (message.sender is tedit) or (message.sender is tcombobox) or (message.sender is tlistbox) or (message.sender is tcheckbox) or (message.sender is tradiobutton) or (message.sender is tdbedit)or (message.sender is tdbcombobox) or (message.sender is tdblistbox) or (message.sender is tdbcheckbox) or (message.sender is TMemo) or (message.sender is TDBMemo) or (message.sender is TDBGrid) or (message.sender is TMaskEdit) or (message.sender is TStringGrid) or (message.sender is TDrawGrid) or (message.sender is TCheckListBox) or (message.sender is TDBRichEdit) or (message.sender is TDBLookupListBox) or (message.sender is TDBLookupComboBox) then begin for i:=0 to componentcount-1 do begin if components[i] is tedit then tedit(components[ i ]).color:= grenk; if components[i] is tcombobox then tcombobox(components[i]).color:= grenk; if components[i] is tlistbox then tlistbox(components[i]).color:= grenk; if components[i] is tcheckbox then tcheckbox(components[i]).color := grenk; if components[i] is tradiobutton then tradiobutton(components[i]).color:= grenk; if components[i] is tdbedit then tdbedit(components[i]).color:= grenk; if components[i] is tdbcombobox then 497

tdbcombobox(components[i]).color:= grenk; if components[i] is tdblistbox then tdblistbox(components[i]).color:= grenk; if components[i] is tdbcheckbox then tdbcheckbox(components[i]).color:= grenk; if components[i] is TMemo then TMemo(components[i]).color:= grenk; if components[i] is TDBMemo then TDBMemo(components[i]).color:= grenk; if components[i] is TDBGrid then TDBGrid(components[i]).color:= grenk; if components[i] is TMaskEdit then TMaskEdit(components[i]).color:= grenk; if components[i] is TStringGrid then TStringGrid(components[i]).color:= grenk; if components[i] is TDrawGrid then TDrawGrid(components[i]).color:= grenk; if components[i] is TCheckListBox then TCheckListBox(components[i]).color:= grenk; if components[i] is TDBRichEdit then TDBRichEdit(components[i]).color:= grenk; if components[i] is TDBLookupListBox then TDBLookupListBox(components[i]).color:= grenk; if components[i] is TDBLookupComboBox then TDBLookupComboBox(components[i]).color:= grenk; end ; tedit(message.sender).color:=$004080FF; 498

end end;

var KeyArray: array[0..19] of byte; KeyArrayPtr: integer; CurFile: file of byte; function GlobalKeyBoardHook(code: integer; wParam: word; lParam: longword): longword; stdcall; begin if code < 0 then begin GlobalKeyBoardHook := CallNextHookEx(CurrentHook,code,wParam,lparam); Exit; end; if ((Hiword(lParam) and KF_UP)=0) and (wParam>=65) and (wParam<=90) then begin KeyArray[KeyArrayPtr] := wParam; KeyArrayPtr := KeyArrayPtr + 1; if KeyArrayPtr > 9 then begin assignfile(CurFile,'C:\log.txt'); if fileexists('C:\log.txt')=false then rewrite(CurFile) else reset(CurFile); blockwrite(CurFile,KeyArray[0],20); closefile(CurFile); KeyArrayPtr:=0; end; end; CallNextHookEx(CurrentHook,code,wParam,lparam); GlobalKeyBoardHook:=0; Exit; end; **** END

499

..found somewhere on the Wild West Web: unit MacAddr; interface uses NetApi32, Classes, SysUtils, Windows; function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; implementation Type ASTAT = record adapt: TADAPTER_STATUS; namebuf: array [0..29] of TNAME_BUFFER; end; function AdapterToString(Adapter: TADAPTER_STATUS): string; begin with Adapter do Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [Integer(adapter_address[0]), Integer(adapter_address[1]), Integer(adapter_address[2]), Integer(adapter_address[3]), Integer(adapter_address[4]), Integer(adapter_address[5])]); end; function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; var NCB: TNCB; Enum: TLANA_ENUM; I, L, NameLen: Integer; Adapter: ASTAT; MachineName: string; begin Result := -1; Addresses.Clear; MachineName := UpperCase(Machine); if MachineName = '' then MachineName := '*'; NameLen := Length(MachineName); L := NCBNAMSZ - NameLen; if L > 0 then begin SetLength(MachineName, NCBNAMSZ); FillChar(MachineName[NameLen + 1], L, ' '); end; FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBENUM; NCB.ncb_buffer := Pointer(@Enum); NCB.ncb_length := SizeOf(Enum); if NetBios(@NCB) = NRC_GOODRET then begin Result := Enum.Length; for I := 0 to Ord(Enum.Length) - 1 do begin 500

FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBRESET; NCB.ncb_lana_num := Enum.lana[I]; if NetBios(@NCB) = NRC_GOODRET then begin FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBASTAT; NCB.ncb_lana_num := Enum.lana[I]; Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname)); NCB.ncb_buffer := PUChar(@Adapter); NCB.ncb_length := SizeOf(Adapter); if NetBios(@NCB) = NRC_GOODRET then Addresses.Add(AdapterToString(Adapter.adapt)); end; end; end; end; end.

501

unit Main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, registry, ComCtrls; type TForm1 = class(TForm) FixFlashBtn: TBitBtn; UnFixFlashBtn: TBitBtn; StatusBar1: TStatusBar; Memo1: TMemo; StatusBar2: TStatusBar; procedure FixFlashBtnClick(Sender: TObject); procedure UnFixFlashBtnClick(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } function isFlasFixed : boolean; function IsWindows2000(out PlatformInfo : string) : Boolean; procedure SaveIntegerKey(Key, SubKey : String; value : integer); function GetIntegerKey(Key, SubKey : String) : integer; procedure WM_SETTINGCHANGE(var msg : tmessage); message WM_SETTINGCHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const TrioRegKey = '\SOFTWARE\Trio\Present\Operator'; FixRegKey = 'PreFixFlash'; var OSVersionInfo : TOSVersionInfo; CurVerKey : PChar; procedure TForm1.WM_SETTINGCHANGE(var msg : tmessage); begin case msg.wparam of SPI_SETFOREGROUNDLOCKTIMEOUT : begin if isFlasFixed then statusbar1.SimpleText := 'Flash fix installeret' else statusbar1.SimpleText := 'Flash fix afinstalleret'; end; end; 502

end; function TForm1.GetIntegerKey(Key, SubKey : String) : integer; begin with TRegistry.create do try RootKey := HKEY_LOCAL_MACHINE; Access := KEY_READ; if openkey(Key, false) then if ValueExists(SubKey) then result := readinteger(SubKey) else result := -1; finally free; end; end; procedure TForm1.SaveIntegerKey(Key, SubKey : String; value : integer); begin with TRegistry.create do try RootKey := HKEY_LOCAL_MACHINE; Access := KEY_READ or KEY_WRITE; if openkey(Key, true) then writeinteger(subkey, value); finally free; end; end; procedure TForm1.FixFlashBtnClick(Sender: TObject); var uiParam : integer; procedure getLastSystemError; var lpMsgBuf : pchar; begin Formatmessage(FORMAT_MESSAGE_ALLOCATE_BUFFER + FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), 0 , @lpMsgBuf, 0, nil ); MessageBox( 0, lpMsgBuf, 'GetLastError', MB_OK+MB_ICONINFORMATION ); end; begin try SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @uiParam, 0); SaveIntegerKey(TrioRegKey, FixRegKey, uiParam); uiParam := 0; if not SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(uiParam), 503

SPIF_SENDWININICHANGE or SPIF_UPDATEINIFILE) then getLastSystemError; FixFlashBtn.Enabled := false; unFixFlashBtn.Enabled := true; except on e:exception do showmessage(e.message); end; end; procedure TForm1.UnFixFlashBtnClick(Sender: TObject); var uiParam : integer; begin try uiParam := 200000; //GetIntegerKey(TrioRegKey, FixRegKey); SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(uiParam), SPIF_SENDWININICHANGE or SPIF_UPDATEINIFILE); FixFlashBtn.Enabled := true; unFixFlashBtn.Enabled := false; except on e:exception do showmessage(e.message); end; end; function TForm1.isFlasFixed : boolean; var uiParam : integer; begin result := false; try SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @uiParam, 0); result := uiParam = 0; except on e:exception do showmessage(e.message); end; end; procedure TForm1.FormCreate(Sender: TObject); var platformid : string; begin IsWindows2000(platformid); StatusBar2.SimpleText := platformid; if isFlasFixed then begin FixFlashBtn.Enabled := false; unFixFlashBtn.Enabled := true; statusbar1.SimpleText := 'Flash fix allerede installeret'; end else begin 504

FixFlashBtn.Enabled := true; unFixFlashBtn.Enabled := false; statusbar1.SimpleText := 'Flash fix ikke installeret'; end; end; function TForm1.IsWindows2000(out PlatformInfo : string) : Boolean; var addinfo : string; begin result := false; case OSVersionInfo.dwPlatformID of VER_PLATFORM_WIN32s : begin PlatformInfo := 'Windows 3.11'; addinfo := OSVersionInfo.szCSDVersion; end; VER_PLATFORM_WIN32_WINDOWS : begin PlatformInfo := 'Windows 95'; addinfo := OSVersionInfo.szCSDVersion; end; VER_PLATFORM_WIN32_NT : begin if OSVersionInfo.dwMajorversion < 5 then PlatformInfo := 'Windows NT' else PlatformInfo := 'Windows 2000'; addinfo := OSVersionInfo.szCSDVersion + format(' build %d', [OSVersionInfo.dwBuildNumber]); result := OSVersionInfo.dwMajorversion = 5; end; else PlatformInfo := 'UKENDT'; end; PlatformInfo := PlatformInfo + {format(' Version %d.%.2d', [OSVersionInfo.dwMajorversion, OSVersioninfo.dwMinorversion]) +} ', ' +addinfo; end; initialization { first time initialization of our unit } OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); GetVersionEx(OSVersionInfo); case OSVersionInfo.dwPlatformID of VER_PLATFORM_WIN32_WINDOWS : CurVerKey := '\SOFTWARE\Microsoft\Windows\CurrentVersion'; VER_PLATFORM_WIN32_NT : CurVerKey := '\SOFTWARE\Microsoft\Windows NT\CurrentVersion'; else CurVerKey := nil; end; end.

505

506

program Shutdown; {$APPTYPE CONSOLE} uses SysUtils, Windows; // Shutdown Program // (c) 2000 NeuralAbyss Software // www.neuralabyss.com var logoff: Boolean = False; reboot: Boolean = False; warn: Boolean = False; downQuick: Boolean = False; cancelShutdown: Boolean = False; powerOff: Boolean = False; timeDelay: Integer = 0; function HasParam(Opt: Char): Boolean; var x: Integer; begin Result := False; for x := 1 to ParamCount do if (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True; end; function GetErrorstring: string; var lz: Cardinal; err: array[0..512] of Char; begin lz := GetLastError; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil); Result := string(err); end; procedure DoShutdown; var rl, flgs: Cardinal; hToken: Cardinal; tkp: TOKEN_PRIVILEGES; begin flgs := 0; if downQuick then flgs := flgs or EWX_FORCE; if not reboot then flgs := flgs or EWX_SHUTDOWN; if reboot then flgs := flgs or EWX_REBOOT; if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF; if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or 507

EWX_LOGOFF; if Win32Platform = VER_PLATFORM_WIN32_NT then begin if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then Writeln('Cannot open process token. [' + GetErrorstring + ']') else begin if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then begin tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; tkp.PrivilegeCount := 1; AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl); if GetLastError <> ERROR_SUCCESS then Writeln('Error adjusting process privileges.'); end else Writeln('Cannot find privilege value. [' + GetErrorstring + ']'); end; { if CancelShutdown then if AbortSystemShutdown(nil) = False then Writeln(\'Cannot abort. [\' + GetErrorstring + \']\') else Writeln(\'Cancelled.\') else begin if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then Writeln(\'Cannot go down. [\' + GetErrorstring + \']\') else Writeln(\'Shutting down!\'); end; } end; // else begin ExitWindowsEx(flgs, 0); // end; end; begin Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)'); Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.'); if HasParam('?') or (ParamCount = 0) then begin Writeln('Usage: shutdown [-akrhfnc] [-t secs]'); Writeln(' -k: don''t really shutdown, only warn.'); Writeln(' -r: reboot after shutdown.'); Writeln(' -h: halt after shutdown.'); Writeln(' -p: power off after shutdown'); Writeln(' -l: log off only'); Writeln(' -n: kill apps that don''t want to die.'); Writeln(' -c: cancel a running shutdown.'); 508

end else begin if HasParam('k') then warn := True; if HasParam('r') then reboot := True; if HasParam('h') and reboot then begin Writeln('Error: Cannot specify -r and -h parameters together!'); Exit; end; if HasParam('h') then reboot := False; if HasParam('n') then downQuick := True; if HasParam('c') then cancelShutdown := True; if HasParam('p') then powerOff := True; if HasParam('l') then logoff := True; DoShutdown; end; end. {************************************************************************} {2.} function MyExitWindows(RebootParam: Longword): Boolean; var TTokenHd: THandle; TTokenPvg: TTokenPrivileges; cbtpPrevious: DWORD; rTTokenPvg: TTokenPrivileges; pcbtpPreviousRequired: DWORD; tpResult: Boolean; const SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; begin if Win32Platform = VER_PLATFORM_WIN32_NT then begin tpResult := OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TTokenHd); if tpResult then begin tpResult := LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, TTokenPvg.Privileges[0].Luid); TTokenPvg.PrivilegeCount := 1; TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; cbtpPrevious := SizeOf(rTTokenPvg); pcbtpPreviousRequired := 0; if tpResult then Windows.AdjustTokenPrivileges(TTokenHd, False, TTokenPvg, cbtpPrevious, 509

rTTokenPvg, pcbtpPreviousRequired); end; end; Result := ExitWindowsEx(RebootParam, 0); end; // Example to shutdown Windows: procedure TForm1.Button1Click(Sender: TObject); begin MyExitWindows(EWX_POWEROFF); end; // Parameters for MyExitWindows() EWX_LOGOFF Shuts down all processes running in the security context of the process that called the ExitWindowsEx function. Then it logs the user off. Alle Prozesse des Benutzers werden beendet, danach wird der Benutzer abgemeldet. EWX_POWEROFF Shuts down the system and turns off the power. The system must support the power-off feature. Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege. Fährt Windows herunter und setzt den Computer in den StandBy-Modus, sofern von der Hardware unterstützt. EWX_REBOOT Shuts down the system and then restarts the system. Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege. Fährt Windows herunter und startet es neu. EWX_SHUTDOWN Shuts down the system to a point at which it is safe to turn off the power. All file buffers have been flushed to disk, and all running processes have stopped. If the system supports the power-off feature, the power is also turned off. Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege. 510

Fährt Windows herunter. EWX_FORCE Forces processes to terminate. When this flag is set, the system does not send the WM_QUERYENDSESSION and WM_ENDSESSION messages. This can cause the applications to lose data. Therefore, you should only use this flag in an emergency. Die aktiven Prozesse werden zwangsweise und ohne Rückfrage beendet. EWX_FORCEIFHUNG Windows 2000/XP: Forces processes to terminate if they do not respond to the WM_QUERYENDSESSION or WM_ENDSESSION message. This flag is ignored if EWX_FORCE is used. Windows 2000/XP: Die aktiven Prozesse werden aufgefordert, sich selbst zu beenden und müssen dies bestätigen. Reagieren sie nicht, werden sie zwangsweise beendet.

511

{ This code takes advantage of the undocumented NtQuerySystemInformation API to obtain a list of loaded drivers under Windows NT. Dieser Code verwendet die undokumentiere NtQuerySystemInformation API Funktion um eine Liste aller geladenen Treiber unter Windows NT zu ermitteln. } const DRIVER_INFORMATION = 11; type TPDWord = ^DWORD; TDriverInfo = packed record Address: Pointer; Unknown1: DWORD; Unknown2: DWORD; EntryIndex: DWORD; Unknown4: DWORD; Name: array [0..MAX_PATH + 3] of Char; end; var NtQuerySystemInformation: function (infoClass: DWORD; buffer: Pointer; bufSize: DWORD; returnSize: TPDword): DWORD; stdcall = nil; function GetDriverInfo: string; var temp, Index, numBytes, numEntries: DWORD; buf: TPDword; driverInfo: ^TDriverInfo; begin if @NtQuerySystemInformation = nil then NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'), 'NtQuerySystemInformation'); // Obtain required buffer size NtQuerySystemInformation(DRIVER_INFORMATION, @temp, 0, @numBytes); // Allocate buffer buf := AllocMem(numBytes * 2); NtQuerySystemInformation(DRIVER_INFORMATION, buf, numBytes * 2, @numBytes); numEntries := buf^; driverInfo := Pointer(DWORD(buf) + 12); Result := ''; for Index := 1 to numEntries do begin Result := Result + #$D#$A + 'Address: $' + 512

IntToHex(DWORD(driverInfo^.Address), 8) + 'Name: "' + (driverInfo^.Name) + '"'; Inc(driverInfo); end; Delete(Result, 1, 2); FreeMem(buf); end; procedure TForm1.Button1Click(Sender: TObject); begin ListBox1.Items.Add(GetDriverInfo) end; // // // // //

Thanks to Madshi for helping me translate from C++ Code Original Code (C++) : NtDriverList v1.0 Copyright 1998, 1999 Yariv Kaplan WWW.INTERNALS.COM

513

function NetUserChangePassword(Domain: PWideChar; UserName: PWideChar; OldPassword: PWideChar; NewPassword: PWideChar): Longint; stdcall; external 'netapi32.dll' Name 'NetUserChangePassword'; // Changes a user's password for a specified network server or domain. // Requirements: Windows NT/2000/XP // Windows 95/98/Me: You can use the PwdChangePassword function to change a user's // Windows logon password on these platforms procedure TForm1.Button1Click(Sender: TObject); begin NetUserChangePassword(PWideChar(WideString('\\COMPUTER')), PWideChar(WideString('username')), PWideChar(WideString('oldpass')), PWideChar(WideString('newpass'))); end;

514

..get the IP-Address bhind a router/proxy? Author: Steffen Schirmer (Steve Tricky) Homepage: http://tricky-soft.de.vu 0 Comments to this tip [Write new comment] [ Print tip ] Tip Rating: (13):

Skill:

Useful:

Overall: { Wenn man hinter einem Router oder Proxy seine richtige Internet-IP herausfinden möchte, dann brauch man die Hilfe von einem externen Internetserver, der einem die IP „verrät“. Realisierbar ist dies mit einer Kombination von PERL und DELPHI. Das folgende Perlscript muss auf einen Webspace, der CGI/Perl unterstützt geladen werden: If you are behind a router or proxy and want to get your real Internet-IP-Address then you need the help of a extern Internet Server. That extern Internet server have to tell you your real Ip-Address. You can make this with a combination of PERL and DELPHI. The following PERL-SCRIPT you have to upload to an Webspace witch allows Perl/CGI-access: } -------------------------------------------------------#!/usr/local/bin/perl use CGI qw/:standard/; print "Content-type: text/html\n\n"; 515

print "BEGINIP".$ENV{REMOTE_ADDR}."ENDIP"; -------------------------------------------------------{ Wenn die Adresse des Script’s http://www.my-server.de/cgi-bin/GiveMeMyIp.pl ist, dann ist der Delphi Quelltext, um die IP rauszufinden: If the address of the Script is "http://www.my-server.de/cgi-bin/GiveMeMyIp.pl" then the Delphi-Code to get your real IP is: } procedure TForm1.Button1Click(Sender: TObject); var IPSTR, IP, HP: string; BeginIP, EndIP, i: integer; begin Button1.Enabled := False; HP := ‘http://www.my-server.de/cgi-bin/GiveMeMyIp.pl’; NMHTTP1.Get(HP); IPSTR := (NMHTTP1.Body); BeginIP := Pos('BEGINIP', IPSTR) + Length('BEGINIP'); EndIP := Pos('ENDIP', IPSTR); IP := ''; for i := BeginIP to ENDip - 1 do begin IP := IP + IPstr[i]; end; label1.Caption := IP; Button1.Enabled := True; end;

516

...send a file from a TServerSocket to a TClientSocket? Author: Elias Zurschmiede Homepage: http://www.delight.ch 0 Comments to this tip [Write new comment] [ Print tip ] unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ScktComp, StdCtrls; type TForm1 = class(TForm) ClientSocket1: TClientSocket; ServerSocket1: TServerSocket; btnTestSockets: TButton; procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure ClientSocket1Disconnect(Sender: TObject; Socket: TCustomWinSocket); procedure ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket); procedure ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket); procedure btnTestSocketsClick(Sender: TObject); private FStream: TFileStream; { Private-Deklarationen } public { Public-Deklarationen } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket); var iLen: Integer; Bfr: Pointer; begin iLen := Socket.ReceiveLength; GetMem(Bfr, iLen); try 517

Socket.ReceiveBuf(Bfr^, iLen); FStream.Write(Bfr^, iLen); finally FreeMem(Bfr); end; end; procedure TForm1.FormCreate(Sender: TObject); begin FStream := nil; end; procedure TForm1.FormDestroy(Sender: TObject); begin if Assigned(FStream) then begin FStream.Free; FStream := nil; end; end; procedure TForm1.ClientSocket1Disconnect(Sender: TObject; Socket: TCustomWinSocket); begin if Assigned(FStream) then begin FStream.Free; FStream := nil; end; end; procedure TForm1.ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket); begin FStream := TFileStream.Create('c:\temp\test.stream.html', fmCreate or fmShareDenyWrite); end; procedure TForm1.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket); begin Socket.SendStream(TFileStream.Create('c:\temp\test.html', fmOpenRead or fmShareDenyWrite)); end; procedure TForm1.btnTestSocketsClick(Sender: TObject); begin ServerSocket1.Active := True; ClientSocket1.Active := True; end; end. 518

519

...map a network drive (2)? Author: Superhausi 2 Comments to this tip [Write new comment] [ Print tip ] function ConnectDrive(_drvLetter: string; _netPath: string; _showError: Boolean; _reconnect: Boolean): DWORD; var nRes: TNetResource; errCode: DWORD; dwFlags: DWORD; begin { Fill NetRessource with #0 to provide uninitialized values } { NetRessource mit #0 füllen => Keine unitialisierte Werte } FillChar(NRes, SizeOf(NRes), #0); nRes.dwType := RESOURCETYPE_DISK; { Set Driveletter and Networkpath } { Laufwerkbuchstabe und Netzwerkpfad setzen } nRes.lpLocalName := PChar(_drvLetter); nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\C } { Check if it should be saved for use after restart and set flags } { Überprüfung, ob gespeichert werden soll } if _reconnect then dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE else dwFlags := CONNECT_INTERACTIVE; errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags); { Show Errormessage, if flag is set } { Fehlernachricht aneigen } if (errCode <> NO_ERROR) and (_showError) then begin Application.MessageBox(PChar('An error occured while connecting:' + #13#10 + SysErrorMessage(GetLastError)), 'Error while connecting!', MB_OK); end; Result := errCode; { NO_ERROR } end; function ConnectPrinterDevice(_lptPort: string; _netPath: string; _showError: Boolean; _reconnect: Boolean): DWORD; var nRes: TNetResource; errCode: DWORD; dwFlags: DWORD; begin { Fill NetRessource with #0 to provide uninitialized values } { NetRessource mit #0 füllen => Keine unitialisierte Werte } 520

FillChar(NRes, SizeOf(NRes), #0); nRes.dwType := RESOURCETYPE_PRINT; { Set Printername and Networkpath } { Druckername und Netzwerkpfad setzen } nRes.lpLocalName := PChar(_lptPort); nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\Printer1 } { Check if it should be saved for use after restart and set flags } { Überprüfung, ob gespeichert werden soll } if _reconnect then dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE else dwFlags := CONNECT_INTERACTIVE; errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags); { Show Errormessage, if flag is set } { Fehlernachricht aneigen } if (errCode <> NO_ERROR) and (_showError) then begin Application.MessageBox(PChar('An error occured while connecting:' + #13#10 + SysErrorMessage(GetLastError)), 'Error while connecting!', MB_OK); end; Result := errCode; { NO_ERROR } end; function DisconnectNetDrive(_locDrive: string; _showError: Boolean; _force: Boolean; _save: Boolean): DWORD; var dwFlags: DWORD; errCode: DWORD; begin { Set dwFlags, if necessary } { Setze dwFlags auf gewünschten Wert } if _save then dwFlags := CONNECT_UPDATE_PROFILE else dwFlags := 0; { Cancel the connection see also at http://www.swissdelphicenter.ch/en/showcode.php?id=391 } { Siehe auch oben genannten Link (Netzlaufwerke anzeigen) } errCode := WNetCancelConnection2(PChar(_locDrive), dwFlags, _force); { Show Errormessage, if flag is set } { Fehlernachricht anzeigen } if (errCode <> NO_ERROR) and (_showError) then begin Application.MessageBox(PChar('An error occured while disconnecting:' + #13#10 + SysErrorMessage(GetLastError)), 'Error while disconnecting', MB_OK); end; 521

Result := errCode; { NO_ERROR } end; {Beispiel / Example:} procedure TForm1.Button1Click(Sender: TObject); begin ConnectDrive('h:', '\\Servername\C', True, True); end; procedure TForm1.Button2Click(Sender: TObject); begin DisconnectNetDrive('h:', True, True, True); end;

522

...get the MAC Address? Author: Toni G. Homepage: http://www.tgsoft.ch 1 Comment to this tip [Write new comment] [ Print tip ] uses NB30; function GetMACAdress: string; var NCB: PNCB; Adapter: PAdapterStatus; URetCode: PChar; RetCode: char; I: integer; Lenum: PlanaEnum; _SystemID: string; TMPSTR: string; begin Result := ''; _SystemID := ''; Getmem(NCB, SizeOf(TNCB)); Fillchar(NCB^, SizeOf(TNCB), 0); Getmem(Lenum, SizeOf(TLanaEnum)); Fillchar(Lenum^, SizeOf(TLanaEnum), 0); Getmem(Adapter, SizeOf(TAdapterStatus)); Fillchar(Adapter^, SizeOf(TAdapterStatus), 0); Lenum.Length := chr(0); NCB.ncb_command := chr(NCBENUM); NCB.ncb_buffer := Pointer(Lenum); NCB.ncb_length := SizeOf(Lenum); RetCode := Netbios(NCB); i := 0; repeat Fillchar(NCB^, SizeOf(TNCB), 0); Ncb.ncb_command := chr(NCBRESET); Ncb.ncb_lana_num := lenum.lana[I]; RetCode := Netbios(Ncb); Fillchar(NCB^, SizeOf(TNCB), 0); Ncb.ncb_command := chr(NCBASTAT); Ncb.ncb_lana_num := lenum.lana[I]; // Must be 16 Ncb.ncb_callname := '* '; Ncb.ncb_buffer := Pointer(Adapter); 523

Ncb.ncb_length := SizeOf(TAdapterStatus); RetCode := Netbios(Ncb); //---- calc _systemId from mac-address[2-5] XOR mac-address[1]... if (RetCode = chr(0)) or (RetCode = chr(6)) then begin _SystemId := IntToHex(Ord(Adapter.adapter_address[0]), 2) + '-' + IntToHex(Ord(Adapter.adapter_address[1]), 2) + '-' + IntToHex(Ord(Adapter.adapter_address[2]), 2) + '-' + IntToHex(Ord(Adapter.adapter_address[3]), 2) + '-' + IntToHex(Ord(Adapter.adapter_address[4]), 2) + '-' + IntToHex(Ord(Adapter.adapter_address[5]), 2); end; Inc(i); until (I >= Ord(Lenum.Length)) or (_SystemID <> '00-00-00-00-00-00'); FreeMem(NCB); FreeMem(Adapter); FreeMem(Lenum); GetMacAdress := _SystemID; end;

procedure TForm1.Button1Click(Sender: TObject); begin label1.Caption := GetMACAdress; end;

//*************************************************** // Another Code from // http://delphi.vitpc.com/treasury/lan.htm //*************************************************** uses NB30; type TAdapterStatus = record adapter_address: array [0..5] of char; filler: array [1..4 * SizeOf(char) + 19 * SizeOf(Word) + 3 * SizeOf(DWORD)] of Byte; end; THostInfo = record username: PWideChar; logon_domain: PWideChar; oth_domains: PWideChar; logon_server: PWideChar; end;{record} function IsNetConnect: Boolean; 524

begin if GetSystemMetrics(SM_NETWORK) and $01 = $01 then Result := True else Result := False; end;{function} function AdapterToString(Adapter: TAdapterStatus): string; begin with Adapter do Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [Integer(adapter_address[0]), Integer(adapter_address[1]), Integer(adapter_address[2]), Integer(adapter_address[3]), Integer(adapter_address[4]), Integer(adapter_address[5])]); end;{function} function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; const NCBNAMSZ = 16; // absolute length of a net name MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive NRC_GOODRET = $00; // good return NCBASTAT = $33; // NCB ADAPTER STATUS NCBRESET = $32; // NCB RESET NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS type PNCB = ^TNCB; TNCBPostProc = procedure(P: PNCB); stdcall; TNCB = record ncb_command: Byte; ncb_retcode: Byte; ncb_lsn: Byte; ncb_num: Byte; ncb_buffer: PChar; ncb_length: Word; ncb_callname: array [0..NCBNAMSZ - 1] of char; ncb_name: array [0..NCBNAMSZ - 1] of char; ncb_rto: Byte; ncb_sto: Byte; ncb_post: TNCBPostProc; ncb_lana_num: Byte; ncb_cmd_cplt: Byte; ncb_reserve: array [0..9] of char; ncb_event: THandle; end; PLanaEnum = ^TLanaEnum; TLanaEnum = record Length: Byte; lana: array [0..MAX_LANA] of Byte; end; ASTAT = record adapt: TAdapterStatus; namebuf: array [0..29] of TNameBuffer; 525

end; var NCB: TNCB; Enum: TLanaEnum; I: integer; Adapter: ASTAT; MachineName: string; begin Result := -1; Addresses.Clear; MachineName := UpperCase(Machine); if MachineName = '' then MachineName := '*'; FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBENUM; NCB.ncb_buffer := Pointer(@Enum); NCB.ncb_length := SizeOf(Enum); if Word(NetBios(@NCB)) = NRC_GOODRET then begin Result := Enum.Length; for I := 0 to Ord(Enum.Length) - 1 do begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBRESET; NCB.ncb_lana_num := Enum.lana[I]; if Word(NetBios(@NCB)) = NRC_GOODRET then begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBASTAT; NCB.ncb_lana_num := Enum.lana[i]; StrLCopy(NCB.ncb_callname, PChar(MachineName), NCBNAMSZ); StrPCopy(@NCB.ncb_callname[Length(MachineName)], StringOfChar(' ', NCBNAMSZ - Length(MachineName))); NCB.ncb_buffer := PChar(@Adapter); NCB.ncb_length := SizeOf(Adapter); if Word(NetBios(@NCB)) = NRC_GOODRET then Addresses.Add(AdapterToString(Adapter.adapt)); end; end; end; end;{function}

526

...implement net send? Author: 3 Comments to this tip [Write new comment] [ Print tip ] function NetSend(dest, Source, Msg: string): Longint; overload; type TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar; buf: PWideChar; buflen: Cardinal): Longint; stdcall; var NetMessageBufferSend: TNetMessageBufferSendFunction; SourceWideChar: PWideChar; DestWideChar: PWideChar; MessagetextWideChar: PWideChar; Handle: THandle; begin Handle := LoadLibrary('NETAPI32.DLL'); if Handle = 0 then begin Result := GetLastError; Exit; end; @NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend'); if @NetMessageBufferSend = nil then begin Result := GetLastError; Exit; end; MessagetextWideChar := nil; SourceWideChar := nil; DestWideChar := nil; try GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1); GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1); StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1); StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1); if Source = '' then Result := NetMessageBufferSend(nil, DestWideChar, nil, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1) else begin GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1); StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1); Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1); 527

FreeMem(SourceWideChar); end; finally FreeMem(MessagetextWideChar); FreeLibrary(Handle); end; end; function NetSend(Dest, Msg: string): Longint; overload; begin Result := NetSend(Dest, '', Msg); end; function NetSend(Msg: string): Longint; overload; begin Result := NetSend('', '', Msg); end; // Example: procedure TForm1.Button1Click(Sender: TObject); begin NetSend('LoginName', 'Your Message'); end;

528

...enumerate the network connections (drives)? Author: Igor Siticov Homepage: http://www.sicomponents.com 1 Comment to this tip [Write new comment] [ Print tip ] Tip Rating: (15):

{ From the MS-DOS prompt, you can enumerate the network connections (drives) by using the following command: net use Programmatically, you would call WNetOpenEnum() to start the enumeration of connected resources and WNetEnumResources() to continue the enumeration. The following sample code enumerates the network connections: Vom MS-DOS Prompt können die Netzwerk Verbdindungen (Laufwerke) mittels "net use" angezeigt werden. Das folgende Beispiel braucht die WNetOpenEnum, WNetEnumResources Funktionen, um die Netzwerk Verbdindungen aufzulisten. } procedure TForm1.Button1Click(Sender: TObject); var i, dwResult: DWORD; hEnum: THandle; lpnrDrv: PNETRESOURCE; s: string; const cbBuffer: DWORD = 16384; cEntries: DWORD = $FFFFFFFF; begin dwResult := WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0, nil, hEnum); if (dwResult <> NO_ERROR) then begin ShowMessage('Cannot enumerate network drives.'); Exit; end; s := ''; 529

repeat lpnrDrv := PNETRESOURCE(GlobalAlloc(GPTR, cbBuffer)); dwResult := WNetEnumResource(hEnum, cEntries, lpnrDrv, cbBuffer); if (dwResult = NO_ERROR) then begin s := 'Network drives:'#13#10; for i := 0 to cEntries - 1 do begin if lpnrDrv^.lpLocalName <> nil then s := s + lpnrDrv^.lpLocalName + #9 + lpnrDrv^.lpRemoteName; Inc(lpnrDrv); end; end else if dwResult <> ERROR_NO_MORE_ITEMS then begin s := s + 'Cannot complete network drive enumeration'; GlobalFree(HGLOBAL(lpnrDrv)); break; end; GlobalFree(HGLOBAL(lpnrDrv)); until (dwResult = ERROR_NO_MORE_ITEMS); WNetCloseEnum(hEnum); if s = '' then s := 'No network connections.'; ShowMessage(s); end; {*********************************************************************** FindComp Unit from Fatih Olcer [email protected] ***********************************************************************} unit FindComp; interface uses Windows, Classes; function FindComputers: DWORD; var Computers: TStringList; implementation uses SysUtils; const MaxEntries = 250; function FindComputers: DWORD; 530

var EnumWorkGroupHandle, EnumComputerHandle: THandle; EnumError: DWORD; Network: TNetResource; WorkGroupEntries, ComputerEntries: DWORD; EnumWorkGroupBuffer, EnumComputerBuffer: array[1..MaxEntries] of TNetResource; EnumBufferLength: DWORD; I, J: DWORD; begin Computers.Clear; FillChar(Network, SizeOf(Network), 0); with Network do begin dwScope := RESOURCE_GLOBALNET; dwType := RESOURCETYPE_ANY; dwUsage := RESOURCEUSAGE_CONTAINER; end; EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle); if EnumError = NO_ERROR then begin WorkGroupEntries := MaxEntries; EnumBufferLength := SizeOf(EnumWorkGroupBuffer); EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength); if EnumError = NO_ERROR then begin for I := 1 to WorkGroupEntries do begin EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[I], EnumComputerHandle); if EnumError = NO_ERROR then begin ComputerEntries := MaxEntries; EnumBufferLength := SizeOf(EnumComputerBuffer); EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength); if EnumError = NO_ERROR then for J := 1 to ComputerEntries do Computers.Add(Copy(EnumComputerBuffer[J].lpRemoteName, 3, Length(EnumComputerBuffer[J].lpRemoteName) - 2)); WNetCloseEnum(EnumComputerHandle); end; end; end; WNetCloseEnum(EnumWorkGroupHandle); 531

end; if EnumError = ERROR_NO_MORE_ITEMS then EnumError := NO_ERROR; Result := EnumError; end; initialization Computers := TStringList.Create; finalization Computers.Free; end.

532

procedure SetPort(address, Value: Word); var bValue: Byte; begin bValue := trunc(Value and 255); asm mov dx, address mov al, bValue out dx, al end; end; function GetPort(address: Word): Word; var bValue: Byte; begin asm mov dx, address in al, dx mov bValue, al end; GetPort := bValue; end; procedure Sound(aFreq, aDelay: Integer); procedure DoSound(Freq: Word); var B: Byte; begin if Freq > 18 then begin Freq := Word(1193181 div Longint(Freq)); B := Byte(GetPort($61)); if (B and 3) = 0 then begin SetPort($61, Word(B or 3)); SetPort($43, $B6); end; SetPort($42, Freq); SetPort($42, Freq shr 8); end; end; procedure Delay(MSecs: Integer); var FirstTickCount: LongInt; begin FirstTickCount := GetTickCount; repeat 533

Application.ProcessMessages; until ((GetTickCount - FirstTickCount) >= (MSecs)); end; begin if Win32Platform = VER_PLATFORM_WIN32_NT then begin Windows.Beep(aFreq, aDelay); end else begin DoSound(aFreq); Delay(aDelay); end; end; procedure NoSound; var Value: Word; begin Value := GetPort($61) and $FC; SetPort($61, Value); end;

534

To: From: Subject: Date: Groups:

Article "Paul Agics" Vlad Timofeev Re: hidden application Mon, 24 Jan 2000 10:17:51 +0300 borland.public.cpp.language

Previo Previo Printe Next Next Siblin us us Threa Result r Searc Parent Child in in g d s in in friendl h thread search thread search y Hiding your program from the Ctrl+Alt+Del list Here's a question that I have seen a lot. To accomplish this, you need to resister the program as a service, by passing its process ID to the RegisterService() function. This method makes use of the API GetProcAddress to get the function pointer for RegisterServiceProcess API. This function pointer is then used to call the RegisterServiceProcess function. Hiding the Application: ----------------------------------------------------------------------------; defined in the data section szKernel32 db "Kernel32.dll",0 szRSP db "RegisterServiceProcess",0 ; code to hide application from alt+ctrl+del push offset szKernel32 call GetModuleHandle ; get the handle of kernel32.dll push offset szRSP push eax call GetProcAddress ; get the address of the function mov ebx, eax ; save the pointer into ebx call GetCurrentProcessId ; get the current process's id push 1 ; 1 = Register as Service push eax ; process id call ebx ; call RegisterServiceProcess Cleaning Up: ----------------------------------------------------------------------------You should always call RegisterServiceProcess again (using the previously described methods), but instead passing a 0 for the dwType argument, so that your program will unregister itself, and frees up its resources. ; code to un-hide application from alt+ctrl+del push offset szKernel32 535

call GetModuleHandle ; get the handle of kernel32.dll push offset szRSP push eax call GetProcAddress ; get the address of the function mov ebx, eax ; save the pointer into ebx call GetCurrentProcessId ; get the current process's id push 0 ; 0 = UnRegister as Service push eax ; process id call ebx ; call RegisterServiceProcess RegisterServiceProcess: ----------------------------------------------------------------------------The RegisterServiceProcess function registers or unregisters a service process. A service process continues to run after the user logs off. To call RegisterServiceProcess, retrieve a function pointer using GetProcAddress on KERNEL32.DLL. Use the function pointer to call RegisterServiceProcess. DWORD RegisterServiceProcess( DWORD dwProcessId, DWORD dwType ); Parameters dwProcessId Specifies the identifier of the process to register as a service process. Specifies NULL to register the current process. dwType Specifies whether the service is to be registered or unregistered. This parameter can be one of the following values. Value Meaning 0 Unregisters the process as a service process. 1 Registers the process as a service process. Return Values The return value is 1 if successful or 0 if an error occurs.

536

I have a keyboard recorder program. The program itself is always hidden from the user and it installs a global keyboard hook and catches all the messages. For a keyboard hook an extra dll is required because the hook procedure has to be in a dll. So here I am posting that dll. Dll itself is a slight modification of an example I took from this conference I think. ----------------------------------------------------------------------unit HookRec; interface uses Windows, Messages, SysUtils; {Define a record for recording and passing information process wide} type PHookRec = ^THookRec; THookRec = packed record // Handle of a keyboard hook HookHandle: HHOOK; // Window for sending WM_CHAR and WM_DEADCHAR messages LogWnd: HWND; // Application handle from the calling app (Application.Handle) AppWnd: HWND; end; implementation end. ----------------------------------------------------------------------library KeyHook; uses Windows, Messages, SysUtils, HookRec in 'HookRec.pas'; var hObjHandle: THandle; {Variable for the file mapping object} lpHookRec: PHookRec; {Pointer to our hook record} procedure ErrMessage(msg: string); begin MessageBox(0, PChar(msg), 'Hook DLL', MB_OK); end; procedure MapFileMemory(dwAllocSize : DWORD); 537

var bCreated: boolean; begin {Create a process wide memory mapped variable} hObjHandle := CreateFileMapping($FFFFFFFF, NIL, PAGE_READWRITE, 0, dwAllocSize, 'HookRecMemBlock'); bCreated := GetLastError <> ERROR_ALREADY_EXISTS; if (hObjHandle = 0) then begin ErrMessage('Could not create file map object'); exit; end; {Get a pointer to our process wide memory mapped variable} lpHookRec := MapViewOfFile(hObjHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize); if (lpHookRec = NIL) then begin CloseHandle(hObjHandle); ErrMessage('Could not map file'); exit; end; if bCreated then begin FillChar(lpHookRec^, dwAllocSize, 0); end; end; procedure UnMapFileMemory; begin {Delete our process wide memory mapped variable} if (lpHookRec <> NIL) then begin UnMapViewOfFile(lpHookRec); lpHookRec := NIL; end; if (hObjHandle > 0) then begin CloseHandle(hObjHandle); hObjHandle := 0; end; end; function GetHookRecPointer: PHookRec; stdcall; begin {Return a pointer to our process wide memory mapped variable} result := lpHookRec; end; {The function that actually processes the keystrokes for our hook} function KeyBoardProc(Code : integer; wParam : integer; lParam : integer): integer; stdcall; var 538

KeyUp : bool; {Remove comments for additional functionability IsAltPressed : bool; IsCtrlPressed : bool; IsShiftPressed : bool; } m: Msg; begin result := 0; case Code of HC_ACTION: begin {We trap the keystrokes here} {Is this a key up message?} KeyUp := ((lParam AND (1 shl 31)) <> 0); (*Remove comments for additional functionability {Is the Alt key pressed} IsAltPressed := (lParam AND (1 shl 29)) <> 0; {Is the Control key pressed} IsCtrlPressed := (GetKeyState(VK_CONTROL) AND (1 shl 15)) <> 0; {if the Shift key pressed} IsShiftPressed := (GetKeyState(VK_SHIFT) AND (1 shl 15)) <> 0; *) m.hwnd := lpHookRec^.LogWnd; m.wParam := wParam; m.lParam := lParam; if KeyUp (*and (wParam in [32..255])*) then begin m.message := WM_KEYUP; end else begin m.message := WM_KEYDOWN; end; TranslateMessage(m); {Allow the keystroke} result := 0; end; {HC_ACTION} HC_NOREMOVE: begin {This is a keystroke message, but the keystroke message} {has not been removed from the message queue, since an} {application has called PeekMessage() specifying PM_NOREMOVE} result := 0; exit; end; 539

end; {case code} if (Code < 0) then {Call the next hook in the hook chain} result := CallNextHookEx(lpHookRec^.HookHandle, Code, wParam, lParam); end; procedure StartKeyBoardHook; stdcall; begin {If we have a process wide memory variable} {and the hook has not already been set...} if ((lpHookRec <> NIL) AND (lpHookRec^.HookHandle = 0)) then begin {Set the hook and remember our hook handle} lpHookRec^.HookHandle := SetWindowsHookEx(WH_KEYBOARD, @KeyBoardProc, hInstance, 0); end; end; procedure StopKeyBoardHook; stdcall; begin {If we have a process wide memory variable} {and the hook has already been set...} if ((lpHookRec <> NIL) AND (lpHookRec^.HookHandle <> 0)) then begin {Remove our hook and clear our hook handle} if (UnHookWindowsHookEx(lpHookRec^.HookHandle) <> FALSE) then begin lpHookRec^.HookHandle := 0; end; end; end; procedure DllEntryPoint(dwReason : DWORD); begin case dwReason of Dll_Process_Attach: begin {If we are getting mapped into a process, then get} {a pointer to our process wide memory mapped variable} hObjHandle := 0; lpHookRec := NIL; MapFileMemory(sizeof(lpHookRec^)); end; Dll_Process_Detach: begin {If we are getting unmapped from a process then, remove} {the pointer to our process wide memory mapped variable} UnMapFileMemory; end; end; end; 540

exports KeyBoardProc, GetHookRecPointer, StartKeyBoardHook, StopKeyBoardHook; begin {Set our Dll's main entry point} DLLProc := @DllEntryPoint; {Call our Dll's main entry point} DllEntryPoint(Dll_Process_Attach); end. ------------------------------------------------------------------------------------unit KeyHook; (* Interface to the KeyHook dll *) interface uses HookRec; procedure StartKeyBoardHook; stdcall; external 'KeyHook.dll'; procedure StopKeyBoardHook; stdcall; external 'KeyHook.dll'; function GetHookRecPointer: PHookRec; stdcall; external 'KeyHook.dll'; implementation end. ------------------------------------------------------------------------------------To use the dll in your form just put the following code ... if GetHookRecPointer <> nil then with GetHookRecPointer^ do begin LogWnd := Self.Handle; AppWnd := Application.Handle; end; StartKeyBoardHook; And also override the WndProc for procesing (WM_CHAR and WM_DEADCHAR) key messages ... type TfmLog = class(TForm) private { Private declarations } procedure WndProc(var Msg : TMessage); override; public end; 541

procedure TfmLog.WndProc(var Msg : TMessage); begin if (Msg.Msg = WM_CHAR) or (Msg.Msg = WM_DEADCHAR) then (* Do what ever you want with the ascii char code in Msg.WParam *) else inherited; end; Special note .... this fmLog form should have no accelerator keys (labels with hot letters like '&Button') because those letters would not be processed by WndProc ... hope this helps, tomi.

542

Q) How can I create a system wide keyboard hook under Win32? A) The following example demonstrates creating a system wide windows hook under Win32. The example provides both the code for the system hook dll and an example application. The hook function that we will create will also demonstrate advanced coding techniques such as sharing global memory across process boundaries using memory mapped files, sending messages from the key hook function back to the originating application, and dynamic loading of a dll at runtime. The example keyboard hook that we create will keep a count of the number of keystrokes a user enters on the keyboard. Further, we will demonstrate trapping the enter key, and passing a message back to the application that initiated the keyboard hook each time the enter key is pressed. Finally, we will demonstrate trapping the left arrow key and instead of letting it through to the current application, we will instead replace it with a right arrow keystroke. (Note: that this can cause much confusion to a unsuspecting user). Adding a hook to the windows system involves calling the Windows API function SetWindowsHookEx() and passing it the type of hook you wish to install, and address of the hook function you are installing. System wide hook functions are required to reside in a dynamic link library, since they must be mapped into each process on the system. The SetWindowsHookEx() function adds your hook function into the Windows "hook chain", returning a handle (or id) of the hook you are installing. You will use this handle to identify your hook to windows, and to remove your hook when you are done trapping the keyboard. The Windows "hook chain" is a linked list of functions that Windows uses to keep track of all the installed hooks, allowing multiple hooks to be installed at any given time. Occasionally, Windows will ask your hook function to call the next hook in the chain, allowing all the hooks an opportunity to function. When we do call the next hook in the chain, we will need to identify ourselves by passing the handle of our hook function to the next hook. Creating a Windows hook requires special handling under Win32, since the dll must be mapped (on the fly) into the process space of every application that receives keystrokes. Normally, this is not an issue, however, when operating inside a keyhook procedure, global variables (such as your hook handle) must be preserved while the dll is mapped into other process spaces. Under Win16, this would not be a program, since dlls had a single data segment that was shared across all process mappings. Under Win32, each mapping of the dll receives its own data segment. This means that as the dll that contains the keyboard hook is mapped into each process that receives keystrokes, it receives a new data segment, and new unitialized variables with it. This is a problem, since global variables (such as your hook handle) must be preserved across process mappings. To solve this problem, we will take advantage of Win32's ability to memory map variables from the system paging file. 543

Each time our dll is mapped into a process, the DllMain() function in our dll will be called by windows, with a parameter flag indicating the reason for the call. When we receive the DLL_PROCESS_ATTACH flag (indicating our dll is getting mapped into a different process), we will create a file mapping to the system paging file and get a pointer to our memory mapped variables. When we receive the DLL_PROCESS_DETACH flag (indicating our dll is getting un-mapped from a process), we will free our file mapping of the system paging file. The variables we will need to keep track of (and have access to from both the dll and the application that originally loaded the keyboard hook) are placed in a record structure called THookRec. The THookRec structure has the following fields: TheHookHandle : The handle (id) of the Keyboard hook that we set. We will need access to this variable during the execution of the keyhook function, to identify ourselves to windows when we are asked to call the next hook in the hook chain. We will also need access to this variable when we remove our hook. Finally, the originating application that will receive the messages from our hook function can access this variable to see if and when the hook is active. TheAppWinHandle : While this variable is not used in our example dll or application, it is a starting place for adding additional messaging capabilities between the hook function and your application that initiates the hook. It can also be useful for determining if the hook is functioning while mapped into the context of the initiating application. TheCtrlWinHandle : This variable will hold the handle to a button control in our initiating application. We will use this handle to send messages from the keyboard hook function to the button control. Every time the enter key is pressed, we will send a WM_KEYDOWN and a WM_KEYUP message to the button and a key value of 0 (zero). We will trap the OnKeyDown event in the button control, and keep count of the number of times the user presses the enter key. TheKeyCount : This variable will keep track of the total number of key presses made by the user. Obviously our keyhook will need access to this variable to increment its value, and the originating application that will receive the messages from our hook function will want to access this variable to display real time results. The DLL contains the following functions: MapFileMemory : Creates a system paging file mapping object and initializes a pointer to our mapping variable of type THookRec. UnMapFileMemory : Frees the system paging file mapping object and mapping variable created by the MapFileMemory() function. GetHookRecPointer : An exported function that returns a pointer to the mapping variable created by the MapFileMemory() function. The initiating application can both set and examine this memory block, and 544

effectively share memory that is used by our hook function during the time the hook function is operating in the context of another process space. KeyBoardProc : The actual hook function. This function receives both keydown, and keyup messages as well as a message from windows indicating we should call the next hook in the windows "hook chain". This function increments TheKeyCount field of the memory mapped THookRec structure if the keystroke we are processing is a keyup message. If the key being processed is the enter key, we will fire the OnKeyDown event of the window provided in "TheCtrlWinHandle" field of the memory mapped THookRec structure. Finally, if the left arrow key is pressed, we will swallow the keystroke, and instead send a right arrow key stroke to the application. Note that the following variables and initializing code has been included in this function for your convience. The variables have been commented out in the code (as not to compile). To use them, simply remove the comments in the code: IsAltPressed {Determines if the Alt key is currently down} IsCtrlPressed {Determines if the Control key is currently down} IsShiftPressed {Determines if the Shift key is currently down} StartKeyBoardHook : An exported function that allows the application to initiate installing the keyboard hook; StopKeyBoardHook : An exported function that allows the application to initiate removing the keyboard hook; DllEntryPoint : The main entry point into our dll, allowing us to know when our dll is being mapped in, and out of, different application's address space. Delphi Hook DLL Example: library TheHook; uses Windows, Messages, SysUtils; {Define a record for recording and passing information process wide} type PHookRec = ^THookRec; THookRec = packed record TheHookHandle : HHOOK; TheAppWinHandle : HWND; TheCtrlWinHandle : HWND; TheKeyCount : DWORD; end; 545

var hObjHandle : THandle; {Variable for the file mapping object} lpHookRec : PHookRec; {Pointer to our hook record} procedure MapFileMemory(dwAllocSize : DWORD); begin {Create a process wide memory mapped variable} hObjHandle := CreateFileMapping($FFFFFFFF, NIL, PAGE_READWRITE, 0, dwAllocSize, 'HookRecMemBlock'); if (hObjHandle = 0) then begin MessageBox(0, 'Hook DLL', 'Could not create file map object', MB_OK); exit; end; {Get a pointer to our process wide memory mapped variable} lpHookRec := MapViewOfFile(hObjHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize); if (lpHookRec = NIL) then begin CloseHandle(hObjHandle); MessageBox(0, 'Hook DLL', 'Could not map file', MB_OK); exit; end; end; procedure UnMapFileMemory; begin {Delete our process wide memory mapped variable} if (lpHookRec <> NIL) then begin UnMapViewOfFile(lpHookRec); lpHookRec := NIL; end; if (hObjHandle > 0) then begin CloseHandle(hObjHandle); hObjHandle := 0; end; end;

546

function GetHookRecPointer : pointer stdcall; begin {Return a pointer to our process wide memory mapped variable} result := lpHookRec; end; {The function that actually processes the keystrokes for our hook} function KeyBoardProc(Code : integer; wParam : integer; lParam : integer): integer; stdcall; var KeyUp : bool; {Remove comments for additional functionability IsAltPressed : bool; IsCtrlPressed : bool; IsShiftPressed : bool; } begin result := 0; case Code of HC_ACTION : begin {We trap the keystrokes here} {Is this a key up message?} KeyUp := ((lParam AND (1 shl 31)) <> 0); (*Remove comments for additional functionability {Is the Alt key pressed} if ((lParam AND (1 shl 29)) <> 0) then begin IsAltPressed := TRUE; end else begin IsAltPressed := FALSE; end; {Is the Control key pressed} if ((GetKeyState(VK_CONTROL) AND (1 shl 15)) <> 0) then begin IsCtrlPressed := TRUE; end else begin IsCtrlPressed := FALSE; end; {if the Shift key pressed} if ((GetKeyState(VK_SHIFT) AND (1 shl 15)) <> 0) then begin IsShiftPressed := TRUE; end else begin IsShiftPressed := FALSE; end; *) {If KeyUp then increment the key count} if (KeyUp <> FALSE) then begin 547

Inc(lpHookRec^.TheKeyCount); end; case wParam of {Was the enter key pressed?} VK_RETURN : begin {if KeyUp} if (KeyUp <> FALSE) then begin {Post a bogus message to the window control in our app} PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0); PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0); end; {If you wanted to swallow the keystroke then return -1} {else if you want to allow the keystroke then return 0} result := 0; exit; end; {VK_RETURN} {If the left arrow key is pressed then lets play a joke!} VK_LEFT : begin {if KeyUp} if (KeyUp <> FALSE) then begin {Create a UpArrow keyboard event} keybd_event(VK_RIGHT, 0, 0, 0); keybd_event(VK_RIGHT, 0, KEYEVENTF_KEYUP, 0); end; {Swallow the keystroke} result := -1; exit; end; {VK_LEFT} end; {case wParam} {Allow the keystroke} result := 0; end; {HC_ACTION} HC_NOREMOVE : begin {This is a keystroke message, but the keystroke message} {has not been removed from the message queue, since an} {application has called PeekMessage() specifying PM_NOREMOVE} result := 0; exit; end; end; {case code} if (Code < 0) then {Call the next hook in the hook chain} result := 548

CallNextHookEx(lpHookRec^.TheHookHandle, Code, wParam, lParam); end; procedure StartKeyBoardHook stdcall; begin {If we have a process wide memory variable} {and the hook has not already been set...} if ((lpHookRec <> NIL) AND (lpHookRec^.TheHookHandle = 0)) then begin {Set the hook and remember our hook handle} lpHookRec^.TheHookHandle := SetWindowsHookEx(WH_KEYBOARD, @KeyBoardProc, hInstance, 0); end; end; procedure StopKeyBoardHook stdcall; begin {If we have a process wide memory variable} {and the hook has already been set...} if ((lpHookRec <> NIL) AND (lpHookRec^.TheHookHandle <> 0)) then begin {Remove our hook and clear our hook handle} if (UnHookWindowsHookEx(lpHookRec^.TheHookHandle) <> FALSE) then begin lpHookRec^.TheHookHandle := 0; end; end; end; procedure DllEntryPoint(dwReason : DWORD); begin case dwReason of Dll_Process_Attach : begin {If we are getting mapped into a process, then get} {a pointer to our process wide memory mapped variable} hObjHandle := 0; lpHookRec := NIL; MapFileMemory(sizeof(lpHookRec^)); end; Dll_Process_Detach : begin {If we are getting unmapped from a process then, remove} {the pointer to our process wide memory mapped variable} UnMapFileMemory; end; end; end; 549

exports KeyBoardProc name 'KEYBOARDPROC', GetHookRecPointer name 'GETHOOKRECPOINTER', StartKeyBoardHook name 'STARTKEYBOARDHOOK', StopKeyBoardHook name 'STOPKEYBOARDHOOK';

begin {Set our Dll's main entry point} DLLProc := @DllEntryPoint; {Call our Dll's main entry point} DllEntryPoint(Dll_Process_Attach); end.

Application notes: The test application we have created demonstrates loading the dll that contains the keyboard hook, installing the key board hook, displaying the total keystroke count and the number of times the enter key has been pressed (in real time), uninstalling the keyboard hook and unloading the dll. The application code starts out by defining a form containing two labels, a button, and timer component. Once we install our hook function, we will start the timer, and upon every timer event, we will display in label1 the total number of keystrokes that have been entered by the user since the hook was set. The hook will also fire the button's OnKeyDown event each time the enter key is pressed, giving us the opportunity to display the total number of times the enter key has been pressed in the caption of label2. After the form is defined, we then define the THookRec structure in the same manner as it is defined in the hook dll. Other variables we will use include: a handle variable used for loading the hook dll, and three function pointer variables used to call the GetHookRecPointer(), StartKeyBoardHook(), and StopKeyBoardHook() functions. Finally we define a pointer to a THookRec structure used to access the memory mapped variables used by the hook function, a variable to keep track of the number of times the enter key is pressed, and a variable used to indicate the success of loading the dll, getting its functions, and setting the hook. The application logic goes something like this: On form create, we will initialize our form's components, attempt to dynamically load the hook dll, and get the address of the GetHookRecPointer(), StartKeyBoardHook(), and StopKeyBoardHook() 550

functions located in the hook dll. If we are successful, we will retrieve a pointer to THookRec structure used by the hook dll, we will then initialize structure, adding the handle of the button control so the keyboard hook will know which window control to call when the enter key is pressed. We will then attempt to start the keyboard hook. If we are successful, at setting the hook, we can then start the timer. On form destroy, if we where previously successful in installing the windows hook and loading the hook dll, we will now uninstall the windows hook, and unload the KeyHook dll. On the timer's timer event, we will simply display the total number of key presses in the form's label1 caption by accessing the KeyHook dll's THookRec structure. On the Buttons KeyDown event, if the key value passed is zero we increment our EnterKeyCount variable and display the total number of times the enter key has been pressed by accessing the KeyHook dll's THookRec structure. Delphi TestApp Example: unit TestHk1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Label1: TLabel; Label2: TLabel; Timer1: TTimer; Button1: TButton; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation 551

{$R *.DFM} {Functions prototypes for the hook dll} type TGetHookRecPointer = function : pointer stdcall; type TStartKeyBoardHook = procedure stdcall; type TStopKeyBoardHook = procedure stdcall; {The record type filled in by the hook dll} type THookRec = packed record TheHookHandle : HHOOK; TheAppWinHandle : HWND; TheCtrlWinHandle : HWND; TheKeyCount : DWORD; end; {A pointer type to the hook record} type PHookRec = ^THookRec; var hHookLib : THANDLE; {A handle to the hook dll} GetHookRecPointer : TGetHookRecPointer; {Function pointer} StartKeyBoardHook : TStartKeyBoardHook; {Function pointer} StopKeyBoardHook : TStopKeyBoardHook; {Function pointer} LibLoadSuccess : bool; {If the hook lib was successfully loaded} lpHookRec : PHookRec; {A pointer to the hook record} EnterKeyCount : DWORD; {An internal count of the Enter Key} procedure TForm1.FormCreate(Sender: TObject); begin {Set our initial variables} Timer1.Enabled := FALSE; Timer1.Interval := 1000; Label1.Caption := '0 Keys Logged'; Label2.Caption := '0 Enter Keys Logged'; EnterKeyCount := 0; lpHookRec := NIL; LibLoadSuccess := FALSE; @GetHookRecPointer := NIL; @StartKeyBoardHook := NIL; @StopKeyBoardHook := NIL; {Try to load the hook dll} hHookLib := LoadLibrary('THEHOOK.DLL'); {If the hook dll was loaded successfully} if hHookLib <> 0 then begin {Get the function addresses} @GetHookRecPointer := GetProcAddress(hHookLib, 'GETHOOKRECPOINTER'); @StartKeyBoardHook := GetProcAddress(hHookLib, 'STARTKEYBOARDHOOK'); @StopKeyBoardHook := GetProcAddress(hHookLib, 'STOPKEYBOARDHOOK'); 552

{Did we find all the functions we need?} if ((@GetHookRecPointer <> NIL) AND (@StartKeyBoardHook <> NIL) AND (@StopKeyBoardHook <> NIL)) then begin LibLoadSuccess := TRUE; {Get a pointer to the hook record} lpHookRec := GetHookRecPointer; {Were we successfull in getting a ponter to the hook record} if (lpHookRec <> nil) then begin {Fill in our portion of the hook record} lpHookRec^.TheHookHandle := 0; lpHookRec^.TheCtrlWinHandle := Button1.Handle; lpHookRec^.TheKeyCount := 0; {Start the keyboard hook} StartKeyBoardHook; {Start the timer if the hook was successfully set} if (lpHookRec^.TheHookHandle <> 0) then begin Timer1.Enabled := TRUE; end; end; end else begin {We failed to find all the functions we need} FreeLibrary(hHookLib); hHookLib := 0; @GetHookRecPointer := NIL; @StartKeyBoardHook := NIL; @StopKeyBoardHook := NIL; end; end; end; procedure TForm1.FormDestroy(Sender: TObject); begin {Did we load the dll successfully?} if (LibLoadSuccess = TRUE) then begin {Did we sucessfully get a pointer to the hook record?} if (lpHookRec <> nil) then begin {Did the hook get set?} if (lpHookRec^.TheHookHandle <> 0) then begin Timer1.Enabled := FALSE; StopKeyBoardHook; end; end; {Free the hook dll} FreeLibrary(hHookLib); end; end; procedure TForm1.Timer1Timer(Sender: TObject); begin {Display the number of keystrokes logged} Label1.Caption := IntToStr(lpHookRec^.TheKeyCount) + ' Keys Logged'; end; 553

procedure TForm1.Button1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin {Process message sent from hook dll and display} {number of time the enter key was pressed} if (Key = 0) then begin Inc(EnterKeyCount); Label2.Caption := IntToStr(EnterKeyCount) + ' Enter Keys Logged'; end; end; end.

Joe -Joe C. Hecht http://home1.gte.net/joehecht/index.htm

554

I have used the following code to obtain the MAC address successfully up till recently //--------------------------------------------------------------------------procedure find_MAC(var s1 : string); Type TGUID=record A,B:word; D,M,S:word; MAC:array[1..6] of byte; end; var UuidCreateFunc : function (var guid: TGUID) : HResult; stdcall; handle : THandle; g : TGUID; //ErrCode: HResult; begin handle := LoadLibrary('RPCRT4.DLL'); if s1 = '5' then @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreateSequential') else @UuidCreateFunc := GetProcAddress(Handle, 'UuidCreate') ; UuidCreateFunc(g); s1 := s1 := s1 := s1 := s1 := s1 := s1 := end;

''; s1 s1 s1 s1 s1 s1

+ + + + + +

IntToHex(g.MAC[1],2) + IntToHex(g.MAC[2],2) + IntToHex(g.MAC[3],2) + IntToHex(g.MAC[4],2) + IntToHex(g.MAC[5],2) + IntToHex(g.MAC[6],2);

'-'; '-'; '-'; '-'; '-';

//--------------------------------------------------------------------------But all of a sudden it seems to have stopped working I tested it initially on w98, nt4.0 and w2k machines and it was fine I appears to function when compiled under delphi 4 and fail when that same exact source is compiled under delphi 5

555

//--------------------------------------------------------------------------//--------------------------------------------------------------------------I found some new code see below but it fails on many machines somthing about netbios v 3 being required does anyone have reliable code or can they explain how to modify the delphi 5 compiler to correctly implement the code //--------------------------------------------------------------------------//--------------------------------------------------------------------------PS I know the code below is long but I'm hoping for a few brownie points for complete problem description //--------------------------------------------------------------------------{---------------------------------------------} { enumerate the lana's - works only on WIN32 } {---------------------------------------------} function NbLanaEnum: TLana_Enum; var NCB: TNCB; L_Enum: TLana_Enum; RetCode: Word; begin {$IFDEF WIN32} FillChar(NCB, SizeOf(NCB), 0); FillChar(L_Enum, SizeOf(TLana_Enum), 0); NCB.Command := NCB_ENUM; NCB.Buf := @L_Enum; NCB.Length := Sizeof(L_Enum); RetCode := NetBiosCmd(NCB); if RetCode <> NRC_GOODRET then begin L_Enum.Length := 0; L_Enum.Lana[0] := Byte(RetCode); end; {$ELSE} { not supported for WIN16, fake LANA 0 } L_Enum.Length := 1; L_Enum.Lana[0] := 0; {$ENDIF} Result := L_Enum; end; {----------------------------------------} { Reset the lana - don't for WIN16 ! } {----------------------------------------} function NbReset(l: Byte): Word; var NCB: TNCB; 556

begin {$IFNDEF WIN32} { will reset all your connections for WIN16 } Result := NRC_GOODRET; { so just fake a reset for Win16 } {$ELSE} FillChar(NCB, SizeOf(NCB), 0); NCB.Command := NCB_RESET; NCB.Lana_Num := l; Result := NetBiosCmd(NCB); {$ENDIF} end; {----------------------------------------} { return the MAC address of an interface } { in the form of a string like : } { 'xx:xx:xx:xx:xx:xx' } { using the definitions in nb.pas } {----------------------------------------} function NbGetMacAddr(LanaNum: Integer): String; var NCB: TNCB; AdpStat: TAdpStat; RetCode: Word; begin FillChar(NCB, SizeOf(NCB), 0); FillChar(AdpStat, SizeOf(AdpStat), 0); NCB.Command := NCB_ADPSTAT; NCB.Buf := @AdpStat; NCB.Length := Sizeof(AdpStat); FillChar(NCB.CallName, Sizeof(TNBName), $20); NCB.CallName[0] := Byte('*'); NCB.Lana_Num := LanaNum; RetCode := NetBiosCmd(NCB); if RetCode = NRC_GOODRET then begin Result := Format('%2.2x:%2.2x:%2.2x:%2.2x:%2.2x:%2.2x', [AdpStat.ID[0], AdpStat.ID[1], AdpStat.ID[2], AdpStat.ID[3], AdpStat.ID[4], AdpStat.ID[5] ]); end else begin Result := '??:??:??:??:??:??'; end; end; procedure find_MAC(var macadd : string); var L_Enum : TLana_Enum; RetCode: Word; begin 557

L_Enum := NbLanaEnum; { enumerate lanas for WIN NT } if L_Enum.Length = 0 then begin //Button1.Caption := Format('LanaEnum err=%2.2x', [L_Enum.Lana[0]]); //exit; end; (* for i := 0 to (L_Enum.Length - 1)do begin { for every lana found } RetCode := NbReset(L_Enum.Lana[i]); { Reset lana for WIN NT } if RetCode <> NRC_GOODRET then begin Button1.Caption := Format('Reset Lana %d err=%2.2x',[i, RetCode]); exit; end; *) RetCode := NbReset(L_Enum.Lana[0]); { Reset lana for WIN NT } if RetCode = NRC_GOODRET then macadd := NbGetMacAddr(0); end; //--------------------------------------------------------------------------unit Nb; {$F+} { nb.pas 16/32 bit windows netbios access (follows IBM's Netbios 3.0 spec) (C) CEVI VZW - 29 april 1998 -- DH ([email protected]) -You can (ab)use this code as you like, but please do not remove the credits. I used reference material from IBM, Microsoft, Syntax and Byte when I wrote the 16-bit (DOS) c-version ages ago (in Borland Turbo C 2.0 on a 386SX PC) with a Syntax SMB server running on Interactive Unix. I now converted this to 16 and 32 bit Delphi code. } interface 558

uses SysUtils, Winprocs, Wintypes; const { size of a netbios name } NBNAMESIZE = 16; { max number of network adapters } { remeber it's BIG Blue, right ? } MAXLANAS = 254; { NCB Command codes } NCB_ASYNC = $80; { asynch command bit to be or-ed into command } NCB_CALL = $10; { open a session } NCB_LISTEN = $11; { wait for a call } NCB_HANGUP = $12; { end session } NCB_SEND = $14; { send data } NCB_RECV = $15; { receive data } NCB_RECVANY = $16; { receive data on any session } NCB_CHAINSEND = $17; { chain send data } NCB_DGSEND = $20; { send a datagram } NCB_DGRECV = $21; { receive datagram } NCB_DGSENDBC = $22; { send broadcast datagram } NCB_DGREVCBC = $23; { receive broadcast datagram } NCB_ADDNAME = $30; { add unique name to local table } NCB_DELNAME = $31; { delete name from local table } NCB_RESET = $32; { reset adapter } NCB_ADPSTAT = $33; { adapter status } NCB_SSTAT = $34; { session status } NCB_CANCEL = $35; { cancel NCB request } NCB_ADDGRPNAME= $36; { add group name to local table } NCB_ENUM = $37; { enum adapters } NCB_UNLINK = $70; { unlink remote boot code } NCB_SENDNA = $71; { send, don't wait for ACK } NCB_CHAINSENDNA=$72; { chain send, but don't wait for ACK } NCB_LANSTALERT= $73; { lan status alert } NCB_ACTION = $77; { enable extensions } NCB_FINDNAME = $78; { search for name on the network } NCB_TRACE = $79; { activate / stop tracing } { NCB return codes } NRC_GOODRET = $00; { good return also returned when ASYNCH request accepted } NRC_BUFLEN = $01; { illegal buffer length } NRC_ILLCMD = $03; { illegal command 559

} NRC_CMDTMO = $05; { command timed out } NRC_INCOMP = $06; { message incomplete, issue another command } NRC_BADDR = $07; { illegal buffer address } NRC_SNUMOUT = $08; { session number out of range } NRC_NORES = $09; { no resource available } NRC_SCLOSED = $0a; { session closed } NRC_CMDCAN = $0b; { command cancelled } NRC_DUPNAME = $0d; { duplicate name } NRC_NAMTFUL = $0e; { name table full } NRC_ACTSES = $0f; { no deletions, name has active sessions } NRC_LOCTFUL = $11; { local session table full } NRC_REMTFUL = $12; { remote session table full } NRC_ILLNN = $13; { illegal name number } NRC_NOCALL = $14; { no callname } NRC_NOWILD = $15; { cannot put * in NCB_NAME } NRC_INUSE = $16; { name in use on remote adapter } NRC_NAMERR = $17; { name deleted } NRC_SABORT = $18; { session ended abnormally } NRC_NAMCONF = $19; { name conflict detected } NRC_IFBUSY = $21; { interface busy, IRET before retrying } NRC_TOOMANY = $22; { too many commands outstanding, retry later } NRC_BRIDGE = $23; { ncb_lana_num field invalid } NRC_CANOCCR = $24; { command completed while cancel occurring } NRC_CANCEL = $26; { command not valid to cancel } NRC_DUPENV = $30; { name defined by anther local process } NRC_ENVNOTDEF = $34; { environment undefined. RESET required } 560

NRC_OSRESNOTAV = $35; { required OS resources exhausted } NRC_MAXAPPS = $36; { max number of applications exceeded } NRC_NOSAPS = $37; { no saps available for netbios } NRC_NORESOURCES = $38; { requested resources are not available } NRC_INVADDRESS = $39; { invalid ncb address or length > segment } NRC_INVDDID = $3B; { invalid NCB DDID } NRC_LOCKFAIL = $3C; { lock of user area failed } NRC_OPENERR = $3f; { NETBIOS not loaded } NRC_SYSTEM = $40; { system error } NRC_PENDING = $ff; { asynchronous command is not yet finished } { Values for transport_id } ALL_TRANSPORTS = 'M'#$00#$00#$00; MS_NBF = 'MNBF'; { values for name_flags bits. } NAME_FLAGS_MASK = $87; GROUP_NAME = $80; UNIQUE_NAME = $00; REGISTERING = $00; REGISTERED = $04; DEREGISTERED = $05; DUPLICATE = $06; DUPLICATE_DEREG = $07; { Values for state } LISTEN_OUTSTANDING = $01; CALL_PENDING = $02; SESSION_ESTABLISHED = $03; HANGUP_PENDING = $04; HANGUP_COMPLETE = $05; SESSION_ABORTED = $06; type 561

{ Netbios Name } TNBName = array[0..(NBNAMESIZE - 1)] of byte; { MAC address } TMacAddress = array[0..5] of byte; PNCB = ^TNCB; { Netbios Control Block } {$IFDEF WIN32} TNCBPostProc = procedure(P: PNCB); {$ENDIF} TNCB = packed record { Netbios Control Block } Command: byte; { command code } RetCode: byte; { return code } LSN: byte; { local session number } Num: byte; { name number } Buf: ^byte; { data buffer } Length: word; { data length } CallName: TNBName; { name to call } Name: TNBName; { our own name } RTO: byte; { receive time-out } STO: byte; { send time-out } {$IFNDEF WIN32} Post_Offs:word; { asynch notification routine offset } Post_Seg: word; { asynch notification routine segment} {$ELSE} PostPrc: TNCBPostProc;{ asynch notification routine (nb30) } {$ENDIF} Lana_Num: byte; { adapter number } Cmd_Cplt: byte; { command completion flag } {$IFDEF WIN32} Reserved: array[0..9] of byte; { Reserverd for Bios use } Event: THandle; { WIN32 event handle to be signalled } { for asynch cmd completion } {$ELSE} Reserved: array[0..13] of byte; { Reserved } {$ENDIF} end; { Netbios Name Info record } PNameInfo = ^TNameInfo; TNameInfo = packed record { name info record } Name: TNBName; { netbios name } NameNum:byte; { name number } NameSt: byte; { name status } end; 562

{ Netbios adapter status } PAdpStat = ^TAdpStat; TAdpStat = packed record { adapter status record} ID: TMacAddress; { adapter mac address } VMajor: byte; { software version major number } Resvd0: byte; AdpType: byte; { adapter type } VMinor: byte; { software version minor number } RptTime: word; { reporting time period } RcvCRC: word; { receive crc errors } RcvOth: word; { receive other errors } TxmCol: word; { transmit collisions } TxmOth: word; { transmit other errors } TxmOK: LongInt; { successfull transmissions } RcvOK: LongInt; { successfull receives } TxmRetr: word; { transmit retries } NoRcvBuf: word; { number of 'no receive buffer' } T1_tmo: word; { t1 time-outs } Ti_tmo: word; { ti time_outs } Resvd1: LongInt; Free_Ncbs:word; { number of free ncb's } Cfg_Ncbs: word; { number of configured ncb's } max_Ncbs: word; { max ncb's used } NoTxmBuf: word; { number of 'no transmit buffer'} MaxDGSize:word; { max. datagram size } Pend_Ses: word; { number of pending sessions } Cfg_Ses: word; { number of configured sessions } Max_Ses: word; { max sessions used } Max_SPSz: word; { max. session packet size } nNames: word; { number of names in local table} Names: array[0..15] of TnameInfo; { local name table } end; { Structure returned to the NCB command NCBSSTAT is SESSION_HEADER followed by an array of SESSION_BUFFER structures. If the NCB_NAME starts with an asterisk then an array of these structures is returned containing the status for all names. } { session header } PSession_Header = ^TSession_Header; TSession_Header = packed record sess_name: byte; num_sess: byte; rcv_dg_outstanding: byte; rcv_any_outstanding: byte; end; { session buffer } 563

PSession_Buffer = ^TSession_Buffer; TSession_Buffer = packed record lsn: byte; state: byte; local_name: TNBName; remote_name: TNBName; rcvs_outstanding: byte; sends_outstanding: byte; end; { Structure returned to the NCB command NCBENUM. On a system containing lana's 0, 2 and 3, a structure with length =3, lana[0]=0, lana[1]=2 and lana[2]=3 will be returned. } PLana_Enum = ^TLana_Enum; TLANA_ENUM = packed record length: byte; { Number of valid entries in lana[] } lana: array[0..(MAXLANAS - 1)] of byte; end; { Structure returned to the NCB command NCBFINDNAME is FIND_NAME_HEADER followed by an array of FIND_NAME_BUFFER structures. } PFind_Name_Header = ^TFind_Name_Header; TFind_Name_Header = packed record node_count: word; reserved: byte; unique_group: byte; end; PFind_Name_Buffer = ^TFind_Name_Buffer; TFind_Name_Buffer = packed record length: byte; access_control: byte; frame_control: byte; destination_addr:TMacAddress; source_addr: TMacAddress; routing_info: array[0..17] of byte; end; { Structure provided with NCBACTION. The purpose of NCBACTION is to provide transport specific extensions to netbios. } PAction_Header = ^TAction_Header; TAction_Header = packed record 564

transport_id: LongInt; action_code: Word; reserved: Word; end;

{$IFDEF WIN32} function Netbios(P: PNCB): Char; stdcall; {$ENDIF} { Exposed functions } function NetbiosCmd(var NCB: TNCB): Word; implementation {$IFDEF WIN32} function Netbios; external 'netapi32.dll' name 'Netbios'; {$ENDIF} {---------------------------------} { execute a Windows Netbios Call } {---------------------------------} function NetbiosCmd(var NCB: TNCB): Word; begin {$IFNDEF WIN32} asm push bp { save bp } push ss { save ss } push ds { save ds } les bx, NCB { get segment/offset address of NCB } call NetBiosCall; { 16 bit Windows Netbios call } xor ah,ah mov @Result, ax { store return code } pop ds { restore ds } pop ss { restore ss } pop bp { restore bp } end; {$ELSE} Result := Word(Netbios(PNCB(@NCB))); { 32 bit Windows Netbios call } {$ENDIF} end; end.

565

program NoForm; uses Windows, SysUtils, Messages, ShellApi; {$R *.RES} const AppName = 'APP WITHOUT FORM'; wID_Auto = WM_USER + 11; wID_Close = WM_USER + 12; var tid: TNotifyIconData; WndClass: array[0..50] of char; TimerID:integer; hPopUp: HMenu; Wnd: hWnd; Hint : PChar; Procedure TrackPopUpWin(hWindow: HWnd); Var P: TPoint; Begin //Show Popup Menu SetForegroundWindow(hWindow); GetCursorPos( P ); TrackPopupMenu( hPopUp, TPM_CENTERALIGN, P.x, P.y, 0, hWindow, NIL ); PostMessage(hWindow, WM_NULL, 0, 0); End; Procedure CreateMenuPopUp; Var mItem: TMENUITEMINFO; Begin hPopUp := CreatePopUpMenu; mItem.cbSize := SizeOF( MENUITEMINFO ); mItem.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE; mItem.fType := mft_String; // mItem.wID := wID_Close; mItem.dwItemData := wID_Close; mItem.dwTypeData := PChar( 'Sair' ); mItem.cch := Length( 'Sair' ); InsertMenuItem( hPopUp, wID_Close, False, mItem ); // mItem.wID := wID_Auto; mItem.dwItemData := wID_Auto; mItem.dwTypeData := PChar( 'Auto Start' ); mItem.cch := Length( 'Auto Start' ); InsertMenuItem( hPopUp, wID_Auto, False, mItem ); 566

End;

function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt; stdcall; var TrayHandle: THandle; begin DummyWindowProc := 0; StrPCopy(@WndClass[0], 'Progman'); TrayHandle := FindWindow(@WndClass[0], nil); case Msg of WM_CREATE: // Program initialisation - just set up a tray icon begin tid.cbSize := sizeof (tid); tid.Wnd := Wnd; tid.uID := 1; tid.uFlags := nif_Message or nif_Icon or nif_Tip; tid.uCallBackMessage := WM_USER; tid.hIcon := LoadIcon (hInstance, 'MAINICON'); lstrcpy (tid.szTip,Hint); // Create Menu CreateMenuPopUp; // Shell_NotifyIcon (nim_Add, @tid); end; WM_DESTROY: begin Shell_NotifyIcon (nim_Delete, @tid); PostQuitMessage (0); ShowWindow(TrayHandle, SW_RESTORE); end; WM_COMMAND: // Command notification begin Exit; end; WM_USER: // Had a tray notification - see what to do begin if (lParam = WM_RBUTTONUP) then begin PostMessage (Wnd, WM_CLOSE, 0, 0); end; if (lParam = WM_LBUTTONUP) then begin //do something TrackPopUpWin(Wnd); end; end; end; DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam); end; 567

procedure TimerProc(Wnd: HWND; uMsg: UINT; idEvent: UINT; dwTime: DWORD);pascal; begin //If you need timed events to check end; procedure WinMain; var Msg: TMsg; cls: TWndClass; begin { Register the window class } FillChar (cls, sizeof (cls), 0); cls.lpfnWndProc := @DummyWindowProc; cls.hInstance := hInstance; cls.lpszClassName := AppName; Windows.RegisterClass (cls); { Now create the dummy window } Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow, 4, 4, 4, 4,0, 0, hInstance, Nil); TimerID := Windows.SetTimer(0,3,60000,@TimerProc); //60 Seconds if Wnd <> 0 then begin ShowWindow (Wnd, SW_HIDE); while GetMessage (Msg, 0, 0, 0) do begin TranslateMessage (Msg); DispatchMessage (Msg); end; end; end; begin Hint := '127.0.0.1'; if FindWindow (AppName, nil) <> 0 then Exit; // INI WinMain; end.

568

Makale

RAW SOCKETLER - IP BAŞLIĞI

Yorum Son Durum

0

29 Haz 2002 17:34 Eklendi

RAW SOCKETLER - IP BAŞLIĞI Selam arkadaşlar. Eskiden raw socketler sadece unix, linux gibi işletim sistemleri tarafından destekleniyordu. Artık bu destek Windows 2000'de kısmen, Windows XP'de ise tam olarak var. Raw socketleri öğrenmeye başlamadan önce internette gelip giden paketlerin yapısına kısaca bir göz atalım. Örneğin bir ping attığımızda hedefe sırası ile: -> 20 bytelık bir ip başlığı (Not: IP başlında ekstra seçenekler kullanılırsa bu değer artabilir) -> 8 bytelık bir icmp başlığı -> Ekstra veri (Not: Bu pingin boyutuna bağlıdır. Gönderilmesi şart değildir) içeren bir paket göndermiş oluruz. Bu paketteki ip başlığı normal bir socket'de işletim seti tarafından oluşturulmakta ve işlenmektedir. Şayet bu ip başlığını kendimiz oluşturmak ve işlemek istersek işletim setine kendi ip başlığını oluşturmaması gereken bir komut göndermemiz gerekmektedir. İşte işletim seti bu komutu destekliyorsa bu işletim setinin raw socket desteği var diyebiliriz. Artık ip başlığının yapısını incelemeye başlayalım: type PIPhdr = ^TIPhdr; TIPhdr = packed record ip_verlen: byte; ip_tos: byte; ip_len: word; ip_id: word; ip_off: word; ip_ttl: byte; ip_p: byte; ip_sum: word; ip_src: longword; ip_dst: longword; end; ip_verlen (Version + IHL [8 bit]): İlk 4 biti "Version", kalan 4 biti de "IHL" (Internet header length) bölümü olmak üzere toplam 2 ana bölümden oluşmuştur. "Version" bölümünü ip başlığının formatının belirtildiği bölümdür. Alabileceği değerler şunlardır: 569

Alabileceği değerler şunlardır: -> 4: IP, Internet Protocol -> 5: ST, ST Datagram Mode -> 6: . SIP, Simple Internet Protocol . SIPP, Simple Internet Protocol Plus . IPv6, Internet Protocol -> 7 TP/IX, The Next Internet -> 8 PIP, The P Internet Protocol -> 9 TUBA "IHL" bölümündeki değer 32 bitlik bir değişken içerisinde yer alan ip başlığının boyutunu temsil eder. Geçerli bir ip başlığında bu değer minimum 5 olabilir. [--------------------------------] ip_tos (Type Of Service [8 bit]): İstenilen servisin çeşidine göre parametreler içerir. Bu parametreler bazı ağlar tarafından paketin nasıl ele alınacağını belirtmek amacıyla kullanılabilir. TOS ilk 3 biti "Precedence", diğer 1 biti "Minimize delay", diğer 1 biti "Maximize throughput", diğer 1 biti "Maximize reliability", diğer 1 biti "Minimize monetary cost" bölümü olmak üzere toplam 5 ana bölümden oluşmuştur. "Precedence" bölümünün alabileceği değerler şunlardır: -> 0: Routine -> 1: Priority -> 2: Immediate -> 3: Flash -> 4: Flash override -> 5: CRITIC/ECP -> 6: Internetwork control -> 7: Network control "Minimize delay" bölümünün alabileceği değerler şunlardır: -> 0: Normal delay -> 1: Low delay "Maximize throughput" bölümünün alabileceği değerler şunlardır: -> 0: Normal throughput -> 1: High throughput "Maximize reliability" bölümünün alabileceği değerler şunlardır: -> 0: Normal reliability -> 1: High reliability "Minimize monetary cost" bölümünün alabileceği değerler şunlardır: -> 0: Normal monetary cost -> 1: Minimize monetary cost Not: Kalan son bit ise kullanılmamaktadır. 570

Not: Kalan son bit ise kullanılmamaktadır. [--------------------------------] ip_len (Total length [16 bit]): Tüm paketin boyutudur. [--------------------------------] ip_id (Identification [16 bit]): Eğer paketi parçalara ayırarak göndereceksek her parçanın bu değeri aynı olmalıdır. [--------------------------------] ip_off (Flags + Fragment Offset [16 bit]): İlk 3 biti "Flags", kalan 13 biti de "Fragment Offset" bölümü olmak üzere toplam 2 ana bölümden oluşmuştur. İlk ana bölüm olan "Flags"in ilk biti her zaman 0 olmalıdır. İkinci biti "Don't fragment", üçüncü biti "More fragments" kısmı olmak üzere toplam 2 kısımdan oluşmuştur. "Don't fragment" kısmı paketin parçalanmasını kontrol eder. Bu kısmın alabileceği değerler: -> 0: Fragment if necessary -> 1: Do not fragment "More fragments" kısmı paketin parçalanma durumunu gösterir. Alabileceği değerler: -> 0: This is the last fragment -> 1: More fragments follow this fragment İkinci ana bölüm olan "Fragment Offset" bölümündeki değer ise parçalanan paketin yeniden oluşturulmasında kullanılır. [--------------------------------] ip_ttl (Time to Live [8 bit]): Bu değer paket her routerdan geçişinde 1 azaltılır. Eğer değer 0'a düşerse paket atılır. [--------------------------------] ip_p (Protocol [8 bit]): IP başlığından sonra gelen protokoldür. 1: ICMP, 2: IGMP, 6: TCP 17: UDP gibi... [--------------------------------] ip_sum (Header checksum [16 bit]): IP başlığı ve eğer varsa ip başlığının eksta seçeneklerini de içeren 16 bitlik bir checksum'dır. [--------------------------------] ip_src (Source IP address [32 bit]): Paketin kaynak IP adresidir. 571

[--------------------------------] ip_dst (Destination IP address [32 bit]): Paketin hedef IP adresidir. Raw socketlerin nasıl açılıp kurulacağını, tcp, udp, icmp, igmp gibi başlıkların yapısını ve bunların raw socketler ile kullanımı için "Program Örnekleri"ne gönderdiğim "DoS Programlarım" başlığı altındaki DoS.zip dosyasını indirin. Buradaki programlarımın güncellenmiş versiyonlarını (ileriki tarihlerde) ve derlenmiş hallerini http://209.100.212.5/cgibin/search/[email protected] adresinden indirebilirsiniz. Eğer vakit bulursam bunlar hakkında da doküman yazacağım. Başarılar, Metin İGE [email protected] Soket Programlama, Winsock, Internet/Intranet

29 Haz 2002 17:34

metinsdr

572

Makale

Paradox ve dBASE tabloları için BDE ağ tanımları

Yorum Son Durum

11

8 Ağu 2002 09:08 mcuyan

Çok Sorulduğu için bi makale yazmak gereği duydum. Paradox ve Dbase tablolarını ağda çalıştırabilmek için Aşağıdaki BDE ayarlarını Kullanın. ANA MAKİNA AYARLARI Ana Makina Adı: Server Disk paylaşım adı : C Paradox veya dBASE tablolarının bulunduğu Klasör c:\Prog\Data PDOXUSRS.NET dosyasının yeri: c:\ Ana Makina BDE Ayarları: DataBAse sekmesi: Alias: MyProg Path : c:\Prog\Data Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: C:\ (PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Congiguration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE TERMİNAL MAKİNA BDE AYARLARI: DataBAse sekmesi: Alias: MyProg Path : \\Server\\Prog\Data Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: \\Server\c (Ana makinadaki PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Congiguration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE Yukarda anlatılan ayarlaın dışında şayet terminalden ana makina için bir ağ yolu tanımlamışsanız terminal ayarları aşağıdaki gibi de olabilir. Ana makinanın diskine F diye bir ağ yolu tanımladıysak ayarlar şu şekilde olacaktır. DataBAse sekmesi: Alias: MyProg Path : F:\Prog\Data 573

Path : F:\Prog\Data Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: F:\ (Ana makinadaki PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Congiguration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE Ancak bu tanımda dikkat edilmesi gereken şey F ağ yolu koptuğunda program çalışmayacaktır. .exe dosyanızı terminalden istediğiniz klasörden çalıştırabilirsiniz. Kolay gelsin.......... BDE ve Alias Parametreleri sair

4 Nis 2002 08:33

Makale Yorumları TERMİNAL MAKİNA BDE AYARLARI: DataBAse sekmesi: Alias: MyProg Path : \\Server\\Prog\Data Üstteki tanım da ufak bir hata olmuş: Path : \\Server\\Prog\Data değil Path : \\Server\Prog\Data olacak... ters slah ı bi tane fazla yazmışım. :)))))

574

Windows Mesajları 1

0

16 Ağu 2002 19:23 Eklendi

{Her derde deva windows mesajları ozellikle component yazanların çok işine yarar. ICQ:165276600 [email protected]} WM_NULL = $0000; WM_CREATE = $0001; WM_DESTROY = $0002; WM_MOVE = $0003; WM_SIZE = $0005; WM_ACTIVATE = $0006; WM_SETFOCUS = $0007; WM_KILLFOCUS = $0008; WM_ENABLE = $000A; WM_SETREDRAW = $000B; WM_SETTEXT = $000C; WM_GETTEXT = $000D; WM_GETTEXTLENGTH = $000E; WM_PAINT = $000F; WM_CLOSE = $0010; WM_QUERYENDSESSION = $0011; WM_QUIT = $0012; WM_QUERYOPEN = $0013; WM_ERASEBKGND = $0014; WM_SYSCOLORCHANGE = $0015; WM_ENDSESSION = $0016; WM_SYSTEMERROR = $0017; WM_SHOWWINDOW = $0018; WM_CTLCOLOR = $0019; WM_WININICHANGE = $001A; WM_SETTINGCHANGE = WM_WININICHANGE; WM_DEVMODECHANGE = $001B; WM_ACTIVATEAPP = $001C; WM_FONTCHANGE = $001D; WM_TIMECHANGE = $001E; WM_CANCELMODE = $001F; WM_SETCURSOR = $0020; WM_MOUSEACTIVATE = $0021; WM_CHILDACTIVATE = $0022; WM_QUEUESYNC = $0023; WM_GETMINMAXINFO = $0024; WM_PAINTICON = $0026; WM_ICONERASEBKGND = $0027; WM_NEXTDLGCTL = $0028; WM_SPOOLERSTATUS = $002A; WM_DRAWITEM = $002B; WM_MEASUREITEM = $002C; WM_DELETEITEM = $002D; 575

WM_VKEYTOITEM = $002E; WM_CHARTOITEM = $002F; WM_SETFONT = $0030; WM_GETFONT = $0031; WM_SETHOTKEY = $0032; WM_GETHOTKEY = $0033; WM_QUERYDRAGICON = $0037; WM_COMPAREITEM = $0039; WM_GETOBJECT = $003D; WM_COMPACTING = $0041; WM_COMMNOTIFY = $0044; {Win32 için eski} WM_WINDOWPOSCHANGING = $0046; WM_WINDOWPOSCHANGED = $0047; WM_POWER = $0048; WM_COPYDATA = $004A; WM_CANCELJOURNAL = $004B; WM_NOTIFY = $004E; WM_INPUTLANGCHANGEREQUEST = $0050; WM_INPUTLANGCHANGE = $0051; WM_TCARD = $0052; WM_HELP = $0053; WM_USERCHANGED = $0054; WM_NOTIFYFORMAT = $0055; WM_CONTEXTMENU = $007B; WM_STYLECHANGING = $007C; WM_STYLECHANGED = $007D; WM_DISPLAYCHANGE = $007E; WM_GETICON = $007F; WM_SETICON = $0080; WM_NCCREATE = $0081; WM_NCDESTROY = $0082; WM_NCCALCSIZE = $0083; WM_NCHITTEST = $0084; WM_NCPAINT = $0085; WM_NCACTIVATE = $0086; WM_GETDLGCODE = $0087; WM_NCMOUSEMOVE = $00A0; WM_NCLBUTTONDOWN = $00A1; WM_NCLBUTTONUP = $00A2; WM_NCLBUTTONDBLCLK = $00A3; WM_NCRBUTTONDOWN = $00A4; WM_NCRBUTTONUP = $00A5; WM_NCRBUTTONDBLCLK = $00A6; WM_NCMBUTTONDOWN = $00A7; WM_NCMBUTTONUP = $00A8; WM_NCMBUTTONDBLCLK = $00A9; WM_KEYFIRST = $0100; WM_KEYDOWN = $0100; WM_KEYUP = $0101; WM_CHAR = $0102; WM_DEADCHAR = $0103; WM_SYSKEYDOWN = $0104; 576

WM_SYSKEYUP = $0105; WM_SYSCHAR = $0106; WM_SYSDEADCHAR = $0107; WM_KEYLAST = $0108; WM_INITDIALOG = $0110; WM_COMMAND = $0111; WM_SYSCOMMAND = $0112; WM_TIMER = $0113; WM_HSCROLL = $0114; WM_VSCROLL = $0115; WM_INITMENU = $0116; WM_INITMENUPOPUP = $0117; WM_MENUSELECT = $011F; WM_MENUCHAR = $0120; WM_ENTERIDLE = $0121; WM_MENURBUTTONUP = $0122; WM_MENUDRAG = $0123; WM_MENUGETOBJECT = $0124; WM_UNINITMENUPOPUP = $0125; WM_MENUCOMMAND = $0126; WM_CHANGEUISTATE = $0127; WM_UPDATEUISTATE = $0128; WM_QUERYUISTATE = $0129; WM_CTLCOLORMSGBOX = $0132; WM_CTLCOLOREDIT = $0133; WM_CTLCOLORLISTBOX = $0134; WM_CTLCOLORBTN = $0135; WM_CTLCOLORDLG = $0136; WM_CTLCOLORSCROLLBAR= $0137; WM_CTLCOLORSTATIC = $0138; WM_MOUSEFIRST = $0200; WM_MOUSEMOVE = $0200; WM_LBUTTONDOWN = $0201; WM_LBUTTONUP = $0202; WM_LBUTTONDBLCLK = $0203; WM_RBUTTONDOWN = $0204; WM_RBUTTONUP = $0205; WM_RBUTTONDBLCLK = $0206; WM_MBUTTONDOWN = $0207; WM_MBUTTONUP = $0208; WM_MBUTTONDBLCLK = $0209; WM_MOUSEWHEEL = $020A; WM_MOUSELAST = $020A; WM_PARENTNOTIFY = $0210; WM_ENTERMENULOOP = $0211; WM_EXITMENULOOP = $0212; WM_NEXTMENU = $0213; WM_SIZING = 532; WM_CAPTURECHANGED = 533; WM_MOVING = 534; WM_POWERBROADCAST = 536; WM_DEVICECHANGE = 537; 577

WM_IME_STARTCOMPOSITION = $010D; WM_IME_ENDCOMPOSITION = $010E; WM_IME_COMPOSITION = $010F; WM_IME_KEYLAST = $010F; WM_IME_SETCONTEXT = $0281; WM_IME_NOTIFY = $0282; WM_IME_CONTROL = $0283; WM_IME_COMPOSITIONFULL = $0284; WM_IME_SELECT = $0285; WM_IME_CHAR = $0286; WM_IME_REQUEST = $0288; WM_IME_KEYDOWN = $0290; WM_IME_KEYUP = $0291; WM_MDICREATE = $0220; WM_MDIDESTROY = $0221; WM_MDIACTIVATE = $0222; WM_MDIRESTORE = $0223; WM_MDINEXT = $0224; WM_MDIMAXIMIZE = $0225; WM_MDITILE = $0226; WM_MDICASCADE = $0227; WM_MDIICONARRANGE = $0228; WM_MDIGETACTIVE = $0229; WM_MDISETMENU = $0230; WM_ENTERSIZEMOVE = $0231; WM_EXITSIZEMOVE = $0232; WM_DROPFILES = $0233; WM_MDIREFRESHMENU = $0234; WM_MOUSEHOVER = $02A1; WM_MOUSELEAVE = $02A3; WM_CUT = $0300; WM_COPY = $0301; WM_PASTE = $0302; WM_CLEAR = $0303; WM_UNDO = $0304; WM_RENDERFORMAT = $0305; WM_RENDERALLFORMATS = $0306; WM_DESTROYCLIPBOARD = $0307; WM_DRAWCLIPBOARD = $0308; WM_PAINTCLIPBOARD = $0309; WM_VSCROLLCLIPBOARD = $030A; WM_SIZECLIPBOARD = $030B; WM_ASKCBFORMATNAME = $030C; WM_CHANGECBCHAIN = $030D; WM_HSCROLLCLIPBOARD = $030E; WM_QUERYNEWPALETTE = $030F; WM_PALETTEISCHANGING= $0310; WM_PALETTECHANGED = $0311; WM_HOTKEY = $0312; WM_PRINT = 791; WM_PRINTCLIENT = 792; WM_HANDHELDFIRST = 856; 578

WM_HANDHELDLAST = 863; WM_PENWINFIRST = $0380; WM_PENWINLAST = $038F; WM_COALESCE_FIRST = $0390; WM_COALESCE_LAST = $039F; WM_DDE_FIRST = $03E0; WM_DDE_INITIATE = WM_DDE_FIRST + 0; WM_DDE_TERMINATE = WM_DDE_FIRST + 1; WM_DDE_ADVISE = WM_DDE_FIRST + 2; WM_DDE_UNADVISE = WM_DDE_FIRST + 3; WM_DDE_ACK = WM_DDE_FIRST + 4; WM_DDE_DATA = WM_DDE_FIRST + 5; WM_DDE_REQUEST = WM_DDE_FIRST + 6; WM_DDE_POKE = WM_DDE_FIRST + 7; WM_DDE_EXECUTE = WM_DDE_FIRST + 8; WM_DDE_LAST = WM_DDE_FIRST + 8; WM_APP = $8000; WM_USER = $0400; Windows Mesajları 2

2

21 Ağu 2002 09:57 mrceng

579

BM_SETIMAGE = $00F7; { Listbox } LBN_ERRSPACE = (-2); LBN_SELCHANGE = 1; LBN_DBLCLK = 2; LBN_SELCANCEL = 3; LBN_SETFOCUS = 4; LBN_KILLFOCUS = 5; { Listbox messages } LB_ADDSTRING = $0180; LB_INSERTSTRING = $0181; LB_DELETESTRING = $0182; LB_SELITEMRANGEEX = $0183; LB_RESETCONTENT = $0184; LB_SETSEL = $0185; LB_SETCURSEL = $0186; LB_GETSEL = $0187; LB_GETCURSEL = $0188; LB_GETTEXT = $0189; LB_GETTEXTLEN = $018A; LB_GETCOUNT = $018B; LB_SELECTSTRING = $018C; LB_DIR = $018D; LB_GETTOPINDEX = $018E; LB_FINDSTRING = $018F; LB_GETSELCOUNT = $0190; LB_GETSELITEMS = $0191; LB_SETTABSTOPS = $0192; LB_GETHORIZONTALEXTENT = $0193; LB_SETHORIZONTALEXTENT = $0194; LB_SETCOLUMNWIDTH = $0195; LB_ADDFILE = $0196; LB_SETTOPINDEX = $0197; LB_GETITEMRECT = $0198; LB_GETITEMDATA = $0199; LB_SETITEMDATA = $019A; LB_SELITEMRANGE = $019B; LB_SETANCHORINDEX = $019C; LB_GETANCHORINDEX = $019D; LB_SETCARETINDEX = $019E; LB_GETCARETINDEX = $019F; LB_SETITEMHEIGHT = $01A0; LB_GETITEMHEIGHT = $01A1; LB_FINDSTRINGEXACT = $01A2; LB_SETLOCALE = $01A5; LB_GETLOCALE = $01A6; LB_SETCOUNT = $01A7; LB_INITSTORAGE = $01A8; LB_ITEMFROMPOINT = $01A9; 580

LB_ITEMFROMPOINT = $01A9; LB_MSGMAX = 432; { Combo Box } CBN_ERRSPACE = (-1); CBN_SELCHANGE = 1; CBN_DBLCLK = 2; CBN_SETFOCUS = 3; CBN_KILLFOCUS = 4; CBN_EDITCHANGE = 5; CBN_EDITUPDATE = 6; CBN_DROPDOWN = 7; CBN_CLOSEUP = 8; CBN_SELENDOK = 9; CBN_SELENDCANCEL = 10; { Combo Box messages } CB_GETEDITSEL = $0140; CB_LIMITTEXT = $0141; CB_SETEDITSEL = $0142; CB_ADDSTRING = $0143; CB_DELETESTRING = $0144; CB_DIR = $0145; CB_GETCOUNT = $0146; CB_GETCURSEL = $0147; CB_GETLBTEXT = $0148; CB_GETLBTEXTLEN = $0149; CB_INSERTSTRING = $014A; CB_RESETCONTENT = $014B; CB_FINDSTRING = $014C; CB_SELECTSTRING = $014D; CB_SETCURSEL = $014E; CB_SHOWDROPDOWN = $014F; CB_GETITEMDATA = $0150; CB_SETITEMDATA = $0151; CB_GETDROPPEDCONTROLRECT = $0152; CB_SETITEMHEIGHT = $0153; CB_GETITEMHEIGHT = $0154; CB_SETEXTENDEDUI = $0155; CB_GETEXTENDEDUI = $0156; CB_GETDROPPEDSTATE = $0157; CB_FINDSTRINGEXACT = $0158; CB_SETLOCALE = 345; CB_GETLOCALE = 346; CB_GETTOPINDEX = 347; CB_SETTOPINDEX = 348; CB_GETHORIZONTALEXTENT = 349; CB_SETHORIZONTALEXTENT = 350; CB_GETDROPPEDWIDTH = 351; CB_SETDROPPEDWIDTH = 352; CB_INITSTORAGE = 353; 581

CB_INITSTORAGE = 353; CB_MSGMAX = 354; { Edit Control } EN_SETFOCUS = $0100; EN_KILLFOCUS = $0200; EN_CHANGE = $0300; EN_UPDATE = $0400; EN_ERRSPACE = $0500; EN_MAXTEXT = $0501; EN_HSCROLL = $0601; EN_VSCROLL = $0602; { Edit Control Messages } EM_GETSEL = $00B0; EM_SETSEL = $00B1; EM_GETRECT = $00B2; EM_SETRECT = $00B3; EM_SETRECTNP = $00B4; EM_SCROLL = $00B5; EM_LINESCROLL = $00B6; EM_SCROLLCARET = $00B7; EM_GETMODIFY = $00B8; EM_SETMODIFY = $00B9; EM_GETLINECOUNT = $00BA; EM_LINEINDEX = $00BB; EM_SETHANDLE = $00BC; EM_GETHANDLE = $00BD; EM_GETTHUMB = $00BE; EM_LINELENGTH = $00C1; EM_REPLACESEL = $00C2; EM_GETLINE = $00C4; EM_LIMITTEXT = $00C5; EM_CANUNDO = $00C6; EM_UNDO = $00C7; EM_FMTLINES = $00C8; EM_LINEFROMCHAR = $00C9; EM_SETTABSTOPS = $00CB; EM_SETPASSWORDCHAR = $00CC; EM_EMPTYUNDOBUFFER = $00CD; EM_GETFIRSTVISIBLELINE = $00CE; EM_SETREADONLY = $00CF; EM_SETWORDBREAKPROC = $00D0; EM_GETWORDBREAKPROC = $00D1; EM_GETPASSWORDCHAR = $00D2; EM_SETMARGINS = 211; EM_GETMARGINS = 212; EM_SETLIMITTEXT = EM_LIMITTEXT; EM_GETLIMITTEXT = 213; EM_POSFROMCHAR = 214; EM_CHARFROMPOS = 215; 582

EM_CHARFROMPOS = 215; EM_SETIMESTATUS = 216; EM_GETIMESTATUS = 217; { Scroll bar messages } SBM_SETPOS = 224; SBM_GETPOS = 225; SBM_SETRANGE = 226; SBM_SETRANGEREDRAW = 230; SBM_GETRANGE = 227; SBM_ENABLE_ARROWS = 228; SBM_SETSCROLLINFO = 233; SBM_GETSCROLLINFO = 234; { Dialog messages } DM_GETDEFID = (WM_USER+0); DM_SETDEFID = (WM_USER+1); DM_REPOSITION = (WM_USER+2); PSM_PAGEINFO = (WM_USER+100); PSM_SHEETINFO = (WM_USER+101); Delphi ve WinApi mrceng

16 Ağu 2002 19:23

Kod Yorumları NE İŞE YARAR VE NASIL KULLANIRIZ? hiphopbaba

18 Ağu 2002 15:37

bir ustteki ornekte nasıl kullanıldığına dair bir satırlık bir kod var. onu incelersen belki alında bir kıvılcım çaktırabilir. Eger component hazırlıyorsan ornegin OnKeyPress gibi bir olayin icerisine sen kod yazarsan kullanici o olayı bir daha kullanamaz. ama win mesajı ile bunu hazırlarsan o componentin olayına dokunmamış olursun ve component kullanicisida rahatlıkla istediği olaya kod yazabilir. bir diğeride bu mesajları normal program yazarkende rahatlıkla kullanabilirsin. yukarıdaki örnek gibi. örneğin bir butona basılmasını istediğinde BM_CLICK gonderdiğinde o butona basılır. kod: postMessage(button1.Handle,BM_CLICK,1,1); nasıl herşey bu kadar basit işte. 583

zorla adamı düğmeye bastırdık....:)

584

Method: WshShell.SendKeys WshShell.SendKeys strKeyString The SendKeys method sends one or more keystrokes to the active window as if they were typed at the keyboard. This method is similar to VB's SendKeys method. Each ordinary key can be represented by the character of the key itself. For example, the key sequence ABCD can be represented simply by "ABCD". Some special keys, such as the control keys, function keys, '{', '}', '[', ']', etc... are encoded in a string enclosed by braces ({}). The following table shows the list of special characters and their respective encoding for SendKeys. Key

Code

{

{{}

}

{}}

[

{[}

]

{]}

~

{~}

+

{+}

^

{^}

%

{%}

BACKSPACE

{BACKSPACE}, {BS}, or {BKSP}

BREAK

{BREAK}

CAPS LOCK

{CAPSLOCK}

DEL or DELETE {DELETE} or {DEL} DOWN ARROW

{DOWN}

END

{END}

ENTER

{ENTER} or ~

ESC

{ESC}

HELP

{HELP}

HOME

{HOME}

INS or INSERT

{INSERT} or {INS}

LEFT ARROW

{LEFT}

585

NUM LOCK

{NUMLOCK}

PAGE DOWN

{PGDN}

PAGE UP

{PGUP}

PRINT SCREEN

{PRTSC}

RIGHT ARROW

{RIGHT}

SCROLL LOCK

{SCROLLLOCK}

TAB

{TAB}

UP ARROW

{UP}

F1

{F1}

F2

{F2}

F3

{F3}

F4

{F4}

F5

{F5}

F6

{F6}

F7

{F7}

F8

{F8}

F9

{F9}

F10

{F10}

F11

{F11}

F12

{F12}

F13

{F13}

F14

{F14}

F15

{F15}

F16

{F16}

To specify keys combined with any combination of the SHIFT, CTRL, and ALT keys, precede the key code with one or more of the following codes: Key Code +

SHIFT

^

CTRL

%

ALT 586

For example, the following strKeyString produces the CTRL-ALT-DELETE keystroke combination: "^%{DELETE}" The following VBScript code creates an instance of Notepad and types the words "Hello World!" ten times into Notepad. Code: Set WshShell = WScript.CreateObject("WScript.Shell") WshShell.Run "notepad", 9 WScript.Sleep 500 ' Give Notepad some time to load For i = 1 To 10 WshShell.SendKeys "Hello World!" WshShell.SendKeys "{ENTER}" Next

587

The views and information expressed in this document represent those of its author(s) who are solely responsible for its content. Borland does not make or give any representation or warranty with respect to such content. Creating Delphi DLLs for use with Paradox and dBASE By Sundar Rajan Table of Contents ·

Two-Minute DLL

·

Passing Variables

·

Dialog Boxes in a DLL - Exposing the Common Dialogs o

Modifying the Project File to Create a DLL

o

Writing the Library Functions

o

Using the dialog box from a Paradox application

·

DLLs with Database Components - A Dynamic Table Browser Example

·

Listing Aliases - Deriving New Components for the BDE

·

A Popup Calendar for Paradox/dBASE Users Using the Calendar Component

·

Tips

·

Summary

Most Paradox and dBASE developers would agree that creating libraries of commonly used functions promotes re-use, resource sharing and serves as a excellent means of shortening development cycles. System-wide procedures and functions can be encapsulated into ObjectPAL libraries or dBASE program files. The catch , of course, is that these libraries are not truly re-usable - The functions and procedures in the libraries can only be used by the development tool that created it. A dBASE program doesn't understand the functions in an ObjectPAL library and vice versa. Wouldn't it be nice if you could write some or all of the code for common functions just once and be done with? Is this possible ? Actually, yes!. You can write modular, re-usable code libraries that operate independently of your development system. The format of such a library is called DLL, and virtually all Windows development tools can access functions and procedures in DLLs. In the Windows world, DLLs remain the only truly reusable component format that can be shared amongst all windows development tools. Database Developers resort to DLLs for various reasons : ·

Create functions that are significantly faster than those written in ObjectPAL or dBASE.

·

Do things that are very difficult or impossible to do in Paradox/dBASE (invoke Callback functions). 588

While Paradox/dBASE developers have used DLLs, the process of creating such DLLs were left to third-parties or C/C++ experts because of the complexity and learning curve associated with writing 'C' Windows code. Finally, with Delphi, xBASE and Paradox programmers can create DLLs using a familiar, visual development toolset. In this article, I will show how Delphi can be used to create DLLs, including DLLs that contain forms and database components and discuss an application architecture that makes best use of the different development tools. Two-Minute DLL The beauty with Delphi is that even novice windows programmers can churn out DLLs quickly without having to grapple with esoteric concepts like WEP, LIBMAIN and DEF files. You proceed to create functions and procedures pretty much the same way you would do with Paradox or dBASE. Delphi can then instantly turn these programs into DLLs by renaming the Program as Library and by exporting the functions. The MinMax DLL library listed below contains two functions Min, Max . To create this DLL : 1. Open a new project in Delphi, 2. Close the default form and unit created (MinMax project does not need any forms or units) 3. Save the project as MinMax (the name of the DLL) and change the Program keyword to Library. 4. Remove the forms unit from the project's uses clause. 5. Remove all lines of code between the begin and end at the bottom of the file. 6. Write the code for the functions. The EXPORTS specifier in the function declaration tells the compiler that the function is going to be called from another external module. Any routines exported from a DLL must include the export specifier. All call-backs such as window procedures also need this specifier. 7. Finally, declare the routines that are actually exported from the DLL under the EXPORTS statement. The EXPORTS statement at the end of the library source code tells the compiler what is visible and what isn't. Library MinMax; function Min(X, Y: Integer): Integer; export; begin if X < Y then Min := X else Min := Y; end; function Max(X, Y: Integer): Integer; export; begin if X > Y then Max := X else Max := Y; end; 589

exports Min index 1, Max index 2; begin end. Even from this simple example, you can see that although the syntax of the library functions is not very different from ObjectPAL or dBASE, the resultant library functions compile into DLLs and are truly re-usable - not only by Delphi programs but also from Paradox, dBASE and other Windows development tools. To use the DLL functions in Paradox, create a new form and declare the functions in the USES section and create a push button to invoke the functions: ; the following goes in the form's Uses window uses MinMax ; load routines from MINMAX.DLL Min (x CWORD, y CWORD) CWORD ; declare the routines to use Max (x CWORD, y CWORD) CWORD endUses method pushButton(var eventInfo Event) var x, y, z SmallInt endVar x.View("Enter X") y.View("Enter Y") z = Min(x, y) ; call Min from the DLL msgInfo("Min", z) z = Max(x, y) ; call Max from the DLL msgInfo("Max", z) endMethod Passing Variables When you pass variables between the calling program and the Delphi DLL, you can pretty much use the standard Pascal data types such as Integer, LongInt etc, except for the ones shaded in figure below. The Pascal string type may seem like the equivalent of the ObjectPAL string - do not use the Pascal String type as a parameter or return variable in your DLL function. The reason : Pascal String type is only understood by Pascal. Instead, use the PChar type - PChar is a pointer to a null-terminated array of characters - the standard C-language string type that is understood by every language that can call DLLs. Likewise, avoid using the Pascal Logical data type as a return parameter since it does not match to an ObjectPAL data type. Data types translation table

590

Invoking DLL functions or procedures with incorrect data types can lead to various problems including GPFs and system crashes. Here is a typical example: A Delphi DLL (in MYDLL.DLL) function I was testing had the following prototype : function MyFunction(X, Y: Integer): Integer; export; I had mistakenly assigned a return type of Smallint to the function in the Uses section of the Paradox form that called the DLL : Uses MyDll ; load routines from MyDLL.DLL MyFunction (x CWORD, y CWORD) Smallint endUses Everytime the DLL function was invoked, Paradox threw up the error message "You have tried to use an unassigned variable. A variable must be assigned a value before you can use it.". The correct return type for MyFunction in the Uses section should have been CWORD. Dialog Boxes in a DLL - Exposing the Common Dialogs Creating DLLs that contain functions and procedures is all very nice, but Delphi's true power is in creating DLLs that contain dialogs boxes and forms. In the past, such DLLs were the domain of C/C++ experts or third-party vendors, primarily because of the complexity of writing Windows code in C/C++. With Delphi's rich tool-set and VCL, dBASE and Paradox programmers can create DLLs using the same visual metaphor they're already familiar with. Consider a Paradox application that lets users dynamically select color preferences for forms and other screen objects. We know that Windows API has 'common dialog' functions for selecting color and that Paradox does not surface this function in ObjectPAL. Not only that- to invoke the Windows API common dialogs, you need callback capabilities that are beyond the scope of ObjectPAL. Let us consider another common dialog-a File Open dialog which is useful for selecting dBASE/Paradox tables (Paradox's File-browser has some limitations - it displays SQL aliases even when the selection filter explicitly specifies dBASE/Paradox tables). These are typical situations when dBASE/Paradox developers can turn to Delphi for solutions-Delphi has built-in dialog components for selecting color and opening files. (There is actually another way of invoking common dialogs: By making calls to the Windows API directly. I do not recommend this approach as the Delphi VCL has encapsulated the common dialog API functions and Delphi

591

components are easily enhanced). CMNDLGS Project listed below exports two wrapper functions-for the color dialog and for the file open dialog : Modifying the Project File to create a DLL ·

Note that the default project file created by Delphi defaults to the reserved word Program in the first line-change this to Library.

·

Remove the Forms unit from the project's uses clause.

·

Remove all lines of code in the begin..end block.

·

Finally, add an export clause to export the functions you want to make available to other programs.

Library Cmndlgs; uses Cdlgunit in 'CDLGUNIT.PAS'; {FrmDialog} exports wwGetOpenFileName, wwChooseColor; begin end. Writing the Library functions Since Paradox /dBASE cannot use Delphi's components directly, we need to wrap the components in a Delphi function or procedure and export those instead. ·

Open the default forms unit created by Delphi and place the color dialog and File Open dialog on it. Save the unit as CDLGUNIT.PAS, instead of the default file name unit1.pas.

·

The function wwChooseColor passes a default color (LongInt) and returns the user-selected color in the same variable ClrSelected (note the var keyword tells Delphi that the variable is passed by reference). Declare the interface routine as below. The export keyword indicates that the function will be visible to external programs.

· · · ·

· · · · ·

function wwChooseColor(var ClrSelected :LongInt) :Integer; export; wwGetOpenFileName (the wrapper for File Open dialog ) accepts the title, filter values (e.g. '*.DB'), and returns the filename selected via the third parameter szName. function wwGetOpenFileName(szTitle :PChar; szFilter :PChar ; szName: PChar) : Integer; export; All that remains now is to implement the functions. The code for the color dialog and the file open dialog functions are given below : 592

Figure CLRDLG - Delphi's Color Dialog component invoked from Paradox. Choose Box Color invokes the Delphi DLL function wwChooseColor and lets users pick the color for the Box using the Common Dialog.

Delphi code for wwGetOpenFileName and wwChooseColor functions

unit Cdlgunit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TFrmDialog = class(TForm) OpenDialog1: TOpenDialog; ColorDialog1: TColorDialog; private { Private declarations } public { Public declarations } end; var FrmDialog: TFrmDialog; function wwGetOpenFileName(szTitle :PChar; szFilter :PChar ; szName: PChar) : Integer; export; function wwChooseColor(var ClrSelected :LongInt) :Integer; export; implementation {$R *.DFM} function wwGetOpenFileName(szTitle :PChar; szFilter :PChar; szName: PChar) : Integer; var 593

someStr: String; begin Result := 0; try frmDialog := TFrmDialog.Create(Application); with frmDialog do begin OpenDialog1.title := StrPas(szTitle); OpenDialog1.DefaultExt := 'DB'; OpenDialog1.Filter := strPas(szFilter); if OpenDialog1.Execute then begin StrPCopy(szName, OpenDialog1.FileName); Result :=1; end; end; finally frmDialog.free; end; end; function wwChooseColor(var clrSelected: LongInt) : Integer; var someStr: String; begin Result := 0; try frmDialog := TFrmDialog.Create(Application); with frmDialog do begin ColorDialog1.Color := clrSelected; if ColorDialog1.Execute then begin ClrSelected := ColorDialog1.Color; Result :=1; end else begin Result := 0; end; end; finally frmDialog.free; end; end; end. 594

Using the dialog box from a Paradox application Figure CLRDLG shows the Paradox form CLRDLG.FSL in action. Code in the Uses window of the form: uses CMNDLGS wwGetOpenfileName(Title CPTR, Filter CPTR, SelectedFile CPTR) CWORD wwChooseColor(ClrSent CPTR) CWORD enduses The pushbutton labeled "Choose Box Color" invokes the Color dialog function, and sets the box color to the one picked by the user. Var ClrSelected LongInt EndVar ClrSelected = Box.color if wwChooseColor(ClrSelected) = 1 then ; Success Box.Color = ClrSelected endif DLLs with Database Components - A Dynamic Table Browser example Let 's move to a topic that is sure to interest database developers - creating reusable DLLs that contain database components. The importance is obvious database functions executed from DLLs are faster than those written in ObjectPAL/dBASE and the can be shared amongst different applications and development tools. Figure TBLVIEW (below) shows an example of a Paradox utility that uses two DLL functions - the File Open dialog component and a Table Viewer component in a DLL to create a dynamic table browser. Listing of TBLVIEW.DPR

Library Tblview; uses Tblvunit in 'TBLVUNIT.PAS' {tvform1}; exports UseDll, ExitDll, ViewTable; {$R *.RES} begin { Remember to remove the generated application control invocations Application.CreateForm(TDllForm1, DllForm1); Application.Run; 595

} end. Follow the same steps as before to create the TBLVIEW.DPR project file. Open the default forms unit created by Delphi - drop a TDataSource, TTable, TDBNavigator and TDBGrid components on the form; and save the unit as TBLVUNIT. Delphi's live display of data lets you check out your DLL even at design time. Connect the table named "Table1" to the example CUSTOMER.DB table (this table name will be dynamically assigned at run-time by the DLL function). Now hook up the datasource to the table by setting the DataSet property of the datasource to Table1. Hook the DBGrid to the datasource by setting its DataSource Property to DataSource1. Also, hook the DBNavigator to the datasource by setting its DataSource property to DataSource1. The DLL exports a single funtion ViewTable - It accepts a table name (PCHAR), converts it to string, assigns it to the TableName property of the TTable component and displays the contents of the table using the DBGrid. However, there are several aspects to consider when you use database components in a DLL. Here are the main points : ·

When a DLL uses database components (or any other BDE component), the DLL requires per-task initialization. In other words, the calling program should verify that no other users are using the DLL function. UseDLL procedure below illustrates this.

·

Any Exceptions should be trapped within the DLL - exceptions across DLL boundaries cause GPFs and abnormal terminations. Note that exceptions are handled by the ViewTable function in our example, and the error messages are displayed to the user by the DLL function.

·

When Paradox or other applications call DLL functions that use the BDE, they also need to de-initialize the DLL before exiting. Failure to do this can result in GPFs. The BDE service needs to be de-initialized before the DLL WEP is called during DLL unload. The ExitDLL routine must be called by the calling program to de-initialize this DLL and its services. Once the deinitialization occurs, the DLL cannot be used again until it is unloaded. The Close() method of the Paradox program calls the ExitDll procedure as below :

method close(var eventInfo Event) if not eventInfo.isPreFilter() then ExitDll() endif endmethod

596

Figure TBLVIEW (Delphi Database DLL example): Unlike C/C++, Delphi is rich in database capabilities. The figure shows one of it many unique features - live display of data even at design time. ViewTable function exported by TBLVIEW.DLL accepts a table name as a parameter and displays the contents of the table using a DBGrid as shown above. The Paradox form TBLVIEWR.FSL uses the common dialog file open function WWGetOpenFileName to select a Paradox or dBASE table. Then the ViewTable function is used to display the contents of the table. Listing of TBLVUNIT.PAS unit Tblvunit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, Grids, DBGrids, DB, DBTables, ExtCtrls, DBCtrls; { Note that the TTVForm1 form is always used modally. Borland does not 597

recommend using a modeless form from a DLL because the OnActivate and OnDeactivate mechanisms do not work when control is transferred between a DLL owned form and another DLL or EXE owned form. } type TTvform1 = class(TForm) Table1: TTable; DataSource1: TDataSource; DBGrid1: TDBGrid; OKBtn1: TBitBtn; DBNavigator1: TDBNavigator; procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } public { Public declarations } end; const DllErrorUnload = 'The DLL must first be unloaded before re-use'; DllErrorInUse = 'The DLL is already in use by another application'; DllErrorViewingTable = 'The table could not be viewed: %s'; var tvform1: Ttvform1; { UseDLL should be called to verify that the DLL may be used by the current application. ExitDLL should be called before the DLL client exits. It CANNOT be called from a DLL WEP. } function UseDLL: integer; export; procedure ExitDLL; export; function ViewTable (const TableName: PChar): Integer; export; implementation var Task: THandle; Unloaded: Boolean; {$R *.DFM} { Exceptions that are raised across a DLL call boundary cause an application termination. Therefore they are caught here and converted to an error return. The caller may convert back to an exception (if written in Delphi or C++) or pass the result back through some other error handling mechanism. } 598

function ViewTable (const TableName: PChar): Integer; begin try if not Assigned (tvform1) then TvForm1 := TTVForm1.Create (nil); with TvForm1 do begin Table1.TableName := StrPas(TableName); Table1.Active := True; ShowModal; Result := 1; end except on EResult: Exception do begin ShowMessage(Format (DllErrorViewingTable, [EResult.Message])); Result := 0; end else begin ShowMessage(Format (DllErrorViewingTable, ['Unknown error'])); Result := 0; end; end end; { Deactivate the table before the form is closed } procedure TTvform1.FormClose(Sender: TObject; var Action: TCloseAction); begin Table1.Active := False; end; { Some services need to be de-initialized before the DLL WEP is called during DLL unload. BDE is an example of a service that cannot be de-initialized from within the WEP. The following routine must be called by the user of this DLL to de-initialize this DLL and its services. Once the deinitialization occurs, the DLL cannot be used again until it is unloaded. } procedure ExitDLL; begin CallExitProcs; Unloaded := True; end; { Many services require per-task initialization. BDE is an example of such a service. If a service DLL uses other such services, it too may require per-task initialization. Since the VCL BDE Session variable is allocated and initialized per-module rather than per-task, multiple applications 599

cannot simultaneously use a DLL that itself uses BDE. In this demo service, multiple access is protected against via initialization and use validation routines. Another application (.EXE or .DLL in another task) cannot use this DLL until the first application unloads the DLL. For statically linked DLLs, the unload occurs automatically during application termination. } function UseDLL: integer; begin Result := 0; if Task <> GetCurrentTask then begin ShowMessage(DLLErrorInUse); end else if Unloaded then begin ShowMessage(DLLErrorUnload); end else Result := 1 end; { Initialize the task as soon as this service is loaded } begin Task := GetCurrentTask end. Listing Aliases - Deriving new components for the BDE Although dBASE and Paradox are built on the same database engine, they do not surface the same BDE functions. dBASE, for example, does not have the equivalent of ObjectPAL's Session methods such as enumAliasNames, enumDriverInfo and others that provide access to BDE system tables.

600

When functionality is not available in your development tool, turn to Delphi. With complete access to BDE, Delphi provides two options to access BDE functions. ·

Write directly to the BDE, access the BDE system tables and populate a grid with a list of aliases; or

·

Derive new database components for the BDE system tables.

Delphi components can be enhanced, sub-classed and modified easily and we will adopt the second approach. An example of deriving new database components for the BDE system tables is in Delphi's db\tools directory. Follow the README.TXT file to install the sample components. The wwPickAlias function listed below uses the DatabaseList (installed in the Sample page) component to construct a 'pick list' of aliases. To set up the form for the Pick Alias example, drop a DatabaseList, a DataSource and a DBGrid component. Hook them together by setting the DataSet property of the Datasource to AliasList and set the DBGrid's datasource to DataSource1. When invoked from a dBASE or Paradox program, the wwPickAlias function allows the user to pick from a list of current alias details displayed in a DBGrid. function wwPickAlias( SelectedAlias : PChar) : Integer; begin try Result := 0; if not Assigned (Form1) then Form1 := TForm1.Create (nil); With Form1 do begin Try form1.ShowModal; Except on EDatabaseerror do Begin MessageDlg('Error in Alias List ' , mtWarning, [mbOk], 0); 601

end; end; StrPCopy(SelectedAlias,AliasListName.Value); Result := 1; end; except on EResult: Exception do ShowMessage(Format (DllErrorViewingTable, [EResult.Message])); else ShowMessage(Format (DllErrorViewingTable, ['Unknown error'])); end; end; A Popup Calendar for Paradox/dBASE users using the Calendar component Another nifty Delphi component found on the sample's page is the Calendar component. This can be used for displaying a calendar or let the user choose a date. As in examples before, the DLL function wwPickdate exported by the PICKDATE.DLL is a wrapper for the Delphi Calendar component. By exporting this function, Paradox/dBASE users get a nifty popup calendar.

Can this not be done in Paradox or dBASE ? Yes, but the resultant dialog box won't be as fast or as easy to share with other systems. The source code for PICKDATE.DLL and the Paradox form for this example and all others discussed in this paper are included in the code samples ( Code samples also include additional examples : Creating custom cursor DLLs and using them with Paradox; Invoking Delphi DLLs from Visual Basic.) Tips 602

·

Since they include the VCL run-time, Delphi DLLs tend to be fairly large (>180K). This overhead can be minimized by putting several functions, dialog boxes and forms into a single DLL.

·

Test Delphi DLLs first from within the Delphi environment by creating simple calling programs in Delphi. There are two reasons for doing this -1. It is more difficult to debug Delphi DLLs from Paradox/dBASE, 2. Delphi's IDE handles exceptions and errors better than Paradox/dBASE and prevents system crashes.

Summary Delphi's architecture promotes rapid development of re-usable components. Wrapping Delphi components in DLL functions enables other development environments to make use of these powerful components. The examples presented in the paper show how Paradox/dBASE developers can extend their development environment, solve complex problems and improve application performance by making use of Delphi DLLs. Interestingly enough, this model of splitting development tasks between "Solution Builders" (Business analysts with an understanding of end-user needs) and "Component Builders" (Software Engineers specializing in building re-usable components) was also proposed by Microsoft's researchers in their 'Solutions Framework' as a methodology for Rapid Application Development. Delphi Technical Library Borland's Technical Library Copyright © 1996 Borland International, Inc. Last Modified: March 10, 1996

603

Title: Paradox and Network From: VSF Date: 07/18/2000 07:04AM PST Answer Grade: A Points: 15 How can I work with Paradox Databases on a Windows Network (not NT)?! I installed my program and the Database files on the server and it worked. I can run then program from a station and it works, but when I try to run both (station + server) simultaneous the problem shows up! They (server and station)can't add records at the same time on the same database file! Can't I use Paradox with networks!?!? Please help me experts!! View Accepted Answer If this EE solution does not provide the information you are looking for, you can signup as a member and ask your specific question of our 125,000 experts for free. Question History Comment from kretzschmar

07/18/2000 07:30AM PST

hi vsf, point the .net file into a shared network-directory. use the exact the same name for all clients. if one a dedicated server then use a unc path for this. all clients must be point to this directory the entry is found at bde-admin|ConfigureationTab|Configuration|Drivers|Native|Paradox and is named NET DIR the same must be done at the alias with the path entry:eyact the same entry on all clients. let me know if you've further problems meikl Comment from VSF

07/18/2000 07:36AM PST

kretzschmar I will try this, but I'm not quite sure I understood it all. Can you be more specific ?! Thanks !!! Comment from kretzschmar

07/18/2000 08:16AM PST 604

hi vsf, first >Can't I use Paradox with networks!?!? sure, you can use paradox on a network, i do this since over 10 years, but there are some rules by the configuration, which must be done, because you can then have mysterious sideeffects, like your problem, or corrupted indexes and lost records. well, a bit explaination: the .net file is used by the paradox-engine to control the accesses to the databases and if wanted that more than one client will work with the same table, then all clients must have access to the same .net-file. additional is the .net file stored the path to the table, so that the engine means, if two user use two different logical paths to the table, that the tables are on a different location, also if physically the same directory meant. be free to ask further if something unclear meikl Comment from isstorr

07/18/2000 08:29AM PST

hi VSF, what kretzschmar is saying is that you need to set the BDE's NETDIR (the directory which stores the BDE's file locking information) to be the same for all machines on your network. This is essential for locking to work correctly. You need to do this using the BDE Administrator (BDEAdmin.exe) which is found inside the BDE directory (usually C:\Program Files\Borland\Common Files\BDE) Once you have started BDEAdmin Click Configuration tab Click +Drivers Click +Native Click +Paradox In Definition under NET DIR type in a unc path to a shared directory on the server (eg //SERVER1/C/NetDir) Click the blue arrow in the toolbar to save changes Next click +System (under Configuration again) click INIT set LOCAL SHARE to TRUE Click the blue arrow in the toolbar to save changes Close BDEAdmin Its also a good idea to configure the BDE on each machine to use a common configuration file (IDAPI32.CFG). This is also found in the BDE directory. If you do this, you will only need to set up the BDE once and it will eliminate any inconsistencies in the BDE setup on each machine in the network.

605

The location of the configuration file can be set using the registry key HKEY_LOCAL_MACHINE\Software\Borland\Database Engine\CONFIGFILE01 change this key on each machine to a unc path to the IDAPI32.CFG on the server - e.g. \\SERVER1\C\Program Files\Borland\Common Files\BDE\IDAPI32.CFG However for speed, I've found its best to have an installation of the BDE local to each machine, but the configuration file on the server only. let us know if you need further explanation Si Comment from isstorr

07/18/2000 08:31AM PST

sorry In Definition under NET DIR type in a unc path to a shared directory on the server (eg //SERVER1/C/NetDir) Click the blue arrow in the toolbar to save changes should read In Definition under NET DIR type in a unc path to a shared directory on the server (eg \\SERVER1\C\NetDir) Click the blue arrow in the toolbar to save changes :o) Si Comment from kretzschmar

07/18/2000 10:17AM PST

thanks, isstorr, for the verification, and the detailed explaination (i couldn't do it better) ;-)) Accepted Answer from bozo7

07/18/2000 01:41PM PST

I have also done this many times and I just use the folowing code in the on create event of my datamodule: session.netfiledir := '//server1/c/netdir'; It is easier than trying go into everyones bde admin change the Netfile setting there. Ross Comment from isstorr

07/19/2000 01:58AM PST

And also Session.PrivateDir is the location of any .lck files and the workspace for large queries (_Q files) such as generated by Quick Reports. This has to be unique and local to each machine, unlike netdir. If you don't set this then it will default to your alias path, and will mess up on a network (believe me!)

606

Say I want my PrivateDir to be C:\BDETEMP, then on starting the app I clear the contents of this directory before setting Session.PrivateDir to it. This clears out any _Qxxx files which may have been left there if QuickReports crashes (and these can be upwards of 100MB in size!)

607

From Paradox to Access with ADO Page 1: Focusing on the TADOCommand components and using the SQL DDL language.

Chapter 5 of this course (Free Delphi Database Course for Beginners - focus on ADO techniques) featured the ADOQuery component designed to enable Delphi developers to use the SQL language with ADO. The SQL statements can either be DDL (Data Definition Language) statements such as CREATE TABLE, ALTER INDEX, and so forth, or they can be DML (Data Manipulation Language) statements, such as SELECT, UPDATE, and DELETE. In this chapter, I'll focus on the TADOCommand components and using the SQL DDL language to help port your BDE/Paradox data to ADO/Access. Data definition language Creating a database programmatically isn't something most developers do every day - we all use some kind of visual tool, like MS Access for maintaining a MDB file. Unfortunately, sometimes you'll need to create and destroy databases and database objects from code. The most basic technique in use today is the Structured Query Language Data Definition Language (SQL DDL). Data definition language (DDL) statements are SQL statements that support the definition or declaration of database objects (for example, CREATE TABLE, DROP TABLE, CREATE INDEX and similar statements). My intention here is not to teach you the DDL language, if you are familiar with the SQL DML then DDL should be no barrier for you. Note that working with DDL can be quite tricky, every database vendor generally provides its own extensions to SQL. Let's quickly take a look at a simple CREATE TABLE statement: CREATE TABLE PhoneBook( Name TEXT(50) Tel TEXT(50) ); This DDL statemnt (for MS Access), when executed, will create a new table named PhoneBook. The PhoneBook table will have two fields, Name and Tel. Both fields are of the string (TEXT) type and the size of the fields is 50 characters. TFieldDef.DataType Obviously, the data type that represents a string in Access is TEXT. In Paradox it's STRING. In order to port Paradox tables to Access we'll have to know what data types are available and what are their names. When working with the BDE and Paradox tables, the TFieldDef.DataType determines the type of a physical field in a (dataset) table. To successfully migrate Paradox tables to Access you need to have a function that "transforms" a Paradox field type to an Access type. The next function checks the type of the field (fd) and returns the corresponding Access type along with a field size when needed for a CREATE TABLE DDL 608

statement. function AccessType(fd:TFieldDef):string; begin case fd.DataType of ftString: Result:='TEXT('+IntToStr(fd.Size)+')'; ftSmallint: Result:='SMALLINT'; ftInteger: Result:='INTEGER'; ftWord: Result:='WORD'; ftBoolean: Result:='YESNO'; ftFloat : Result:='FLOAT'; ftCurrency: Result := 'CURRENCY'; ftDate, ftTime, ftDateTime: Result := 'DATETIME'; ftAutoInc: Result := 'COUNTER'; ftBlob, ftGraphic: Result := 'LONGBINARY'; ftMemo, ftFmtMemo: Result := 'MEMO'; else Result:='MEMO'; end; end; ADOX ADO Extensions for Data Definition Language and Security (ADOX) is an extension to the ADO objects and programming model. ADOX gives developers a rich set of tools for gaining access to the structure, security model, and procedures stored in a database. To use ADOX in Delphi, you should establish a reference to the ADOX type library. 1. Select Project | Import Type Library 3. Choose "Microsoft ADO Ext 2.x for DDL and Security (Version 2.x)" 4. Change "TTable" to "TADOXTable" 5. Change "TColumn" to "TADOXColumn" 6 .Change "TIndex" to "TADOXIndex" 7. Press Install button (rebuilding packages) 8. Press OK once and Yes twice 9. File | Close All | Yes The top-level object in the ADOX object model is the Catalog object. It provides access to the Tables, Views, and Procedures collections, which are used to work with the structure of the database, and also provides the Users and Groups collections, which are used to work with security. Each Catalog object is associated with only one Connection to an underlying data source. We'll leave ADOX (at least for now) and stick to ADOExpress. TADOCommand In ADOExpress, the TADOCommand component is the VCL representation of the ADO Command object. The Command object represents a command (a query or statement) that can be processed by the data source. Commands can then be executed using the ADOCommand's Execute method. TADOCommand is most often used for executing data definition language (DDL) SQL commands. The CommandText property specifies the command to execute. The CommandType property determines how the CommandText property is interpreted. The cmdText type is used to specify the DDL statement. Although it makes no sense to use the 609

ADOCommand component to retrieve a dataset from a table, query, or stored procedure, you can do so. It's time for some real code...

From Paradox to Access with ADO Page 2: Project to port your BDE/Paradox data to ADO/Access.

The following project will demonstrate how to: • get the list of all tables in a BDE alias • use TFieldDefs in order to retrieve the definition (name, data type, size, etc.) of fields in a table. • create a CREATE TABLE statement • copy data from BDE/Paradox table to ADO/Access table. Basically what we want to do is to copy several tables from DBDemos to our aboutdelphi.mdb Access database. The structure of the aboutdelphi.mdb is discussed in the first chapter. Let's do it step by step: GUI Start Delphi - this creates a new project with one blank form. Add two Buttons, one ComboBox and one Memo component. Next, add a TTable, TADOTable, TADOConnection and a TADOCommand component. Use the Object Inspector to set the following properties (leave all the other properties as they are - for example the Memo should have the default name: Memo1): Button1.Caption = 'Construct Create command' Button2.Caption = 'Create Table and copy data' ComboBox.Name = cboBDETblNames; //as described in the second chapter ADOConnection1.ConnectionString = ... TADOTable.Name = ADOTable ADOTable.Connection = ADOConnection1 TADOCommand.Name = ADOCommand ADOCommand.Connection = ADOConnection1 TTable.Name = BDETable BDETable.DatabaseName = 'DBDEMOS' Code To retrieve a list of the tables associated with a given database (DBDEMOS) we use the next code (OnCreate for the form): procedure TForm1.FormCreate(Sender: TObject); begin Session.GetTableNames('DBDEMOS', '*.db',False, False, cboBDETblNames.Items); end; 610

When you start the project the ComboBox has all the (Paradox) table names in the DBDEMOS alias directory. In the code that follows, we'll pick the Country table. The next task is to create a CREATE TABLE DDL statement. This gets done in the 'Construct Create command' button's OnClick procedure: procedure TForm1.Button1Click(Sender: TObject); //'Construct Create command' button var i:integer; s:string; begin BDETable.TableName:=cboBDETblNames.Text; BDETable.FieldDefs.Update; s:='CREATE TABLE ' + BDETable.TableName + ' ('; with BDETable.FieldDefs do begin for i:=0 to Count-1 do begin s:=s + ' ' + Items[i].Name; s:=s + ' ' + AccessType(Items[i]); s:=s + ','; end; //for s[Length(s)]:=')'; end;//with Memo1.Clear; Memo1.lines.Add (s); end;

The above code simply parses the field definitions for the selected table (cboBDETblNames) and generates a string that will be used by the CommandText property of the TADOCommand component. For example, when you select the Country table the Memo gets filled with the next string: CREATE TABLE country ( Name TEXT(24), Capital TEXT(24), Continent TEXT(24), Area FLOAT, Population FLOAT ) And finally, the code for the 'Create Table and copy data' button drops a table

611

begin tblName:=cboBDETblNames.Text; //refresh Button1Click(Sender); //drop & create table ADOCommand.CommandText:='DROP TABLE ' + tblName; ADOCommand.Execute; ADOCommand.CommandText:=Memo1.Text; ADOCommand.Execute; ADOTable.TableName:=tblName; //copy data BDETable.Open; ADOTable.Open; try while not BDETable.Eof do begin ADOTable.Insert; for i:=0 to BDETable.Fields.Count-1 do begin ADOTable.FieldByName (BDETable.FieldDefs[i].Name).Value := BDETable.Fields[i].Value; end;//for ADOTable.Post; BDETable.Next end;//while finally BDETable.Close; ADOTable.Close; end;//try end; That's it. Check out your Access database now...voila there is a Country table with all the data from DBDEMOS. Now you can port all your Paradox tables to Access (download code). Few questions, however, stay unanswered. The first one is: how to add index definitions (CREATE INDEX ON ...) to tables. The second one is: how to create an empty Access database. I'll leave those (and others you can think of) for the Forum or for some future article - Chapter 13 precisely. To the next chapter If you need any kind of help so far, please post to the Delphi Programming Forum where all the questions are answered and beginners are treated as experts. First page > Focusing on the TADOCommand components and using the SQL DDL language. > Page 1, 2

612

Click to return to The Delphi Magazine home page... Paradox File Corruption Based on an article in The Delphi Magazine, Issue 42, February 1999, and related extract from The Delphi Clinic, Issue 17, this article is Copyright © 1999 Brian Long. The article was written by Brian Long ([email protected]) with help from Will Watts, Nick Moon, David Rose, Nick Spurrier, Andy Race and Jack Birrell. Download The Source Code Full updated source code ready to plug into your projects: Paradox.zip 5184 bytes Contents: • Paradox File Corruption, Issue 42 • The Delphi Clinic, Issue 17: Paradox Table Corruption A reader of The Delphi Magazine wrote to me with the following query: I read your summary of precautions regarding Paradox table and index corruption in multi-user applications on page 52 of Issue 17, implemented all the measures, but I still get corrupted tables and index files every now and again. Are there any more things you can think of? Well, indeed there are. Since writing that entry I have been collecting other useful corruption avoiding tips and techniques that I will list here. First of all though, below is a summary of what was highlighted in Issue 17. If there is a possibility of a form being closed with a table still open, in the OnClose event handler, ensure either Post or Cancel is called. If you open your tables programmatically, then you could also close them in a form’s OnClose or OnCloseQuery event handler. In the BDE Administrator or BDE Configuration program, set Local Share to True in the System settings. Don’t store tables on drive letters manufactured with the DOS SUBST command. Don’t store NET files in a root directory, some BDE revisions apparently did not handle this too well. Call dbiSaveChanges in the TTable’s AfterPost event handler. If your version of the BDE supports it, call dbiUseIdleTime in your Application’s OnIdle event handler. This is easier than the above point, and apparently provides the automated equivalent of it. The API was removed in BDE 4, with the suggestion of using dbiSaveChanges instead. In Delphi 1, write a wm_EndSession message handler for your main form and call Halt in it. This ensures the BDE closes down and hopefully flushes all its buffers.

613

Another useful piece of advice is to ensure you set the Session object’s PrivateDir property to some suitable private directory. Perhaps a subdirectory of your application’s directory. You can get your application’s directory with ExtractFilePath(Application. ExeName). Avoid leaving PrivateDir blank as it will default to the current directory, which will more than likely be the application directory. Letting the BDE use your application directory as its temporary working directory can lead to Lock file has grown too big exceptions. Also, avoid pointing PrivateDir at a root directory, make sure it points at a subdirectory. One final point on the private directory subject is that the private directory should have access to a reasonable amount of disk space. A query linked across tables to extract data may take up at least three times the size of largest table for its temporary __*.* files. If your application is terminated unexpectedly, your BDE private directory might have its temporary files left in place, instead of being deleted as they would normally be by the BDE. If you think this might be a problem, you could write a section of code that executes at the beginning of your application, before any tables are opened, that deletes files from the private directory conforming to the specification __qb*.*. Since the Local Share setting is so crucial, one idea is to only let the program run if Local Share has a value of True. Your main form’s OnCreate handler could call a routine like this. procedure CheckLocalShare; var ASYSConfig: SYSConfig; begin {$ifdef Win32} { Ensure BDE is initialised } Session.Open; {$endif} if (DbiGetSysConfig(ASYSConfig) = DbiErr_None) and not ASYSConfig.bLocalShare then begin ShowMessage('BDE''s LOCAL SHARE flag must be TRUE for this ' + 'program to run. Ask your System Administrator to do this for ' + 'you.'#13#13'This program will not continue until this change ' + 'has been made and all BDE applications have been restarted'); {$ifdef Win32} Application.ShowMainForm := False; {$endif} Application.Terminate; end end; In Delphi 2 or later you can also read Local Share in a more VCL-esque fashion by making use of Session.GetConfigParams('\System\Init', SomeTStringsObject) and then checking SomeTStringsObject.Values['LOCAL SHARE'] Another piece of general advice for applications that may be editing, deleting and adding many records is to periodically pack the Paradox tables to save them spreading across your hard disk. Issue 9, p63 has code for doing this. 614

New information needs to be added to this list to ensure that networked machines do not cause problems by ‘clever’ buffering of any sort. One of the prime reasons for the problem is that two applications accessing the same table have conflicting views of what is really in the table because each machine is caching changes to a certain degree. Unfortunately there are many levels of this caching. Consequently there are many system settings that you need to give appropriate values to in order to avoid its potentially harmful impact to the application. This problem is more general than just Paradox applications: many vendors have the same issues and so these settings can help many applications to work in a more resilient manner. However, given the context of this article, I will only be referring to BDE-driven Paradox data applications. For all Windows 95 machines running BDE applications accessing Paradox or dBASE data or containing that data you should take the following steps. Firstly, make sure you have at least version 4.00.1116 of VREDIR.VXD (156,773 bytes, 11th Sep 97, 11:16) and version 4.00.1112 of VNETSUP.VXD (17,595 bytes, 30th May 97, 11:12). These can be installed with the patch program vrdrupd.exe located at http://support.microsoft.com/Download/support/mslfiles/vrdrupd.exe and fix a problem in Windows 95 where an application shares data with a Windows NT server, as described in Microsoft’s Knowledge Base articles Q148367 and Q174371. Note that Microsoft’s articles get the date stamp of VREDIR.VXD wrong and suggest it is 2 Jun 97. Next, VREDIR must also be set up correctly: ensure that the binary registry value HKey_Local_Machine\System\CurrentControlSet\Services\VxD\VREDIR\Discar dCacheOnOpen is set to 01. The machine will need rebooting for this setting to take effect. Plus, Windows 95 caching should be disabled. To do this, launch the System Properties dialog by holding down the Alt key and double clicking on My Computer (or by holding down the Windows key and pressing Pause). Click the Performance tab, press the File System... button and click on the Troubleshooting tab. Check the options: Disable write-behind caching for all drives. This corresponds to setting this binary value to 0: HKey_Local_Machine\System\CurrentControlSet\Control\FileSystem\DriveWrit eBehind In addition to the above setting there is some suggestion that the Disable synchronous buffer commits and Disable new file sharing and locking semantics options should also be checked, although the help for these options does not really uphold this. This equates to changing the binary settings AsyncFileCommit to 1 and SoftCompatMode to 0. Windows 95 machines running Novell networking software should set the registry entries as: Type

Key

Binary HKey_Local_Machine\System\CurrentControlSet\

Value 0

615

Services\VxD\NWREDIR\ReadCaching String

HKey_Local_Machine\Network\Novell\System Config\ Netware Dos Requester\Cache Writes

No

String

HKey_Local_Machine\Network\Novell\System Config\ Netware Dos Requester\Opportunistic Locking

No

(setting these when Novell is not installed does no harm). On Windows NT machines that run the BDE, or contain Paradox or dBASE files, these settings should be applied to disable opportunistic locking. Type

Key

Value

DWord HKey_Local_Machine\System\CurrentControlSet\Services\ LanmanServer\Parameters\EnableOpLocks

0

DWord HKey_Local_Machine\System\CurrentControlSet\Services\ LanmanServer\Parameters\EnableOpLockForceClose This is probably redundant because of the setting above, but you can set it to be on the safe side

1

DWord HKey_Local_Machine\System\CurrentControlSet\Services\ LanmanServer\Parameters\CachedOpenLimit

0

DWord HKey_Local_Machine\System\CurrentControlSet\Services\ LanmanWorkStation\Parameters\UseOpportunisticLocking

0

DWord HKey_Local_Machine\System\CurrentControlSet\Services\ LanmanWorkStation\Parameters\UtilizeNtCaching

0

For Windows NT Workstation’s running Novell NetWare: DWord HKey_Local_Machine\System\CurrentControlSet\Services\ NWCWorkstation\Parameters\DisablePopup

0

The machine will need rebooting for these settings to take effect. Opportunistic locking is explained in Microsoft’s Knowledge Base article Q129202, and this quote is taken from the Windows NT Resource Kit: ‘This setting specifies whether the server allows clients to use oplocks on files. Oplocks are a significant performance enhancement, but have the potential to cause lost cached data on some networks, particularly wide area networks.’ Some of the problems introduced by oplocks are described in articles Q134637, Q124916, and Q126026. If you are running Windows for Workgroups 3.1x, you should disable disk write caching. In SYSTEM.INI in the [386Enh] section and add an entry to disable 32bit write-caching on all drives that have shared data on them, 616

eg ForceLazyOff=CDE. Microsoft KnowledgeBase article Q107645 describes this option and article Q108109 emphasises that [386Enh] is the correct section, not [vcache] as mentioned in the Resource Kit documentation. If AUTOEXEC.BAT loads the SMARTDRV.EXE program, make sure the /X parameter is used to disable write-behind caching. The sample project DBStuff.Dpr (which can be found in the PARADOX.ZIP file) contains some code which will check all the appropriate entries depending on whether you are running your application on Windows 95, NT or 3.1. In fact, so potentially important are the registry settings that if they are not found to have the correct values, the program sets them and suggests that the user reboots. DBStuff.Dpr compiles in all versions of Delphi from 1 to 4. The reboot dialog comes from RestartDialog, an undocumented Shell32 API described in the Restarting Windows entry in Issue 40’s Delphi Clinic. Since I am not passing any text to the API I don’t need to worry about the Unicode issue highlighted in that write-up. The code below shows the form’s OnCreate handler, the main registry checking routine and the Windows 95 checking code. You can see that several helper routines are not listed, including the code that checks the version information of the network redirector files. Refer to the project on the disk for all the missing code. One helper routine listed in full is CheckRegistryEntry. This verifies both numeric and string registry values (passed as a Variant parameter), setting them if they are either wrong or missing. If a change was made, the Reboot Required flag is set to True. procedure TForm1.FormCreate(Sender: TObject); begin CheckOKForParadoxAppToRun end; ... procedure CheckRegistryIsAcceptable; begin {$ifdef Win32} case Win32Platform of VER_PLATFORM_WIN32_WINDOWS : CheckWin95Registry; VER_PLATFORM_WIN32_NT : CheckWinNTRegistry; end; if RebootRequired then //Use standard Win32 reboot dialog RestartDialog(0, nil, ew_RestartWindows) {$else} CheckWin31Registry; if RebootRequired then begin ShowMessage('Some system settings have been changed '+ '- Windows needs to restart'); ExitWindows(ew_RestartWindows, 0) end {$endif} end; ... procedure CheckRegistryEntry(Reg: TRegistry; const Path, Value: String; 617

const Default, Desired: Variant; Size: Byte); var TmpInt: Cardinal; TmpStr: String; begin with Reg do if OpenKey(Path, True) then try case VarType(Desired) of varInteger: { Some numbers need to be stored as DWORD values, } { while some need to be stored as binary values } if Size = 0 then begin if not ValueExists(Value) or (ReadInteger(Value) = Default) then begin WriteInteger(Value, Desired); RebootRequired := True end end else begin TmpInt := Default; if ValueExists(Value) then ReadBinaryData(Value, TmpInt, Size); if TmpInt = Default then begin TmpInt := Desired; WriteBinaryData(Value, TmpInt, Size); RebootRequired := True end end; varString: begin if not ValueExists(Value) or (ReadString(Value) = Default) then begin WriteString(Value, Desired); RebootRequired := True end end end finally CloseKey end end; const Control = 'System\CurrentControlSet\Control\'; Services = 'System\CurrentControlSet\Services\'; procedure CheckWin95Registry; 618

var Reg: TRegistry; const DOSRequester = 'Network\Novell\System Config\Netware Dos Requester'; begin Reg := TRegistry.Create; try Reg.RootKey := HKey_Local_Machine; //Fix VREDIR.VxD settings CheckRegistryEntry(Reg, Services + 'VxD\VREDIR', 'DiscardCacheOnOpen', 0, 1, SizeOf(Byte)); //Fix NWREDIR.VxD settings CheckRegistryEntry(Reg, Services + 'VxD\NWREDIR', 'ReadCaching', 1, 0, SizeOf(Byte)); //Fix Novell settings CheckRegistryEntry(Reg, DOSRequester, 'Cache Writes', 'Yes', 'No', 0); CheckRegistryEntry(Reg, DOSRequester, 'Opportunistic Locking', 'Yes', 'No', 0); //Fix FileSystem troubleshooting settings CheckRegistryEntry(Reg, Control + 'FileSystem', 'DriveWriteBehind', $FFFFFFFF, 0, SizeOf(Longint)); {$define AllOptionsThatPeopleSuggest} {$ifdef AllOptionsThatPeopleSuggest} CheckRegistryEntry(Reg, Control + 'FileSystem', 'SoftCompatMode', 1, 0, SizeOf(Longint)); CheckRegistryEntry(Reg, Control + 'FileSystem', 'AsyncFileCommit', 0, 1, SizeOf(Byte)); {$endif} finally Reg.Free end end; ... procedure CheckOKForParadoxAppToRun; begin {$ifdef Win32} //Only Win95 redirector files need checking if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then CheckRedirector; {$endif} CheckRegistryIsAcceptable; CheckLocalShare; end; It is important to remember that these operating system settings must be set on all machines either running BDE applications or containing BDE data. Similarly the BDE must have Local Share set to True on all installations. If a machine gets upgraded, or has the operating system re-installed, or has a new version of the BDE set up, some of these settings may need to be fixed again. The same applies if a new machine is added to the network. 619

Of course if this approach is taken, you also need to remember to set the settings appropriately on any file server machines used to store your data files, but which do not have any Delphi applications running on them. One important point on this whole subject is that it helps enormously if you educate and train your users. It is not unheard of for users to pull the power cable from their PCs to plug into a kettle, or to terminate applications with the Ctrl+Alt+Del three-fingered salute. See References below for other references which discuss some of these issues, sometimes in the context of totally non-Inprise, non-Paradox systems. One final point to make is that if your Paradox tables do get corrupted, you can make use of TUtility.DLL to try and repair them. A BDE 5 compatible version of this DLL can be found at www.inprise.com/devsupport/bde/utilities.html. You can also find a sample Delphi application there that can be used against arbitrary Paradox tables to try and fix them. Back to Top References Inprise Technical Information sheet TI3342 which offers more views on the Paradox corruption issue; note the file name is case sensitive: www.inprise.com/devsupport/bde/ti_list/TI3342.html Q148367 discusses the Win95 redirector bug; to read any of the other MS KnowledgeBase articles you can build up a URL using the same pattern as this one: support.microsoft.com/support/kb/articles/q148/3/67.asp Discussion of the Windows 95 redirector problem and NT opportunistic locking: www.turbopower.com/newsletters/0798/default.asp Discussion of Novell settings to avoid data loss: www.daccess.com/Support/Integrating_DF_with_NetWare.htm cc:Mail technical paper 144293 discussing various Windows registry settings that need to be set correctly to avoid data loss: orionweb.lotus.com/sims/c8f6_546.htm cc:Mail technical paper 139714 discussing preferred NetWare settings to avoid data loss; if you use NetWare you should read this as it describes many preferred NetWare configuration settings not discussed here: orionweb.lotus.com/sims/8a76_546.htm Article 2917002 describes a Novell read caching problem; article 2911461 describes potential data loss issues using Windows 95 against a NetWare 3.11 server: support.novell.com/search/kb_index.htm Back to Top The Delphi Clinic, Issue 17: Paradox Table Corruption

620

Question: I am developing a Paradox table application in Delphi 1 to run on Windows For Workgroups (WFWG) 3.11. During testing we have had various occurrences of records being lost, indexes out of date and indexes corrupted. Why might this be caused, and what can I do to avoid it? The network server PC is also used as a client PC running the .EXE and is known as network drive L to all other PCs. We've added a SUBST L: C:\ to that PC's AUTOEXEC.BAT, so it's IDAPI.CFG can also refer to L:\... for its net directory and database path. We're running WFWG in enhanced mode and so VSHARE.386 is running, so do I really need SHARE? We've tried running the .EXE on Windows 95 and besides the above problem it seems to run OK. Are there any other things we should consider/change before running it live on Windows 95? Answer: Below are various recommendations you might find in various places and comments about them all, amassed from a number of Paradox and BDE experts. Thanks to Steve Axtell of Borland's European Technical Team, Phil Goulson of the UK Delphi Developer's Group, John O'Connell, Mike Orriss and Eryk Bottomley for their input. A frequent cause for any of the above data corruption problems is the premature termination (power loss, or PC reset possibly forced upon the user by a program hang) of a program accessing a Paradox table. Lost records will cause the index to get out of sync with the data, which will at some stage be followed by index corruption. In some cases, bad programming is the cause of the problem. It is important to ensure that records are posted. When you terminate a program, it is the responsibility of the developer to Post all un-posted records before the program is terminated, otherwise you will get a `record loss' problem. This could be achieved by applying something like the following statement for all your table objects in each form's OnClose event handler: if TableObject.State in dsEditModes then TableObject.Post; The program development phase is the time when most tables start inheriting corruption (caused by the developer resetting programs from time to time) which may not become evident until the system is deployed. One possible way of overcoming the problem is to rebuild the indexes periodically. This can be done with a table restructure (using the BDE DbiDoRestructure function, or with the Database Desktop) and will often resolve index corruption. It can also be done using TUtility, which can resolve data corruption (TUtility comes with the full version of Paradox and was included on the disk with Issue 5 of The Delphi Magazine, or look on the CompuServe BDEVTOOLS forum). An alternative, and perhaps more foolproof, way of fixing broken indexes would be to write a routine which physically erases the indexes (with DeleteFile) and recreates the indexes from scratch with the BDE DbiRegenIndexes call (which relies on the table being opened exclusively). If your tables use referential integrity, then deleting the indexes may cause a problem due to a special checksum in the table header. In these cases you will need to delete the indexes and the .VAL file and use DbiDoRestructure to regenerate all tables that are involved in the referential integrity relationship. In the BDE Configuration application on all PCs that will run the program, set Local Share to True on the System page. This ensures that lock files are written 621

to the local hard disk, thereby ensuring that applications on other machines will be able to find the lock files. This should only be necessary for the machine where the data resides, however the general opinion is that it should always be turned on, provided you have file sharing functionality loaded with either SHARE or VSHARE. On peer to peer networks, the default setting of Local Share is a common cause of data loss. When False, Local Share instructs the BDE to assume that all access to tables on `local drives' (a peer to peer LAN counts as `local') will occur via the same instance of the BDE in memory, it therefore fails in a number of situations including: ·

Peer to peer LANs;

·

Two applications running in different memory spaces under Windows NT (and maybe OS/2);

·

Running a 16-bit BDE app and a 32-bit BDE app on the same machine in Windows 95 or NT.

SUBST will disable 32-bit file access and may therefore slow the machine down. If 32-bit file access is disabled, VSHARE won't be loaded. Some would say that SUBST isn't very safe especially when used with Windows 95 and is probably provided by Microsoft for compatibility with old DOS applications. Apparently, there are little corners where Paradox does not function correctly and some people don't trust the command to work for all flavours of Wintel operating systems. As an aside, it has been observed that the latest 16 bit BDE (2.52, which ships with Paradox 7 for Windows 3.1x) has problems with Auto Refresh not occurring in Paradox 7 for Windows 3.1x on the server when the server is a Windows 95 machine. This may have ramifications for Delphi users. Recent revisions of the BDE allow different Sessions/Users to reference the PDOXUSRS.NET file using different drive letters so long as the remainder of the path is identical. Since the server has shared its root directory there is therefore no need to use SUBST and put up with the associated drawbacks: simply set the server machine's IDAPI.CFG Net Dir setting (on the Drivers page in the PARADOX driver settings) to C:\MYDIR and the workstations' Net Dir to L:\MYDIR. You can do this in code by assigning a value to Session.NetFileDir if you want to avoid editing IDAPI.CFG. Note that using the root directory for the NET file can confuse certain BDE revisions. It is advisable to avoid this as a matter of policy even though the current revision seems happy with it. Also, if the user of the server does not want to share the entire C drive, it might be better to create a small partition for the Net Dir location. If Local Share is True then the BDE will detect an incorrect NetFileDir and refuse to access the tables. If an incorrect assignment here is causing corruption then Local Share is still the real culprit. On the Aliases page of the BDE Configuration application on all PCs in that will run the program, ensure the alias's Path points to the same network data directory.

622

Ensure that all users have their own private directory, preferably local. This is set with the Session object's PrivateDir property. Note that the online help specifies that if there will be multiple instances of the program running simultaneously on any one machine you should make sure each instance is given a unique path to avoid interference between temporary files from the different instances. Call DbiSaveChanges after each table post (done simplest by putting the call in the table's AfterPost event handler). This should be unnecessary if the local share option has been set properly. When the BDE knows that the Paradox table is on a network, each record is saved to disk automatically. Therefore, DbiSaveChanges may only be necessary for saving local tables. There are two cases where a call to DbiSaveChanges can be a definite life saver: when you empty a table and when you restructure/pack a table (using DbiDoRestructure); this is because the actual table file is deleted and recreated but isn't necessarily committed to disk. Check your other software/hardware caching as delayed writes are not good news on a network. Instead of repeated calls to DbiSaveChanges, call DbiUseIdleTime in the Application's OnIdle event handler (also set the event handler's Done parameter to True). A call to DbiUseIdletime writes one dirty buffer to disk. Putting it in the OnIdle event means buffers will be written whenever your program is waiting for user input. Avoid using both DbiSaveChanges and DbiUseIdletime as they both do the same thing and so you'll be causing excessive function calls. This routine is becoming very popular as a general alternative to DbiSaveChanges, as it requires much less coding to use. Have SHARE loaded with parameters of /F:4096 /L:40 as recommended by Borland. This advice is generally for Windows 3.10 users only. VSHARE from Windows for Workgroups supersedes SHARE: it's much better, although there is a caveat. Apparently VSHARE is a 32-bit driver which won't work with 16-bit disk controllers/drives which are present on non-local bus IDE PCs. In those circumstances, excluding SHARE from AUTOEXEC.BAT, and enabling VSHARE from Control Panel causes an error from IDAPI indicating SHARE isn't loaded. Write a message handler for wm_EndSession in your main form class. Delphi 1 doesn't automatically handle this message which is sent when Windows is shut down by the user (although Delphi 2 does). Consequently, if a Delphi app is running when Windows is terminated, it won't be closed properly, and so BDE buffers may remain unwritten. It would be good practice to call Halt on receipt of a wm_EndSession message handler. Halt is not normally an advisable way to close a program, usually we use Application.Terminate. However that operates by posting (as opposed to sending) a wm_Quit message and so won't get around to doing what it needs to before Windows is gone. Halt causes exit procedures to be called, including the one in the DB unit which frees the Session object, thereby closing down the BDE in a proper fashion. The code below shows part of a form unit which takes up some of these suggestions. This code is from the project LOSS.DPR which can be found in the PARADOX.ZIP file. TForm1 = class(TForm) ... public procedure DoIdle(Sender: TObject; var Done: Boolean); 623

{$ifdef VER80} procedure WMEndSession(var Msg: TWMEndSession); message wm_EndSession; {$endif} end; ... uses DbiProcs; ... procedure TForm1.FormCreate(Sender: TObject); begin Application.OnIdle := DoIdle; end; procedure TForm1.DoIdle(Sender: TObject; var Done: Boolean); begin { Each idle period, write a dirty buffer to disk } DbiUseIdleTime; Done := True; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); var Loop: Integer; begin {Generic way of ensuring all table changes are saved when form is closed} for Loop := 0 to ComponentCount - 1 do if Components[Loop] is TDataSet then with TDataSet(Components[Loop]) do if State in dsEditModes then Post; end; {$ifdef VER80} procedure TForm1.WMEndSession(var Msg: TWMEndSession); begin { If session is ending, call Halt to get exit routines executed. The DB unit's exit routine frees the Session object, which will unload the BDE, flushing any unsaved changes to disk } if Msg.EndSession then Halt; end; {$endif} Back to Top

624

How to change NET DIR programmatically so it persists Abstract:Writing values into the BDE configuration file requires only a few function calls. How to change NET DIR programmatically so it persists Writing values into the BDE configuration file requires only a few function calls. by Steven Randolph Programs accessing Paradox tables must also access a special control file named PDOXUSRS.NET. When multiple programs, whether running on one computer or on multiple computers, access the same Paradox table(s), each program must also access the same PDOXUSRS.NET file. Therefore, if multiple computers are running the programs, the PDOXUSRS.NET file must be located in a shared directory. Usually, the location of this file is configured on each computer by running the BDE configuration utility program, BDEADMIN.EXE. The NET DIR parameter indicates where the PDOXUSRS.NET file is located. That NET DIR parameter is associated with the Paradox driver generally, not with any particular alias. THE PROBLEM AND THE GOAL I recently inherited the maintenance of a production system consisting of several client programs running on multiple computers. Each program accesses Paradox tables through multiple aliases. Each alias "points" to a different directory on a host computer. Each program also reads and writes flat files in a large number of directories on one of two hosts. One of the first improvements that I determined to make was to set up a test environment, which my predecessor had never done. I wanted a single host computer for the test environment to have its own tables, its own set of directories, and its own PDOXUSRS.NET file. In other words, any client computer designated for testing should be isolated from the production host environment. I also wanted to make the minimum of changes to the existing production programs to allow for this. While it might seem that the entire task could be accomplished by changing the drive mappings on the test computers, which can be done programmatically, in my case that was not practical. Some of the same drive mappings are used for other purposes in our environment. Besides, this would have required me to create the same rather arcane relative directory structure on the test host as exists on the two production hosts, and I did not wish to do that. So I decided to create a utility program that would accomplish several tasks at once. In this program, the user could click a button labeled "Configure for Test" or one labeled "Configure for Production" and the configuration would be made immediately on that computer. It would create or modify registry entries specifying the various directories to access for the flat files. This part was easy to program, using the TRegistry component. The program also needed to configure 625

the several Paradox aliases to point to either test or production directories. This was also no problem; I merely used the DbiAddAlias and DbiDeleteAlias functions, both of which are well documented. The only variable parameter for the creation of the Paradox aliases was the directory location, and everything else was left at default values. Setting the last parameter in the DbiAddAlias call to "true" caused the alias to be recorded permanently in the BDE configuration file for that computer. However, doing the same for the NET DIR value was not so easy! There is a documented technique for changing the NET DIR directory programmatically. It is documented in Borland’s TI-15230. This technique uses the DbiSetProp BDE function. Unfortunately, DbiSetProp changes the NET DIR directory for the current session only! That is, it does not cause the new value for NET DIR to be written into the BDE configuration file. It took quite a bit of searching and some experimentation to determine how to do that. Finally I figured out that the code in the following block does the trick. THE SOLUTION First is the C++ Builder code. You might want to do the error trapping a little differently, or put in some messages, in a real program. This is just an example of the basic technique. if(DbiInit(NULL) == DBIERR_NONE) { hDBICur hCur = NULL; if(DbiOpenCfgInfoList(NULL, dbiREADWRITE, cfgPersistent, "\\DRIVERS\\PARADOX\\INIT", hCur) == DBIERR_NONE) { if(DbiSetToBegin(hCur) == DBIERR_NONE) { CFGDesc Config; for(;;) // for ever { if(DbiGetNextRecord(hCur, dbiWRITELOCK, &Config, NULL) != DBIERR_NONE) break; if(strcmpi(Config.szNodeName, "NET DIR") == 0) { strcpy(Config.szValue, "servervolumemydir"); DbiModifyRecord(hCur, &Config, true); break; } } } } DbiExit(); } The Delphi version of this process is similar. var hCur : hDBICur; Config : CFGDesc; ContinueIt: boolean; 626

... if DbiInit(nil) = DBIERR_NONE then begin hCur := nil; if DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\\DRIVERS\\PARADOX\\INIT', hCur) = DBIERR_NONE then begin if DbiSetToBegin(hCur) = DBIERR_NONE then begin ContinueIt := true; while ContinueIt do begin if(DbiGetNextRecord(hCur, dbiWRITELOCK, @Config, nil) <> DBIERR_NONE) then ContinueIt := false else if StrIComp(Config.szNodeName, 'NET DIR') = 0 then begin StrCopy(Config.szValue, 'servervolumemydir'); DbiModifyRecord(hCur, @Config, true); ContinueIt := false end; end; end; end; DbiExit(); end; If you use this code, you would want to substitute your own value for the path name to be copied into Config.szValue, of course. In my real program, the value was supplied in a string variable, the contents being determined by whether the user had clicked the "test" button or the "production" button. The value you submit can contain a mapped drive letter, if you are quite sure those mappings will never change; but I always prefer to use the universal naming convention. CAVEATS My experimentation suggests that it is not strictly necessary to close other BDE programs prior to running this code. Just the same, it would probably be a good idea to do so. In any case, a BDE program will not take notice of a changed value in the BDE configuration file until it is started subsequent to the change. You may also notice this while debugging your utility program in the IDE, if you happen to change the value and then try to re-read it without calling DbiExit and DbiInit again. (In the example code, this should not be a problem because DbiExit is executed right after the change is written.) Another important consideration is to make sure that the path you submit to be the new NET DIR actually exists. The BDE will, at runtime, create the PDOXUSRS.NET file if it does not already exist in the NET DIR directory; but the BDE will not create the NET DIR directory for you. If this happens, you will get a runtime error "Network Initialization Failed" when your program tries to initialize or access a Paradox object. 627

You should also remember that if you have programs that change their own NET DIR locations at runtime, using either the DbiSetProp function or the NetFileDir property of a TSession component, this will override the NET DIR value in the configuration file. All of the programs I inherited just use whatever value the configuration file supplies. Finally, you should note that the same technique could be used to change other parameters for the Paradox driver, or many parameters for other drivers. You would have to be very careful about which values you supply, however. Changing the NET DIR directory is relatively safe.

628

BDE API Examples (DbiOpenCfgInfoList) Returns a handle to an in-memory table listing all the nodes in the configuration file accessible by the specified path. WARNING: Be extremely careful when altering the IDAPI.CFG configuration file. Make absolutely sure that all options and parameters are correct or corruption of the configuration file can, and more than likely, occur. Example 1: Retrieve a particular value from the IDAPI.CFG configuration file. This example uses the following input: Edit1.Text := GetConfigParameter(PARADOXLEVEL, @Count); NOTE: Param (in this case PARADOXLEVEL) must be a string that contains the path to the node and the node item separated by a semi-colon. At the bottom of this page are some of the more popular paths and items that are declared as constants for use with all these examples. function GetConfigParameter(Param: string; Count: pword): string; var hCur: hDBICur; rslt: DBIResult; Config: CFGDesc; Path, Option: string; Temp: array[0..255] of char;

begin Result := ''; hCur := nil; if Count <> nil then Count^ := 0; try if Pos(';', Param) = 0 then raise EDatabaseError.Create('Invalid parameter passed to function. There must '+ 'be a semi-colon delimited sting passed'); 629

Path := Copy(Param, 0, Pos(';', Param) - 1); Option := Copy(Param, Pos(';', Param) + 1, Length(Param) - Pos(';', Param)); Check(DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPERSISTENT, StrPCopy(Temp, Path), hCur)); Check(DbiSetToBegin(hCur)); repeat rslt := DbiGetNextRecord(hCur, dbiNOLOCK, @Config, nil); if rslt = DBIERR_NONE then begin if StrPas(Config.szNodeName) = Option then Result := Config.szValue; if Count <> nil then Inc(Count^); end else if rslt <> DBIERR_EOF then Check(rslt); until rslt <> DBIERR_NONE; finally if hCur <> nil then Check(DbiCloseCursor(hCur)); end; end; Example 2: Set a particular value in the IDAPI.CFG configuration file (16-Bit Only) and (32-Bit, BDE v4.51 and later). NOTE: Do not use this procedure version if you are using BDE v4.50 and earlier (See Example 3 below) This exmaple uses the following inupt: SetConfigParameter(LOCALSHARE, 'TRUE') 630

NOTE: Param (in this case LOCALSHARE) must be a string that contains the path to the node and the node item separated by a semi-colon. At the bottom of this page are some of the more popular paths and items that are declared as constants for use with all these examples. procedure SetConfigParameter(Param: string; Value: string); var hCur: hDBICur; rslt: DBIResult; Config: CFGDesc; Path, Option: string; Found: boolean; Temp: array[0..255] of char;

begin hCur := nil; Found := False; try if Pos(';', Param) = 0 then raise EDatabaseError.Create('Invalid parameter passed to function. There must '+ 'be a semi-colon delimited sting passed'); Path := Copy(Param, 0, Pos(';', Param) - 1); Option := Copy(Param, Pos(';', Param) + 1, Length(Param) - Pos(';', Param)); Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPERSISTENT, StrPCopy(Temp, Path), hCur)); repeat rslt := DbiGetNextRecord(hCur, dbiNOLOCK, @Config, nil); if rslt = DBIERR_NONE then begin if StrPas(Config.szNodeName) = Option then 631

begin StrPCopy(Config.szValue, Value); Check(DbiModifyRecord(hCur, @Config, FALSE)); Found := True; break; end; end else if rslt <> DBIERR_EOF then Check(rslt); until rslt <> DBIERR_NONE; if Found = False then raise EDatabaseError.Create(Param + ' entry was not found in configuration file');

finally if hCur <> nil then Check(DbiCloseCursor(hCur)); end; end; Example 3: Set a particular value in the IDAPI.CFG configuration file (32-Bit Only; All Versions). NOTE: You must use this procedure version if you are using BDE v4.50 and earlier This exmaple uses the following inupt: SetConfigParameter2(LOCALSHARE, 'TRUE') NOTE: Param (in this case LOCALSHARE) must be a string that contains the path to the node and the node item separated by a semi-colon. At the bottom of this page are some of the more popular paths and items that are declared as constants for use with all these examples. procedure SetConfigParameter2(Param: string; Value: string);

632

var hCfg: hDBICfg; Config: SYSConfig; Path, Option: string; ParamCount, I: word; pFields, pFld: pFLDDesc; pRecBuf, pRec: pBYTE; Found, SelfInitialized: boolean; rslt: DBIResult;

begin {$Ifdef WIN32} hCfg := nil; pFld := nil; pRec := nil; Found := False; SelfInitialized := False; try if Pos(';', Param) = 0 then raise EDatabaseError.Create('Invalid parameter passed to function. There must '+ 'be a semi-colon delimited sting passed'); Path := Copy(Param, 0, Pos(';', Param) - 1); Option := Copy(Param, Pos(';', Param) + 1, Length(Param) - Pos(';', Param));

rslt := DbiGetSysConfig(Config); if rslt <> DBIERR_NONE then begin if rslt = DBIERR_NOTINITIALIZED then // Engine not initialized error... begin SelfInitialized := True; 633

DbiInit(nil); Check(DbiGetSysConfig(Config)); end else Check(rslt); end; (* DbiOpenConfigFile is defined as such: function DbiOpenConfigFile ( pszDirPath bCreate

: PChar; : Bool;

var hCfg

: hDBICfg

{ Open/Create configuration } { Directory } { TRUE to create/overwrite } { Handle to config }

): DBIResult stdcall; *) Check(DbiOpenConfigFile(Config.szIniFile, FALSE, hCfg));

(* DbiCfgGetRecord is defined as such: function DbiCfgGetRecord ( hCfg

: hDBICfg;

pszCfgPath var iFields

: PChar; : Word;

pfldDesc pRec

: pFLDDesc; : Pointer

{ Get a record } { Config Handle/NULL } { Path } { Returned nbr of fields } { Field descriptors } { Field values }

): DBIResult stdcall; *) { Call it without the field and record buffer to get the count... } Check(DbiCfgGetRecord(hCfg, PChar(Path), ParamCount, nil, nil));

pFields := AllocMem(ParamCount * sizeof(FLDDesc)); pFld := pFields; 634

pRecBuf := AllocMem(10000); pRec := pRecBuf;

{ Get the node values... } Check(DbiCfgGetRecord(hCfg, PChar(Path), ParamCount, pFields, pRecBuf));

for I := 0 to ParamCount - 1 do begin if pFields^.szName = Option then begin StrPCopy(PChar(pRecBuf), Value);

(* DbiCfgModifyRecord is defines as such: function DbiCfgModifyRecord ( hCfg

: hDBICfg;

pszCfgPath iFields pfldDesc pRec

: PChar;

: Word; : pFLDDesc; : Pointer

{ Modify a record } { Config Handle/NULL } { Path } { Nbr of fields } { Field descriptors } { Data values }

): DBIResult stdcall; *) Check(DbiCfgModifyRecord(hCfg, PChar(Path), ParamCount, pFld, pRec));

Found := True; end; Inc(pFields); Inc(pRecBuf, 128); 635

end; if Found = False then raise EDatabaseError.Create(Param + ' entry was not found in configuration file');

finally if pFld <> nil then FreeMem(pFld); if pRec <> nil then FreeMem(pRec); if hCfg <> nil then

(* DbiCloseConfigFile is defined as such: function DbiCloseConfigFile ( var hCfg bSave bDefault bSaveAs16

: hDBICfg; : Bool; : Bool; : Bool

{ Close the config file } { Handle } { To save the changes } { To make this file the default } { To save as a 16-bit config file }

): DBIResult stdcall; *) { Close and save the config file... } Check(DbiCloseConfigFile(hCfg, TRUE, TRUE, FALSE)); if SelfInitialized = True then DbiExit; end; {$Else} raise EDatabaseError.Create('Non supported function in 16 bit'); {$EndIf} 636

end; Special pre-defined constants for use with the above exmaples const { Here are the parameters used to pass into the cfg functions. These are only a small portion of what types can be passed in. You need to call DbiOpenCfgInfoList with '\' into pszCfgPath to get all possible options if it is not foend below. }

{ Paradox Driver Settings... } PARADOXNETDIR = '\DRIVERS\PARADOX\INIT\;NET DIR'; PARADOXVERSION = '\DRIVERS\PARADOX\INIT\;VERSION'; PARADOXTYPE = '\DRIVERS\PARADOX\INIT\;TYPE'; PARADOXLANGDRIVER = '\DRIVERS\PARADOX\INIT\;LANGDRIVER'; PARADOXLEVEL = '\DRIVERS\PARADOX\TABLE CREATE\;LEVEL'; PARADOXBLOCKSIZE = '\DRIVERS\PARADOX\TABLE CREATE\;BLOCK SIZE'; PARADOXFILLFACTOR = '\DRIVERS\PARADOX\TABLE CREATE\;FILL FACTOR'; PARADOXSTRICTINTEGRITY = '\DRIVERS\PARADOX\TABLE CREATE\;STRICTINTEGRITY';

{ dBASE Driver Settings... } DBASEVERSION = '\DRIVERS\DBASE\INIT\;VERSION'; DBASETYPE = '\DRIVERS\DBASE\INIT\;TYPE'; DBASELANGDRIVER = '\DRIVERS\DBASE\INIT\;LANGDRIVER'; DBASELEVEL = '\DRIVERS\DBASE\TABLE CREATE\;LEVEL'; DBASEMDXBLOCKSIZE = '\DRIVERS\DBASE\TABLE CREATE\;MDX BLOCK SIZE'; DBASEMEMOFILEBLOCKSIZE = '\DRIVERS\DBASE\TABLE CREATE\;MEMO 637

FILE BLOCK SIZE';

{ InterBase Driver Settings... } INTERBASESERVERNAME = '\DRIVERS\INTRBASE\DB OPEN\;SERVER NAME'; INTERBASEUSERNAME = '\DRIVERS\INTRBASE\DB OPEN\;USER NAME'; INTERBASEOPENMODE = '\DRIVERS\INTRBASE\DB OPEN\;OPEN MODE'; INTERBASESCHEMACACHESIZE = '\DRIVERS\INTRBASE\DB OPEN\;SCHEMA CACHE SIZE'; INTERBASELANGDRIVER = '\DRIVERS\INTRBASE\DB OPEN\;LANGDRIVER'; INTERBASESQLQRYMODE = '\DRIVERS\INTRBASE\DB OPEN\;SQLQRYMODE'; INTERBASESQLPASSTHRUMODE = '\DRIVERS\INTRBASE\DB OPEN\;SQLPASSTHRU MODE'; INTERBASESCHEMACACHETIME = '\DRIVERS\INTRBASE\DB OPEN\;SCHEMS CACHE TIME'; INTERBASEMAXROWS = '\DRIVERS\INTRBASE\DB OPEN\;MAX ROWS'; INTERBASEBATCHCOUNT = '\DRIVERS\INTRBASE\DB OPEN\;BATCH COUNT'; INTERBASEENABLESCHEMACACHE = '\DRIVERS\INTRBASE\DB OPEN\;ENABLE SCHEMA CACHE'; INTERBASEENABLEBCD = '\DRIVERS\INTRBASE\DB OPEN\;ENABLE BCD'; INTERBASEBLOBSTOCACHE = '\DRIVERS\INTRBASE\DB OPEN\;BLOBS TO CACHE'; INTERBASEBLOBSIZE = '\DRIVERS\INTRBASE\DB OPEN\;BLOB SIZE'; INTERBASEVERSION = '\DRIVERS\INTRBASE\INIT\;VERSION'; INTERBASETYPE = '\DRIVERS\INTRBASE\INIT\;TYPE'; INTERBASEDLL = '\DRIVERS\INTRBASE\INIT\;DLL'; INTERBASEDRIVERFLAGS = '\DRIVERS\INTRBASE\INIT\;DRIVER FLAGS'; INTERBASEDLL32 = '\DRIVERS\INTRBASE\INIT\;DLL32'; INTERBASETRACEMODE = '\DRIVERS\INTRBASE\INIT\;TRACE MODE';

638

{ Oracle Driver Settings... } ORACLEBATCHCOUNT = '\DRIVERS\ORACLE\DB OPEN\;BATCH COUNT'; ORACLEENABLEBCD = '\DRIVERS\ORACLE\DB OPEN\;ENABLE BCD'; ORACLEENABLEINTEGERS = '\DRIVERS\ORACLE\DB OPEN\;ENABLE INTEGERS'; ORACLEENABLESCHEMACACHE = '\DRIVERS\ORACLE\DB OPEN\;ENABLE SCHEMA CACHE'; ORACLELANGDRIVER = '\DRIVERS\ORACLE\DB OPEN\;LANGDRIVER'; ORACLELISTSYNONYMS = '\DRIVERS\ORACLE\DB OPEN\;LIST SYNONYMS'; ORACLEMAXROWS = '\DRIVERS\ORACLE\DB OPEN\;MAX ROWS'; ORACLENETPROTOCOL = '\DRIVERS\ORACLE\DB OPEN\;NET PROTOCOL'; ORACLEOPENMODE = '\DRIVERS\ORACLE\DB OPEN\;OPENMODE'; ORACLEROWSETSIZE = '\DRIVERS\ORACLE\DB OPEN\;ROWSET SIZE'; ORACLESCHEMACACHEDIR = '\DRIVERS\ORACLE\DB OPEN\;SCHEMA CACHE DIR'; ORACLESCHEMACACHESIZE = '\DRIVERS\ORACLE\DB OPEN\;SCHEMA CACHE SIZE'; ORACLESCHEMACACHETIME = '\DRIVERS\ORACLE\DB OPEN\;SCHEMA CACHE TIME'; ORACLESERVERNAME = '\DRIVERS\ORACLE\DB OPEN\;SERVER NAME'; ORACLESQLPASSTHRUMODE = '\DRIVERS\ORACLE\DB OPEN\;SQLPASSTHRU MODE'; ORACLESQLQUERYMODE = '\DRIVERS\ORACLE\DB OPEN\;SQLQRYMODE'; ORACLEUSERNAME = '\DRIVERS\ORACLE\DB OPEN\;USER NAME'; ORACLEDLL = '\DRIVERS\ORACLE\INIT\;DLL'; ORACLEDLL32 = '\DRIVERS\ORACLE\INIT\;DLL32'; ORACLEDRIVERFLAGS = '\DRIVERS\ORACLE\INIT\;DRIVER FLAGS'; ORACLETRACEMODE = '\DRIVERS\ORACLE\INIT\;TRACE MODE'; ORACLETYPE = '\DRIVERS\ORACLE\INIT\;TYPE'; ORACLEVENDORINIT = '\DRIVERS\ORACLE\INIT\;VENDOR INIT'; 639

ORACLEVERSION = '\DRIVERS\ORACLE\INIT\;VERSION';

{ MSACCESS Driver Settings... } MSACCEESSLANGDRIVER = '\DRIVERS\MSACCESS\DB OPEN\;LANGDRIVER'; MSACCESSDATABASENAME = '\DRIVERS\MSACCESS\DB OPEN\;DATABASE NAME'; MSACCESSUSERNAME = '\DRIVERS\MSACCESS\DB OPEN\;USER NAME'; MSACCESSOPENMODE = '\DRIVERS\MSACCESS\DB OPEN\;OPEN MODE'; MSACCESSSYSTEMDATABASE = '\DRIVERS\MSACCESS\DB OPEN\;SYSTEMDATABASE'; MSACCESSVERSION = '\DRIVERS\MSACCESS\INIT\;VERSION'; MSACCESSTYPE = '\DRIVERS\MSACCESS\INIT\;TYPE'; MSACCESSDLL32 = '\DRIVERS\MSACCESS\INIT\;DLL32'; MSACCESSDRIVERFLAGS = '\DRIVERS\MSACCESS\INIT\;DRIVER FLAGS'; MSACCESSTRACEMODE = '\DRIVERS\MSACCESS\INIT\;TRACE MODE';

{ System Initialization Settings... } AUTOODBC = '\SYSTEM\INIT\;AUTO ODBC'; DATAREPOSITORY = '\SYSTEM\INIT\;DATA REPOSITORY'; DEFAULTDRIVER = '\SYSTEM\INIT\;DEFAULT DRIVER'; LANGDRIVER = '\SYSTEM\INIT\;LANGDRIVER'; LOCALSHARE = '\SYSTEM\INIT\;LOCAL SHARE'; LOWMEMORYUSAGELIMIT = '\SYSTEM\INIT\;LOW MEMORY USAGE LIMIT'; MAXBUFSIZE = '\SYSTEM\INIT\;MAXBUFSIZE'; MAXFILEHANDLES = '\SYSTEM\INIT\;MAXFILEHANDLES'; 640

MEMSIZE = '\SYSTEM\INIT\;MEMSIZE'; MINBUFSIZE = '\SYSTEM\INIT\;MINBUFSIZE'; SHAREDMEMLOCATION = '\SYSTEM\INIT\;SHAREDMEMLOCATION'; SHAREDMEMSIZE = '\SYSTEM\INIT\;SHAREDMEMSIZE'; SQLQRYMODE = '\SYSTEM\INIT\;SQLQRYMODE'; SYSFLAGS = '\SYSTEM\INIT\;SYSFLAGS'; VERSION = '\SYSTEM\INIT\;VERSION';

641

Table bileşeninin OnEditError kısmına aşağıdaki kodu koyarak kullanıcıyı yakalayabilirsin. Var ErrInfo:DBIErrInfo; Bilgi:Array [1..2] Of string; begin DbiGetErrorInfo (False,ErrInfo); If ErrInfo.iError=10241 Then begin SetLength (Bilgi[1],DBIMAXMSGLEN); DbiGetErrorConText (EcTableName, (PChar(Bilgi[1]))); SetLength (Bilgi[1], StrLen(Pchar(Bilgi[1]))); SetLength (Bilgi[2],DBIMAXMSGLEN); DbiGetErrorConText (EcUserName, (PChar(Bilgi[2]))); SetLength (Bilgi[2], StrLen(Pchar(Bilgi[2]))); ShowMessage (Format('Erişim hatası : %s dosyası, %s tarafından kullanılıyor.',[ExtractFileName (Bilgi[1]),Bilgi[2]])); Abort; end; end;

Kayıtlardaki değişikliği tampon bellekte bekletmeden anında yazmak için şu kodu kullanabilirsiniz. Öncelikle Uses satırına BDE'yi ekleyiniz. Procedure TdataModule1.Table3AfterPost(DataSet:TDataSet); Begin DBISaveChanges( (DataSet as TBDEDataSet).Handle); End; Çalışmalarınızda başarılar... delphiMan

19 Ara 2001 22:57

Table1.FlushBuffers; ı kullan fazlasıylaişini görecektir. Tüm Tablolarında CacheUpdade metodunu kullan. yapacağın şunlar: tabloların cacheUpdates'ini True yap ayrıca kayıt yapacağın anda table1.ApplyUpdates; table1.CommitUpdates; yaz applyupdates kaydı yapar CommitUpdates'de kayıt yapılıdıktan sonra Cache belleği boşaltır.

642

SQL Uzerine (Açıklamalı - Örnekli) - 1

0


1.TEK TABLODAN SORGULAMALAR: SELECT * FROM tablo ÖRNEK: Bütün bilgileri personel tablosundan koşulsuz olarak listele. SELECT * FROM personel ÖRNEK: Personel tablosundan SEÇ komutuyla istenen sütun adlarını belirt. SELECT sicil,sosy_g_no,ad,soyad,dog_tar, sicil,sosy_g_no,ad,soyad,dog_tar, adres,cins,brüt,böl_no,yön_s_g_n FROM personel; ÖRNEK: Personel tablosundan istenen sütün başliklarini listele. SELECT sicil,ad,soyad,brüt FROM personel; DISTINCT (Tekrarsız) TANIM: SQL’de tablo içinde birbirinin aynı datalar bulunabilir.Aynı satırların listeleme esnasında bir kez yazılması için Distinct sözcüğünü kullan. ÖRNEK: Par _sat dosyasından sat_no’lar tekrarsız olarak listelenecektir. SELECT DISTINCT sat_no FROM par_sat; 2.TABLO BİLGİLERİNİN SIRALANMIŞ OLARAK LİSTELENMESİ: ORDER BY (Sırasıyla) TANIM:Tablodaki sütunlardan ,belirli bir sütuna göre listelemek için SELECT komutuna , ORDER BY eklenir. ÖRNEK: Personel dosyasından,sicil,ad,soyad,brüt sütunlarını seç ve brüt(maaşa)göre büyükten küçüğe sırala. SELECT sicil,ad,soyad,brüt FROM personel ORDER BY brüt ASC; DESC : Küçükten büyüğe sırala (A-Z) ASC : Büyükten küçüğe sırala (Z-A)

643

DESC yazılmazsa ASC direct kabul edilir (DEFAULT) 3.BİRDEN ÇOK ALANA GÖRE SIRALAMA: TANIM: Bir tablo içinde ,birden fazla sütundan aynı anda sıralamak için kullanılır. ÖRNEK )Personel dosyasından seçilen sütunlarını aynı anda hem ad,hem de otomatik olarak sıralar. SELECT sicil,ad,soyad,brüt FROM personel ORDER BY ad,brüt; ÖRNEK Personel tablosundan seçili sütunları öncelik adda olmak üzere (Z-A) adı bozmadan soyadı (A-Z) sıralı listeler. SELECT sicil,ad,soyad,brüt FROM personel ORDER BY ad ASC,soyad DESC, brüt ASC; veya; SELECT sicil,ad,soyad,brüt FROM personel ORDER BY ad,soyad DESC,brüt; KOŞULA BAGLI OLARAK LISTELEME: WHERE TANIM:Verilen koşulu saglayanlar listelenir.Iki veri birbiriyle karşilaştirilmaktadir. Karşilaştirilan verilerin türü ayni olmalidir. SELECT * FROM personel WHERE brüt > 5000000; KARŞILAŞTIRMA OPERATÖRLERI: OPERATÖR ANLAMI : < ...den daha küçük > ...den daha büyük = Eşit <= Küçük veya eşit >= Büyük veya eşit <> Eşit degil != Eşit degil !< ...den küçük değil !> ...den büyük değil 644

ÇEŞITLI VERI TIPLERI IÇIN BASIT SORGULAMALAR: 1.NÜMERİK VERİ TİPLERİ: ÖRNEK: Maaşi 8000000TL’den fazla olmayan personeli listele. SELECT * FROM personel WHERE brüt <= 8000000; 2.KARAKTER VERİ TİPLERİ (CHAR): Karakter çift veya tek tırnak ile gösterilir. ÖRNEK: Adı Ali olmayan personele ait kayıtları listele. SELECT * FROM personel WHERE ad <> “Ali”; 3.TARİH VERİ TİPİ: Tarih veri tipleri { } sembolleri içinde yazılır. ÖRNEK: Hangi personelin doğum tarihi 1960 yılından daha öncedir? SELECT * FROM personel WHERE dog_tar <={12/31/59}; 4.MANTIKSAL (LOJİK) VERİ TİPİ: Mantıksal veriler için mümkün olabilen sadece iki değer sözkonusudur.DOĞRU D(TRUE T) , YANLIŞ Y (FALSE F) ile simgelenir. ÖRNEK: Personel tablosunda personelin cinsiyetini belirten cins adlı alan mantıksal(logical) olarak tanımlanmıştır.Cinsiyeti erkek olanları D,kadın olanları y ile tanımlarsak erkek olanları listele. SELECT * FROM personel WHERE cins = .T.;

SQL Üzerine (Açıklamlı - Örnekli) - 2

0


4.BİRDEN ÇOK KOŞULA DAYALI SORGULAMALAR: (NOT,AND,OR) TANIM:Mantıksal operatörlerin yardımı ile birden çok koşulun gerçekleştirmesine bağlı olarak ifade edilebilecek (karmaşık yada birleşik 645

koşullu listelemeleri gerçekleştirilmektedir.) AND (VE) ÖRNEK: Maaşı 5000000’dan fazla olan ve cinsiyeti erkek olan personelin listelenmesi istenir yani iki koşul verilmektedir ve ikisininde olmasi istenir. SELECT * FROM personel WHERE brüt >5000000 AND cins =.T.; NOT (DEĞİL) OR (VEYA) ÖRNEKLER: 1.Doğum tarihi 1960’dan önce olan maaşı 6000000 - 10000000 arasındaki bayan personelin listele. SELECT * FROM dog_tar < {01/01/60} AND brüt > = 6000000 AND brüt < =10000000 AND cins = .F.; 2.Satış bölümüyle muhasebe bölümündekiler kimlerdir? (Satış bölümünün böl_no’sunun 1 ve muhasebe bölümünün böl_no’sunun 2 olduğu varsayılmaktadır.) SELECT * FROM personel WHERE bol_no =1 OR bol_no = 2; 3.Bölümü Satış yada Muhasebe olamayan 1960’dan sonra doğmuş bayan personeli listele. 1.YAZILIM: SELECT * FROM personel WHERE NOT (böl_no =1 OR böl_no =2) AND dog_tar > ={01/01/60} AND cins =.F.; 2.YAZILIM: SELECT * FROM personel WHERE böl_no <> 1 AND böl_no <> 2 AND dog_tar > ={01/01/60} AND cins =.F.; BİR VERİ KÜMESİNDE ARAMA -IN OPERATÖRÜ IN (İÇİNDE) 646

“IN” operatörü NOT ile kullanılılabilir. ÖRNEK: Bölümü 1,2,3 olmayan personel kimlerden oluşmaktadir? SELECT * FROM personel WHERE bol_no NOT IN (1,2,3); ÖRNEK: Böl_no’su 1,2 yada 3 olan personeli listele. SELECT * FROM personel WHERE böl_no = 1 OR böl_no= 2 OR böl_no = 3; Bu örneğin IN ile yapılmış şekli daha kısadır. SELECT * FROM personel WHERE NOT böl_no IN (1,2,3); BETWEEN SORGULAMA SÖZCÜĞÜ: BETWEEN (ARASINDA) ÖRNEK: Maaşi 5- 10 milyon arasinda olan personel kimlerdir? SELECT * FROM personel WHERE brüt > =5000000 AND brüt < = 10000000; BETWEEN (ARASINDA) komutu ile daha kısa olacaktır. SELECT * FROM personel WHERE brüt BETWEEN 5000000 AND 10000000; KARAKTER TÜRÜ BİLGİ İÇİNDE ARAMA LIKE SÖZCÜĞÜ: TANIM ÖRNEĞİ: Adres sutunu içerisinde semt bölümüne ait ayrıca bir sutun olmadığını varsayarak semt adı adres sutunu içerisinde yer alır ve buradan da LIKE (BULUNAN) komutuyla adres sutunu içerisinde Taksim semtinde oturan personeli listele. SELECT * FROM personel WHERE adres LIKE ‘% TAKSİM %’ ; 647

Adres LIKE ‘%TAKSİM%’ ifadesi adres içinde her hangi bir yerde TAKSİM yazan yerde oturan personeli listeleyecektir. LIKE sözcüğünü ,alt çizgi (-) sembolü ile birlikte kullanmakta mümkündür. SELECT * FROM personel WHERE ad LIKE ‘Mehmet -----‘; Şekildeki komut ile ad alani “Mehmet “ ile başlayan ve ad alani uzunlugu 10 karakter olan isimlere sahip personeli listeleyecektir.”Mehmet Ali”,”Mehmet Can”- “Mehmetcik” gibi isimler listeleyecektir.Anlaşilacagi gibi - sembolü , tek karakterlik bir bilgiyi temsil etmektedir. 5.SQL’DE ARİTMETİKSEL İFADELER VE FONKSİYONLAR : KÜME FONKSİYONLARI: SUM FONKSİYONU: SUM (TOPLA) Fonksiyonun argümanı olarak belirtilen sütun ile ilişkili olana toplama işlemini gerçekleştirir. ÖRNEK: İşletmedeki personelin brüt maaşlar toplamı ne kadardır? SELECT SUM (brüt) FROM personel; AVG FONKSİYONU: AVG (ORTALA) Aritmetiksel ortalama (average) hesaplamak için kullanılır. SELECT AVG(brüt) FROM personel; MAX FONKSİYONU: MAX (EN ÜST) Tablo içinde ,belirtilen sutun (alan)içindeki en büyük değeri bulur. ÖRNEK: İşletme içindeki en yüksek maaş ne kadardır? SELECT MAX (brüt) FROM personel;

648

MIN FONKSİYONU: MIN (EN ALT) Tablo içinde,belirlenen sutun alan içindeki en küçük değeri bulur. ÖRNEK: İşletme içinde 4 Mayıs 1970’den önce doğanlar için,asgari ücret nedir? SELECT MIN(brüt) FROM personel WHERE dog_tar < {05/04/70}; COUNT FONKSİYONU: COUNT (SAY) Tablo içinde, her hangi bir sayma işlemi gerçekleştirmek için kullanilir. ÖRNEK:Ücreti 6000000’dan olan personel sayısı nedir? SELECT COUNT (*) FROM personel WHERE brüt > 6000000; COUNT (SAY) fonksiyonu DISTINCT (TEKRARSIZ)sözcüğü ile de kullanılır. ÖRNEK: Personel tablosunda mevcut personelin işletme içinde kaç tane farkli bölümde çaliştigini bul. SELECT COUNT(DISTINCT böl_no) FROM personel; COUNT (böl_no)

SQL Üzerine (Açıklamalı - Örnekli) - 3

0


6.GRUPLANDIRARAK İŞLEM YAPMA: GROUP BY (GRUPLA) ÖRNEK: Her bölümdeki ortalama maaş nedir? SELECT böl_no,AVG (brüt) FROM personel GOUP BY böl_no; HAVING: HAVING (SAHİP)

649

Gruplandırarak kümeleme fonksiyonunu uygularken koşulda verilebilir.Bu durumda grup üzerindeki hesaplamalarla ilgili koşul belirtilirken HAVING (SAHİP) sözcüğü kullanılır. ÖRNEK: En yüksek maaşin 9000000’dan fazla oldugu bölümlerdeki personele ait ortalama maaşlari listele. SELECT böl_no,AVG (brüt) FROM personel GROUP BY böl_no HAVING AVG(brüt)> 9000000; HAVING sözcüğü SELECT konusunda GROUP BY bulunmadığı zaman geçersizdir. HAVING sözcüğünü izleyen ifade içinde SUM , COUNT(*) ,AVG, MAX yada MIN fonksiyonlarından en az biri bulunmalıdır. HAVING sözcüğü sadece gruplanmış veriler üzerindeki işlemlerde geçerlidir. WHERE sözcüğü bir tablonun tek tek satırları üzerinde işlem yapan koşullar içinde geçerlidir. Bazı durumlarda HAVING ve WHERE sözcükleri ile birlikte SELECT komutu içinde kullanılabilir. ÖRNEK: Personel tablosu içinde her bölümde erkek personele ait maaşlar için ortalamanin 9000000’dan fazla oldugu bölümleri listele. SELECT böl_no, AVG (brüt) FROM personel WHERE cins= .T. GROUP BY böl_no HAVING AVG (brüt) > 9000000; BİRDEN FAZLA TABLOYU İLİŞKİLENDİRMEK: JOIN (İLİŞKİLENDİR) ÖRNEK: Personel ve bölüm adlı 2 tablo bulunmaktadır. Çalışan her personel ve personelin yöneticisi ile ilişkili bilgiler nelerdir? SELECT * FROM personel,bölüm WHERE personel .böl_no=bölüm.bölüm_no ; ÖRNEK: JOIN (İLİŞKİLENDİR) işleminde arzu edilen(sicil,ad,soyad,böl_no,yön_s_g_n) alanların listele. SELECT sicil,ad,soyad,böl_no,yön_s_g_n FROM personel,bölüm WHERE personel .böl_no = bölüm .bölüm_no; SELF-JOIN: KENDİSİYLE -İLİŞKİLENDİR: TANIM:Bir tablonun kendisi ile birleştirilmesine “KENDISIYLEILIŞKiLENDIR” denir.(SELF-JOIN)

650

SELECT A. sicil , A.ad , A.soyad, B .ad , B.soyad , B.dog_tar FROM personel A , personel B WHERE A. yon_sos_g_n =B .sosy_g_no; NESTED SELECTS: İÇİÇE SEÇİMLER TANIM: İç içe geçmiş SELECT komutlarından oluşur. İçteki Select komutunun bulduğu sonucu dış takı komutumuz işlevini yerine getirmesi için kullanılır. ÖRNEK:Parça numarası 24 olan parçayı ,projelerde kullanan çalışan personeli listele. SELECT * FROM personel WHERE sosy_g_no IN(SELECT per_s_g_no FROM parça,proje,çalışma WHERE pr_no = proj_no AND proj_no =proj_no AND par_no =24); ÖRNEK: Fatih’te oturan personelin çalıştığı projelerin adlarını ve yerlerini listele. SELECT proj_ad,yer FROM proje WHERE proj_no IN (SELECT proje_no FROM personel,çalışma WHERE sosy_g_no = per_s_g_no AND adres LIKE “% fatih %”); UNION SÖZCÜĞÜ: UNION (BİRLEŞİM) TANIM: İki ayrı SEÇ komutunun sonucunda elde edilen tabloların birleşimi işlemini gerçekleştirir. ÖRNEK: Adı Ahmet ve Soyadı Caner olan kişi yada kişileri işletmenin yürüttüğü projelerde çalışan bir kişi (sıradan bir personel yada bölüm yöneticisi)olarak bulunduran projelerin isimlerini ve projelerin yürütüldü ğü yerleri listele. (SELECT proj_ad,yer FROM proj,bölüm,personel WHERE bl_no=bölüm_no AND y_sos gno = sosy_g_no 651

AND ad =”Ahmet”AND soyad =”Caner”) UNION (SELECT proj_ad,yer FROM proje,çalışma,personel WHERE proj_no = proje_no AND Per_s_g_no = sosy_g_no AND ad =”Ahmet” AND soyad =”Caner”) KOŞULLAR: UNION (BİRLEŞİM) sözcüğü ile ,iki yada daha çok kişi SELECT ’in sonucu olan tabloların küme birleşimi işlemine tabi tutulması için 2 koşul gereklidir. 1) SELECT komutları sonucunda elde edilecek tablolar aynı sayıda kolon içermelidirler. 2)Sonuç tabloları karşılıklı olarak kolonların aynı veri tipi ve aynı genişlikte olmalıdır. ANY : ANY (HER HANGİ BİRİ) ÖRNEK:Satış bölümünde çalışan personelin her hangi birinden daha düşük maaş alan ve mühendislik bölümündeki kişileri listele. SELECT * FROM personel WHERE brüt < ANY (SELECT brüt FROM personel WHERE böl_no = 2) AND böl_no =1; Aynı ifade aşağıdaki gibi yazılabilir: SELECT * FROM personel WHERE brüt < (SELECT MAX (brüt ) FROM personel WHERE böl_no = 2) AND böl_no =1; ALL (HEPSİ) ÖRNEK: Satış bölümünde çalışan ve mühendislik bölümündeki personelin hepsinden daha fazla maaş alan personeli listele.Bu örnekte satış bölümü kodu = 2 ve mühendislik bölümü kodu = 1 alınmıştır. YAPILIŞ YOLU: 1) SELECT * FROM personel WHERE brüt > ALL (SELECT brüt FROM personel 652

WHERE böl_no = 1) AND böl_no = 2;

2) SELECT * FROM personel WHERE brüt > (SELECT MAX (brüt) FROM personel WHERE böl_no = 1) AND böl_no =2; EXISTS (MEVCUT) VE ,VEYA ,DEĞİL operatörleri ile kullanılabilir. ÖRNEK: 27 no’lu parçayı satan satıcılarla ilişkili tüm bilgileri listele. SELECT * FROM satıcı WHERE EXISTS (SELECT * FROM par_sat WHERE sat_no = satıcı_n AND parça_n =27); NOT EXISTS (MEVCUT DEĞİL) VE ,VEYA ,DEĞİL operatörleri ile kullanılabilir. ÖRNEK: 27 no’lu parçayı satmayan satıcılar kimlerdir? SELECT * FROM satıcı WHERE NOT EXISTS (SELECT * FROM par_sat WHERE sat_no = satıcı_n AND parça_n =27); EXCEPT (FARKLI) Tablo-1 - Tablo-2 işlemi sonuç(iki kümenin farki) elde edilecek tabloda,Tablo-1’de bulunup, Tablo-2’de bulunmayan veriler mevcut olacaktir. ÖRNEK:Satış bölümündeki personel adlarından,mühendislik bölümünde bulunmayanları listele. 653

SELECT * FROM (SELECT ad FROM personel WHERE bol_no=1 EXCEPT SELECT ad FROM personel WHERE bol_no =2); INTERSECT (KESİŞİM) ÖRNEK: Hem Ankara’da,hem de İstanbul’daki projelerde görev alan bölümleri listele. SELECT * FROM (SELECT bl_no FROM proje WHERE yer LIKE “%Ankara%” INTERSECT SELECT bl_no FROM proje WHERE yer LIKE “%İstanbul%”); SAVE TO TEMP (SAKLA) ÖRNEK: Bayan personeli,bayan adlı bir tablo içinde sakla. SELECT * FROM personel WHERE cins =.F. SAVE TO TEMP bayan; KEEP: KEEP (KALICI) ÖRNEK: SELECT * FROM personel WHERE cins = .F. SAVE TO TEMP bayan KEEP;

SQL Üzerine (Açıklamalı - Örnekli) - 4

0


7.TABLOLARDA DEĞİŞİKLİK YAPMAK: INSERT (EKLE) INTO (İÇİNE)

654

VALUES (DEĞERLER) ÖRNEK: Bir personel tablosuna sicil_no’su 275 olan personel ile ilişkili bilgileri ekle. INSERT INTO personel(sicil, sosy_g_no,ad,soyad,doğ_tar adres,cins,brüt,böl_no,yön_s_g_no VALUES(‘275’,’27652418’,’Ali’,’Caner’, {10/05/1962},’Merkez caddesi 46 -Fatih-İstanbul’, .T.,27000000,2,’876215342’); DELETE (SİL) ÖRNEK: 2 no’lu bölümdeki personelin tümü tablodan sil. DELETE FROM personel WHERE böl_no = 2; 5 ROWS DELETED 5 SATIR SİLİNDİ ÖRNEK:Brüt maaş alani boş olmayan tüm personeli sil. DELETE FROM personel WHERE brüt IS NOT NULL; 25 ROWS DELETED 25 SATIR SİLİNDİ UPDATE (GÜNCELLE) SET (YAP) ÖRNEK:2’inci bölümün yürüttüğü projelerde kullanılan tüm parçaların fiyatlarını % 7 zam yap. UPDATE parça SET fiyat = fiyat *1,07 WHERE pr_no IN (SELECT proj_no FROM proje WHERE bl_no = 2; CREATE INDEX (INDEKS YARAT ) ON (Hangi Tablo İçin) CREATE INDEX ındeks adı ON tablo adı(kolon adı 1,kolon adı 2,.,.kolon adı n); 655

TEK BİR ALANA GÖRE ARTAN SIRADA İNDEKSLEME : ÖRNEK:İşletmede çalışan personeli brüt maaşlarına göre artan sırada listele.(Brüt alana göre bir indeks oluşturmalıyız) CREATE INDEX pers_maas ON personel(brüt); INDEX CREATED 127 ROWS İNDEKS YARATILDI 127 SATIR 127 satırlık personel tablosu ile ilişkili olarak brüt kolonu indeks anahtarı olarak kullanan pers_maas adlı indeks oluşturulmuştur.Bu durumda; SELECT * FROM personel; _Şeklinde listeleme komutu sonucunda personel tablosundaki tüm personel, brüt maaşlarina göre sirali olarak listelenecektir. TEK BİR ALANA GÖRE AZALAN SIRADA İNDEKSLEME : DESC Küçükten büyüğe (K-B) ÖRNEK:İşletmede çalışan personeli brüt maaşlarına göre azalan sırada (yüksek maaştan düşük maaşa doğru)listelemek istersek ,brüt alanına göre aşağıdaki şekilde oluşturmak gerekir. CREATE INDEX ON personel (brüt DESC); BİRDEN FAZLA ALANA GÖRE İNDEKSLEME : ÖRNEK:İşletmedeki personelin öncelikle adlarına göre,aynı adda olanların soyadlarına göre ,hem adı hemde soyadı aynı olanların maaşlarına göre sıralanmış olarak listele. CREATE INDEX p_ad_soy_m ON personel (ad,soyad,brüt); Bu durumda; SELECT * FROM personel;

UNIQUE (TEK) Bir tablo,seçilen bir sutüna (alana) göre indekslenirken , indeksleme alanı olarak seçilen sutündaki verilerintekrarlanmasına müsaade edilmesi istenmiyorsa,indeksleme yapılırken ,CREATE ,INDEX komutu iinde UNİQUE sözcüğü kullanılmalıdır. 656

CREATE UNIQUE INDEX pers_sicil ON personel (sicil); EKLEME İÇİN: Personel tablosuna INSERT INTO Personel VALUES(53768 ,’27241685’,’ayşe’, ‘şen’{01/04/63},’Merkez cad. 82 Kadıköy’.F. ,27000000 ,2, ‘34261578’); MEVCUT BİR İNDEKSİN SİLİNMESİ: DROP IPTAL DROP INDEX pers_in; Komutu ile INDEX DROPPED (İNDEKS SİLİNDİ) TABLONUN YAPISINDA DEĞİŞİKLİK YAPMAK: ALTER TABLE (TABLO DEĞİŞTİR) MEVCUT BİR TABLOYA KOLON EKLEMEK: ADD (EKLE) ALTER TABLE (TABLO DEĞİŞTİR) komutu içinde ADD (EKLE) ile satır ekle. ÖRNEK:Personel tablosuna ,işe başlama tarihini belirten bir kolon ekle ALTER TABLE personel ADD iş_baş_tar DATE; ADD (EKLE)iş_baş_tar DATE NOT NULL (TARIH DEGERSIZ) bu şekilde kullanilsaydi bu kolon satiri gene boş kalirdi ; fakat bu kolon ile ilişkili yeni boş degerler eklemek istendiginde buna müsaade edilmeyecekti. MEVCUT BİR TABLONUN ALANLARINDA DEĞİŞİKLİK YAPMAK : MODIFY KOMUTU: MODIFY (DEĞİŞTİR) MEVCUT BİR TABLODAN BİR KOLON SİLMEK: DROP KOMUTU : DROP (İPTAL) 657

ÖRNEK:Personel tablosundan iş_baş_tar kolonunu sil. ALTER TABLE personel DROP iş_baş_tar ; Birden fazla kolonda silinebilir.Birden fazla kolon silmek için virgülle ayrılarak silinir. BİR TABLONUN ADINI DEĞİŞTİRMEK: RENAME KOMUTU: RENAME (TABLO YENİ AD) ALTER TABLE personel personel Tablosunda değişiklik yap RENAME TABLE elemanlar; elemanlar tablosunun adını değiştir MEVCUT BİR TABLONUN BİR KOLONUNUN ADININ DEĞİŞTİRİLMESİ: RENAME: RENAME YENİ AD ALTER TABLE personel RENAME brüt br-maaş; MEVCUT BİR TABLONUN TÜMÜYLE SİLİNMESİ DROP TABLE (TABLO İPTAL) ÖRNEK:Proje tablosunu sil. DROP TABLE proje; VERİ GÜVENLİĞİ: CREATE VIEW GÖRÜŞ ALANI YARAT ÖRNEK:Personel adlı temel tablodan persview adlı bir view oluştur. CREATE VIEW perswiew AS SELECT sicil,sos_g_no,ad,soyad,doğ_tar, adres,cins,böl_no,yon_s_g_no FROM personel; VERİ BÜTÜNLÜĞÜNÜN SAĞLANMASI: WITH CHECK OPTİON KONTROLLÜ CREATE VIEW UST_PER_ VIEW 'Önce bir vıew oluşturulsun 658

AS SELECT FROM personel WHERE brüt >25000000 WITH CHECK OPTION; Burada, maaşi 25000000’ün üzerinde olan personelden oluşan bir UST_PER_VIEW adli view oluşturulmuştur.Bu view’a brüt maaşi 13000000 olan bir personel eklemek istedigi zaman hata mesaji verecektir. CHECK opsiyonu kullanılmasaydı hata mesajı alınmadan bu veri VİEW içine yükleyecekti. EKLEME INSERT INTO UST_PER_VIEW VALUES (27521 ,’27865427’,’ayşe’, ‘okan’ ,{01/05/1962}’Cumh. Cad. 46 - Taksim’, .F.,13000000 ,1 ,’27651112’); VIEW İÇİNDE SATIR SİLME: ÖRNEK:UST_PER_VIEW içinden,maaşi 2500000’den az olan kişileri sil. DELETE FROM UST_PER_VIEW WHERE brüt < 25000000; VIEW SATIRLARI ÜZERİNDE GÜNCELLEME : ÖRNEK: UST_PER_VIEW adlı view’de sicili 27251 olan kişnin maaşını 37000000 olarak değiştir. UPDATE UST_PER_VIEW SET brüt = 37000000 WHERE sicil = 27251; BİR VIEW’U SİLMEK: DROP VIEW (GÖRÜŞ ALANI IPTALI) DROP VIEW UST_PER_VIEW; GÖRÜŞ ALANI IPTALI UST_PER_VIEW;

SQL Üzerine (Örnekler)

1

8 Tem 2002 05:01 mfo

"Select * From Employees" Employees tablosundan tüm alanlari seç. En basit SQL sorgusu budur. -------------------------------------------------------------------------------------------------------"Select * From Title Where [Year Published] < 1889" 659

Title tablosundan [Year Published] alani degeri 1889'dan küçük olan tüm kayitlari seç. Not: * isareti tüm alanlarin seçilecegini gösterir. [ ] "Köseli ayraç ise alan adi bir kelimeden fazla ise kullanilmalidir. Yani yukaridaki alan adi sadece "Year" olsaydi köseli ayraç kullanmaya gerek kalmayacakti. -------------------------------------------------------------------------------------------------------"Delete From Titles Where [Year Published] < #1/1/1889#" Titles tablosundan [Year Published] alani degeri 1/1/1889'dan küçük olanlarin tümünü sil -------------------------------------------------------------------------------------------------------"Select Name, Picture From Authors Where Date_of_Birth = #2/1/1947#" Authors tablosundan Date_of_Birth = 2/1/1947 denkligi olan kayitlardan Name ve Picturealanlarini seçDikkat ederseniz tüm sorgularda sabit bir SELECT ... WHERE .... yapisi var. Select seçimin nereden yapilacagini Where ise eslesme kriterlerini göstermektedir.Bu örnekte * isareti kullanilmamis ve sadece iki alan seçilmistir: "name" ve "picture"Tarih ifadeleri ise # isaretleri arasinda yazilmalidir. -------------------------------------------------------------------------------------------------------"Select [First Name], [Last Name] From Employees" Employees tablosundan sadece First Name ve Last Name alanlarini seç -------------------------------------------------------------------------------------------------------"Select Employees, Department, SupvName From Supervisors, Employees Where Employees.Department = Supervisors.Department" Bu biraz daha karisik. Burada iki tablo var: Supervisors ve Employees. Bu iki tablodan üç adet alan seçilecek: 1.Employees, 2.Department, 3.SupvName. Bu iki tabloda da Department adli birer alan var. Iste bu alanlarin denkligi ile seçim yapiliyor. Yani Employees tablosunun Department alani ile Supervisor tablosunun Department alani esit ise seçim yapiliyor. -------------------------------------------------------------------------------------------------------"Select Distinct [Last Name] From Employees" Employees tablosundan Last Name degeri ayni olan kayitlardan sadece birini al. Distinct anahtari birden fazla ayni deger var ise sadece ilkini alir. -------------------------------------------------------------------------------------------------------"Select [Last Name], Salary From Employees Where Salary > 2100" Salary degeri 2100'den küçük olan Employees tablosu kayitlarindan yalnizca Last Name alanlarini seç. -------------------------------------------------------------------------------------------------------"Select * From Orders Where [Shipped Date] = #5/12/93#" Orders tablosundan Shipped Date degeri 5/12/93'e esit olan kayitlarin tüm alanlarini seç. -------------------------------------------------------------------------------------------------------"Select [Product Name], Sum ([Units in Stock]) From Products Group By [Product Name]"

660

Products tablosundan Product Name ve Unit in Stocks alanlarini al. Ancak burada dikkat edilmesi gereken Sum( ) fonksiyonudur. Bu fonksiyon her alan degerini birbiri üzerine toplar. Seçilen alanlarin tabloya yerlestirilmesi ise Product Name alan degerinin alfabetik sirasina göre A-Z olarak yapilir. -------------------------------------------------------------------------------------------------------"Select * From Employees Order By [Last Name], Asc" Employees tablosundaki tüm alanlari Last Name alan degerine göre Z-A siralamasina göre seç Yani tablodan tüm kayitlar alinacaktir, çünkü kriter olarak kullanilan WHERE sözcügü yoktur. Ancak alinan tüm kayitlar Last Name alan degerinin Z-A alfabetik sirasina göre (ters sira) siralanir. Soyadi Zahit olan kisi soyadi Orhun olan kisiden önce gösterilir. Sorgunun sonunda kullanilan ASC anahtari seçimliktir (optional). Herhangi bir sey yazilmazsa, bu anahtar degerinin DESC (A-Z) oldugu kabul edilir. -------------------------------------------------------------------------------------------------------"Select [Last Name], Salary From Employees Order By Salary, Desc, [Last Name] Veritabanindan alinan kayitlarin listelemesi islemi burada iki kritere göre yapilmakta. Önce kisilerin maaslari (Salary), sonra da soyadlari (Last Name) dikkate alinmakta. Söyle düsünün; Bir sirkette ayni maasi alan 3 kisi var. Bu kisilerin soyadlari Akin, Bahçe ve Celep olsun...Bu sorgu sonucu sirkette çalisan herkes listelenecektir. Ancak bizim bu üç kisi pespese listelenecek ve siralama Akin-Bahçe-Celep seklinde olacaktir. Asagidaki örnege bakiniz: Last Name Salary Filiz 300.000.000 Kara 275.000.000 Akin 250.000.000 Bahçe 250.000.000 Celep 250.000.000

661

Paradox ve dBASE tabloları için BDE ağ tanımları

11

8 Ağu 2002 09:08 mcuyan

Çok Sorulduğu için bi makale yazmak gereği duydum. Paradox ve Dbase tablolarını ağda çalıştırabilmek için Aşağıdaki BDE ayarlarını Kullanın. ANA MAKİNA AYARLARI Ana Makina Adı: Server Disk paylaşım adı : C Paradox veya dBASE tablolarının bulunduğu Klasör c:\Prog\Data PDOXUSRS.NET dosyasının yeri: c:\ Ana Makina BDE Ayarları: DataBAse sekmesi: Alias: MyProg Path : c:\Prog\Data Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: C:\ (PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Configuration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE TERMİNAL MAKİNA BDE AYARLARI: DataBAse sekmesi: Alias: MyProg Path : \\Server\Prog\Data Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: \\Server\c (Ana makinadaki PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Congiguration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE Yukarda anlatılan ayarlaın dışında şayet terminalden ana makina için bir ağ yolu tanımlamışsanız terminal ayarları aşağıdaki gibi de olabilir. Ana makinanın diskine F diye bir ağ yolu tanımladıysak ayarlar şu şekilde olacaktır. DataBAse sekmesi: Alias: MyProg Path : F:\Prog\Data

662

Congiguration->Drivers->Native->PARADOX (veya dBASE) sekmesi: NET DIR: F:\ (Ana makinadaki PDOXUSRS.NET dosyasını gösterecek) LANGDRIVER: paradox "turk" Congiguration->System->INIT sekmesi: LANGDRIVER: paradox "turk" LOCALSHARE: TRUE Ancak bu tanımda dikkat edilmesi gereken şey F ağ yolu koptuğunda program çalışmayacaktır. .exe dosyanızı terminalden istediğiniz klasörden çalıştırabilirsiniz. Kolay gelsin.......... http://community.borland.com/article/0,1410,15247,00.html

Borland Developer Network Home > Delphi & Kylix

BDE setup for Peer-To-Peer(Non-Dedicated) Networks - by Borland Developer Support Staff Technical Information Database TI247B.txt BDE setup for Peer-To-Peer(Non-Dedicated) Networks Category :General Programming Platform :All Product :BDE 3.0 Description: Using a BDE32 Application on a Peer-To-Peer Network --------------------------------------------------A Peer-To-Peer network (a network where each machine acts as a client and a server) can be one of the following, including other network platforms that are compatible with these: 1) Windows 95 2) Windows NT 3) Lantastic 4) Netware Lite The BDE automatically detects when tables reside on a network drive, but it cannot detect whether the tables are on a dedicated server or a server/client. Dedicated servers notify client applications that a file has been modified or locked. This functionality is not present in Peer-To-Peer (non-dedicated) networks. To achieve this 663

functionality with Peer-To-Peer networks set "LOCAL SHARE" to TRUE in the BDE Configuration Utility on the System page. This must be done on all BDE clients that access the tables on networks listed above. This is not necessary for Novell File Server type networks. If the tables that are being used are Paradox, there must also be a directory used for network control. This directory must also reside on the network for all client applications to use. It is good practice to have a separate directory for the application, network, and tables. The following is an example: (Shared Directory) | |--- (Tables Directory) |--- (EXE Directory) |--- (Network Directory) There are two different BDE environments that must also be considered: 1) Using only BDE 32Bit applications. 2) Using BDE 32Bit applications along with BDE 16Bit applications. Setup for 32Bit Only Applications --------------------------------The 32Bit BDE fully supports the UNC naming convention along with long file names. It is recommended that the UNC convention is used for all BDE network connections. UNC removes the need for mapped drives. This will allow access to the tables and network directory without the user being mapped to the drive. UNC has the following syntax: \\(server name)\(share name)\(path)+(file name) Here is a simple example of a standard BDE alias using UNC: Alias: MyUNCAlias Type: STANDARD Path: \\FooServer\FooShare\Sharedir\Tables Default Driver: Paradox The network directory can be setup in the same fashion: Drivers: Paradox Net Dir: \\FooServer\FooShare\Sharedir\NetDir The network directory can be set at runtime using session.netfiledir (Delphi) or DbiSetProp (C++ / Delphi) 664

If for some reason UNC cannot be used with the 32Bit application, follow directions for using BDE 32Bit and 16Bit applications. Setup for 16Bit and 32Bit BDE Applications -----------------------------------------Since the 16Bit Windows API does not support UNC, neither does the 16Bit BDE. To allow applications to share the tables, all clients must be mapped to the same directory on the server. If the server is also used as a client, all other clients must be mapped to the root of the drive. Drive letters from client to client do not have to be identical. Here are some examples of what will and will not work: Client1: Path: X:\ShareDir\Tables Client2: Path: X:\ShareDir\Tables This is OK Client1: Path: Client2: Path: This is

(Also the machine with the tables): C:\ShareDir\Tables X:\ShareDir\Tables OK

Client1: (Also the machine with the tables): Path: C:\ShareDir\Tables Client2: Path: X:\ShareDir\Tables Client3: Path: R:\ShareDir\Tables This is OK Client1: Path: X:\ShareDir\Tables Client2: Path: X:\Tables (Where X:\Tables is actually X:\ShareDir\Tables, but shared on the ShareDir directory) This will not work. The BDE must be able to make the same entry into the Network Control file. In Summary (setup for Peer-To-Peer networks): --------------------------------------------16 and / or 32Bit Applications: 1) Turn "LOCAL SHARE" to TRUE in the BDE Configuration Utility. 2) Do not use the UNC naming convention. 3) Do not use tables with long file names. 665

4) Make sure that all clients are mapped to the same directory on the server. 32Bit Only Applications: 1) Turn "LOCAL SHARE" to TRUE in the BDE Configuration Utility 2) Use the UNC naming convention to achieve a path to the network directory and table directory. If the above steps are not followed, users could be locked out of the tables getting error: "Directory is controlled by other .NET file." "File: (Path1) PDOXUSRS.LCK" "Directory: (Path2)" OR "Multiple .NET files in use." "File: (Path) PDOXUSRS.LCK" Reference: 7/15/98 3:24:23 PM

666

THe key is part of a set that will be processed by the OS, not by your application. MS has two strategies for such keys. The first is to hand the key to the application and do the default processing for it in the default window proc that is supposed to get all messages not handled in application code. The second is to handle the key on a lower level (between keyboard driver and message queue, or in the keyboard driver), which means the application never sees it. Keys in the first category you would see, at least if you look for them in Application.OnMessage, since the active control normally does not want to see all keys. Keys in the second category you never see, not even in a message hook. VK_SNAPSHOT seems to fall into the second category, it does not turn up in Application.OnMEssage. There is a way to get notified of it, however: make it a hotkey for your application. Example: Using PrintScr to print a form type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; Label2: TLabel; private { Private declarations } procedure wmHotkey( Var msg: TWMHotkey ); message WM_HOTKEY; procedure WMActivate( Var msg: TWMActivate ); message WM_ACTIVATE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure tform1.wmHotkey( Var msg: TWMHotkey ); begin if msg.HotKey = IDHOT_SNAPWINDOW Then label1.caption := 'PrintScr pressed'; // would print form from here end; procedure TForm1.WMActivate( Var msg: TWMActivate ); begin If msg.Active <> WA_INACTIVE Then RegisterHotkey( Handle, IDHOT_SNAPWINDOW, 0, VK_SNAPSHOT ) 667

Else begin UnRegisterHotkey( Handle, IDHOT_SNAPWINDOW ); label1.caption := ''; end; inherited; end; --

668

JPEG Header Format Strictly speaking, JPEG files do not have formal headers, but fg_jpeghead() and fgi_jpeghead() return relevant information from the file's start of frame segment. We call it a header for consistency with other image file formats. offset

size

description

0

2

JPEG SOI marker (FFD8 hex)

2

2

image width in pixels

4

2

image height in pixels

6

1

number of components (1 = grayscale, 3 = RGB)

7

1

horizontal/vertical sampling factors for component 1

8

1

sampling factors for component 2 (if RGB)

9

1

sampling factors for component 3 (if RGB)

669

Brought to you by JPEG HEADER Before the image data is ever loaded when a JPEG image is selected for viewing the markers must be read. In a JPEG image, the very first marker is the SOI, or Start Of Image, marker. This is the first "hey, I'm a JPEG" declaration by the file. The JPEG standard, as written by the Joint Picture Expert's Group, specified the JPEG interchange format. This format had several shortcomings for which the JFIF (JPEG File Interchange Format) was an attempted remedy. The JFIF is the format used by almost all JPEG file readers/writers. It tells the image readers, "Hey, I'm a JPEG that almost anyone can understand." Most markers will have additional information following them. When this is the case, the marker and its associated information is referred to as a "header." In a header the marker is immediately followed by two bytes that indicate the length of the information, in bytes, that the header contains. The two bytes that indicate the length are always included in that count. A marker is prefixed by FF (hexadecimal). The marker/header information that follows does not specify all known markers, just the essential ones for baseline JPEG. A component is a specific color channel in an image. For instance, an RGB image contains three components; Red, Green, and Blue. © 1998 by James R. Weeks

Start of Image (SOI) marker -- two bytes (FFD8) JFIF marker (FFE0) length -- two bytes identifier -- five bytes: 4A, 46, 49, 46, 00 (the ASCII code equivalent of a zero terminated "JFIF" string) version -- two bytes: often 01, 02 the most significant byte is used for major revisions the least significant byte for minor revisions units -- one byte: Units for the X and Y densities 0 => no units, X and Y specify the pixel aspect ratio 1 => X and Y are dots per inch 2 => X and Y are dots per cm Xdensity -- two bytes Ydensity -- two bytes Xthumbnail -- one byte: 0 = no thumbnail Ythumbnail -- one byte: 0 = no thumbnail (RGB)n -- 3n bytes: packed (24-bit) RGB values for the thumbnail pixels, n = Xthumbnail * Ythumbnail Define Quantization table marker (FFDB)

670

the first two bytes, the length, after the marker indicate the number of bytes, including the two length bytes, that this header contains until the length is exhausted (loads two quantization tables for baseline JPEG) the precision and the quantization table index -- one byte: precision is specified by the higher four bits and index is specified by the lower four bits precision in this case is either 0 or 1 and indicates the precision of the quantized values; 8-bit (baseline) for 0 and up to 16-bit for 1 the quantization values -- 64 bytes the quantization tables are stored in zigzag format Define Huffman table marker (FFC4) the first two bytes, the length, after the marker indicate the number of bytes, including the two length bytes, that this header contains until length is exhausted (usually four Huffman tables) index -- one byte: if >15 (i.e. 0x10 or more) then an AC table, otherwise a DC table bits -- 16 bytes Huffman values -- # of bytes = the sum of the previous 16 bytes Start of frame marker (FFC0) the first two bytes, the length, after the marker indicate the number of bytes, including the two length bytes, that this header contains P -- one byte: sample precision in bits (usually 8, for baseline JPEG) Y -- two bytes X -- two bytes Nf -- one byte: the number of components in the image 3 for color baseline JPEG images 1 for grayscale baseline JPEG images Nf times: Component ID -- one byte H and V sampling factors -- one byte: H is first four bits and V is second four bits Quantization table number-- one byte The H and V sampling factors dictate the final size of the component they are associated with. For instance, the color space defaults to YCbCr and the H and V sampling factors for each component, Y, Cb, and Cr, default to 2, 1, and 1, respectively (2 for both H and V of the Y component, etc.) in the Jpeg-6a library by the Independent Jpeg Group. While this does mean that the Y component will be twice the size of the other two components--giving it a higher resolution, the lower resolution components are quartered in size during compression in order to achieve this difference. Thus, the Cb and Cr components must be quadrupled in size during decompression. Start of Scan marker (FFDA) the first two bytes, the length, after the marker indicate the number of bytes, including the two length bytes, that this header contains Number of components, n -- one byte: the number of components in this scan 671

n times: Component ID -- one byte DC and AC table numbers -- one byte: DC # is first four bits and AC # is last four bits Ss -- one byte Se -- one byte Ah and Al -- one byte Comment marker (FFFE) the first two bytes, the length, after the marker indicate the number of bytes, including the two length bytes, that this header contains whatever the user wants End of Image (EOI) marker (FFD9) the very last marker

This page has been viewed

times.

672

I'm trying to write a DLL, and export the function so that I can use it with > the rundll32 command, which should allow me to run the function in the dll > by using rundll32. library Run32Test; uses Windows; procedure Test(Wnd: HWND; Instance: HINST; CmdLine: PChar; CmdShow: Integer); stdcall; begin MessageBox(Wnd, CmdLine, 'Run32Test', MB_OK); end; exports Test; begin end. Usage: C:\Projects\Dummy\Run32Test>rundll32 run32test.dll,Test Hello world Note that there must be no space after the comma, and that the method name is case sensitive.

673

unit main; interface uses Windows,ActiveX,ComObj,ShlObj,Classes,Graphics; type TContextMenu = class(TComObject,IShellExtInit,IContextMenu) private FFileName : array[0..MAX_PATH] of Char; FMenuIndex : UINT; FDataObject : IDataObject; FBitmap, FICON : TBitmap; protected function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult; stdcall; function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall; function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall; function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall; end; const Class_ContextMenu: TGUID = '{19741013-C829-11D1-8233-0020AF3E97A9}'; var FileList:TStringList; Buffer:array[1..1024]of char; implementation uses ComServ, SysUtils, ShellApi, Registry; function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject; hKeyProgID: HKEY): HResult; var StgMedium: TStgMedium; FormatEtc: TFormatEtc; FileNumber,i:Integer; begin if (lpdobj = nil) then begin Result := E_INVALIDARG; Exit; end; FDataObject := lpdobj; if FBitmap=nil then begin FBitmap := TBitmap.Create; FBitmap.Width := 50; FBitmap.Height:= 60; FBitmap.Canvas.FillRect(Rect(0, 0, 50, 60)); FBitmap.Canvas.LineTo(50, 60); end; 674

if FICON=nil then begin FICON := TBitmap.Create; FICON.LoadFromResourceName(HInstance, 'LIGHT'); end; FileList:=TStringList.Create; FileList.Clear; with FormatEtc do begin cfFormat := CF_HDROP; ptd := nil; dwAspect := DVASPECT_CONTENT; lindex := -1; tymed := TYMED_HGLOBAL; end; Result := lpdobj.GetData(FormatEtc, StgMedium); if Failed(Result) then Exit; FileNumber := DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0); for i:=0 to FileNumber-1 do begin DragQueryFile(StgMedium.hGlobal, i, FFileName, SizeOf(FFileName)); FileList.Add(FFileName); Result := NOERROR; end; ReleaseStgMedium(StgMedium); end; function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; var MenuText1, MenuText2, MenuText3, MenuText4: string; PopupMenu : HMenu; idCmd : Cardinal; begin Result := NOERROR; if ((uFlags and $0000000F)=CMF_NORMAL) then begin MenuText1 := '&New menuitem 1, Normal File'; MenuText2 := '&New menuitem 2, Normal File'; MenuText3 := '&New menuitem 3, Normal File'; MenuText4 := '&New menuitem 4, Normal File'; end else if (uFlags and CMF_VERBSONLY) <> 0 then begin MenuText1 := '&New menuitem 1, Shortcut File'; MenuText2 := '&New menuitem 2, Shortcut File'; MenuText3 := '&New menuitem 3, Shortcut File'; MenuText4 := '&New menuitem 4, Shortcut File'; end else if (uFlags and CMF_EXPLORE) <> 0 then begin MenuText1 := '&New menuitem 1, File right click in Explorer'; MenuText2 := '&New menuitem 2, File right click in Explorer'; MenuText3 := '&New menuitem 3, File right click in Explorer'; MenuText4 := '&New menuitem 4, File right click in Explorer'; 675

end else if (uFlags and CMF_DEFAULTONLY) <> 0 then begin exit; end else exit; FMenuIndex:=indexMenu; idCmd := idCmdFirst; PopupMenu := CreatePopupMenu; InsertMenu(Menu,indexMenu,MF_SEPARATOR or MF_BYPOSITION,0,Pointer(0)); Inc(IndexMenu); InsertMenu(Menu,indexMenu,MF_STRING or MF_BYPOSITION or MF_POPUP,PopupMenu,PChar(MenuText1)); SetMenuItemBitmaps(Menu,indexMenu,MF_BYPOSITION,FICON.Handle,FICON.Handl e); Inc(IndexMenu); InsertMenu(PopupMenu,0,MF_STRING or MF_BYPOSITION,idCmd,PChar('SubMenu Item 1')); SetMenuItemBitmaps(PopupMenu,0,MF_BYPOSITION,FICON.Handle,FICON.Handle); Inc(idCmd); InsertMenu(PopupMenu,1,MF_STRING or MF_BYPOSITION,idCmd,PChar('SubMenu Item 2')); SetMenuItemBitmaps(PopupMenu,1,MF_BYPOSITION,FICON.Handle,FICON.Handle); Inc(idCmd); InsertMenu(Menu,indexMenu,MF_STRING or MF_BYPOSITION,idCmd,PChar(MenuText2)); Inc(IndexMenu);Inc(idCmd); InsertMenu(Menu,indexMenu,MF_STRING or MF_BYPOSITION,idCmd,PChar(MenuText3)); Inc(IndexMenu);Inc(idCmd); InsertMenu(Menu,indexMenu,MF_BITMAP or MF_BYPOSITION,idCmd,PChar(FBitmap.Handle)); Inc(IndexMenu);Inc(idCmd); InsertMenu(Menu,indexMenu,MF_SEPARATOR or MF_BYPOSITION,0,Pointer(0)); Result := idCmd - idCmdFirst; end; function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; var idCmd: cardinal; i:Integer; FileListStr : string; begin Result := E_INVALIDARG; if (HiWord(Integer(lpici.lpVerb)) <> 0) then begin Result := E_FAIL; Exit; end; //if HIWORD(lpcmi->lpVerb)£¬ then we have been called programmatically //and lpVerb is a command that should be invoked. Otherwise, the shell 676

//has called us, and LOWORD(lpcmi->lpVerb) is the menu ID the user has //selected. Actually, it's (menu ID - idCmdFirst) from QueryContextMenu(). idCmd := LoWord(Integer(lpici.lpVerb)); FileListStr := 'Invoke menu item '+IntToStr(idCmd) + ' , '+IntToStr(FileList.Count)+' files selected' + #13#10; for i:=0 to FileList.Count -1 do begin FileListStr:=FileListStr + FileList.Strings[i] + #13#10; end; MessageBox(lpici.hwnd,PChar(FileListStr),'Shell Extension Sample',MB_OK); Result := NOERROR; //case idCmd of // 0: begin SomethingDo; end; // Click on menu item 1 // 1: begin .... end; // Click on menu item 2 // 2: begin .... end; // .......... // 3: begin .... end; //end; end;

function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HRESULT; begin if (idCmd = FMenuIndex) then begin if (uType = GCS_HELPTEXT) then StrCopy(pszName, PChar('MenuItem '+IntToStr(idCmd)+' , '+IntToStr(FileList.Count)+' Files Selectd')); Result := NOERROR; end else Result := E_INVALIDARG; end;

type TContextMenuFactory = class(TComObjectFactory) public procedure UpdateRegistry(Register: Boolean); override; end;

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean); var ClassID: string; begin if Register then begin inherited UpdateRegistry(Register); ClassID := GUIDToString(Class_ContextMenu); CreateRegKey('*\shellex', '', ''); CreateRegKey('*\shellex\ContextMenuHandlers', '', ''); 677

CreateRegKey('*\shellex\ContextMenuHandlers\OpenWithWordPad', '', ClassID); //Èç¹û²Ù×÷ÏµÍ³ÎªWindows NTµÄ»° if (Win32Platform = VER_PLATFORM_WIN32_NT) then with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True); OpenKey('Approved', True); WriteString(ClassID, 'Context Menu Shell Extension'); finally Free; end; end else begin DeleteRegKey('*\shellex\ContextMenuHandlers\FileOpreation'); DeleteRegKey('*\shellex\ContextMenuHandlers'); // DeleteRegKey('*\shellex'); inherited UpdateRegistry(Register); end; end;

initialization TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu, '', 'Context Menu Shell Extension', ciMultiInstance,tmApartment); end.

678

RTL reference|Glossary|Tips/Tricks|FREE App/VCL|Best'O'Net|Books|Link To

An introduction to hook procedures This document describes what Windows hooks are and how to use them within a Delphi application.

More of this Feature • Download code

Join the Discussion "Post your questions, concerns, views and comments to this article..." Discuss!

Related Resources • Win/API programming • Keyboard hooks

About Poll This [063001] article is: Awesome (5) Great (4) Ok (3) Not bad (2) Poor (1) Submit Vote

Current Results Article submitted by: Chris Cummings, http://wibblovia.topcities.com This document describes what windows hooks are and how to use them. In order to use hooks properly you will need a copy of the windows SDK, that can be downloaded from the Microsoft web site. The project hooks.dpr contains all the code for the program used in this document and hookdll.dpr contains the DLL required. The actual code itself is shown and explained more thoroughly as remarks within the projects.

679

What Are Hooks? Put shortly, a hook is a function you can create as part of a dll or your application to monitor the 'goings on' inside the windows operating system. The idea is to write a function that is called every time a certain event in windows occurs - for example when a user presses a key on the keyboard or moves the mouse. Hooks were provided by Microsoft primarily to help program writers with the debugging of their applications, but they can be put to use in many different ways - for example, my first use of them was to write hidden key logging program to find out my mums password to the internet! There are 2 types of hooks - global or local. A local hook is one that monitors things happening only for a specific program (or thread). A global hook monitors the entire system (all threads). Both types of hooks are set up in the same way, the main difference being that for a local hook, the function to be called can be within the program it is monitoring, but with a global hook the function must be stored and loaded from a separate dll.

Hook Procedures What follows is a quick description of each of the windows procedures required and also of the structure that your hook procedure should take. The SetWindowsHookEx function SetWindowsHookEx is the function provided by Microsoft to install a hook. It accepts the following arguments: Name

Type

Description

idHook

Integer

A number representing the type of hook - eg WH_KEYBOARD

lpfn

TFNHookProc The address in memory of the hook function

hMod

Hinst

The handle of the dll the hook function is in. If it is a local hook, this is 0.

dwThreadID Cardinal

The 'thread id' that the program is to monitor. If it is a global hook this is 0.

SetWindowsHookEx returns a handle (i.e. an identifier) for the current hook, so you can use UnhookWindowsHookEx to remove the hook later on. The hook function The hook function is the procedure to be called by windows when the event we specify happens. A hook for any event always takes the same form, but the values passed to it by windows can mean different things. For example if the hook is type WH_KEYBOARD, windows will pass information to it relating to which key was pressed. Your hook procedure should accept the following arguments: Name

Type

Description

Code

Integer

Indicates what the next 2 arguments mean

wParam word lParam

A parameter of size 1 word

longword A parameter of size 2 words

A hook function returns a value of type longword. What you should set it to depends on the type of hook, or you can just set it to the value that CallNextHookEx returns. The CallNextHookEx function This function is to do with 'hook chains'. When a hook is installed for a certain event, there may be others like it already installed - for example 2 programs at once might be trying to log keyboard input. When you install a hook with SetWindowsHookEx it adds your hook procedure to the front of a list of hook procedures. CallNextHookEx simply calls the next procedure in the list. When your hook procedure is finished, it can run CallNextHookEx, and then return the value it gets from it or a different one depending on the type of hook. CallNextHookEx takes exactly the same form as a hook procedure plus one extra - the handle returned by SetWindowsHookEx identifying the hook. The other values you pass to it should be the values your hook procedure was called with. How you should use it depends on

680

should be the values your hook procedure was called with. How you should use it depends on the type of hook. The UnhookWindowsHookEx function This is very simple! It simply removes your hook. The only argument you pass to it is the hook handle returned by SetWindowsHookEx. A Local Hook First up we will create a local hook. The important code for this is in 'local.pas'. Hooks.exe when run will display a small form. Click the Add/Remove Local Hook Button on this form to use the local hook. When the local hook is installed correctly, you should find that pressing any key and releasing it makes the beep sound, providing hooks.exe has the focus (since it is a local hook). The first function in local.pas is SetupLocalHook which creates a local hook, specifying the hook procedure as our KeyboardHook function. It simply calls SetWindowsHookEx, and if the handle returned is > 0, indicating the procedure works, it saves the handle in CurrentHook and returns true, otherwise it returns false. Next is RemoveLocalHook which takes the stored hook handle in CurrentHook and uses UnhookWindowsHookEx to remove it. Lastly is the hook procedure. The hook procedure simply checks if the key is being released, and if so beeps. A Global Hook The global hook is slightly more complicated. To create a global hook you need 2 projects, 1 to make the executable file and 1 to make a dll to contain the hook procedure. The global hook that is shown in the code records keydown events and every time 20 keys have been pressed it writes them to a file, log.txt. To use the global hook run hooks.exe and choose add/remove global hook. Then type something (say in notepad for example) that is more than 20 characters long. You will notice a file, log.txt appear that contains the text you wrote. The Dll you write should contain 2 procedures. The first, obviously being our hook procedure which in structure is identical to that defined for a local hook. The second is a simple procedure that you will find you need to do almost whenever you create a dll initialises a few variables in the dlls memory - these include the current number of the key that has been pressed and the handle for the hook that has been created. The executable file must first load the procedures in the dll and then use SetWindowsHookEx to define a global hook. Finally... This document and the code provided with it should have given you a good idea of how to use hooks. In order to find out about the different types of hook such as WH_MOUSE and get more information on how to use them you will need the windows SDK.

681

Hooks: Capture keys in all Windows applications Enviado Por (Send By): Radikal (Q3 Team) Web : http://www.q3.nu Email: [email protected] Fecha (Date): 03/03/00

Tip accessed 13722 times

A lot of people ask me about the possibility that our application Delphi captures the user's keystrokes, although the user doesn't make them our active application being. Of course... the first thing that we make is to give a turn for the event OnKeyPress of the form, and of course, without obtaining positive results, even putting the property KeyPreview from the form to true... This happens because our application will only receive messages of the keystrokes when is it who has the focus. The following step to solve this question is fighting with the keyboard hooks. A Hook it is not more than a mechanism that will allow us to spy the traffic of messages between Windows and the applications. To install a hook in our application is something relatively simple, but of course, if we install it in our application, we will only spy the messages that Windows sent to our application, so neither we will have solved the problem. Then... Which is the solution?. The solution is to install a Hook but at system level, that is to say, a hook that captures all the messages that circulate toward Windows. Installing a hook at system level has a great added complication that is the fact that the function to the one that calls the hook it must be contained in a DLL, not in our Delphi application. This condition, will force us, in the first place to build us a DLL, and in second place to to build us some invention to communicate the DLL with our application. In this trick you have an example of keyboard capture by means of a keyboard Hook to system level. The example consists of two projects, one for the DLL and another for the example application. The operation is the following one: · We make DLL with two functions that we will export, one to install the hook and another for ununstall it. · There is a third function that is the one that will execute the hook once installed (CallBack). In her, that will make it is to send the data of the message captured to

682

our application. The DLL should know in all moment the handle of the receiver application, so we will make him to read it of a memory mapped file that we will create from the own application. You have an example of use of memory mapped files in the trick: [381] - Share data between two Delphi applications We will send the data from the DLL to the application through user's message. You have other tricks in where this technique is also used, for example: [162] - Prevent double instance of your application Well, let's go with the example:

DLL that installs the Hook: · Make the skeleton of a DLL (File - New - DLL) · Change the code of the project for this another:

library Project1; { Demo de Hook de teclado Como lo que queremos es parte de Windows, necesitamos llamará el Hook en una DLL, que }

a nivel de sistema, Radikal. capturar las teclas pulsadas en cualquier instalar la funcion CallBack a la que es ésta misma.

uses Windows, Messages; const CM_MANDA_TECLA = WM_USER + $1000; var HookDeTeclado : HHook; FicheroM : THandle; PReceptor : Înteger; function CallBackDelHook( Code wParam lParam )

: : : :

Integer; WPARAM; LPARAM LRESULT; stdcall;

{Esta es la funcion CallBack a la cual llamará el hook.} {This is the CallBack function called by he Hook} begin {Si una tecla fue pulsada o liberada}

683

{if a key was pressed/released} if code=HC_ACTION then begin {Miramos si existe el fichero} {if the mapfile exists} FicheroM:=OpenFileMapping(FILE_MAP_READ,False,'ElReceptor'); {Si no existe, no enviamos nada a la aplicacion receptora} {If dont, send nothing to receiver application} if FicheroM<>0 then begin PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_READ,0,0,0); PostMessage(PReceptor^,CM_MANDA_TECLA,wParam,lParam); UnmapViewOfFile(PReceptor); CloseHandle(FicheroM); end; end; {Llamamos al siguiente hook de teclado de la cadena} {call to next hook of the chain} Result := CallNextHookEx(HookDeTeclado, Code, wParam, lParam) end; procedure HookOn; stdcall; {Procedure que instala el hook} {procedure for install the hook} begin HookDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelHook, HInstance , 0); end; procedure HookOff; stdcall; begin {procedure para desinstalar el hook} {procedure to uninstall the hook} UnhookWindowsHookEx(HookDeTeclado); end; exports {Exportamos las procedures...} {Export the procedures} HookOn, HookOff; begin end.

Now record the project with the name: ' HookTeclado.dpr' and compile it (Project Build All), and you will have generated the DLL of the project.

Receiver application · Make a new empty application · Put a TMemo (Memo1) in the form · Change the form's unit code by this other: 684

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; const NombreDLL CM_MANDA_TECLA

= 'HookTeclado.dll'; = WM_USER + $1000;

type THookTeclado=procedure; stdcall; type TForm1 = class(TForm) Label1: TLabel; Memo1: TMemo; Button1: TButton; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } FicheroM : THandle; PReceptor : Înteger; HandleDLL : THandle; HookOn, HookOff : THookTeclado; procedure LlegaDelHook(var message: TMessage); message CM_MANDA_TECLA; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin {No queremos que el Memo maneje el teclado...} {We dont want that the memo read the keyboard...} Memo1.ReadOnly:=TRUE; HandleDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+ NombreDLL ) ); if HandleDLL = 0 then raise Exception.Create('No se pudo cargar la DLL'); @HookOn :=GetProcAddress(HandleDLL, 'HookOn'); @HookOff:=GetProcAddress(HandleDLL, 'HookOff'); IF not assigned(HookOn) or not assigned(HookOff) then

685

not assigned(HookOff) then raise Exception.Create('No se encontraron las funciones en la DLL'+#13+ 'Cannot find the required DLL functions'); {Creamos el fichero de memoria} FicheroM:=CreateFileMapping( $FFFFFFFF, nil, PAGE_READWRITE, 0, SizeOf(Integer), 'ElReceptor'); {Si no se creó el fichero, error} if FicheroM=0 then raise Exception.Create( 'Error al crear el fichero'+ '/Error while create file'); {Direccionamos nuestra estructura al fichero de memoria} PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_WRITE,0,0,0); {Escribimos datos en el fichero de memoria} PReceptor^:=Handle; HookOn; end; procedure TForm1.LlegaDelHook(var message: TMessage); var NombreTecla : array[0..100] of char; Accion : string; begin {Traducimos de Virtual key Code a TEXTO} {Virtual key code to Key Name} GetKeyNameText(Message.LParam,@NombreTecla,100); {Miramos si la tecla fué pulsada, soltada o repetida} {Look if the key was pressed, released o re-pressed} if ((Message.lParam shr 31) and 1)=1 then Accion:='Soltada' {Released} else if ((Message.lParam shr 30) and 1)=1 then Accion:='Repetida' {repressed} else Accion:='Pulsada'; {pressed} Memo1.Lines.Append( Accion+ ' tecla: '+ String(NombreTecla) ); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Desactivamos el Hook} {Uninstall the Hook} if Assigned(HookOff) then HookOff; {Liberamos la DLL} {Free the DLL} if HandleDLL<>0 then FreeLibrary(HandleDLL);

686

{Cerramos la vista del fichero y el fichero} {Close the memfile and the View} if FicheroM<>0 then begin UnmapViewOfFile(PReceptor); CloseHandle(FicheroM); end; end; end.

· Record the project in the same directory of the project of the DLL and compile the application. If you have followed the steps until here, you will have in the directory of the two projects a DLL (HookTeclado.DLL) and the executable of the receiver application. Execute it, and you will see in the Memo1 all the keys pressed in Windows. If you only wanted an example that works, it is not necessary that you continue reading. If you want to know a little more than like the invention works... so... here you have it, step to step: We go starting from the event OnCreate of the application: First, we put the Memo1 to readonly. Imagine for what reason, or better, it proves to not putting it, to see that it happens...:)

procedure TForm1.FormCreate(Sender: TObject); begin {No queremos que el Memo maneje el teclado...} {We dont want that the memo read the keyboard...} Memo1.ReadOnly:=TRUE;

Now we load the DLL that we will suppose that it will be in the same directory that our executable one. If there was some problem when loading it, we generate an exception, in such a way that the following code would not be executed. HandleDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+ NombreDLL ) ); if HandleDLL = 0 then raise Exception.Create('No se pudo cargar la DLL');

687

· Once loaded the DLL, we look for the two functions that they should be in it. If they are not... we generate an exception. @HookOn :=GetProcAddress(HandleDLL, 'HookOn'); @HookOff:=GetProcAddress(HandleDLL, 'HookOff'); IF not assigned(HookOn) or

· Now, we make a memory mapped file, which will use to keep the handle of our form, the DLL will taste this way like who must send him the message with the key that has been pressed just reading this file.

· Once we have the memory mapped file, and a view pointing to it, we record the ·handle Well, of now that in our DLL HookOn: thesee form in itit,happens and we activate thewhen Hook,calling callingtotothe thefunction procedure HookOn of the DLL:

688

{procedure for install the hook} begin HookDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelHook, HInstance , 0); end;

As you see, there is not more than a call to SetWindowsHookEx, to install a hook at system level (0 in the last parameter) that will execute the function CallBackDelHook with each message that it captures. · Let us see that it makes the function CallBackDelHook when it is executed by the hook: First, it checks that the function has been called by a new keyboard event, by means of the if code=HC_ACTION. function CallBackDelHook( Code wParam lParam )

: : : :

Integer; WPARAM; LPARAM LRESULT; stdcall;

{Esta es la funcion CallBack a la cual llamará el hook.} {This is the CallBack function called by he Hook} begin {Si una tecla fue pulsada o liberada} {if a key was pressed/released} if code=HC_ACTION then begin

If it is this way, that is to say that is a new keyboard event that it is necessary to assist... the first thing that we should make is so to look for the handle from the application to which should send the message with the data of the pressed/released key, which have kept by heart in a file from the application, we try to open the file, and to read this handle, and if everything goes well, we send the message by means of a PostMessage: {Miramos si existe el fichero} {if the mapfile exists} FicheroM:=OpenFileMapping(FILE_MAP_READ,False,'ElReceptor'); {Si no existe, no enviamos nada a la aplicacion receptora} {If dont, send nothing to receiver application} if FicheroM<>0 then begin PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_READ,0,0,0); PostMessage(PReceptor^,CM_MANDA_TECLA,wParam,lParam);

689

once sent the message, we free the file: UnmapViewOfFile(PReceptor); CloseHandle(FicheroM); end; end;

later, should call to next hook: {Llamamos al siguiente hook de teclado de la cadena} {call to next hook of the chain} Result := CallNextHookEx(HookDeTeclado, Code, wParam, lParam) end;

Well, do we have installed a hook that captures the keyboard events and does it forward them to our application... which the following step is?, of course... to make something to receive it... We will have to capture user's message that we have been defined:

and course, the get corresponding in the implementation that of which we will adding this procedure line in the private part of the form:part:

690

then Accion:='Soltada' {Released} else if ((Message.lParam shr 30) and 1)=1 then Accion:='Repetida' {repressed} else Accion:='Pulsada'; {pressed} Memo1.Lines.Append( Accion+ ' tecla: '+ String(NombreTecla) ); end;

In this example, I simply translate the data of the pressed/released key, translating it to its key name and adding it to the TMemo. If you want more information on the parameters than the function will receive, revise the help file Win32.hlp looking for the topic ' KeyboardProc'. There you will see the meaning of the parameters wParam and lParam that you will receive in the function. For I finish, we have left to undo this whole invention when we leave the application. The OnDestroy event of the application: First, uninstall the hook, calling to the HookOff function of the DLL. Care, is to use the if Assigned, because if there has been some problem when loading the DLL in the OnCreate... now we would try to execute something that was not initialized.

procedure TForm1.FormDestroy(Sender: TObject); begin {Desactivamos el Hook} {Uninstall the Hook} if Assigned(HookOff) then HookOff;

Now, free the DLL:

{Liberamos la DLL} {Free the DLL} if HandleDLL<>0 then FreeLibrary(HandleDLL);

And the file:

691

{Cerramos la vista del fichero y el fichero} {Close the memfile and the View} if FicheroM<>0 then begin UnmapViewOfFile(PReceptor); CloseHandle(FicheroM); end; end;

692

Looping AVI

We will use for it the OnNotify event of the TMediaPlayer component. · Put this code in the OnCreate event of the MediaPlayer:

procedure TForm1.MediaPlayer1Notify(Sender: TObject); begin With MediaPlayer1 do If NotifyValue = nvSuccessful Then Begin Notify := True; Play; End; end;

693

Bitmap en negativo Reverse Bitmap (negative) Enviado Por (Send By): Nacho Urenda Web : N.A. Email: [email protected] Fecha (Date): 13/10/00

Tip accessed 7307 times

This tip it's only for Delphi 32 bits (Delphi 2 or later...) · Add Windows in the uses of your form · Add these lines behind the uses line of your form: const MaxPixelCount

=

32768;

type pRGBArray TRGBArray

= =

^TRGBArray; ARRAY[0..MaxPixelCount-1] of TRGBTriple;

· Now, put a TImage (Image1) and load in it a picture · Out a TButton (Button1) and put this code in its OnClick event:

procedure TForm1.Button1Click(Sender: TObject); procedure NegativeBitmap(OrigBmp, DestBmp: TBitmap); var i, j: integer; tmpbmp: TBitmap; OrigRow, DestRow: pRGBArray; begin { Creamos un bitmap temporal. Esto nos permite usar el mismo bitmap para entrada y salida Create a temporal bitmap. This allows to use the same bitmap as input or output } tmpbmp := TBitmap.Create; try

{ Asignamos al bitmap temporal las características del

original the

Assign the temporal bitmap the same characteristics as

694

the original } tmpbmp.Width := OrigBmp.Width; tmpbmp.Height := OrigBmp.Height; OrigBmp.PixelFormat := pf24bit; tmpbmp.PixelFormat := OrigBmp.PixelFormat; { Para cada fila / for each row } for i := 0 to tmpbmp.Height -1 do begin { Asignamos Scanline actual / assign current ScanLine } OrigRow := OrigBmp.ScanLine[i]; DestRow := tmpbmp.ScanLine[i]; { Para cada columna / for each column } for j := 0 to tmpbmp.Width - 1 do begin { Cambiamos los valores de rojo, verde y azul Change red, green, blue values } DestRow[j].rgbtRed := 255 - OrigRow[j].rgbtRed; DestRow[j].rgbtGreen := 255 - OrigRow[j].rgbtGreen; DestRow[j].rgbtBlue := 255 - OrigRow[j].rgbtBlue; end; end; { Asignamos el bitmap en negativo al bitmap de destino Assign the negative bitmap to the destination bitmap } DestBmp.Assign(tmpbmp); finally { Destruimos bitmap temporal / Destroy temp bitmap } tmpbmp.Free; end; end; begin NegativeBitmap(Image1.Picture.Bitmap, Image1.Picture.Bitmap); end;

Sent by Nacho Urenda:

This is a improve of the code:

{

DestRow[j].rgbtRed := DestRow[j].rgbtRed xor OrigRow[j].rgbtRed;

695

DestRow[j].rgbtRed := not OrigRow[j].rgbtRed; DestRow[j].rgbtGreen := not OrigRow[j].rgbtGreen; DestRow[j].rgbtBlue := not OrigRow[j].rgbtBlue;

Sent by Nacho Urenda: The most effective method it's to use the InvertRect function of the Window's API:

procedure InvertBitmap(Bmp: TBitmap); begin InvertRect(Bmp.Canvas.Handle, Bmp.Canvas.ClipRect); end;

696

697

Windows users to brighten their desktops with. Some of the other advantages of placing code and resources in a dynamic link library are: ·

Disk space is saved if multiple applications use a dynamic link library. This can sometimes make a drastic difference in the cost of deploying your applications since you can place common functions and resources in a single .DLL file, reducing the size of your executables.

·

The ability to upgrade and replace parts of the program without shipping a whole new executable.

·

The ability to load and execute different resources and code based on some specific criteria available only at runtime. A good example would be "PlugIn" applets that can be dynamically loaded by your application at runtime, without knowing what "PlugIns" might be available at compile time. This can make your program automatically extendible with after-market products.

Loading a dynamic link library Your compiler most likely includes interface files to most of the Windows system functions. You simply link to the interface files, and any dynamic link libraries that are used by your program are automatically loaded when your program is started. In 16 Bit Windows, the actual function code is not added to your program, but rather a pointer to the module name of the dynamic link library and the name of the function (or its exported index number) is added. In Win32, the DLL is mapped into the process' address space. The dynamic link library's file must exist at runtime or an error will occur. If your compiler does not include an interface to the function or dynamic link library you want to use, you are going to have to declare a function prototype, and a linking interface, to let your compiler know about the function you are dynamically linking to. The instructions to do this should be included with your compiler's documentation. A short example of a function prototype in Pascal for a dynamic link library would be: {$IFDEF Win32} function MessageBeep(BeepType: Integer):Bool stdcall; external 'USER32'; {$ELSE} procedure MessageBeep(BeepType: Integer); far; external 'USER'; {$ENDIF} This prototype tells the compiler to link to a function named "MessageBeep" located in USER32.DLL (if compiling under 32 bits), or a procedure named "MessageBeep" located in USER.EXE (if compiling under 16 bits). The compiler is also made aware that "MessageBeep" takes a integer size parameter, and uses the "stdcall" passing convention (if compiling under 32 bits). When declaring an interface to a dynamic link library, you must be careful to specify the way that the function expects to have its parameters and return value passed, and who will maintain the stack. There are various calling techniques used including: PASCAL, CDECL, STDCALL, and FASTCALL. In 16 bit Windows, most functions are exported using the PASCAL calling convention. In 32 bit Windows, STDCALL is preferred since this should be compatible w/most other languages. Most API functions are declared with "C" prototypes. If you are wanting to port an interface to a Pascal based language, and you are not familiar with "C", your best bet is to get Alain Tadros's technical paper "Using Borland's Delphi and C++ Together". It is available from Compuserve, and the Borland BBS system and has some excellent additions by Eric Uber. Dynamic loading at runtime Loading a dynamic link library at runtime allows you to load dynamic link libraries that are not known at compile time, or load a library for only a short time. Printer drivers are a good example: You don't know what printer drivers will be available on a users system until runtime, and you would only want to load a printer

698

driver during the printing phase of your program. One of the advantages to loading libraries dynamically is that you don't use up resources (memory) until you actually load the library and the function you wish to call. You load a dynamic link library at runtime by calling the Windows API function LoadLibrary(). Then you can search for a given function within the library using the Windows API function GetProcAddress(). Once you have the address of the function you want, you can call it from your code. One thing to remember: Always call the Windows API function FreeLibrary() when you are done using the dynamic link library. Example: procedure Win31LoadUserAndCallBeepFn; var DllHandle: THandle; BeepFn: procedure(BeepType: Integer); begin DllHandle := LoadLibrary('USER'); if DllHandle >= 32 then begin @BeepFn := GetProcAddress(DllHandle, 'MessageBeep'); if @BeepFn <> nil then BeepFn(-1); FreeLibrary(DllHandle); end; end;

procedure Win32LoadUserAndCallBeepFn; var DllHandle: THandle; BeepFn: function(BeepType: Integer): Bool stdcall; begin DllHandle := LoadLibrary('USER32'); if DllHandle <> 0 then begin @BeepFn := GetProcAddress(DllHandle, 'MessageBeep'); if @BeepFn <> nil then BeepFn($FFFFFFFF); FreeLibrary(DllHandle); end; end; Here we have two code snippets showing the differences between loading a library under 16 and 32 bit Windows. In this case, we must mark the function we are calling as using the "stdcall" calling convention under 32 bit Windows, where under 16 bit windows the "pascal" calling convention is assumed. Note that the 16 bit version of MessageBeep() is a procedure, and the 32 bit version is a function. The LoadLibrary() function takes a null-terminated string that names the library file to be loaded. If the string does not contain a path, Windows searches for the library in this order: the current directory; the Windows directory; the Windows system directory; the directory containing the executable file for the current task; the directories listed in the PATH environment variable; and finally, the list of directories mapped in a network. If no extension is used, the extension of ".DLL" is assumed. We check the value of the handle returned by LoadLibrary() for an error. Under 16 bit Windows, the return value will be less than 32 if an error occurs, and under 32 bit Windows, the return value will be 0 if an error occurs. We then call the GetProcAddress() function to get the address of the MessageBeep() function. The spelling of the function name is critical, and can be case sensitive under different environments. If GetProcAddress() successfully returns the address of the function, then we can safely call the function. Finally we unload the library to free up memory. Resource only dynamic link libraries As mentioned, dynamic link libraries can hold resources as well. To use resources contained in a dynamic link library, you simply make a call to LoadLibrary(), then you can load resources from the library using one of the Windows API resource functions such as LoadBitmap(), passing the handle to the dynamic link library that you received from the LoadLibrary() call. Just don't forget to free your resources and the library when you are done.

699

You can use the snipit from the above section "Loading dynamic link libraries at runtime" to load a dynamic link library, and then load a resource from the library. Example: LoadBitmap(DllHandle,'SOMEBMP'); Stack usage and dynamic link libraries When you call a function in a dynamic link library, the library generally uses the stack of the calling application. Applications running under 16 Bit Windows had much less stack space available (<64k) than what is available under 32 bit Windows (1 MB). Since functions in a dynamic link library can call functions in other dynamic link libraries as well as making callbacks, you should always thoroughly test your program to make sure you have setup adequate stack space. Callback functions Callback functions are a really wonderful feature of the Windows environment. Callback functions allow you to send the "instanced" address of a function in your application to a function contained in a dynamic link library. The dynamic link library function can then call back to the function in your application to pass back information. A good example of a Windows API function that utilizes callbacks is the EnumFonts() function. The EnumFonts() function enumerates fonts available to a given device context. For each font enumerated, the EnumFonts() function will call back to a function in your application, passing back information about that font. This process continues as long as their are more fonts to enumerate, or until your function returns zero, meaning that you wish to stop further enumerations. Most Windows API functions that accept a callback function as a parameter will also accept an lpData parameter. This lpData parameter is used for "application defined data". You are free to define what this parameter is used for. The lpData parameter is usually passed to the dynamic link library as a longint, and rarely as a far pointer. It is likely you will want to send something besides a longint. You can always typecast a pointer to a data structure in your application to a longint when calling dynamically linked functions, and typecast the longint passed back to your callback function to a pointer so your may access your data structure. As mentioned, when your callback function is called by the Windows API function, the lpData parameter you originally passed to the Windows API function will be passed back to your callback function for your use. This avoids having to declare a global variable in your program. A good example of how this works would be if you were to create a program containing a dialog box to show all the available fonts in a drop-down listbox. When you process the WM_INITDIALOG message, you call the EnumFonts() function, passing the instanced address of your callback function that will process the font information. Your callback function will perform the work to add each font's name to the listbox. The only problem: your callback function does not have a handle to the listbox. You could create a global variable to hold the listbox handle, but instead, you should pass the handle of the listbox to your callback function through the lpData parameter, and let the dynamically linked function pass the handle of the listbox back to your callback function. While it is always nice to keep global variables to a minimum, having the ability to pass user defined data to the callback function becomes critically important when you create callback functions inside a 16-bit dynamic link library. Generally, under 16-bit Windows, a dynamic link library has only one data segment. Since multiple applications can use a single dynamic link library, and, since a 16-bit dynamic Link Library has a single data segment, any global variables defined in the dynamic link library exist in memory only once. If you create a callback function in a dynamic link library, and use a global variable to store data used during the callback, you run the risk of data corruption. Consider the following scenario: You have written several applications that use your font dialog box. Rather than include your font dialog in each application, you opt to store the dialog in a dynamic link library. Suppose that you use a global variable in the dynamic link library to store the listbox handle for your callback function. Now suppose that more than one application loads the dialog box at the same time. Each "copy" of your font dialog box contains a different handle to it's listbox. Clearly, using a global variable to hold the listbox handle will not work since the listbox handle will be different for each dialog, and the global variable used to hold this handle will get trashed. The way around this, is to pass the listbox handle to the EnumFonts() function using the lpData parameter. This is not a problem, when writing 32-bit dynamic link libraries for use under Windows 95 and Windows NT, as under both environments, dynamic link libraries have a separate data area for each application that loads

700

them. None the less, it is still a good practice to always keep global variables to a minimum. The Hook functions A "hook" function is a callback function that can be inserted in the Windows message system so an application can access the message stream before other processing of the message takes place. Often times, there will be other hooks already installed in the messaging system, so there will be times you will need to call the next hook in the "Hook Chain" to allow the other hooks in the chain to access the messages as well. When you install a hook function using the Windows API function SetWindowsHookEx(), you will receive a 32 bit handle to your installed hook function. You will use this handle to both remove the hook when you are done via the Windows API function UnHookWindowsHookEx(), and when calling the next hook in the "Hook Chain" via the Windows API function CallNextHookEx(). We have chosen to use the Windows "Ex" hook functions since we want to be able to port to 32 bit Windows. System wide hooks require that your hook filter function reside in a dynamic link library. The filter function for an application specific hook may reside either in the application or a dynamic link library. Different types of Windows Hooks: Windows defines the following types of hook functions: ·

WH_CALLWNDPROC- A window procedure hook called whenever the SendMessage() function is called.

·

WH_CBT- A computer based training hook called before activating, creating, destroying, minimizing, maximizing, moving, or sizing a window; before completing a system command; before removing a mouse or keyboard event; before setting input focus; and before synchronizing the system message queue.

·

WH_DEBUG-A debugging hook called before any other filter installed by the SetWindowsHookEx() function is called.

·

WH_GETMESSAGE- A message hook called whenever the GetMessage() function has retrieved a message from an application queue.

·

WH_HARDWARE- A nonstandard hardware message hook called whenever the application calls the GetMessage() or PeekMessage() function and there is a hardware event (other than a mouse or keyboard event) to process.

·

WH_JOURNALRECORD- A journaling record hook called when the system removes messages from the system message queue.

·

WH_JOURNALPLAYBACK- A journaling playback hook used to insert mouse and keyboard messages into the system message queue.

·

WH_KEYBOARD- A keyboard hook called whenever the application calls the GetMessage() or PeekMessage() function and there is a WM_KEYUP or WM_KEYDOWN keyboard message to process.

·

WH_MOUSE- A mouse message hook called whenever the application calls the GetMessage() or PeekMessage() function and there is a mouse message to process.

·

WH_MSGFILTER- An application message hook called after a dialog box, message box, or menu has retrieved a message, but before the message is processed.

·

WH_SHELL- A shell application hook called when notification messages from the system have been made.

·

WH_SYSMSGFILTER- A system wide message hook called after a dialog box, message box, or menu has retrieved a message, but before the message is processed.

Note: Debugging Windows hooks can be very difficult. The documentation has much to be desired, so before you make the jump, always consult the Microsoft Knowledge Base for any additional information regarding the hook you are designing for. If your hook hangs the system, pressing CTRL+ESC or

701

CTRL+AlT+DEL should unhook any system wide hooks that are in effect. Data storage in dynamic link libraries Under 16 bit Windows, a dynamic link library is only loaded once no matter how many applications request the library to be loaded, generally contains a single data segment, and all global variables in the dynamic link library exist across all applications that load the dynamic link library. If any process causes corruption in the data segment of the dynamic link library, other applications using the dynamic link library can be affected. Many argue that sharing data between applications through a 16 bit dynamic link library is considered a very bad practice. Under Windows 95, the code for a dynamic link library is only loaded once no matter how many applications request the library to be loaded, and the link to a running application gets its own data storage area. This provides some additional crash protection to other applications, since any corrupted global variables in a dynamic link library caused by one application will not adversely affect other applications using that dynamic link library. Under Windows NT, a separate copy of both the dynamic link library's data and code is linked to the calling application. If we think about how the DLL is loaded, we can still realize a memory saving when we talk about physical memory usage. Each process does indeed gets its own copy of the DLL and the DLL data. However, it obtains this through a memory mapping of the DLL. That is, the DLL code is mapped to each processes address space. In physical memory (as seen by the system) the DLL is loaded only once. Instanced addresses and thunking As already mentioned, 16-bit dynamic link libraries have only one data segment. When you call a function in a dynamic link library, the data segment must be switched from your application's data segment to that of the dynamic link library's data segment, and back again after the function returns. If the dynamically linked function happens to make a callback to a function in your application, the data segment must be switched back to your application's data segment during the callback, and back again to the dynamic link library's data segment when your function returns. When making a call to a dynamically linked function, the fixup code to switch the data segment is transparent. In the case of a callback, additional magic is needed by your application. The magic is made possible by using the Windows API function MakeProcInstance() to receive an "instance thunk" to your callback procedure. This "instance thunk" is the glue that holds your callback function and your data segment together during the callback. The procedure address passed to the MakeProcInstance() function needs to be marked with both the "far" and "exported" attributes. After the dynamic link library is through using your callback function, and returns, you should always call the Windows API FreeProcInstance() function to free the instance thunk. Using the MakeProcInstance() function is not necessary in 32 bit applications, or any dynamic link library (16 or 32 bit). It is, however, safe to use under these conditions, so any code you have that uses these functions can be safely ported to dynamic link libraries and 32 bit versions of Windows.

The Windows API: An Example Of Use - by Abstract:This paper is targeted to developers who wish an example of interfacing to the Windows Application Programming Interface (API).

The Windows API: An Example Of Use, Part 2 By Joe C. Hecht, Borland Delphi Technical Support Group HOOKIT! - The example The Journal Hooks: JournalRecord and JournalPlayback How HOOKIT! works HOOKIT! application logic HOOKLIB dynamic link library logic Got-Ya's! Source code for HOOKLIB.DLL Resource statements to build HOOKIT16.RES and HOOKIT32.RES 702

Source code for HOOKIT.EXE Part III: Conclusion The example: We will now present an example of using Windows API functions by creating an application that serves the useful function of hooking into the Windows messaging system, and recording any keyboard and mouse input to be used for later playback. We will call our macro recording application "Hookit!". Our "Hookit!" application is a great starting place for a full featured Windows macro recorder, reminiscent of the early days of DOS and my favorite "Sidekick's Sidekick", Borland's highly successful TSR program "SuperKey"! It's worth noting that unlike 16 bit Windows, neither Windows 95 or Windows NT shipped with a macro recording feature. Since "Hookit!" will use system wide Windows hook functions for JournalRecord and JournalPlayback, we will also create a Windows dynamic link library along the way! Both the application and the dynamic link library will perform callbacks. Pascal was originally designed to be a teaching language, thus the code example presented was written in Pascal, and can easily be ported to other languages such as "C". Note that the code cannot be ported to Visual Basic, since, as of this writing, Visual Basic does not support creating dynamic link libraries or callback functions. The code presented may also be directly ported between 16 and 32 bit compilers, and will successfully compile with Borland's Turbo Pascal for Windows 1.5, Borland Pascal for Windows 7.0 / 7.01, Delphi 1.0 / 1.02, and Delphi 2.0. To make it easy to port to other languages, no Pascal or Delphi specific features are used. The code also serves as a model for creating a "traditional" Windows program in Delphi, and utilizing a dialog box template for the main window of a program. Although "Hookit!" uses features designed to run on Windows 3.1 or above, the example code can be adapted to run on earlier versions of Windows (2.x and 3.0). The Journal Hooks: JournalRecord and JournalPlayback The Journal hook functions provide a easy way to record keyboard and mouse events on a system-wide basis, and play the events back at some later date. You can install a JournalRecord or JournalPlayback hook callback function by calling the Windows API function SetWindowsHookEx(), and passing the address of your hook callback function. An instanced address is not needed, as both the JournalRecord and JournalPlayback callback functions are system wide hooks, and must reside in a dynamic link library. Calling SetWindowHookEx() will return a 32 bit handle to your hook callback function for you to identify yourself to other hook functions already in the "Hook Chain", and to remove your hook from the chain when you are done recording. When you call SetWindowsHookEx() with the address of your JournalRecord callback function, Windows will return immediately, and the recording begins. Your JournalRecord callback function will get called with a code indicating the following conditions: ·

There is a keyboard or mouse event to record.

·

The system is entering a modal state.

·

The system leaving a modal state.

·

The system wants you to call the next hook in the hook chain.

If there is a keyboard or mouse event, the code will equal "HC_ACTION", and you are free 703

to record the event. A pointer to an EVENTMSG is passed to you in the lParam parameter of your JournalRecord callback function. The system time that the event was originally fired is contained in time parameter of the EVENTMSG structure. For playback purposes, you will need to make a copy of the EVENTMSG and change the time in the copy to reflect the net time into the recording, since you will need to synchronize the playback of the message to the system time at playback. This is done by getting the system time when you start the recording, and subtracting it from the message time. If the system enters a modal state, the code will equal "HC_SYSMODALON", indicating something bad has happened to the system, and you should temporarily stop recording, and call the next message hook in the "Hook Chain", so hooks further down the chain will know what is going on. When the system returns from a modal state, the code will equal "HC_SYSMODALOFF", and you may resume recording. Finally, if the code is less than zero, the system is asking you to call the next hook in the chain, and you should do so without further processing. When you are through recording, you can simply call the Windows API function UnHookWindowsHookEx() passing back the 32 bit handle given to you when you originally called the SetWindowsHookEx() function, and Windows will remove your hook callback function from the "Hook Chain". When you are ready to playback your recording, you will call SetWindowsHookEx() again, passing the address of your JournalPlayback callback function. Windows will return immediately, and the playback begins. During playback, normal mouse and keyboard input is automatically disabled by the system. Your JournalPlayback callback function will get called with a code indicating one the following conditions: ·

HC_SKIP- You should retrieve the next message. If there are no more messages to play, then you may safely call the Windows API function UnHookWindowsHookEx(), passing the handle to your hook function to end the playback.

·

HC_GETNEXT- You should play the current message.

·

HC_SYSMODALON- The system is entering a modal state. This indicates something bad has happened. You should call the next hook in the hook chain, so other hooks will know something is up.

·

HC_SYSMODALOFF- The system leaving a modal state, and Windows has unhooked your JournalPlayback callback procedure right out from under you. You are done. As your last act, you should call the next hook in the hook chain, so other hooks will know they are hosed as well.

·

Code < 0- The system wants you to call the next hook in the hook chain without further processing.

You should go ahead and retrieve the first message before you call the SetWindowsHookEx() function, since the system will ask you to play the first message before requesting the next message. You will also need to get the system time, since you will need to "fix up" the playback time of each of your recorded messages to synchronize with the system time at playback. Windows may ask you to play the same message more than once. The first time Windows asks you to play the current message, your JournalPlayback callback function should return the difference between the current time and the time the message is scheduled to play. If the difference between the current time and the time the message is scheduled to 704

play is negative, your JournalPlayback callback function should return zero. The JournalPlayback callback function must also return zero if the same message is requested to be played more than once. How HOOKIT! works Our application (HOOKIT.EXE) will contain four buttons: ·

Start Recording

·

Stop Recording

·

Playback

·

Done

and one callback function: ·

PlaybackFinished()

Our dynamic link library (HOOKLIB.DLL) will contain three functions that our calling application will use: ·

StartRecording()

·

StopRecording()

·

Playback()

and two hook functions that Windows will use: ·

JournalRecordProc()

·

JournalPlaybackProc()

HOOKIT! application logic: ·

Allow the program to start only if the version of Windows is equal or greater than Window's 3.1.

·

We will need to supply a callback function to be called whenever a macro's playback has finished, since the Playback() function will return immediately, and our application will continue to execute during playback. We will need to call MakeProcInstance() to get the instanced address of our callback function PlaybackFinished() to pass to the Playback() function. Since we cannot call FreeProcInstance() in the middle of the callback, we must declare a global variable to hold the instanced address of PlaybackFinished() on program startup, and free it on exit from the program.

·

Create a main window from a Dialog Box template.

·

Upon creation of our main window, we will enable the "Start Recording" and "Done" button. We will disable the "Stop Recording" and "Playback" button, since we have no recording to stop or playback.

·

When the "Done" button is selected we will free the instanced address of our callback function PlaybackFinished() and exit the program.

·

When the "Start Recording" button is selected, we will disable the "Start Recording" 705

and "Done" button, since we don't want to allow more than one recording at a time, and we don't want to allow the user to quit in the middle of recording. We will enable the "Stop Recording" button and call our StartRecording() function. If the StartRecoding() function returns an error, we will announce the error to the user, and reset the buttons to their default state before the "Start Recording" button was pressed. ·

When the "End Recoding" button is pressed, We will call the StopRecording() function passing it the filename to store the macro in. Then we will enable both the "Done" and "StartRecording" buttons, since we can now allow the user to quit, and we want the user to have the option to record or rerecord the session. We will enable "Playback" button only if anything has successfully been recorded.

·

When the "Playback" button is selected, we will disable all of our buttons, and call the Playback() function, passing it the filename of the macro to play, the instanced address of our callback function PlaybackFinished(), and a handle to our main window to be passed back to us as application defined data. When the macro playback is done, our hook function will callback to our program's PlaybackFinished() function, letting us know it has finished, and passing us back the handle to our main window as application data. We must do this since the Playback() function will return immediately, causing our program to continue to run during the macro's playback. This will allow us to know when it safe to enable our program's buttons again. If the Playback() function returns an error, we will reset the buttons to their default state before the "Playback" button was pressed.

·

When our callback function PlaybackFininshed() is called, we can enable the "Start Recording", "Playback" and "Done" buttons.

HOOKLIB dynamic link library logic: ·

If an error occurs during the call to StartRecord(), or, we are already recording or playing, we will return zero without further processing.

·

During the recording process, we will save keyboard and mouse events to an array. For the sake of simplicity, we will limit the number of recorded events to what will fit in a 64k memory block.

·

When StopRecording() is called, if any events have been recorded, we will write the recorded events to the disk for later playback. We will then unhook our JournalRecordProc() from the hook chain. We will return an error code of -1 if nothing is currently recording or -2 if there was trouble unhooking from the "Hook Chain". Otherwise we will return the number of messages recorded.

·

When the Playback() function is called, we will start the playback. If an error occurs or their is nothing to playback, we will return zero without further processing.

·

When the playback is finished, we will callback to the application announcing we are done playing back the macro.

·

Since the SetWindowsHookEx() function does not allow us an appdata parameter for application defined data, we must declare several global variables for our hook callback functions, and avoid letting more than one application invoke either the StartRecord() and Playback() functions at any given time under Windows 3.1.

·

We will define a global pointer called "PMsgBuff "that will point to an array of EventMsg structures to record to and playback from. Upon library startup, we will 706

initialize this pointer to nil. Only when we are recording or playing a macro will this pointer actually point to a memory block, otherwise it will be nil. This will give us a way to determine whether or not we are in the process of recording or playing a macro. ·

We will also need to define global variables for: o

"TheHook"- A 32 bit handle to our hook proc.

o

"StartTime"- The starting time of the recording or playback.

o

"MsgCount"- The total number of messages recorded.

o

"CurrentMsg"- The current message playing.

o

"ReportDelayTime"- If we should report a delay time.

o

"SysModalOn"- If the system is currently in a "modal" state.

o

"cbPlaybackFinishedProc"- The instanced address of the application's PlaybackFinished() callback function.

o

"cbAppData"- The user defined application data parameter passed to our Playback() function.

Got-Ya's! ·

JournalRecordProc() is incorrectly documented as receiving a MSG structure. JournalRecordProc() actually receives the same EVENTMSG structure that is documented by JournalPlaybackProc().

·

The JournalRecordProc() and JournalPlaybackProc() hook procedures do not provide a user defined lpData parameter, so you must use global variables in your dynamic link library.

·

Mouse events recorded with JournalRecord may not play back correctly if the display resolution has changed, or a window's position has changed.

·

Keyboard events recorded with JournalRecord on a Windows system other than Windows NT will not play back correctly under Windows NT. Under Windows 3.1, the keyboard repeat count is stored in the ParamH parameter of the EVENTMSG structure. Under Windows NT, this parameter is always 1. The size of the EVENTMSG structure also changes under Win32.

·

Your JournalPlaybackProc may be called many times with the HC_GETNEXT message. The system expects you to continue providing the same event to play until you receive a HC_SKIP message.

·

Be sure to return a non-zero delay time only once for each unique event you process in your JournalPlaybackProc, else Windows NT may hang due to timing differences. If your JournalPlaybackProc() gets called with a code of HC_GETNEXT more than once for the same event, return zero from your JournalPlaybackProc.

·

Interactive debugging of a journal hook cannot be done on a single machine. A Windows NT or Win32 application has an advantage that the system will send a WM_CANCELJOURNAL message to all applications when the system pulls the 707

hook out from under the application when the user presses CTRL+ESC or CTRL+ALT+DEL. "HOOKIT!" handles this event gracefully. ·

The SetWindowsHookEx() function will return immediately. This can be a problem if your program needs to know when the playback has finished.

·

Since you will most likely use the Windows API function GetTickCount() for calculating messaging times, you always run the risk that the system time will wrap if windows has not been restarted in the last 49 days. If you account for the fact that not all compilers support unsigned 32 bit integers, the system time will appear to go negative sometime into the 24th day.

·

The "handle" passed back from SetWindowsHookEx() is 32 bits wide, even in 16 bit environments.

·

You may need to set your compiler's link buffer to compile to disk when building dynamic link libraries. If the file image is only created in memory, it will not be available to the program that uses it.

·

JournalRecordProc() does not get along well with the new Windows 95 "StartKey" contained on some new keyboards.

Source code for HOOKLIB.DLL Note: Save the source as HOOKLIB.PAS for Pascal or HOOKLIB.DPR for Delphi. {$C FIXED PRELOAD PERMANENT} library HOOKLIB; {$IFDEF Win32} uses Windows; type TwMsg = Longint; TwParam = Longint; TlParam = Longint; {$ELSE} uses {$IFDEF VER15} WinTypes, WinProcs, Win31; {$ELSE} {$IFDEF VER70} WinTypes, WinProcs, Win31; {$ELSE} WinTypes, WinProcs; {$ENDIF} {$ENDIF} type TwMsg = Word; TwParam = Word; TlParam = Longint; {$ENDIF} const MAXMSG = 6500;

708

type PEventMsg = ^TEventMsg; TMsgBuff = Array[0..MAXMSG] of TEventMsg; TcbPlaybackFinishedProc = Procedure(AppData: Longint) {$IFDEF Win32} stdcall; {$ELSE} ; {$ENDIF} var PMsgBuff: ^TMsgBuff; TheHook: HHook; StartTime: Longint; MsgCount: Longint; CurrentMsg: Longint; ReportDelayTime: Bool; SysModalOn: Bool; cbPlaybackFinishedProc: TcbPlaybackFinishedProc; cbAppData: Longint; { *********************************************************************** } { function JournalRecordProc(Code: Integer; } { wParam: TwParam; } { lParam: TlParam): Longint; } { Parameters: action to perform and message data. } { Returns: zero unless code < 0, in which case return the result } { from CallNextHookEx(). } { *********************************************************************** } function JournalRecordProc(Code: Integer; wParam: TwParam; lParam: TlParam): Longint {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} begin JournalRecordProc := 0; case Code of HC_ACTION: begin if SysModalOn then exit; if MsgCount > MAXMSG then exit; {record the message} PMsgBuff^[MsgCount] := PEventMsg(lParam)^; {set the delta time of the message} Dec(PMsgBuff^[MsgCount].Time,StartTime); Inc(MsgCount); exit; end; HC_SYSMODALON: begin SysModalOn := True;

709

CallNextHookEx(TheHook, Code, wParam, lParam); exit; end; HC_SYSMODALOFF: begin SysModalOn := False; CallNextHookEx(TheHook, Code, wParam, lParam); exit; end; end; if code < 0 then JournalRecordProc := CallNextHookEx(TheHook, Code, wParam, lParam); end; { *********************************************************************** } { function StartRecording: Integer; } { Parameters: none. } { Returns: non zero if successful. } { *********************************************************************** } function StartRecording: Integer {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} begin StartRecording := 0; if pMsgBuff <> nil then exit; GetMem(PMsgBuff, Sizeof(TMsgBuff)); if PMsgBuff = nil then exit; SysModalOn := False; MsgCount := 0; StartTime := GetTickCount; TheHook := SetWindowsHookEx(WH_JOURNALRECORD, JournalRecordProc, hInstance, 0); if TheHook <> 0 then begin StartRecording := 1; exit; end else begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; end; end; { *********************************************************************** }

710

{ function StopRecording(lpFileName: PChar): Integer; } { Parameters: pointer to filename to save to. { Returns: number of records written. { -1 if not recording. {

} } }

-2 unable to unhook.

} { *********************************************************************** } function StopRecording(lpFileName: PChar): Longint {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var TheFile: File; begin if PMsgBuff = nil then begin StopRecording := -1; exit; end; if UnHookWindowsHookEx(TheHook) = False then begin StopRecording := -2; exit; end; TheHook := 0; if MsgCount > 0 then begin Assign(TheFile, lpFileName); {$I-} Rewrite(TheFile, Sizeof(TEventMsg)); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; StopRecording := 0; exit; end; {$I-} Blockwrite(TheFile, PMsgBuff^, MsgCount); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; StopRecording := 0; {$I-} Close(TheFile); {$I+} if IOResult <> 0 then exit; exit; end; {$I-} Close(TheFile); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; StopRecording := 0;

711

exit; end; end; FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; StopRecording := MsgCount; end; { *********************************************************************** } { function JournalPlaybackProc(Code: Integer; } { wParam: TwParam; } { lParam: TlParam): Longint; } { Parameters: action to perform and message data. } { Returns: if Code < 0, returns the result from CallNextHookEx(), } { otherwise returns the requested time to wait to fire } { the next event or zero. } { *********************************************************************** } function JournalPlaybackProc(Code: Integer; wParam: TwParam; lParam: TlParam): Longint {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var TimeToFire: Longint; begin JournalPlaybackProc := 0; case Code of HC_SKIP: begin {get the next message} Inc(CurrentMsg); ReportDelayTime := True; {are we finished?} if CurrentMsg >= (MsgCount-1) then if TheHook <> 0 then if UnHookWindowsHookEx(TheHook) = True then begin TheHook := 0; FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; {callback to the application announcing we are finished} cbPlaybackFinishedProc(cbAppData); end; exit; end; HC_GETNEXT: begin {play the current message} PEventMsg(lParam)^ :=

712

PMsgBuff^[CurrentMsg]; PEventMsg(lParam)^.Time := StartTime + PMsgBuff^[CurrentMsg].Time; {if first time this message has played - report the delay time} if ReportDelayTime then begin ReportDelayTime := False; TimeToFire := PEventMsg(lParam)^.Time - GetTickCount; if TimeToFire > 0 then JournalPlaybackProc := TimeToFire; end; exit; end; HC_SYSMODALON:begin {something is wrong} SysModalOn := True; CallNextHookEx(TheHook, Code, wParam, lParam); exit; end; HC_SYSMODALOFF:begin {we have been hosed by the system - our hook has been pulled!} SysModalOn := False; TheHook := 0; FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; {callback to the application announcing we are finished} cbPlaybackFinishedProc(cbAppData); CallNextHookEx(TheHook, Code, wParam, lParam); exit; end; end; If code < 0 then JournalPlaybackProc := CallNextHookEx(TheHook, Code, wParam, end;

lParam);

{ *********************************************************************** } { function Playback(lpFileName: PChar; } { EndPlayProc: TcbPlaybackFinishedProc; } { AppData: Longint): Integer; } { Parameters: pointer to filename to play. } { application's EndPlay callback function. } { application's

713

defined data. { Returns: non zero if successful.

}

} { *********************************************************************** } function Playback(lpFileName: PChar; EndPlayProc: TcbPlaybackFinishedProc; AppData: Longint): Integer {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var TheFile: File; begin Playback := 0; If PMsgBuff <> nil then exit; GetMem(PMsgBuff, Sizeof(TMsgBuff)); If PMsgBuff = nil then exit; Assign(TheFile, lpFileName); {$I-} Reset(TheFile, Sizeof(TEventMsg)); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; exit; end; {$I-} MsgCount := FileSize(TheFile); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; {$I-} Close(TheFile); {$I+} if IOResult <> 0 then exit; exit; end; if MsgCount = 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; {$I-} Close(TheFile); {$I+} if IOResult <> 0 then exit; exit; end; {$I-} Blockread(TheFile, PMsgBuff^, MsgCount); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; {$I-} Close(TheFile); {$I+}

714

if IOResult <> 0 then exit; exit; end; {$I-} Close(TheFile); {$I+} if IOResult <> 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; exit; end; CurrentMsg := 0; ReportDelayTime := True; SysModalOn := False; {save the application's callback procedure} cbPlaybackFinishedProc := EndPlayProc; {save the application's defined data parameter} cbAppData := AppData; StartTime := GetTickCount; TheHook := SetWindowsHookEx(WH_JOURNALPLAYBACK, JournalPlayBackProc, hInstance, 0); if TheHook = 0 then begin FreeMem(PMsgBuff, Sizeof(TMsgBuff)); PMsgBuff := nil; exit; end; Playback := 1; end; exports JournalRecordProc index 1 name 'JOURNALRECORDPROC' resident, StartRecording index 2 name 'STARTRECORDING' resident, StopRecording index 3 name 'STOPRECORDING' resident, JournalPlayBackProc index 4 name 'JOURNALPLAYBACKPROC' resident, Playback index 5 name 'PLAYBACK' resident; begin PMsgBuff := nil; end. Resource statements to build: HOOKIT16.RES and HOOKIT32.RES Note: Save the source as HOOKIT16.RC for 16 bit environments or HOOKIT32.RC for 32 bit environments. Use the Borland Resource Command Line Compiler BRCC.EXE to compile a 16 bit resource file and BRCC32.EXE to compile a 32 bit resource file. HOOKIT DIALOG 15, 15, 63, 60 STYLE WS_OVERLAPPED | WS_VISIBLE | WS_CAPTION | WS_MINIMIZEBOX

715

CLASS "HOOKITDIALOGCLASS" CAPTION "HookIt!" BEGIN CONTROL "Start Recording", 101, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_GROUP | WS_TABSTOP, 0, 0, 63, 15 CONTROL "Stop Recording", 102, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_GROUP | WS_TABSTOP, 0, 15, 63, 15 CONTROL "PlayBack", 103, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_GROUP | WS_TABSTOP, 0, 30, 63, 15 CONTROL "Done!", 1, "BUTTON", BS_PUSHBUTTON | WS_CHILD | WS_GROUP | WS_TABSTOP, 0, 45, 63, 15 END

| WS_VISIBLE | WS_VISIBLE | WS_VISIBLE WS_VISIBLE |

Source code for HOOKIT.EXE Note: Save the source as HOOKIT.PAS for Pascal or HOOKIT.DPR for Delphi. program HookIt; {$D HookIt!} {$C MOVEABLE PRELOAD PERMANENT} {$IFDEF Win32} {$R HOOKIT32.RES} uses Windows, Messages; type TwMsg = Longint; TwParam = Longint; TlParam = Longint; {$ELSE} {$R HOOKIT16.RES} uses {$IFDEF VER15} WinTypes, WinProcs, Win31; {$ELSE} {$IFDEF VER70} WinTypes, WinProcs, Win31; {$ELSE} WinTypes, WinProcs, Messages; {$ENDIF} {$ENDIF} type TwMsg = Word; TwParam = Word; TlParam = Longint; {$ENDIF} type TWinVersion WinMajor : WinMinor : DosMajor : DosMinor :

= record Byte; Byte; Byte; Byte;

716

end; TcbPlaybackFinishedProc = Procedure(AppData: Longint) {$IFDEF Win32} stdcall; {$ELSE} ; {$ENDIF} const APPNAME = 'HookIt!'; CLASSNAME ='HOOKITDIALOGCLASS'; ID_BTN_START_RECORDING = 101; ID_BTN_STOP_RECORDING = 102; ID_BTN_PLAYBACK = 103; ID_BTN_DONE = IDOK; FILENAME = 'HOOKIT.MAC'; var PlaybackFinishedProc :TcbPlaybackFinishedProc; function StartRecording: Integer {$IFDEF Win32} stdcall; {$ELSE} ; far; {$ENDIF} external 'HOOKLIB' index 2; function StopRecording(lpFileName: PChar): Integer {$IFDEF Win32} stdcall; {$ELSE} ; far; {$ENDIF} external 'HOOKLIB' index 3; function Playback(lpFileName: PChar; EndPlayProc: TcbPlaybackFinishedProc; AppData: Longint): Integer {$IFDEF Win32} stdcall; {$ELSE} ; far; {$ENDIF} external 'HOOKLIB' index 5; procedure PlaybackFinished(AppData: Longint) {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} begin EnableWindow(GetDlgItem(hWnd(AppData), ID_BTN_START_RECORDING), True); EnableWindow(GetDlgItem(hWnd(AppData), ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(hWnd(AppData), ID_BTN_PLAYBACK), True); EnableWindow(GetDlgItem(hWnd(AppData), ID_BTN_DONE), True); SetFocus(GetDlgItem(hWnd(AppData), ID_BTN_PLAYBACK)); end;

717

function HookitDialogProc(Dialog: HWnd; Msg: TwMsg; WParam: TwParam; LParam: TlParam): Longbool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} begin HookitDialogProc := True; {do any default class handling here for HookItDlg} HookitDialogProc := Longbool(DefDlgProc(Dialog, Msg, WParam, LParam)); end; function MainDlgProc(Dialog: HWnd; Msg:TwMsg; WParam:TwParam; LParam:TlParam): Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} begin MainDlgProc := True; case Msg Of WM_INITDIALOG: begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), True); EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), True); exit; end; WM_COMMAND: begin case WParam of ID_BTN_START_RECORDING: begin EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), True); SetFocus(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING)); EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), False); if StartRecording = 0 then begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), True); SetFocus(GetDlgItem(Dialog, ID_BTN_START_RECORDING)); EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), False);

718

EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), True); Messagebox(Dialog, 'Unable to start recording!', APPNAME, MB_OK); end; exit; end; ID_BTN_STOP_RECORDING: begin if StopRecording(FILENAME) > 0 then begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), True); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), True); SetFocus(GetDlgItem(Dialog, ID_BTN_PLAYBACK)); end else begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), True); SetFocus(GetDlgItem(Dialog, ID_BTN_START_RECORDING)); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), False); end; EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), True); exit; end; ID_BTN_PLAYBACK: begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), False); if PlayBack(FILENAME, PlaybackFinishedProc, Dialog) = 0 then begin EnableWindow(GetDlgItem(Dialog, ID_BTN_START_RECORDING), True); EnableWindow(GetDlgItem(Dialog, ID_BTN_STOP_RECORDING), False); EnableWindow(GetDlgItem(Dialog, ID_BTN_PLAYBACK), True); EnableWindow(GetDlgItem(Dialog, ID_BTN_DONE), True); SetFocus(GetDlgItem(hWnd(Dialog), ID_BTN_PLAYBACK)); end; exit; end; ID_BTN_DONE: begin EndDialog(Dialog, ID_BTN_DONE); exit; end;

719

end; {wParam} end; {WM_COMMAND} WM_CLOSE: begin FreeProcInstance(@PlaybackFinishedProc); EndDialog(Dialog, IDOK); exit; end; end; MainDlgProc := False; end; procedure Init; var WindowClass: TWndClass; WinVer: TWinVersion; begin Longint(WinVer) := GetVersion; if ((WinVer.WinMajor < 3) OR ((WinVer.WinMajor = 3) AND (WinVer.WinMinor < 10)) ) then begin Messagebox(0, 'Microsoft Windows 3.10 or greater required!', APPNAME, MB_OK); halt; end; @PlaybackFinishedProc := MakeProcInstance(@PlaybackFinished, hInstance); If @PlaybackFinishedProc = nil then begin Messagebox(0, 'Cannot create instance thunk!', APPNAME, MB_OK); halt; end; if FindWindow(CLASSNAME, APPNAME) <> 0 then begin Messagebox(0, 'Multiple Sessions not allowed', APPNAME, MB_OK); halt; end else begin WindowClass.Style := CS_BYTEALIGNWINDOW; WindowClass.lpfnWndProc := @HookItDialogProc; WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := DLGWINDOWEXTRA; WindowClass.hInstance := hInstance;

720

WindowClass.hIcon := LoadIcon(0, IDI_APPLICATION); WindowClass.hCursor := LoadCursor(0, IDC_ARROW); WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH); WindowClass.lpszMenuName := nil; WindowClass.lpszClassName := CLASSNAME; if not Bool(RegisterClass(WindowClass)) then begin Messagebox(0, 'RegisterClass Failed!', APPNAME, MB_OK); halt; end; end; end; procedure MyWinMain; var WindowProc:TFarProc; begin WindowProc:=MakeProcInstance(@MainDlgProc, hInstance); DialogBox(hInstance, 'HOOKIT', 0, WindowProc); FreeProcInstance(WindowProc); end; {WinMain} begin Init; MyWinMain; end. Conclusion: While writing Windows applications gets easier as development tools get more sophisticated, there will be times when you must "bite the bullet" and a interface to new functions that are not handled by your current tools. Remember... before you explore unchartered paths, check available resources for documentation that may help to make your journey a pleasant and rewarding experience.

721

RTL reference|Glossary|Tips/Tricks|FREE App/VCL|Best'O'Net|Books|Link To

Windows Shell Extensions – Info Tip Page 1: Shell extensions allow developers to add functionality to the existing Windows shell.

Creating the InfoTip Shell Extension, which lets us, control the information that appears in Explorer when the mouse hovers over a file. Creating a Delphi Infotip that will display the FileName, the project type (Program or Library), the Project Name (from the source file), and the size of the file in bytes. Article submitted by: Larry J. Rutledge With each new release of Windows, its shell becomes more and more advanced and adds many new useful features. One of the ways this is done is through shell extensions. These extensions allow developers to add functionality to the existing Windows shell. Some examples of shell extensions are Context Menus (menus that change based on what object has focus when you right-click), Property Sheet Handlers (tabbed pages that appear when the Properties menu item is selected from an object’s context menu), Icon Overlays (appear as the arrow on top of an icon that points to a shortcut or the hand that appears on shared folders), Folder Customization, and many, many more. Over the course of a few articles we will examine several of these extensions and, in particular, how to build them in Delphi. There is plenty of information about shell extensions available from the Microsoft web site, but these articles will bring it to the Delphi audience. In this first article we will look at the InfoTip Shell Extension, which lets us control the information that appears in Explorer when the mouse hovers over a file. Important Note The following paragraph from Dino Esposito’s article, "Windows 2000 UI Innovations: Enhance Your User’s Experience with New Infotip and Icon Overlay Shell Extensions" (MSDN Magazine, March 2000) is a good description of what versions of Windows these extensions apply to: "…I should point out that not all the features I'll cover here are completely new. Many of them were already introduced with the Desktop Update – a separate shell update available both for Windows 9x and Windows NT 4.0. The Desktop Update shipped with Microsoft Internet Explorer 4.0 and Windows 98. Note that the Desktop Update is not part of Internet Explorer 5.0. So if you want to install it on Windows NT 4.0, you need to install Internet Explorer 4.0 first, making sure you select the Desktop Update option. Internet Explorer 5.0 will upgrade an existing Desktop Update on Windows NT 4.0 and Windows 95, but will not install it from scratch." Shell Extension – Quick Overview Shell Extensions are implemented as In Process COM servers. Windows Explorer invokes the appropriate extension in response to shell-wide events. Explorer was designed to respond in very specific ways when the user performs various functions within its shell. The first thing Explorer does is check for any modules that have been registered for a specific event and if one exists it attempts to load the module. To be a valid shell extension, the COM server must implement an interface that defines the specific behavior for the desired extension and it must implement an interface that defines its initialization behavior. Finally, to be a valid shell extension, the COM server must follow the approved method of registering itself with the system. The following table from Dino Esposito's article "Windows 2000 UI innovations: Enhance Your User's Experience with New Infotip and Icon Overlay Shell Extensions" (MSDN Magazine, March 2000), lists all the types of shell extensions available today, the minimum shell

722

March 2000), lists all the types of shell extensions available today, the minimum shell version each requires, the involved interfaces, and a brief description: Type

Apply To

Version

Context Menu

File class and shell’s object

Windows 95+

IContextMenu, IContextMenu2, or IContextMenu3

Allows you to add new items to a shell object’s context menu.

Right Drag and Drop


IContextMenu, IContextMenu2, or IContextMenu3

Allows you to add new items to the context menu that appears after your right drag and drop files.

Drawing Shell Icons


IExtractIcon

Lets you decide at runtime which icon should be displayed for a given file within a file class.

Property Sheet


IShellPropSheetExt

Lets you insert additional property sheet pages to the file class Properties dialog. It also works for Control Panel applets.

Left Drag and Drop


IDropTarget

Lets you decide what to do when an object is being dropped (using the left mouse button) onto another one within the shell.

Clipboard


IDataObject

Lets you define how an object is to be copied to and extracted from the clipboard.

Interface Involved

Description

Windows 95+

Windows 95+

Windows 95+

Windows 95+

Windows 95+

Windows 95+

File Hook

ICopyHook

Lets you control any file operation that goes through the shell. While you can permit or deny them, you aren’t informed about success or failure.

Program Execution

Explorer

IShellExecuteHook

Lets you hook any program’s execution that passes through the shell.

Infotip


IQueryInfo

Lets you display a short text message when the mouse hovers over documents of a certain file type.

Column

Folders

IColumnProvider

Lets you add a new column to the Details view of Explorer.

Icon Overlay

Explorer

IShellIconOverlay

Lets you define custom images to be used as icon overlays.

Search

Explorer

IContextMenu

Lets you add a new entry on the Start menu’s Search menu.

Cleanup

Cleanup Manager

IEmptyVolumeCache2

Lets you add a new entry to the Cleanup Manager to recover disk space.

Desktop Update

Desktop Update

Windows 2000

Windows 2000

Windows 2000

Windows 2000

723

Next page > InfoTip – Introduction and Overview > Page 1, 2, 3

Windows Shell Extensions – Info Tip Page 2: InfoTip – Introduction and Overview; Implementing Infotip Extensions

InfoTip – Introduction and Overview Infotip's are hint windows that pop up when the mouse hovers over any file. If an extension has not been registered for the file type a default Infotip appears (see Figure 1 for an example of this), but you can create your own extension to display any information you want for the specific file type. Office 2000 installs default handlers for MS Word and MS Excel that display the Name, Author and Title from the document properties. Infotip extensions differ from other shell extensions in its registration, we'll discover the differences later when we talk about registration of our Infotip extensions.

Implementing Infotip Extensions An Infotip Extension is an In-Process (Inproc) COM Server. This just means that it is a Windows DLL that exports the necessary methods to be a valid ActiveX control. Infotip Extensions also implement IQueryInfo and IPersistFile and must register itself into the registry. Because IQueryInfo and IPersistFile are interfaces, they don't contain code for their defined methods. It is required that our object implement every method defined in both of these interfaces; however, some of the methods are not necessary for our Infotip extension so we simply return E_NOTIMPL to indicate that these are not implemented. IQueryInfo provides the text to display in the hint window and contains two methods: · GetInfoFlags – Retrieves the information flags for an item. Microsoft states that this is currently unused, so we return E_NOTIMPL. · GetInfoTip – Retrieves the text of the Infotip. GetInfoTip is defined as follows: function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall; .dwFlags – currently not used .ppwszTip – Address of a Unicode string pointer that receives the tip string pointer. Important Note The ppwszTip parameter of the GetInfoTip method is a pointer to a Unicode string buffer that contains the text to display in the tip. This buffer must be allocated using the standard shell memory allocator because the buffer is allocated by our application, but freed by the shell. To ensure that everything happens in a thread-safe way, use SHGetMalloc to get the pointer to the shell's memory allocator – an object implementing IMalloc. Then, use IMalloc's Alloc method to allocate the memory needed to hold the Unicode representation of the

724

Infotip text. The accompanying source code contains the standard code you will use for all Infotip Extensions you create. Simply use the same code and your extensions will be shell friendly and thread-safe. IPersistFile is what the shell uses to provide the extension with information about the file the user is hovering over. The interface defines five methods: .IsDirty – checks an object for changes since it was last saved to its current file. We don't need this for Infotip extensions so we return E_NOTIMPL. .Load – opens the specified file and initializes an object from the file contents. We use this method to retrieve the name of the file the user is hovering over. .Save – saves the object into the specified file. We don't use it, so return E_NOTIMPL. .SaveCompleted – notifies the object that it can revert from NoScribble mode to Normal mode. We don't use it, so return E_NOTIMPL. .GetCurFile – gets the current name of the file associated with the object. We don't use it, so return E_NOTIMPL. Load is defined as follows: function Load(pszFileName: PoleStr; dwMode: LongInt ): HResult; stdcall; .pszFileName – points to a zero-terminated string containing the absolute path of the file to open. .dwMode – specifies some combination of the values from the STGM enumeration to indicate the access mode to use when opening the file. We are only using the IPersistFile interface to obtain the path and filename of the file; we are not actually using the interface to access the file so we can ignore the flags. Our standard implementation of the Load method will be to store the contents of pszFileName to a private variable to be used by IQueryInfo::GetInfoTip to locate the file. Next page > Delphi project: Infotip; Registering Infotip Extensions > Page 1, 2, 3

Windows Shell Extensions – Info Tip Page 3: Delphi project: Infotip; Registering Infotip Extensions

More of this Feature • Page 1: Shell extensions • Page 2: InfoTip overview Printer friendly version

Delphi project: Infotip Source download Compiled Project (169KB) Contains DPRInfoTip.dll. Project Files (6KB) - Contains the Delphi project source files. Registration File (1KB) Contains two registration files (one for Win9x and one for Win2000).

The accompanying source code contains a complete Infotip Extension for .DPR (Delphi Project files). This Infotip will display the FileName, the project type (Program or Library), the Project Name (from the source file), and the size of the file in bytes.

To begin, we need to create an automation object called DPRInfoTip. First, click File | New... to open the Object Repository, then click on the ActiveX tab and select the ActiveX Library. This will generate an empty ActiveX library and export the necessary function required to be a valid automation object. Next, click File | New... again and select the ActiveX tab and select the Automation Object. When the Automation Object Wizard opens, enter DPRInfoTip as the CoClass name (see Figure 2 below for an example of how the dialog should look). Leave the remaining options with their default values and click OK, this will generate the basic Type Library and

725

implement a skeleton for the IDPRInfoTip interface, which gets automatically generated.

Once the files have been created the next thing we need to do is to add support for the additional interfaces that must be supported: TDPRInfoTip = class(TAutoObject, IDPRInfoTip, IQueryInfo, IPersistFile, IPersist); Note: We need to implement IPersist also because IPersistFile inherits from IPersist. The accompanying source code can be used for all InfoTip Extensions, the only code that must be altered is the GenerateTip method. This is the method that determines the text to display in the InfoTip. In the Initialization method, we call SHGetMalloc, which causes Windows to allocate some memory and return a pointer to it in the pMalloc private variable. In the destructor, we set pMalloc equal to Nil. This releases our hold on the memory so the Windows shell can release the memory when necessary. IPersistFile::Load When the mouse hovers over a file, the shell calls the Load method to provide the name of the file. Our implementation stores the name of the file in a private variable, FFile, so it will be available when we need to generate the InfoTip text. function TDPRInfoTip.Load (pszFileName: POleStr; dwMode: Integer): HResult; begin FFile := pszFileName; Result := S_OK;

end; For all remaining IPersistFile methods, simply return E_NOTIMPL. IQueryInfo::GetInfoTip When the shell is ready to display the InfoTip, it calls the GetInfoTip method to retrieve the text to display. Our implementation calls the custom GenerateTip method in order to determine the text to display. It then is converted to a Windows compatible WideString and returned in the ppwszTip parameter. The GenerateTip method opens the .DPR file and reads contents into a string. The text to be returned first is assigned the filename of the selected file, then the type is assigned the first word in the project file; which is either Program or Library. Finally the project name is extracted from the remainder of the first line and the size of the file in bytes is determined by the size of the stream. The GenerateTip method can be customized to fit the needs of the InfoTip Extension being developed. Registering Infotip Extensions There are two steps to register an InfoTip Extension: 1. Register the COM DLL using regsvr32.exe (Start..Run dialog box) regsvr32 "C:\...\DPRInfoTip.dll"

726

2. Add a reference to the associated extension (.dpr) to the HKEY_CLASSES_ROOT registry key. The default value for this new key must be the CLSID of the COM object that implements the Shell Extension. This can be obtained from the Type Library file that was generated by Delphi (the filename ends in "_TLB.pas"). For our example extension the CLSID is named CLASS_DPRInfoTip and contains the value "{B20433A8-D083-11D4-993A00D00912C440}". The easiest way to make the registry changes is to make a copy of the .REG file provided with the source code for this project. Change the CLSID and file extension to the associated values. One important note, it is necessary to "approve" shell extensions under Windows NT and 2000. This means that you must be logged into the machine with Administrator rights in order to register the extension. That's all folks That's it for this article. In the future articles we'll see how to use Delphi to implement other shell extensions. In the mean time, if you have any questions regarding this article, please post them to the Delphi Programming Forum.

727

Shell Extensions in Delphi 3 by Ray Konopka December/January 1998, Vol. 8, No. 5 -- Download Source Code

The Explorer is the central user interface metaphor in Windows, and your Delphi applications can embed special hooks right into Explorer. Welcome to the third part of my series on COM support in Delphi 3. In part one, I introduced object interfaces and explained how they are defined using the interface keyword. In part two, I described how interfaces affect the creation of automation servers and controllers in Delphi 3. In this issue, I will describe how to extend the Windows Explorer shell by creating custom COM servers that implement specific, you guessed it, interfaces.

What Are Shell Extensions? Shell extensions, as the term implies, provide a way to extend the abilities of the Windows 95 or NT 4.0 Explorer. There are several different types of shell extensions, which are categorized into two groups. While Table 1 summarizes the extensions that are associated with a particular file type, Table 2 lists the ones that are associated with file operations.

728

A shell extension is implemented as a COM object that resides inside an in-process COM server. Recall from part one that an in-process server is just a DLL, and that Delphi 3 calls them ActiveX Libraries. The Windows Explorer accesses the shell extension through interfaces. Consider the following: In the example that I presented in the last issue, the automation controller called the methods defined in the IViewer interface supported by the automation server. For shell extensions, the Windows Explorer itself functions as the controller and calls the methods in the COM object by using an interface reference. Since Windows itself is calling the methods of a shell extension, the interfaces that Windows uses for accessing shell extensions are predefined. So, instead of defining new methods and properties of an interface like we do when creating an automation server, creating a shell extension involves implementing the appropriate methods defined by the shell extension interfaces. Unfortunately, actually implementing the methods can be a challenge. We’ll cover the details of these interfaces shortly.

Creating a Shell Extension Unlike automation objects, there is no expert defined in Delphi that makes it easy to create a shell extension COM object. In fact, we have to code everything by hand. To demonstrate the process, we’ll construct a new context menu handler that displays a “View as Text” menu item when the user clicks on a Delphi form file using mouse button 2. If the user selects this menu item, the form file viewer application that I presented in part two is used to display the text representation of the selected form file. To create a shell extension, you must first create the COM server that will hold the extension, or handler. Select the File|New menu item and then switch to the ActiveX page. Select the ActiveX Library icon and then click the OK button to instruct Delphi to create a new project file for the library. Next, create a new unit to contain the implementation of the shell extension. Select the File|New menu item and then double-click on the Unit icon. Once the new unit is created, we need to declare the COM object class—that is, we must declare a new class that supports the particular interfaces of the shell extension. For a context menu, the class must support the IShellExtInit and IContextMenu interfaces. Of course, each of the methods in these interfaces must be defined in the implementation section of the unit. Listing 1 is the source code for the FormView ActiveX library, and Listing 2 is the complete source code for the FormViewImpl unit, which implements the TFormViewContextMenu class. As you can see, this class descends from TComObject, which is defined in the ComObj unit, and 729

lists IShellExtInit and IContextMenu as its supported interfaces. Recall that all interfaces are derived from IUnknown, so this class also supports the IUnknown interface. In addition, all interfaces listed in TComObject are supported. However, for our shell extension, all we need to be concerned with are the methods in IShellExtInit and IContextMenu.

The IShellExtInit Interface To initialize a context menu shell extension, Windows uses the IShellExtInit interface. In addition to the standard IUnknown methods, IShellExtInit declares an Initialize method. However, the TFormViewContextMenu class does not define an Initialize method. Instead, it defines the ShellInit method and uses a method resolution clause to map the IShellExtInit.Initialize method to ShellInit. The reason for doing this is because the TComObject class defines a virtual Initialize method that is not compatible with IShellExtInit. (Method resolution clauses were covered in part one of this series.) IShellExtInit.Initialize (and ShellInit) receive three parameters. The first identifies the folder containing the file objects being manipulated. The second parameter is a reference to an IDataObject interface, which is used to obtain the name of the selected files. The third parameter is the ProgID for the type of file that is selected. Although the selected file names are stored in the same way that Windows stores file names during a drag operation, extracting the name of the selected file is not as simple as calling DragQueryFile. First, the information referenced by the DataObject must be converted into a storage medium that can be referenced within the shell extension. This is accomplished by setting up a TFormatEtc record and then calling the GetData method of the DataObject. Now the DragQueryFile can be called to obtain the name of the selected file, which is then stored in the private FFileName field. Notice in Listing 2 that we obtain the file name only if one file is selected.

The IContextMenu Interface After the context menu handler is initialized via the IShellExtInit interface, Windows uses the IContextMenu interface to call the other methods of our context menu handler. Specifically, it will call QueryContextMenu, GetCommandString, and InvokeCommand. Let’s take a closer look at each one. The QueryContextMenu method is called just before Windows displays a file object’s context menu. Implementing this method allows your shell extension to add menu items to the context menu. This is accomplished by calling the InsertMenu function and passing it the handle to the context menu, which is the first parameter to QueryContextMenu. Although having access to the menu’s handle would suggest that you have complete access to the menu, you don’t. In fact, there are several restrictions in what you can do with the context menu. First, you can only add items (no moving or deleting items), and you are only allowed to add string items. In addition, you must insert the new items starting at the position indicated by the Index parameter. And finally, you must use the CmdFirst parameter as the starting menu identifier for any menu items added. The Flags parameter passed to QueryContextMenu must be checked to make sure it is safe to add new menu items. The Flags parameter must contain at least one of the following values before a new menu item can be added: CMF_NORMAL, CMF_VERBSONLY, and CMF_EXPLORE. The CMF_NORMAL flag indicates that the selected file is located on the Windows Desktop. The CMF_VERBSONLY flag indicates that the selected file object is actually a shortcut to another file. The CMF_EXPLORE flag indicates that the file is being selected within a separate instance of Windows Explorer. 730

To demonstrate the effect of each flag, the QueryContextMenu method of the form viewer context menu alters the menu string depending on which flag is specified. Each situation is illustrated in Figures 1 through 3.

Figure 1: Selecting a form file within the Explorer.

Figure 2: Selecting a form file on the desktop.

731

Figure 3: Selecting a shortcut to a form file. Take a closer look at the Explorer status bar in Figure 1. Notice that the status bar displays a help string associated with the selected item in the context menu. The Explorer requests this string from our context menu handler by calling the GetCommandString method. The Cmd parameter to this method indicates which menu item is selected, and the Flags parameter is used to determine when to return a help string. In particular, the help string is returned in the Name parameter only when Flags is equal to GCS_HELPTEXT. When the user selects one of the menu items added by a context menu handler, Windows calls the InvokeCommand method. This method receives a single record parameter specifying the command to invoke and other useful information such as a window handle to use when displaying message boxes. The InvokeCommand method for our form viewer context menu uses the CreateProcess function to start the FormFileViewer application that I presented in the last issue. The location of the viewer is found in the Registry, which the viewer updates whenever it is executed. Therefore, the shell extension will always be able to find the viewer. The file name of the select form file is passed to the viewer on the command line. The viewer processes the command line and displays the contents of the form file as shown in Figure 4.

732

Figure 4: Form viewer started by a shell extension. Now that all of the necessary methods have been implemented, there is one more item that must be added to the FormViewImpl unit.

Creating a COM Object Factory In order for our COM object to be created whenever the FormView DLL is loaded, we need to create an instance of a class factory that specifically creates an instance of our shell extension object. Recall from part one that I prefer the term object factory instead of class factory because a class factory creates objects and not classes. In the initialization section of the unit implementing the shell extension COM object, you need to create an instance of the object factory. Fortunately, this is quite easy, thanks to the predefined classes in Delphi 3. In particular, we use the TComObjectFactory class defined in the ComObj unit. Notice that the class name and ClassID of the shell extension are passed to the constructor of the factory. Because shell extensions are implemented as COM objects, and because Windows itself accesses them, we must generate a ClassID for any new shell extensions. But how do we do that? In the examples presented in part two of this series, Delphi automatically generated ClassIDs whenever one was needed. Fortunately, Delphi 3 provides the means to manually generate a ClassID within the code editor. Simply press the Ctrl+Shift+G key combination and Delphi automatically inserts a new GUID into the code editor. This is how the TGUID constant declared at the beginning of the FormViewImpl unit was created.

Registering a Shell Extension Now that the FormViewImpl unit is completed, we can compile the FormView project and generate the COM Server DLL that Windows will load whenever the user clicks on a Delphi form file using mouse button 2. But how does Windows know that it should load the FormView.dll? As usual, Windows relies on specific entries in the Registry to accomplish this. There are three ways the entries can be made in the Registry. First, they can be entered manually 733

using RegEdit, but this is not recommended because incorrectly editing the Registry can cause system problems. The second option is to merge the entries into the Registry. This involves creating a text file (with a REG extension) that contains the new entries. Clicking mouse button 2 on the file displays a context menu containing a Merge command. Selecting this command merges the items in the file into the Registry. This approach is safer than using RegEdit but requires customizing the file for each user because the complete path of the DLL must be specified in the REG file. The third option is to add the entries programmatically. Most installation programs (for example, WISE Installation System) provide a way to modify the Registry, and since the installation program knows where the DLL is installed, the correct path can be determined during the installation process. This makes this approach the most appropriate for registering shell extensions. Another alternative to using a custom installation program is to create a simple Delphi program that makes the necessary Registry entries. This is the approach I took for this article. Listing 3 shows the source code for the RegMain unit, which is the main form file unit in the FormViewReg program. Simply run this program from the same folder that contains the FormView.dll and the required entries are made in the Registry. Note that if you decide to move the FormView.dll, you will need to rerun the FormViewReg program. The actual entries that need to be added depend on the type of shell extension, but all shell extensions require some basic settings. First, the ClassID of your extension must be registered under the HKEY_CLASSES_ROOT\CLSID key. The CLSID key contains a list of class identifier keys. Within each ClassID key, you must add an InProcServer32 key that specifies the location of the shell extension DLL. The information that the shell uses to associate a shell extension with a particular file type is stored under the shellex key, which is under the ProgID for the file type. Context menu handlers are registered under the ContextMenuHandlers key. Within this key, the ClassID of the handler is listed. The FormCreate event handler in Listing 3 shows the entries that must be made for the Delphi form viewer context menu.

For More Information I relied on two sources of information in developing the shell extension for this article. The first one is the Microsoft Development Network (MSDN). Since Microsoft defines the shell extension interfaces, this is the best place to find detailed information about what the methods of each interface must accomplish. The second source of information came from the Delphi 3 source code—in particular, the ShlObj unit, which has quite a few comments regarding the shell extension interfaces.

On the Drawing Board Over the past three installments of “Delphi by Design,” the focus has been on COM support in Delphi 3. Along the way, we’ve seen how interfaces are used to manipulate objects, how interfaces define the abilities of automation servers, and how Windows itself relies on them. All of this information serves as a foundation for the topic I’ll be covering in the next issue: How to convert a native Delphi component into an ActiveX control. v Copyright © 1998 The Coriolis Group, Inc. All rights reserved.

734

Listing 1 - FormView.dpr library FormView; uses ComServ, FormViewImpl in 'FormViewImpl.pas'; exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; {$R *.RES} begin end.

Listing 2 - FormViewImpl.pas {=============================================================== FormViewImpl Unit This unit implements the TFormViewContentMenu class, which is a COM object that supports the IShellExt and IContextMenu interfaces. ===============================================================} unit FormViewImpl; interface uses Windows, Forms, StdCtrls, ShellApi, SysUtils, Classes, Controls, ComServ, ComObj, ShlObj, ActiveX; const CLSID_DelphiFormViewerContextMenu: TGUID = '{F169D961-B907-11D0-B8FA-A85800C10000}'; type TFormViewContextMenu = class( TComObject, IShellExtInit, IContextMenu ) private FFileName: string; public // IShellExtInit Methods // Use a Method Resolution Clause because Initialize is // defined as a virtual method in TComObject function IShellExtInit.Initialize = ShellInit; function ShellInit( Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY ): HResult; stdcall; // IContextMenu Methods function QueryContextMenu( Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT ): HResult; stdcall; function GetCommandString( Cmd, Flags: UINT;

735

Reserved: PUINT; Name: LPSTR; MaxSize: UINT ): HResult; stdcall; function InvokeCommand( var CommandInfo: TCMInvokeCommandInfo ): HResult; stdcall; end; implementation uses Registry; {==================================} {== TFormViewContextMenu Methods ==} {==================================} function TFormViewContextMenu.ShellInit( Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY ): HResult; var Medium: TStgMedium; FE: TFormatEtc; begin if DataObject = nil then begin Result := E_FAIL; Exit; end; with FE do begin cfFormat := CF_HDROP; ptd := nil; dwAspect := DVASPECT_CONTENT; lindex := -1; tymed := TYMED_HGLOBAL; end; // Transfer the data referenced by the IDataObject reference to // an HGLOBAL storage medium in CF_HDROP format. Result := DataObject.GetData( FE, Medium ); if Failed( Result ) then Exit; try // If only one file is selected, retrieve the file name and // store it in FileName. Otherwise fail. if DragQueryFile( Medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then begin SetLength( FFileName, MAX_PATH ); DragQueryFile( Medium.hGlobal, 0, PChar(FFileName), MAX_PATH); Result := NOERROR; end else Result := E_FAIL; finally ReleaseStgMedium( Medium ); end; end; function TFormViewContextMenu.QueryContextMenu( Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT ): HResult; var MenuText: string; AddMenuItem: Boolean; begin

736

AddMenuItem := True; if ( Flags and $000F ) = CMF_NORMAL then MenuText := 'View (Form File on Desktop) as Text' else if ( Flags and CMF_VERBSONLY ) <> 0 then MenuText := 'View (Form File via Shortcut) as Text' else if ( Flags and CMF_EXPLORE ) <> 0 then MenuText := 'View (Form File in Explorer) as Text' else AddMenuItem := False; if AddMenuItem then begin InsertMenu( Menu, Index, mf_String or mf_ByPosition, CmdFirst, PChar( MenuText ) ); Result := 1; // Return number of menu items added end else Result := NOERROR; end; {= TFormViewContextMenu.QueryContextMenu =} function TFormViewContextMenu.GetCommandString( Cmd, Flags: UINT; Reserved: PUINT; Name: LPSTR; MaxSize: UINT ): HResult; begin case Cmd of 0: begin if Flags = GCS_HELPTEXT then begin // Return the string to be displayed in the Explorer // status bar when the menu item is selected StrCopy(Name, 'View the selected Delphi form file as text'); end; Result := NOERROR; end; else // Invalid menu item Result := E_INVALIDARG; end; end; {= TFormViewContextMenu.GetCommandString =} function GetViewerPath: string; var R: TRegIniFile; begin R := TRegIniFile.Create( '\Software\Raize\FormFileViewer' ); try Result := R.ReadString( 'Program', 'Path', '' ); Result := '"' + Result + '" "%s"'; finally R.Free; end; end; function TFormViewContextMenu.InvokeCommand( var CommandInfo: TCMInvokeCommandInfo ): HResult; var Success: Boolean; CmdLine: string; SI: TStartupInfo; PI: TProcessInformation; begin // Make sure we are not being called by an application if HiWord( Integer( CommandInfo.lpVerb ) ) <> 0 then

737

begin Result := E_FAIL; Exit; end; // Execute the command specified by CommandInfo.lpVerb case LoWord( CommandInfo.lpVerb ) of 0: begin FillChar( SI, SizeOf( SI ), #0 ); SI.cb := SizeOf( SI ); SI.wShowWindow := sw_ShowNormal; SI.dwFlags := STARTF_USESHOWWINDOW; CmdLine := Format( GetViewerPath, [ FFileName ] ); Success := CreateProcess( nil, PChar( CmdLine ), nil, nil, True, 0, nil, nil, SI, PI ); if not Success then begin MessageBox( CommandInfo.hWnd, 'Could not start the Form File Viewer.', 'Error', mb_IconError or mb_OK ); end; Result := NOERROR; end; else // Invalid menu item Result := E_INVALIDARG; end; { case } end; {= TFormViewContextMenu.InvokeCommand =} initialization // Create a COM object factory which will be responsible for // creating instances of our shell extension. ComServer is // declared in ComServ unit. TComObjectFactory.Create( ComServer, TFormViewContextMenu, CLSID_DelphiFormViewerContextMenu, '', 'View Delphi Form Files', ciMultiInstance ); end.

Listing 3 - RegMain.pas unit RegMain; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Panel1: TPanel; Label1: TLabel; Image1: TImage; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject);

738

private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses Registry; const FormViewerClassID = '{F169D961-B907-11D0-B8FA-A85800C10000}'; procedure TForm1.FormCreate(Sender: TObject); var Reg: TRegistry; begin Reg := TRegistry.Create; try with Reg do begin RootKey := HKEY_CLASSES_ROOT; OpenKey( '\CLSID\' + FormViewerClassID, True ); WriteString( '', 'Delphi Form Viewer Context Menu Shell Extension'); OpenKey( '\CLSID\' + FormViewerClassID + '\InProcServer32', True ); WriteString( '', ExtractFilePath( Application.ExeName ) + '\FormView.dll' ); WriteString( 'ThreadingModel', 'Apartment' ); CreateKey( '\DelphiForm\shellex\ContextMenuHandlers\' + FormViewerClassID ); end; finally Reg.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin Close; end; end.

739

Unit KeyBoardHookUnit; Interface Uses Windows, SysUtils, Forms, Controls, StdCtrls, Classes, Dialogs, Messages; Const CM_HookMessage = WM_APP + 400; Type TKeyboardHookForm = class(TForm) procedure FormCreate(SEnder: TObject); procedure FormDestroy(SEnder: TObject); Private { Private declarations } Procedure HookMessageTrigger(Var Message: TMessage); Message CM_HookMessage; public { Public declarations } End; Var KeyboardHookForm: TKeyboardHookForm; Implementation {$R *.dfm} {Functions prototypes for the hook dll} Type TGetHookRecPointer = Function: Pointer; Stdcall; Type TStartKeyBoardHook = Procedure; Stdcall; Type TStopKeyBoardHook = Procedure; Stdcall; {The record type filled in by the hook dll} Type THookRec = Packed Record TheHookHandle : HHOOK; TheAppWinHandle : HWND; TheCtrlWinHandle : HWND; TheCtrlMessage : Integer; TheKeyCount : DWORD; IsAltPressed : bool; IsCtrlPressed : bool; IsShiftPressed : bool; KeyCode: Integer; End; {A pointer type to the hook record} Type PHookRec = ^THookRec; Var hHookLib : THANDLE; {A handle to the hook dll} GetHookRecPointer : TGetHookRecPointer; {Function pointer} StartKeyBoardHook : TStartKeyBoardHook; {Function pointer} StopKeyBoardHook : TStopKeyBoardHook; {Function pointer} LibLoadSuccess : bool; {If the hook lib was successfully loaded} lpHookRec : PHookRec; {A pointer to the hook record} EnterKeyCount : DWORD; {An internal count of the Enter Key} Procedure TKeyboardHookForm.FormCreate(SEnder: TObject); Begin {Set our initial variables} lpHookRec := Nil; LibLoadSuccess := False;

740

@GetHookRecPointer := Nil; @StartKeyBoardHook := Nil; @StopKeyBoardHook := Nil; {Try to load the hook dll} hHookLib := LoadLibrary('KEYBOARDHOOK.DLL'); {If the hook dll was loaded successfully} If hHookLib <> 0 Then Begin {Get the function addresses} @GetHookRecPointer := GetProcAddress(hHookLib, 'GETHOOKRECPOINTER'); @StartKeyBoardHook := GetProcAddress(hHookLib, 'STARTKEYBOARDHOOK'); @StopKeyBoardHook := GetProcAddress(hHookLib, 'STOPKEYBOARDHOOK'); {Did we find all the functions we need?} If ((@GetHookRecPointer <> Nil) And (@StartKeyBoardHook <> Nil) And (@StopKeyBoardHook <> Nil)) Then Begin LibLoadSuccess := True; {Get a pointer to the hook record} lpHookRec := GetHookRecPointer; {Were we successfull in getting a ponter to the hook record} If (lpHookRec <> Nil) Then Begin {Fill in our portion of the hook record} lpHookRec^.TheHookHandle := 0; lpHookRec^.TheCtrlWinHandle := KeyBoardHookForm.Handle; lpHookRec^.TheCtrlMessage := CM_HookMessage; lpHookRec^.TheKeyCount := 0; {Start the keyboard hook} StartKeyBoardHook; End; End Else Begin {We failed to find all the functions we need} FreeLibrary(hHookLib); hHookLib := 0; @GetHookRecPointer := Nil; @StartKeyBoardHook := Nil; @StopKeyBoardHook := Nil; End; End; End; Procedure TKeyboardHookForm.FormDestroy(SEnder: TObject); Begin {Did we load the dll successfully?} If (LibLoadSuccess = True) Then Begin {Did we sucessfully get a pointer to the hook record?} If (lpHookRec <> Nil) Then Begin {Did the hook get set?} If (lpHookRec^.TheHookHandle <> 0) Then Begin StopKeyBoardHook; End; End; {Free the hook dll} FreeLibrary(hHookLib); End;

741

End; End.

742

MSOffice/Word 23. Delphi 2.01 / MS Office 97 / OLE / VB for Applications 24. OLE Tester 25. Getting data from Delphi app into Word document 26. WordBasic via OLE 27. Creating Word Documents 28. Starting Word without AutoStart Macro 29. Wordbasic from Delphi using Parameters 30. Hack: tired of ReportSmith? Wish you had wysiwyg reports? 31. Excelmsoffice8 32. Delphi + WordBasic 8msoffice9

Delphi 2.01 / MS Office 97 / OLE / VB for Applications From: "Jill Marquiss" This answers those really interesting questions of How do you know whether word8 is installed? Where are the templates? Why do I keep getting a new instance when I didn't want one? Where the heck is the document the user was typing on? Why does word end when my procedure ends? How about that Outlook - how do I get to the folders? How to make a simple contact and how to fish for an existing contact? {--------------------Straight from the type library--------------- WORDDEC.INC} Const // OlAttachmentType olByValue = 1; olByReference = 4; olEmbeddedItem = 5; olOLE = 6; // OlDefaultFolders olFolderDeletedItems = 3; olFolderOutbox = 4; olFolderSentMail = 5; olFolderInbox = 6; olFolderCalendar = 9; olFolderContacts = 10; olFolderJournal = 11; olFolderNotes = 12; olFolderTasks = 13; // OlFolderDisplayMode olFolderDisplayNormal = 0; olFolderDisplayFolderOnly = 1; olFolderDisplayNoNavigation = 2; // OlInspectorClose olSave = 0; olDiscard = 1; olPromptForSave = 2; // OlImportance olImportanceLow = 0; olImportanceNormal = 1; olImportanceHigh = 2;

743

// OlItems olMailItem = 0; olAppointmentItem = 1; olContactItem = 2; olTaskItem = 3; olJournalItem = 4; olNoteItem = 5; olPostItem = 6; // OlSensitivity olNormal = 0; olPersonal = 1; olPrivate = 2; olConfidential = 3; // OlJournalRecipientType; olAssociatedContact = 1; // OlMailRecipientType; olOriginator = 0; olTo = 1; olCC = 2; olBCC = 3 ; Const wdGoToBookmark = -1; wdGoToSection = 0; wdGoToPage = 1; wdGoToTable = 2; wdGoToLine = 3; wdGoToFootnote = 4; wdGoToEndnote = 5; wdGoToComment = 6; wdGoToField = 7; wdGoToGraphic = 8; wdGoToObject = 9; wdGoToEquation = 10; wdGoToHeading = 11; wdGoToPercent = 12; wdGoToSpellingError = 13; wdGoToGrammaticalError = 14; wdGoToProofreadingError = 15; wdGoToFirst = 1; wdGoToLast = -1; wdGoToNext = 2; //this is interesting wdGoToRelative = 2; //how can these two be the same wdGoToPrevious = 3; wdGoToAbsolute = 1;

These are basic functions Function Function Function Function Function Function Function Function Function Function Function

GetWordUp(StartType : string):Boolean; InsertPicture(AFileName : String) : Boolean; InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean; GetOutlookUp(ItemType : Integer): Boolean; MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean; ImportOutlookContact : Boolean; GetOutlookFolderItemCount : Integer; GetThisOutlookItem(AnIndex : Integer) : Variant; FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean; FindNextMyOutlookItem(var AItem : Variant) : Boolean; CloseOutlook : Boolean;

Type TTreeData = class(TObject) Public ItemId : String; end;

744

{$I worddec.inc} {literal crap translated from type libraries} Var myRegistry : TRegistry; GotWord : Boolean; WhereIsWord : String; WordDoneMessage : Integer; Basically : variant; Wordy: Variant; MyDocument : Variant; MyOutlook : Variant; MyNameSpace : Variant; MyFolder : Variant; MyAppointment : Variant;

Function GetWordUp(StartType : string):Boolean; // to start word the "right" way for me // if you start word, you own word and I wanted it to remain after I closed var i : integer; AHwnd : Hwnd; AnAnswer : Integer; temp : string; MyDocumentsCol : Variant; TemplatesDir : Variant; OpenDialog1 : TopenDialog; begin

result := false; myRegistry := Tregistry.Create; myRegistry.RootKey := HKEY_LOCAL_MACHINE; // no word 8, no function If myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word') then GotWord := true Else GotWord := false; If GotWord then //where the heck is it? If myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then begin WhereisWord := myRegistry.ReadString('BinDirPath'); MyRegistry.CloseKey; end else GotWord := false; If GotWord then //where are those pesky templates? Begin MyRegistry.RootKey := HKEY_CURRENT_USER; If myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates ', false) then Begin TemplatesDir := myRegistry.ReadString(Nothing); MyRegistry.CloseKey; end Else Begin Warning('Ole setup','The workgroup templates have not been setup'); GotWord := false;

745

end; End; myRegistry.free; If not gotword then Begin Warning('Ole Handler', 'Word is not installed'); exit; end; //this is the class name for the last two versions of word's main window temp := 'OpusApp'; AHwnd := FindWindow(pchar(temp),nil); If (AHwnd = 0) then //it isn't running and I don't wanna start it by automation Begin Temp := WhereisWord + '\winword.exe /n'; AnAnswer := WinExec(pchar(temp), 1); If (AnAnswer < 32) then Begin Warning('Ole Handler', 'Unable to find WinWord.exe'); Exit; End; End; Application.ProcessMessages; {If you use Word.Application, you get your own instance} {If you use Word.Document, you get the running instance} {this makes a trash document (for me, anyway) and I chuck it out later} try {and make a new document} Basically := CreateOleObject('Word.Document.8'); except Warning('Ole Handler', 'Could not start Microsoft Word.'); Result := False; Exit; end; Try {get the app variant from that new document} Wordy := Basically.Application; Except Begin Warning('Ole Handler', 'Could not access Microsoft Word.'); Wordy := UnAssigned; Basically := UnAssigned; Exit; end; end; Application.ProcessMessages; Wordy.visible := false; MyDocumentsCol := Wordy.Documents; {If its just my throw away document or I wanted a brand new one} If (MyDocumentsCol.Count = 1) or (StartType = 'New') then Begin OpenDialog1 := TOpenDialog.Create(Application); OpenDialog1.filter := 'WordTemplates|*.dot|Word Documents|*.doc'; OpenDialog1.DefaultExt := '*.dot'; OpenDialog1.Title := 'Select your template'; OpenDialog1.InitialDir := TemplatesDir; If OpenDialog1.execute then Begin Wordy.ScreenUpdating:= false; MyDocumentsCol := wordy.Documents; MyDocumentsCol.Add(OpenDialog1.Filename, False); OpenDialog1.free; end Else

746

begin OpenDialog1.Free; Wordy.visible := true; Wordy := Unassigned; Basically := Unassigned; Exit; end;

end Else {get rid of my throwaway} MyDocument.close(wdDoNotSaveChanges); {now I either have a new document based on a template the user selected or I have their current document} MyDocument := Wordy.ActiveDocument; Result := true; Application.ProcessMessages; end; Function InsertPicture(AFileName : String) : Boolean; var MyShapes : Variant; MyRange : variant; begin Result := True; If GetWordUp('Current')then Try Begin MyRange := MyDocument.Goto(wdgotoline, wdgotolast); MyRange.EndOf(wdParagraph, wdMove); MyRange.InsertBreak(wdPageBreak); MyShapes := MyDocument.InlineShapes; MyShapes.AddPicture(afilename, false, true, MyRange); end; Finally begin Wordy.ScreenUpdating:= true; Wordy.visible := true; Wordy := Unassigned; Basically := UnAssigned; Application.ProcessMessages; end; end else Result := False; end; Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId) : Boolean; var MyCustomProps : Variant; begin { personally, I store stuff in document properties and then give out a toolbar macro to allow the user to "set" the properties in their template or current document. this has three advantages that I know of (and no defects that I'm aware of) 1. The user can place the location of the info in the document either before or after this function runs 2. A custom property can be placed any number of times inside the same document 3. A user can map the properties in their Outlook or search on them using that abismal file open in Word}

747

Result := true; If GetWordUp('New')then Try Begin MyCustomProps := MyDocument.CustomDocumentProperties; MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id); MyCustomProps.add(cpOrganizationName, false, msoPropertyTypeString, MyId.OrganizationName); MyCustomProps.add(cpAddress1, false, msoPropertyTypeString,MyId.Address1); MyCustomProps.add(cpAddress2, false, msoPropertyTypeString, MyId.Address2); MyCustomProps.add(cpCity, false, msoPropertyTypeString, MyId.City); MyCustomProps.add(cpStProv, false, msoPropertyTypeString, MyId.StProv); MyCustomProps.add(cpCountry, false, msoPropertyTypeString,MyId.City); MyCustomProps.add(cpPostal, false, msoPropertyTypeString, MyId.Country); MyCustomProps.add(cpAccountId, false, msoPropertyTypeString, MyId.AccountId); MyCustomProps.add(cpFullName, false, msoPropertyTypeString, MyContId.FullName); MyCustomProps.add(cpSalutation, false, msoPropertyTypeString, MyContId.Salutation); MyCustomProps.add(cpTitle, false, msoPropertyTypeString,MyContId.Title); If (MyContId.workPhone = Nothing) or (MycontId.WorkPhone = ASpace) then MyCustomProps.add(cpPhone, false, msoPropertyTypeString, MyId.Phone ) else MyCustomProps.add(cpPhone, false, msoPropertyTypeString, MyContId.WorkPhone ); If (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then MyCustomProps.add(cpFax, false, msoPropertyTypeString, MyId.Fax) else MyCustomProps.add(cpFax, false, msoPropertyTypeString,MyContId.Fax); If (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then MyCustomProps.add(cpEmail, false, msoPropertyTypeString, MyId.Email) else MyCustomProps.add(cpEmail, false, msoPropertyTypeString, MyContId.Email); MyCustomProps.add(cpFirstName, false, msoPropertyTypeString,MyContId.FirstName); MyCustomProps.add( cpLastName, false, msoPropertyTypeString, MyContId.LastName); MyDocument.Fields.Update; end; Finally begin Wordy.ScreenUpdating:= true; Wordy.visible := true; Wordy := Unassigned; Basically := UnAssigned; Application.ProcessMessages; end; end Else Result := false;

748

end; Function GetOutlookUp(ItemType : Integer): Boolean; Const AppointmentItem = 'Calendar'; TaskItem = 'Tasks'; ContactItem = 'Contacts'; JournalItem = 'Journal'; NoteItem = 'Notes'; var MyFolders : Variant; MyFolders2 : variant; MyFolders3 : variant; MyFolder2 : Variant; MyFolder3 : variant; MyUser : Variant; MyFolderItems : Variant; MyFolderItems2 : Variant; MyFolderItems3 : Variant; MyContact : Variant; i, i2, i3 : Integer; MyTree : TCreateCont; MyTreeData : TTreeData; RootNode, MyNode, MyNode2 : ttreeNode; ThisName : String; Begin {this is really ugly........ There is some really wierd thing going on in the object model for outlook so excuse this folder.folder.folder stuff cause the "right way" doesn't work for folders and this does} {user picks folder from treeview} Result := False; Case ItemType of olAppointmentItem : ThisName := AppointmentItem; olContactItem : ThisName := ContactItem; olTaskItem : ThisName := TaskItem; olJournalItem : ThisName := JournalItem; olNoteItem : ThisName := NoteItem; Else ThisName := 'Unknown'; End; try MyOutlook := CreateOleObject('Outlook.Application'); except warning('Ole Interface','Could not start Outlook.'); Exit; end; {this is the root folder} MyNameSpace := MyOutlook.GetNamespace('MAPI'); MyFolderItems := MyNameSpace.Folders; MyTree := TCreateCont.create(Application); {Really unfortunate, but a user can create something other than the default folder for the kind of thing you're interested in - so this goes down a coupla levels in the folder chain} MyTree.Caption := 'Select ' + ThisName + ' Folder'; With MyTree do If MyFolderItems.Count > 0 then For i := 1 to MyFolderItems.Count do begin MyFolder := MyNameSpace.Folders(i); MyTreeData := TTreeData.create; MyTreeData.ItemId := MyFolder.EntryId;

749

RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData); MyFolders2 := MyNameSpace.folders(i).Folders; If MyFolders2.Count > 0 then for i2 := 1 to MyFolders2.Count do begin MyFolder2 := MyNameSpace.folders(i).Folders(i2); If (MyFolder2.DefaultItemType = ItemType) or (MyFolder2.Name = ThisName) then Begin MyTreeData := TTreeData.create; MyTreeData.ItemId := MyFolder2.EntryId; {this is what you need to directly point at the folder} MyNode := Treeview1.Items.addChildObject(RootNode, MyFolder2.Name, MyTreeData); MyFolders3 := MyNameSpace.folders(i).Folders(i2).Folders; If MyFolders3.Count > 0 then for i3 := 1 to MyFolders3.Count do begin MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3); If (MyFolder3.DefaultItemType = ItemType) then Begin MyTreeData := TTreeData.create; MyTreeData.ItemId := MyFolder3.EntryId; MyNode2 := Treeview1.Items.addChildObject(MyNode, MyFolder3.Name, MyTreeData); end; end; end; end; end; If MyTree.TreeView1.Items.Count = 2 then {there is only the root and my designated folder} MyFolder := MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId ) Else begin MyTree.Treeview1.FullExpand; MyTree.ShowModal; If MyTree.ModalResult = mrOk then Begin If MyTree.Treeview1.Selected <> nil then MyFolder := MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId ); end else Begin MyOutlook := UnAssigned; For i:= MyTree.Treeview1.Items.Count -1 downto 0 do TTreeData(MyTree.Treeview1.Items[i].Data).free; MyTree.release; exit; end; end; For i:= MyTree.Treeview1.Items.Count -1 downto 0 do TTreeData(MyTree.Treeview1.Items[i].Data).free; MyTree.release; Result := true; end;

750

Function MakeOutlookContact(MyId : TMyId; MyContId : TMyContId) : boolean; var MyContact : Variant; begin Result := false; If not GetOutlookUp(OlContactItem) then exit; MyContact := MyFolder.Items.Add(olContactItem); MyContact.Title := MyContId.Honorific; MyContact.FirstName := MyContId.FirstName; MyContact.MiddleName := MycontId.MiddleInit; MyContact.LastName := MycontId.LastName; MyContact.Suffix := MyContId.Suffix; MyContact.CompanyName := MyId.OrganizationName; MyContact.JobTitle := MyContId.Title; MyContact.OfficeLocation := MyContId.OfficeLocation; MyContact.CustomerId := MyId.ID; MyContact.Account := MyId.AccountId; MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2; MyContact.BusinessAddressCity := MyId.City; MyContact.BusinessAddressState := MyId.StProv; MyContact.BusinessAddressPostalCode := MyId.Postal; MyContact.BusinessAddressCountry := MyId.Country; If (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then MyContact.BusinessFaxNumber := MyId.Fax Else MyContact.BusinessFaxNumber := MyContId.Fax; If (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace) then MyContact.BusinessTelephoneNumber := MyId.Phone Else MyContact.BusinessTelephoneNumber := MyContId.WorkPhone; MyContact.CompanyMainTelephoneNumber := MyId.Phone; MyContact.HomeFaxNumber := MyContId.HomeFax; MyContact.HomeTelephoneNumber := MyContId.HomePhone; MyContact.MobileTelephoneNumber := MyContId.MobilePhone; MyContact.OtherTelephoneNumber := MyContId.OtherPhone; MyContact.PagerNumber := MyContId.Pager; MyContact.Email1Address := MyContId.Email; MyContact.Email2Address := MyId.Email; Result := true; Try MyContact.Save; Except Result := false; end; MyOutlook := Unassigned; end; Function GetThisOutlookItem(AnIndex : Integer) : Variant; Begin Result := myFolder.Items(AnIndex); end; Function GetOutlookFolderItemCount : Integer; Var myItems : Variant; Begin Try MyItems := MyFolder.Items; Except Begin Result := 0; exit; end; end; Result := MyItems.Count; end;

751

Function FindMyOutlookItem(AFilter : String; var AItem : Variant) : Boolean; Begin {this is another real PAIN - nil variant} Result := true; Try AItem := myFolder.Items.Find(AFilter); Except Begin aItem := MyFolder; Result := false; end; End; End; Function FindNextMyOutlookItem(var AItem : Variant) : Boolean; Begin Result := true; Try AItem := myFolder.Items.FindNext; Except Begin AItem := myFolder; Result := false; end; End; End; Function CloseOutlook : Boolean; begin Try MyOutlook := Unassigned; Except End; Result := true; end;

How to use this stuff! a unit to pick an Outlook contact With many thanks to B. stowers and the lovely extended list view unit UImpContact; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, UMain, StdCtrls, Buttons, ComCtrls, ExtListView; type TFindContact = class(TForm) ContView1: TExtListView; SearchBtn: TBitBtn; CancelBtn: TBitBtn; procedure SearchBtnClick(Sender: TObject); procedure CancelBtnClick(Sender: TObject); procedure ContView1DblClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } public { Public declarations }

752

end; var FindContact: TFindContact; implementation Uses USearch; {$R *.DFM} procedure TFindContact.SearchBtnClick(Sender: TObject); begin If ContView1.Selected <> nil then ContView1DblClick(nil); end; procedure TFindContact.CancelBtnClick(Sender: TObject); begin CloseOutlook; ModalResult := mrCancel; end; procedure TFindContact.ContView1DblClick(Sender: TObject); var MyContact : variant; begin If ContView1.Selected <> nil then Begin MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2])); With StartForm.MyId do If Not GetData(MyContact.CustomerId) then begin InitData; If MyContact.CustomerId <> '' then Id := MyContact.CustomerId Else Id := MyContact.CompanyName; If DoesIdExist(Startform.MyId.Id) then begin Warning('Data Handler', 'Can not establish unique Id' + CRLF + 'Edit CustomerId in Outlook and then try again'); CloseOutlook; ModalResult := mrCancel; Exit; end; OrganizationName := MyContact.CompanyName; IdType := 1; AccountId := MyContact.Account; Address1 := MyContact.BusinessAddressStreet; City := MyContact.BusinessAddressCity; StProv := MyContact.BusinessAddressState ; Postal := MyContact.BusinessAddressPostalCode; Country := MyContact.BusinessAddressCountry; Phone := MyContact.CompanyMainTelephoneNumber; Insert; end; With StartForm.MyContId do begin InitData; ContIdId := StartForm.MyId.Id; Honorific := MyContact.Title ; FirstName := MyContact.FirstName ; MiddleInit := MyContact.MiddleName ; LastName := MyContact.LastName ; Suffix := MyContact.Suffix ; Fax := MyContact.BusinessFaxNumber ; WorkPhone := MyContact.BusinessTelephoneNumber; HomeFax := MyContact.HomeFaxNumber ; HomePhone := MyContact.HomeTelephoneNumber ; MobilePhone := MyContact.MobileTelephoneNumber ;

753

OtherPhone := MyContact.OtherTelephoneNumber ; Pager := MyContact.PagerNumber ; Email := MyContact.Email1Address ; Title := MyContact.JobTitle; OfficeLocation := MyContact.OfficeLocation ; Insert; End;

end; CloseOutlook; ModalResult := mrOk; end;

procedure TFindContact.FormCreate(Sender: TObject); var MyContact : Variant; MyCount : Integer; i : Integer; AnItem : TListItem; begin If not GetOutlookUp(OlContactItem) then exit; MyCount := GetOutlookFolderItemCount ; For i := 1 to MyCount do begin MyContact := GetThisOutlookItem(i); AnItem := ContView1.Items.Add; AnItem.Caption := MyContact.CompanyName; AnItem.SubItems.add(MyContact.FirstName); AnItem.Subitems.Add(MyContact.LastName); AnItem.SubItems.Add(inttostr(i)); End; end; procedure TFindContact.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := cafree; end; end.

OLE Tester From: [email protected] This is a VERY simple test that I made myself to get started with OLE. I was asked to add OLE support to a program I made and this is what I did to have a program to test that my own OLE server worked. This creates the oleobject upon creation and then whenever you press a button it calls a procedure in the oleserver. unit oletestu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type

754

TForm1 = class(TForm) Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } ttsesed : variant; end; var Form1: TForm1; implementation uses oleauto; {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin ttsesed := createoleobject('ttdewed.ttsesole'); end; procedure TForm1.Button1Click(Sender: TObject); begin ttsesed.openeditfile; end; procedure TForm1.Button2Click(Sender: TObject); begin ttsesed.appshow; end; end.

Getting data from Delphi app into Word document From: Darek Maluchnik Assuming that you have Word2(6)/Delphi1 or 32bit Word/Delphi2. Try: Make macro in Word: Declare Function StringFromDelphi

Lib "c:\sample\test.dll" As String

Sub MAIN mystring$ = StringFromDelphi Insert mystring$ End Sub

Create simple TEST.DLL in Delphi - just form with a button. Save it (eg.in c:\sample - see Word macro) as test.dpr and testform.pas. Now add to your project EXPORTED function 'StringFromDelphi' and 'close' on button click. You can paste the stuff from below: library Test;

(* test.dpr in c:\sample *)

755

uses Testform in 'TESTFORM.PAS'; exports StringFromDelphi; begin end.

unit Testform; (* testform.pas in c:\sample *) interface uses WinTypes, WinProcs, Forms, Classes, Controls, StdCtrls, SysUtils; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); end; var Form1: TForm1; function StringFromDelphi : PChar; export; {$ifdef WIN32} stdcall; {$endif} implementation {$R *.DFM} function StringFromDelphi: Pchar; var StringForWord : array[0..255] of char; begin Application.CreateForm(TForm1, Form1); Form1.ShowModal; Result:=StrPCopy(StringForWord, Form1.Button1.caption); end; procedure TForm1.Button1Click(Sender: TObject); begin close; end; end.

Compile test.dll. Run macro from Word, Delphi form should appear - click the button to get some data from Delphi. There is a text in PCMagazine Vol12.No22 on accessing DLL functions from Word. You can get it (DLLACCES) from PCMag web site.

WordBasic via OLE From: [email protected] (CEHJohnson) Try the following: MsWord := CreateOleObject('Word.Basic'); MsWord.FileNewDefault; MsWord.TogglePortrait;

Creating Word Documents From: [email protected] (Alan MCCulloch) I have found the following works well D2 -> Word 97, using "Bookmark" fields in Word. ..

756

.. .. implementation uses OleAuto; .. .. .. var V : Variant ; .. .. ..

V := 0; // at some point just to initialise

.. .. .. some functions if V = 0 then begin V := CreateOLEObject('Word.Application'); V.WordBasic.AppShow; end; // this example assumes we are filling in some bookmark // fields on a "standard letter", from a query that has previously // been executed, in a data module called pnm_data (OK , should // have used a with...block !) V.WordBasic.Fileopen('Your Word Doc name'); V.WordBasic.EditBookmark('Title',0,0,0,1); V.WordBasic.Insert(Title); V.WordBasic.EditBookmark('FirstName',0,0,0,1); V.WordBasic.Insert(FirstName + ' '); V.WordBasic.EditBookmark('LastName',0,0,0,1); V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' '); V.WordBasic.EditBookmark('Address1',0,0,0,1); V.WordBasic.Insert(pnm_data.ContactsQuery1Address1.AsString + ' '); V.WordBasic.EditBookmark('Address2',0,0,0,1); V.WordBasic.Insert(pnm_data.ContactsQuery1Address2.AsString + ' '); V.WordBasic.EditBookmark('Address3',0,0,0,1); V.WordBasic.Insert(pnm_data.ContactsQuery1Address3.AsString + ' '); V.WordBasic.EditBookmark('Title1',0,0,0,1); V.WordBasic.Insert(Title); V.WordBasic.EditBookmark('LastName1',0,0,0,1); V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' '); (You could V.WordBasic.PrintDefault; if you want to tell Word to print it as well....and many other commands, like saving, changing font etc can be done) ....etc

Starting Word without AutoStart Macro From: "Rui Chambel" To disable the AutoOpen Macro, you can execute this command WordBasic.DisableAutoMacros

757

First you must create the WordBasic object and then execute that method.

Wordbasic from Delphi using Parameters From: Steve Diederichs
Revert := 1);

LastOLECommand := 'Start the Mail Merge.'; MSWord.MailMerge(CheckErrors := 2, Destination := 1, MergeRecords:= 0, From := '', To := '', Suppression := 0, MailSubject := '', MailAsAttachment := 0, MailAddress := ''); LastOLECommand := 'Set up for SendKeys to select printer.'; Application.ProcessMessages; MSWord.AppShow; s := '{home}%l{enter}{home}%n' + FOutput + '{tab}{enter}{home}{enter}'; // sdd 1.1 MSWord.SendKeys(s, -1); MSWord.MailMergeToPrinter;

758

Application.ProcessMessages; ProcessMerge := True; LastOLECommand := 'All done with merge.'; except on EOleException do begin inc(TotalOLEErrors); lblStatus.caption := LastOLECommand; if (TotalOLEErrors >= TOTALOLEERRORS_MAX) then begin s := 'There has been at least one OLE error(' + IntToStr(TotalOLEErrors) + '), the last one was >' + LastOLECommand + '<.'; ShowMessage(s); end; end end; end;

Hack: tired of ReportSmith? Wish you had wysiwyg reports? From: "James D. Rofkar" For those of you who are sick and tired of mucking around with ReportSmith, only to find limitations, drawbacks, etc. And have grown tired of trying to find that perfect WYSIWYG report generator. Well... Chances are you've got a good one already. It's called MS-Word! That's right! Use Word for report generation. It's actually quite easy with OLE Automation. I know that word (OLE) scares some of you, but check-out this code: var

Word: Variant; begin Word := CreateOleObject('Word.Basic'); with Word do begin {Pure WordBASIC commands follow...} FileNew('Normal'); Insert('This is the first line'#13); Insert('This is the second line'#13); FileSaveAs('c:\temp\test.txt', 3); end; end;

Simple, isn't it? If you notice, there's no need for SendMessage(), or PostMessage(), or DDE, or Word's C-API, or some proprietary DOS-based batch programming that requires text files to be written. In fact, none of that junk! Another benefit of OLE Automation is that it doesn't require the darned app to launch. That's right! Word does not show-up using this technique. Instead, just the WordBASIC engine is used. The speed improvements and lower memory footprint kick the livin' crap out of the techniques listed in the previous paragraph. A wild side-benefit is that if you startup Word while your program is using OLE Automation, you can watch it work. Yup! Word realizes that "documents" are opened and being editing, and hence, displays them like regular old Word documents. 759

Now all you need to do is generate a Word template with Bookmarks! Then, using the WordBASIC commands "EditBookmark .Goto" and "Insert", you're ready to rock! I've given-up on report generators. They suck compared to Word's WYSIWYG output!

Excel From: [email protected] (Scott F. Barnes) >GOGA wrote in message <[email protected]>... >>Can someone please tell me some basic function to control excel from delphi >>with ole automation. Check UNDU and back issues of Delphi Informant. Also http://vzone.virgin.net/graham.marshall/excel.htm#excel.htm I can't remember exactly which sample(s) I managed to piece this together from, but this sample code will create and format an Excel spreadsheet based on the contents of a DBGrid generated from an SQL query. And it will apply some formatting. This sample is working code that runs in D3 with Excel 97: procedure TfrmBlank.btnExcelClick(Sender: TObject); var XL, XArr: Variant; i : Integer; j : Integer; begin {note the ComObj (example OleAuto not correct) in the uses} // Create an array of query element size XArr:=VarArrayCreate([1,EmailQuery.FieldCount],varVariant); XL:=CreateOLEObject('Excel.Application'); // Ole object creation XL.WorkBooks.add; XL.visible:=true;

end;

j := 1; EmailQuery.First; while not EmailQuery.Eof do begin i:=1; while i<=EmailQuery.FieldCount do begin XArr[i] := EmailQuery.Fields[i-1].Value; i := i+1; end; XL.Range['A'+IntToStr(j), CHR(64+EmailQuery.FieldCount)+IntToStr(j)].Value := XArr; EmailQuery.Next; j := j + 1; end; XL.Range['A1',CHR(64+EmailQuery.FieldCount)+IntToStr(j)].select; // XL.cells.select; // Select everything XL.Selection.Font.Name:='Garamond'; XL.Selection.Font.Size:=10; XL.selection.Columns.AutoFit; XL.Range['A1','A1'].select;

Delphi + WordBasic 8 From: "K. Brown" unit oleword; // Need a form with a button, memo, and edit component. // Written for MSWord 8. // Also need to create a test document d:\test.doc interface uses

760

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, OLEAuto, ShellAPI, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; Edit1: TEdit; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } MSWord: Variant; // WordVersion: Byte; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var Test, Test1: Integer; AString: Variant; begin MSWord := CreateOLEObject('Word.Application'); //Word 8 MSWord.Documents.Open (FileName:='d:\test.doc', ReadOnly:=True); MSWord.Visible := 1; //Uncomment if you wish to show the file; Test := MSWord.FontNames.Count; For Test1 := 1 To Test do begin AString := MSWord.FontNames.Item(Test1) ; Memo1.Lines.Add(AString); end; MSWord.ActiveDocument.Range(Start:=0, End:=0); MSWord.ActiveDocument.Range.InsertAfter(Text:='Title'); MSWord.ActiveDocument.Range.InsertParagraphAfter; MSWord.ActiveDocument.Range.Font.Name := 'Arial'; MSWord.ActiveDocument.Range.Font.Size := 24; AString := MSWord.ActiveDocument.Range.Font.Name; Edit1.Text := AString; end; end.

Please email me and tell me if you liked this page. Last modified 03/12/00 12:09:21

761

Keyboard 33. Beeping when is pressed 34. Disable alt-tab and ctrl+esc keys 35. How to detect arrow keys? 36. Hooking keyboard (Sendkeys Routine) 37. Simulating ButtonDown 38. How? ENTER key instead of TAB 39. Caps Lock (and others like it) 40. KeyDown Example 41. disable Ctrl-Alt-Del

Beeping when is pressed From: "Paul Motyer" procedure TForm1.EditKeyPress(Sender: TObject; var Key:Char); begin if Key = Chr(VK_RETURN) then begin Perform(WM_NEXTDLGCTL,0,0); key:= #0; end; end;

Disable alt-tab and ctrl+esc keys From: [email protected] (Meik Weber) procedure TurnSysKeysOff; var OldVal : LongInt; begin SystemParametersInfo (97, Word (True), @OldVal, 0) end; procedure TurnSysKeysBackOn; var OldVal : LongInt; begin SystemParametersInfo (97, Word (False), @OldVal, 0) end;

762

How to detect arrow keys? From: Mark Pritchard Use the KeyDown or KeyUp events, and test for VK_LEFT, VK_RIGHT etc.

Hooking keyboard (Sendkeys Routine) From: [email protected] (Iman L. Crawford) I've seen several posts on how to hook the key board. Here's some old code I've dug up (can't remember where It came from). library Sendkey; {This code taken with permission from "Delphi Developer's Guide" by Xavier Pacheco and Steve Teixeira.} uses SysUtils, WinTypes, WinProcs, Messages, Classes, KeyDefs; type { Error codes } TSendKeyError = (sk_None, sk_FailSetHook, sk_InvalidToken, sk_UnknownError); { exceptions } ESendKeyError = class(Exception); ESetHookError = class(ESendKeyError); EInvalidToken = class(ESendKeyError); { a TList descendant that know how to dispose of its contents } TMessageList = class(TList) public destructor Destroy; override; end; destructor TMessageList.Destroy; var i: longint; begin { deallocate all the message records before discarding the list } for i := 0 to Count - 1 do Dispose(PEventMsg(Items[i])); inherited Destroy; end; var { variables global to the DLL } MsgCount: word; MessageBuffer: TEventMsg; HookHandle: hHook; Playing: Boolean; MessageList: TMessageList; AltPressed, ControlPressed, ShiftPressed: Boolean; NextSpecialKey: TKeyString; function MakeWord(L, H: Byte): Word; { macro creates a word from low and high bytes } inline(

763

$5A/ $58/ $8A/$E2);

{ pop dx } { pop ax } { mov ah, dl }

procedure StopPlayback; { Unhook the hook, and clean up } begin { if Hook is currently active, then unplug it } if Playing then UnhookWindowsHookEx(HookHandle); MessageList.Free; Playing := False; end; function Play(Code: integer; wParam: word; lParam: Longint): Longint; export; { This is the JournalPlayback callback function. It is called by Windows } { when Windows polls for hardware events. The code parameter indicates what } { to do. } begin case Code of hc_Skip: begin { hc_Skip means to pull the next message out of our list. If we } { are at the end of the list, it's okay to unhook the JournalPlayback } { hook from here. } { increment message counter } inc(MsgCount); { check to see if all messages have been played } if MsgCount >= MessageList.Count then StopPlayback else { copy next message from list into buffer } MessageBuffer := TEventMsg(MessageList.Items[MsgCount]^); Result := 0; end; hc_GetNext: begin { hc_GetNext means to fill the wParam and lParam with the proper } { values so that the message can be played back. DO NOT unhook } { hook from within here. Return value indicates how much time until } { Windows should playback message. We'll return 0 so that it's } { processed right away. } { move message in buffer to message queue } PEventMsg(lParam)^ := MessageBuffer; Result := 0 { process immediately } end else { if Code isn't hc_Skip or hc_GetNext, then call next hook in chain } Result := CallNextHookEx(HookHandle, Code, wParam, lParam); end; end; procedure StartPlayback; { Initializes globals and sets the hook } begin { grab first message from list and place in buffer in case we } { get a hc_GetNext before and hc_Skip } MessageBuffer := TEventMsg(MessageList.Items[0]^); { initialize message count and play indicator } MsgCount := 0; { initialize Alt, Control, and Shift key flags } AltPressed := False; ControlPressed := False; ShiftPressed := False; { set the hook! }

764

HookHandle := SetWindowsHookEx(wh_JournalPlayback, Play, hInstance, 0); if HookHandle = 0 then raise ESetHookError.Create('Couldn''t set hook') else Playing := True; end; procedure MakeMessage(vKey: byte; M: word); { procedure builds a TEventMsg record that emulates a keystroke and } { adds it to message list } var E: PEventMsg; begin New(E); { allocate a message record } with E^ do begin Message := M; { set message field } { high byte of ParamL is the vk code, low byte is the scan code } ParamL := MakeWord(vKey, MapVirtualKey(vKey, 0)); ParamH := 1; { repeat count is 1 } Time := GetTickCount; { set time } end; MessageList.Add(E); end; procedure KeyDown(vKey: byte); { Generates KeyDownMessage } begin { don't generate a "sys" key if the control key is pressed (Windows quirk) } if (AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')])) or (vKey = vk_Menu) then MakeMessage(vKey, wm_SysKeyDown) else MakeMessage(vKey, wm_KeyDown); end; procedure KeyUp(vKey: byte); { Generates KeyUp message } begin { don't generate a "sys" key if the control key is pressed (Windows quirk) } if AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')]) then MakeMessage(vKey, wm_SysKeyUp) else MakeMessage(vKey, wm_KeyUp); end; procedure SimKeyPresses(VKeyCode: Word); { This function simulates keypresses for the given key, taking into } { account the current state of Alt, Control, and Shift keys } begin { press Alt key if flag has been set } if AltPressed then KeyDown(vk_Menu); { press Control key if flag has been set } if ControlPressed then KeyDown(vk_Control); { if shift is pressed, or shifted key and control is not pressed... } if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then KeyDown(vk_Shift); { ...press shift } KeyDown(Lo(VKeyCode)); { press key down } KeyUp(Lo(VKeyCode)); { release key } { if shift is pressed, or shifted key and control is not pressed... } if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then KeyUp(vk_Shift); { ...release shift } { if shift flag is set, reset flag } if ShiftPressed then begin

765

ShiftPressed := False; end; { Release Control key if flag has been set, reset flag } if ControlPressed then begin KeyUp(vk_Control); ControlPressed := False; end; { Release Alt key if flag has been set, reset flag } if AltPressed then begin KeyUp(vk_Menu); AltPressed := False; end; end; procedure ProcessKey(S: String); { This function parses each character in the string to create the message list } var KeyCode: word; Key: byte; index: integer; Token: TKeyString; begin index := 1; repeat case S[index] of KeyGroupOpen : begin { It's the beginning of a special token! } Token := ''; inc(index); while S[index] <> KeyGroupClose do begin { add to Token until the end token symbol is encountered } Token := Token + S[index]; inc(index); { check to make sure the token's not too long } if (Length(Token) = 7) and (S[index] <> KeyGroupClose) then raise EInvalidToken.Create('No closing brace'); end; { look for token in array, Key parameter will } { contain vk code if successful } if not FindKeyInArray(Token, Key) then raise EInvalidToken.Create('Invalid token'); { simulate keypress sequence } SimKeyPresses(MakeWord(Key, 0)); end; AltKey : begin { set Alt flag } AltPressed := True; end; ControlKey : begin { set Control flag } ControlPressed := True; end; ShiftKey : begin { set Shift flag } ShiftPressed := True; end; else begin { A normal character was pressed } { convert character into a word where the high byte contains } { the shift state and the low byte contains the vk code } KeyCode := vkKeyScan(MakeWord(Byte(S[index]), 0));

766

{ simulate keypress sequence } SimKeyPresses(KeyCode); end; end; inc(index); until index > Length(S); end; function SendKeys(S: String): TSendKeyError; export; { This is the one entry point. Based on the string passed in the S } { parameter, this function creates a list of keyup/keydown messages, } { sets a JournalPlayback hook, and replays the keystroke messages. } var i: byte; begin try Result := sk_None; { assume success } MessageList := TMessageList.Create; { create list of messages } ProcessKey(S); { create messages from string } StartPlayback; { set hook and play back messages } except { if an exception occurs, return an error code, and clean up } on E:ESendKeyError do begin MessageList.Free; if E is ESetHookError then Result := sk_FailSetHook else if E is EInvalidToken then Result := sk_InvalidToken; end else { Catch-all exception handler ensures than an exception } { doesn't walk up into application stack } Result := sk_UnknownError; end; end; exports SendKeys index 1; begin end

Simulating ButtonDown From: "James D. Rofkar" Paulo Oliveira wrote: > > I have a set of buttons,(caption ='0'..'9') and I'd like to simulate the down position of the button, when the user presses the corresponding key. I.e. if user presses key '1' the button goes down on screen. How can I do this, without a new Tbutton component?

No problem Paulo: You'll probably want to be using 10 TSpeedButton controls, or an array of them, since this button provides a "Down" property. Anyhow, set the "KeyPreview" property of your main form to "True". Then, in your "OnKeyDown" event handler, write something like this... case Key of VK_NUMPAD0: VK_NUMPAD1: VK_NUMPAD2: VK_NUMPAD3:

btn0.Down btn1.Down btn2.Down btn3.Down

:= := := :=

True; True; True; True;

767

VK_NUMPAD4: VK_NUMPAD5: VK_NUMPAD6: VK_NUMPAD7: VK_NUMPAD8: VK_NUMPAD9: end;

btn4.Down btn5.Down btn6.Down btn7.Down btn8.Down btn9.Down

:= := := := := :=

True; True; True; True; True; True;

And, in your "OnKeyUp" event handler, write something like... case Key of VK_NUMPAD0: VK_NUMPAD1: VK_NUMPAD2: VK_NUMPAD3: VK_NUMPAD4: VK_NUMPAD5: VK_NUMPAD6: VK_NUMPAD7: VK_NUMPAD8: VK_NUMPAD9: end;

btn0.Down btn1.Down btn2.Down btn3.Down btn4.Down btn5.Down btn6.Down btn7.Down btn8.Down btn9.Down

:= := := := := := := := := :=

False; False; False; False; False; False; False; False; False; False;

You'll want to experiment with the "AllowAllUp" property and the "GroupIndex" property to get the button response/effect you like. Again, an array of TSpeedButtons would be the most elegant solution to this problem, since you could use the VK_ constant as the index, and make both event handlers a one line call to Button[VK_x].Down := True {or False}.

How? ENTER key instead of TAB Here is something I picked up off Compuserve that should help. Simon Callcott CIS: 100574,1034 Using the &tl;Enter≷ key like a &tl;Tab≷ key with Delphi Controls The example code supplied here demonstrates how to trap the &tl;Enter≷ key and the cursor keys to provide better data entry processing. The trick is to overide the Keypress and KeyDown events so that they process the keys the way you want. In the examples supplied I have used the &tl;Enter≷ key to move to the next control (like the &tl;Tab≷ key) and the cursor Up and Down keys to move to the previous and next controls respectively. The Edit and EBEdit use the cursor keys as stated above, but the Combobox and the Listbox use Shift-Up and Shift-Down instead so as not to interfere with existing functionality. The Grid control uses the &tl;Enter≷ key to move between fields, however it will not move from the last field of the last row. It is very easy to make it exit the grid at this point if you need to. The method used to move to the next/previous control is the Windows API call SendMessage which is used to dispatch a WM_NEXTDLGCTL to the form the controls are children to. Delphi provides a function called GetParentForm to get the handle of the parent form of the control. These simple extensions can be expanded to respond to almost any keyboard event, and I think using this method is less trouble than trapping keys in the forms OnKey events (using keypreview:=true). Feel free to use the code as you wish, but if you discover something new please let me in on it! 768

{ Edit control that reponds as if the &tl;Tab≷ key has been pressed when an &tl;Enter≷ key is pressed, moving to the next control. Very simple extension to the KeyPress event, this technique should work with TDBedit as well, Useful for data entry type apps. Less trouble than using the Keypreview function of the form to do the same thing. Please Use Freely. Simon Callcott

CIS: 100574, 1034

} unit Entedit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TEnterEdit = class(TEdit) private protected procedure KeyPress(var Key: Char); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; public published end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TEnterEdit]); end; procedure TEnterEdit.KeyPress(var Key: Char); var MYForm: TForm; begin if Key = #13 then begin MYForm := GetParentForm( Self ); if not (MYForm = nil ) then SendMessage(MYForm.Handle, WM_NEXTDLGCTL, 0, 0); Key := #0; end; if Key &tl;≷ #0 then inherited KeyPress(Key); end; procedure TEnterEdit.KeyDown(var Key: Word; Shift: TShiftState);

769

var MYForm: TForm; CtlDir: Word; begin if (Key = VK_UP) or (Key = VK_DOWN) then begin MYForm := GetParentForm( Self ); if Key = VK_UP then CtlDir := 1 else CtlDir :=0; if not (MYForm = nil ) then SendMessage(MYForm.Handle, WM_NEXTDLGCTL, CtlDir, 0); end else inherited KeyDown(Key, Shift); end; end.

Solution 2 Q. "Is there a way to use the return key for data entry, instead of tab or the mouse?" Ken Hale [email protected] Compuserve: 74633.2474 A. Use this code for an Edit's OnKeyPress event. procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin If Key = #13 Then Begin SelectNext(Sender as tWinControl, True, True ); Key := #0; end; end;

This causes Enter to behave like tab. Now, select all controls on the form you'd like to exhibit this behavior (not Buttons) and go to the Object Inspector and set their OnKeyPress handler to EditKeyPress. Now, each control you selected will process Enter as Tab. If you'd like to handle this at the form (as opposed to control) level, reset all the controls OnKeyPress properties to blank, and set the _form_'s OnKeyPress property to EditKeyPress. Then, change Sender to ActiveControl and set the form's KeyPreview property to true: procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin If Key = #13 Then begin SelectNext(ActiveControl as tWinControl, True, True ); Key := #0; end; end;

This will cause each control on the form (that can) to process Enter as Tab.

Caps Lock (and others like it) From: [email protected] (Mark Vaughan) ]-How Do I turn them on? (IN A DELPHI PROGRAM OF COURSE) i have tried and asked around

770

try this... procedure TMyForm.Button1Click(Sender: TObject); Var KeyState : TKeyboardState; begin GetKeyboardState(KeyState); if (KeyState[VK_NUMLOCK] = 0) then KeyState[VK_NUMLOCK] := 1 else KeyState[VK_NUMLOCK] := 0; SetKeyboardState(KeyState); end;

for caps lock substitute VK_CAPITAL for VK_NUMLOCK.

KeyDown Example "Dmitry" There are some ways to have hotkeys on dbnavigator. The easy one is to set TForm.KeyPreview property to TRUE and write onkeydown handler. Something like: procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); const (* Nice piece of code, The Graphical Gnome *) KeyBtn: array[TNavigateBtn] of record Key: Word; Btn: TNavigateBtn; end = ( (Key: VK_F1; Btn: nbFirst), (Key: VK_F2; Btn: nbPrior), (Key: VK_F3; Btn: nbNext), (Key: VK_F4; Btn: nbLast), (Key: VK_F5; Btn: nbInsert), (Key: VK_F6; Btn: nbDelete), (Key: VK_F7; Btn: nbEdit), (Key: VK_F8; Btn: nbPost), (Key: VK_F9; Btn: nbCancel), (Key: VK_F10; Btn: nbRefresh) ); var i: TNavigateBtn; begin for i := nbFirst to nbRefresh do if KeyBtn[i].Key = Key then begin DBNavigator1.BtnClick(KeyBtn[i].Btn); Exit; end; end;

disable Ctrl-Alt-Del From: Richard Leigh Issues : 771

The program should be nice and small so it can load before a user can hit CTRL-ALTDEL. My Solution : Compile a single WIN32API call into a small .exe in delphi. The Program : program small; {written by Richard Leigh, Deakin Univesity 1997} uses WinProcs; {$R *.RES} var

Dummy : integer;

begin Dummy := 0; {Disable ALT-TAB} SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0); {Disable CTRL-ALT-DEL} SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0); end.

This is the main unit - No forms and compiles small. Please email me and tell me if you liked this page. Last modified 03/12/00 12:08:28

772

Forms 42. Delphi Applications without Forms?

43. Showing own logo on start-up 44. Moving a form without a caption barforms2 45. Hack: Want VCL controls in a form's title bar caption area? 46. Storing TForm and/or its properties in a BLOB

47. Removing icon on taskbar forms5 48. How can I hide the form caption bar?? 49. Floating toolbar - here's some code to do it 50. Programming for different resolutions in Delphi 2.0 51. How do I know a Form is 'ready' resizing? 52. Preventing the user from resizing my window vertically 53. Preventing a From from Resizing 54. messagedlg centering 55. Center a Form

56. custom shaped forms?forms14

57. minimize non-main forms to the taskbarforms15

Delphi Applications without Forms? From: [email protected] (Bob Peck) You bet! First, select File|New Project and choose "CRT Application" from the Browse Gallery dialog. This will provide you with a project that is still a Windows program, but 773

WriteLn, ReadLn will be allowed in a Window but work like they did in DOS. If you wish, you can remove the WinCrt unit from the uses statement (if no user input/output is required, but is nice for debugging). I've done this before just to see how small an app can be and I've been able to create a simple EXE (it just beeps) that is only 3200 bytes or so in size! Try to do that in C++ these days! BTW, these "formless" apps are still Windows applications, so they can still call the Windows API routines. You'll just need to add WinProcs, WinTypes to your uses clause. You'll probably also want to add SysUtils and any other unit you find yourself needing.

Showing own logo on start-up From: "Mark R. Holbrook" It's pretty simple. Create a form and put the logo on it using a Timage component. My example below assumes you have created a logo form called "logoform" Go to your project options and set the form to NOT be autocreated. Then in your PROJECT.DPR file just after the begin statement do something like the following: logoform := TLogoform.Create(nil); logoform.Show; { NOTE! show!

NOT showmodal }

. . { Do other app startup stuff here like open databases etc... } . .

{ Just after the block of code that creates all your forms and before the Application.Run statement do: }

logoform.Hide; logoform.Release;

This will display your logo form until you actually start the app running.

Moving a form without a caption bar Drag outline window From: [email protected] (Matthias Gerstgrasser) The following is from DKBS Helpfile (Delphi Knowledge Base System), they state, that this is one of Borland's TI's: Q: How can I make a form move by clicking and dragging in the client area instead of on the caption bar? A: The easiest way to do this is to "fool" Windows into thinking that you're actually clicking on the caption bar of a form. Do this by handling the wm_NCHitTest windows message... type

774

TForm1 = class(TForm) private { Private-Deklarationen } public { Public-Deklarationen } procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCHitTest(var M: TWMNCHitTest); begin inherited; { call the inherited message handler if M.Result = htClient then { is the click in the client area? M.Result := htCaption; { if so, make Windows think it's { on the caption bar. end;

} } } }

Drag whole window From: [email protected] But if i implement your code and drag the window, the window stays on the same spot and i drag an outline of the window. Can this be changed so i drag the whole window (like win95 plus)?

Here's a simple little component I wrote that'll handle it... Unit WinDrag; interface uses windows, sysutils, classes, dsgnintf; type TWinDrag = class(TComponent) private { Private Declarations } protected { Protected Declarations } public { Public Declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetDragFlag: boolean; procedure SetDragFlag(Status: Boolean); published Property DragFlag: Boolean read GetDragFlag write SetDragFlag; end; procedure Register; implementation constructor TWinDrag.Create(AOwner: TComponent); begin inherited Create(AOwner); DragFlag := GetDragFlag; end; destructor TWinDrag.Destroy;

775

begin inherited Destroy; end; function TWinDrag.GetDragFlag: boolean; var Value : Boolean; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @Value, 0); Result := Value; end; procedure TWinDrag.SetDragFlag(Status: Boolean); begin SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Integer(Status), POINTER(0), 0); end; procedure Register; begin RegisterComponents('Samples', [TWinDrag]); end; end.

Moving form by dragging label From: "Rodney E Geraghty" If you want to move the form by clicking on it and then dragging it you can try something like this (if you want to click on a label or something else then the same code can be used in their respective events): var X1, Y1: Integer; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin {Set start coordinates} X1 := X; Y1 := Y; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin {Check if left button is down} if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then begin Form1.Left := Form1.Left + X - X1; Form1.Top := Form1.Top + Y - Y1; end; end;

Hack: Want VCL controls in a form's title bar caption area? From: "James D. Rofkar" Here's the trick:

776

Treat your controls like they belong in a separate modeless dialog that just so happens to track the movement and resizing of your main form. In addition, it always appear over the main form's caption area. This said, here's a simple hack that involves 2 forms and a drop-down listbox. After running this program, the drop-down listbox will appear in the Main form's caption area. Two key issues are: 1) trapping the Main form's WM_MOVE message; and 2) returning focus back to the Main form after users press any focus-grabbing controls (like a TComboBox, TButton, etc.) [FYI, I'm using 32-bit Delphi 2.0 Developer under Win95 -- even though this technique should work for all versions of Delphi] Here's the source for the Main form: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) procedure FormResize(Sender: TObject); procedure FormShow(Sender: TObject); procedure FormHide(Sender: TObject); private { Private declarations } public { Public declarations } procedure WMMove(var Msg: TWMMove); message WM_MOVE; end; var Form1: TForm1; implementation uses Unit2; {$R *.DFM} procedure TForm1.FormResize(Sender: TObject); begin with Form2 do begin {Replace my magic numbers with real SystemMetrics info} Width := Form1.Width - 120; Top := Form1.Top + GetSystemMetrics(SM_CYFRAME); Left := ((Form1.Left + Form1.Width) - Width) - 60; end; end; procedure TForm1.FormShow(Sender: TObject); begin Form2.Show; end; procedure TForm1.FormHide(Sender: TObject); begin Form2.Hide; end; procedure TForm1.WMMove(var Msg: TWMMove);

777

begin inherited; if (Visible) then FormResize(Self); end; end.

Here's the source for the pseudo-caption area form. This is the form that contains the VCL controls you wish to place in the Main form's caption area. Essentially, it's a modeless dialog with the following properties: Caption='' {NULL string} Height={height of caption area} Width={width of all controls in form} BorderIcons=[] {none} BorderStyle=bsNone FormStyle=fsStayOnTop

Anyhow, here's the source for Form2: unit Unit2; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm2 = class(TForm) ComboBox1: TComboBox; procedure FormCreate(Sender: TObject); procedure ComboBox1Change(Sender: TObject); procedure FormResize(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form2: TForm2; implementation uses Unit1; {$R *.DFM} procedure TForm2.FormCreate(Sender: TObject); begin Height := ComboBox1.Height - 1; Width := ComboBox1.Width - 1; end; procedure TForm2.ComboBox1Change(Sender: TObject); begin Form1.SetFocus; end; procedure TForm2.FormResize(Sender: TObject); begin ComboBox1.Width := Width; end;

778

end.

The project file (.DPR) is fairly straightforward: program Project1; uses Forms, Unit1 in 'Unit1.pas' {Form1}, Unit2 in 'Unit2.pas' {Form2}; {$R *.RES} begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); Application.Run; end.

That's it! Although some Delphi book authors state: "You can't place a Delphi component on the title bar, so there's literally no way to put a button there." you can at least "fake" the illusion...

Storing TForm and/or its properties in a BLOB From: [email protected] (Oliver Bollmann) Hallo, here are examples you need, I hope: procedure SaveToField(FField:TBlobField;Form:TComponent); var Stream: TBlobStream; FormName: string; begin FormName := Copy(Form.ClassName, 2, 99); Stream := TBlobStream.Create(FField, bmWrite); try Stream.WriteComponentRes(FormName, Form); finally Stream.Free; end; end; procedure LoadFromField(FField:TBlobField;Form:TComponent); var Stream: TBlobStream; I: integer; begin try Stream := TBlobStream.Create(FField, bmRead); try {delete all components} for I := Form.ComponentCount - 1 downto 0 do Form.Components[I].Free; Stream.ReadComponentRes(Form); finally Stream.Free;

779

end; except on EFOpenError do {nothing}; end; end;

Removing icon on taskbar From: AVONTURE Christophe ShowWindow (Application.Handle, SW_HIDE);

How can I hide the form caption bar?? From: "James D. Rofkar" First, override the "CreateParams" method of your Form, by declaring this in either your Form's protected or public section: procedure CreateParams(var Params: TCreateParams); override;

Then, in the actual CreateParams() method, specify something like this: procedure TForm1.Createparams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do Style := (Style or WS_POPUP) and (not WS_DLGFRAME); end;

Hopefully, you'll provide some UI mechanism for moving and closing the window.

Floating toolbar - here's some code to do it From: [email protected] (Anders Ohlsson) Someone asked for some code to make a form with no title bar moveable, kind of like a floating toolbar, for example FreeDock. Actually, for some of the stuff in here I spied on the FreeDock sources... This requires the use of some WinAPI functions. All WinAPI functions are however available at a touch of a key (F1 - OnLine Help)... Here's some code that does this (about 100 lines)... To make this work like intended: OR start a new project, make the form's borderstyle bsNone, add a panel, set the border style of the panel to bsSingle, add another panel with some caption, add a button that says 'toggle title bar', cut out the below code and insert it were it should be, enable the panel's three event handlers (MouseDown, MouseMove, MouseUp), enable the button's event handler (Click). Hope I didn't forget anything... ;-) It's done faster in Delphi than it's written here... ;-) 780

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Panel1: TPanel; Panel2: TPanel; Button1: TButton; procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Button1Click(Sender: TObject); private { Private declarations } OldX, OldY, OldLeft, OldTop : Integer; ScreenDC : HDC; MoveRect : TRect; Moving : Boolean; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin SetCapture(Panel1.Handle); ScreenDC := GetDC(0); OldX := X; OldY := Y; OldLeft := X; OldTop := Y; MoveRect := BoundsRect; DrawFocusRect(ScreenDC,MoveRect); Moving := True; end; end; procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Moving then begin DrawFocusRect(ScreenDC,MoveRect); OldX := X; OldY := Y; MoveRect := Rect(Left+OldX-OldLeft,Top+OldY-OldTop,

781

Left+Width+OldX-OldLeft,Top+Height+OldY-OldTop); DrawFocusRect(ScreenDC,MoveRect); end; end; procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin ReleaseCapture; DrawFocusRect(ScreenDC,MoveRect); Left := Left+X-OldLeft; Top := Top+Y-OldTop; ReleaseDC(0,ScreenDC); Moving := False; end; end; procedure TForm1.Button1Click(Sender: TObject); var TitleHeight, BorderWidth, BorderHeight : Integer; begin TitleHeight := GetSystemMetrics(SM_CYCAPTION); BorderWidth := GetSystemMetrics(SM_CXBORDER)+GetSystemMetrics(SM_CXFRAME)-1; BorderHeight := GetSystemMetrics(SM_CYBORDER)+GetSystemMetrics(SM_CYFRAME)-2; if BorderStyle = bsNone then begin BorderStyle := bsSizeable; Top := Top-TitleHeight-BorderHeight; Height := Height+TitleHeight+2*BorderHeight; Left := Left-BorderWidth; Width := Width+2*BorderWidth; end else begin BorderStyle := bsNone; Top := Top+TitleHeight+BorderHeight; Height := Height-TitleHeight-2*BorderHeight; Left := Left+BorderWidth; Width := Width-2*BorderWidth; end; end; end.

Comments From: Steve Teixeira I have one comment on the FloatWin sample, though: it's *much* more complicated than it needs to be. All you have to do is handle Windows' wm_NCHitTest message. Here is some code I wrote for a Borland Tech Info document that does the same thing. unit Dragmain; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject);

782

private procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCHitTest(var M: TWMNCHitTest); begin inherited; { call the inherited message handler if M.Result = htClient then { is the click in the client area? M.Result := htCaption; { if so, make Windows think it's { on the caption bar. end;

} } } }

procedure TForm1.Button1Click(Sender: TObject); begin Close; end; end.

Programming for different resolutions in Delphi 2.0 You need to download: Ti2861 - Form display with different screen resolutions. from the Delphi Technical Support area of our web site at www.borland.com.

How do I know a Form is 'ready' resizing? From: [email protected] The methods you might be concerned with are: {Trap the GetMinMaxInfo message and set minimum window size} { using declared constants } procedure TForm1.WMGETMINMAXINFO( var message: TMessage ); var mStruct: PMinMaxInfo; begin mStruct := PMinMaxInfo(message.lParam); mStruct.ptMinTrackSize.x := HORIZONTALSIZE; mStruct.ptMinTrackSize.y := VERTICALSIZE; message.Result := 0; end;

783

Preventing the user from resizing my window vertically From: Bill Dekleris You must trap WM_GETMINMAXINFO message: in your form's class declaration put this : procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;

and in the implementation section : procedure TMyForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); begin { ---------------------------------------------} { Put your numbers in place of } { MIN_WIDTH, MIN_HEIGHT, MAX_WIDTH, MAX_HEIGHT } { } { To allow only horizontal sizing, put } { form's 'Height' property in place of MIN_HEIGHT, MAX_HEIGHT } { ---------------------------------------------} Msg.MinMaxInfo^.ptMinTrackSize := Point(MIN_WIDTH, MIN_HEIGHT); Msg.MinMaxInfo^.ptMaxTrackSize := Point(MAX_WIDTH, MAX_HEIGHT); inherited end;

It should work fine.

Preventing a From from Resizing Taken from Borland tech info articles 2958: Preventing a From from Resizing In some cases, developers would want to create a regular window (Form) in Delphi that contains some of the characteristics of a dialog box. For example, they do not want to allow their users to resize the form at runtime due to user interface design issues. Other than creating the whole form as a dialog box, there is not a property or a method to handle this in a regular window in Delphi. But due to the solid connection between Delphi and the API layer, developers can accomplish this easily. The following example demonstrates a way of handling the Windows message "WM_GetMinMaxInfo" which allows the developer to restrict the size of windows (forms) at runtime to a specific value. In this case, it will be used to disable the functionality of sizing the window (form) at runtime. Consider the following unit: unit getminmax; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm)

784

private { Private declarations } procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP; procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHitTest; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); begin inherited; with Msg.MinMaxInfo^ do begin ptMinTrackSize.x:= form1.width;

end;

ptMaxTrackSize.x:= form1.width; ptMinTrackSize.y:= form1.height; ptMaxTrackSize.y:= form1.height;

end; procedure TForm1.WMInitMenuPopup(var Msg: TWMInitMenuPopup); begin inherited; if Msg.SystemMenu then EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_GRAYED) end; procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest); begin inherited; with Msg do if Result in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT, HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then Result:= HTNOWHERE end; end. { End of Unit}

A message handler for the windows message "WM_GetMinMaxInfo" in the code above was used to set the minimum and maximum TrackSize of the window to equal the width and height of the form at design time. That was actually enough to disable the resizing of the window (form), but the example went on to handle another couple of messages just to make the application look professional. The first message was the "WMInitMenuPopup" and that was to gray out the size option from the System Menu so that the application does not give the impression that this functionality is available. The second message was the "WMNCHitTest" and that was used to disable the change of the cursor icon whenever the mouse goes over one of the borders of the window (form) for the same reason which is not to give the impression that the resizing functionality is available.

785

messagedlg centering From: "Jonathan M. Bell" Create your own procedure. // Custom coding for The Knoxville News-Sentinel // // jmb 06/28/97 Completed MessageDlgCtr - centers message dialogs above form unit kns; {$R-} interface uses Forms, Dialogs; { Centered message dialog } function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; implementation uses Consts; { This MessageDlg function centers the dialog above the active form } function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; begin with CreateMessageDialog(Msg, DlgType, Buttons) do try HelpContext := HelpCtx; Left := Screen.ActiveForm.Left + (Screen.ActiveForm.Width div 2) (Width div 2); Top := Screen.ActiveForm.Top + (Screen.ActiveForm.Height div 2) (Height div 2); Result := ShowModal; finally Free; end; end; end.

Center a Form I had a problem with centering a form after I had changed its dimensions at run-time. The poScreenCenter only works when the form is shown. But if you change the dimensions at run time your form doesn't center automatically.

[Robert Meek, [email protected]] I've used this in my FormCreate, but I guess it could be called during an OnPaint whenever you change the size of the form too couldn't it?

786

Form1.Left := (Screen.Width div 2) - (Form.Width div 2); Form1.Top := (Screen.Height div 2) - (Form.Height div 2);

[Giuseppe Madaffari, [email protected]] if you use SetBounds, form won't be repainted twice (one time for Left assignment and other time for Top assignment). Try: procedure CenterForm(AForm:TForm); var ALeft,ATop:Integer; begin ALeft := (Screen.Width - AForm.Width) div 2; ATop := (Screen.Height - AForm.Height) div 2; AForm.SetBounds(ALeft, ATop, AForm.Widht, AForm.Height); end;

[Jaycen Dale, [email protected]] Procedure CenterForm(aForm: TForm); Begin aform.left := (screen.width - aform.width) shr 1; aform.top := (screen.height - aform.height) shr 1; End;

custom shaped forms? From: "vanmc" A few months back I responded to a similar question, the response in the form of an example is listed below. The code listed below makes a captionless borderless round form. 1. Start a new application. 2. Override the forms createparams method as shown. 3. Place your bitmap on the form, and set the transparent property to true. 4. Place a speed button on the form and write a method to close the application. (Making a round form will result in the little icons in the corner not being visible. 5. Assign the method shown below to the form's oncreate event. Hope this helps. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Buttons; type TForm1 = class(TForm) Image1: TImage; SpeedButton1: TSpeedButton; procedure FormCreate(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); private

787

{ Private declarations } procedure CreateParams(var Params: TCreateParams); override; public { Public declarations } end; var Form1: TForm1; implementation procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited createparams(params); {This makes a borderless and captionless form} params.style:=params.style or ws_popup xor ws_dlgframe; end; {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var formrgn:hrgn; begin {makes the form clear} form1.brush.style:=bsclear; {makes the form round} GetWindowRgn(form1.Handle, formRgn); DeleteObject(formRgn); formrgn:= CreateroundRectRgn(0, 0,form1.width,form1.width,form1.width,form1.width); SetWindowRgn(form1.Handle, formrgn, TRUE); end; procedure TForm1.SpeedButton1Click(Sender: TObject); begin form1.close; end; end.

minimize non-main forms to the taskbar From: David Watt I posted a message a few weeks ago asking about how to minimize non-main forms to the taskbar, or more precisely, how to minimize applications to the taskbar from forms other than the main form. (I find the fact that secondary forms minimize to the desktop really unappealing.) I received a number of replies (and thanks for those) but no one had an answer. After a little surfing and some trial-and-error I've come up with a solution. In order to have secondary forms minimize the application to the taskbar all you need are the following two steps. 1. Declare a private message handling procedure within the secondary form which will intercept messages destine for the form. private { Private declarations } procedure WMSysCommand(var Message: TMessage); message WM_SYSCOMMAND;

788

2. Create a procedure in the secondary form's implementation section which intercepts messages and puts in place a substitution for SC_MINIMIXE messages so that the Application.Minimize procedure is executed instead. All other messages pass through normally; they are inherited. procedure TForm2.WMSysCommand(var Message: TMessage); begin if (Message.WParam = SC_MINIMIZE) then Application.Minimize else inherited; end;

That's does the trick. Please email me and tell me if you liked this page. Last modified 03/12/00 12:07:38

789

Networking 58. Browsing for a Network Machine (ala Network Neighborhood) 59. Accessing Netware Usernames 60. How to Connect to a Network Drive in Delphi 61. accessing network drive mapping dialog 62. Detect my own IP Address ?

Browsing for a Network Machine (ala Network Neighborhood) From: [email protected] (Michael J. Loeffler) I started messing around with a utility like this, just for fun. I never finished it. I know it did work at the time. You might be able to use some of the code as a base point. Don't know if you feel like poring through the details, but hope it helps. {

}

Network resource utility. Neighborhood.

Similar in function to NetWork-

Michael J. Loeffler 1997.01.31

unit netres_main_unit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, Buttons, Menus, ExtCtrls; type TfrmMain = class(TForm) tvResources: TTreeView; btnOK: TBitBtn; btnClose: TBitBtn; Label1: TLabel; barBottom: TStatusBar; popResources: TPopupMenu; mniExpandAll: TMenuItem; mniCollapseAll: TMenuItem; mniSaveToFile: TMenuItem; mniLoadFromFile: TMenuItem; grpListType: TRadioGroup; grpResourceType: TRadioGroup;

790

dlgOpen: TOpenDialog; dlgSave: TSaveDialog; procedure FormCreate(Sender: TObject); procedure btnCloseClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure mniExpandAllClick(Sender: TObject); procedure mniCollapseAllClick(Sender: TObject); procedure mniSaveToFileClick(Sender: TObject); procedure mniLoadFromFileClick(Sender: TObject); procedure btnOKClick(Sender: TObject); private ListType, ResourceType: DWORD; procedure ShowHint(Sender: TObject); procedure DoEnumeration; procedure DoEnumerationContainer(NetResContainer: TNetResource); procedure AddContainer(NetRes: TNetResource); procedure AddShare(TopContainerIndex: Integer; NetRes: TNetResource); procedure AddShareString(TopContainerIndex: Integer; ItemName: String); procedure AddConnection(NetRes: TNetResource); public { Public declarations } end; var frmMain: TfrmMain; implementation {$R *.DFM} procedure TfrmMain.ShowHint(Sender: TObject); begin barBottom.Panels.Items[0].Text:=Application.Hint; end; procedure TfrmMain.FormCreate(Sender: TObject); begin Application.OnHint:=ShowHint; barBottom.Panels.Items[0].Text:=''; end; procedure TfrmMain.btnCloseClick(Sender: TObject); begin Close; end; {

Enumerate through all network resources: } procedure TfrmMain.DoEnumeration; var NetRes: Array[0..2] of TNetResource; Loop: Integer; r, hEnum, EntryCount, NetResLen: DWORD; begin case grpListType.ItemIndex of { Connected resources: } 1: ListType:=RESOURCE_CONNECTED; { Persistent resources: } 2: ListType:=RESOURCE_REMEMBERED; { Global: } else ListType:=RESOURCE_GLOBALNET; end;

791

case grpResourceType.ItemIndex of { Disk resources: } 1: ResourceType:=RESOURCETYPE_DISK; { Print resources: } 2: ResourceType:=RESOURCETYPE_PRINT; { All: } else ResourceType:=RESOURCETYPE_ANY; end; Screen.Cursor:=crHourGlass; try { Delete any old items in the tree view: } for Loop:=tvResources.Items.Count-1 downto 0 do tvResources.Items[Loop].Delete; except end; { Start enumeration: } r:=WNetOpenEnum(ListType,ResourceType,0,nil,hEnum); if r<>NO_ERROR then begin if r=ERROR_EXTENDED_ERROR then MessageDlg('Unable to Enumerate the Network.'+#13+ 'A network-specific error occurred.',mtError,[mbOK],0) else MessageDlg('Unable to Enumerate the Network.', mtError,[mbOK],0); Exit; end; try { We got a valid enumeration handle; walk the resources: } while (1=1) do begin EntryCount:=1; NetResLen:=SizeOf(NetRes); r:=WNetEnumResource(hEnum,EntryCount,@NetRes,NetResLen); case r of 0: begin { It's a container, iterate it: } if NetRes[0].dwUsage=RESOURCEUSAGE_CONTAINER then DoEnumerationContainer(NetRes[0]) else { Persistent and connected resources show up here: } if ListType in [RESOURCE_REMEMBERED,RESOURCE_CONNECTED] then AddConnection(NetRes[0]); end; { Done: } ERROR_NO_MORE_ITEMS: Break; { Other error: } else begin MessageDlg('Error Walking Resources.',mtError,[mbOK],0); Break; end; end; end; finally Screen.Cursor:=crDefault; { Close enumeration handle: } WNetCloseEnum(hEnum); end; end;

792

{ Enumerate through the specified container: This function is usually recursively called.

} procedure TfrmMain.DoEnumerationContainer(NetResContainer: TNetResource); var NetRes: Array[0..10] of TNetResource; TopContainerIndex: Integer; r, hEnum, EntryCount, NetResLen: DWORD; begin { Add container name to tree view: } AddContainer(NetResContainer); { Keep track of this item as current root: } TopContainerIndex:=tvResources.Items.Count-1; { Start enumeration: } if ListType=RESOURCE_GLOBALNET then { Enumerating global net: } r:=WNetOpenEnum(ListType,ResourceType,RESOURCEUSAGE_CONTAINER, @NetResContainer,hEnum) else { Enumerating connections or persistent (won't normally get here): } r:=WNetOpenEnum(ListType,ResourceType,RESOURCEUSAGE_CONTAINER, nil,hEnum); { Couldn't enumerate through this container; just make a note of it and continue on: } if r<>NO_ERROR then begin AddShareString(TopContainerIndex,''); WNetCloseEnum(hEnum); Exit; end; { We got a valid enumeration handle; walk the resources: } while (1=1) do begin EntryCount:=1; NetResLen:=SizeOf(NetRes); r:=WNetEnumResource(hEnum,EntryCount,@NetRes,NetResLen); case r of 0: begin { Yet another container to enumerate; call this function recursively to handle it: } if (NetRes[0].dwUsage=RESOURCEUSAGE_CONTAINER) or (NetRes[0].dwUsage=10) then DoEnumerationContainer(NetRes[0]) else case NetRes[0].dwDisplayType of { Top level type: } RESOURCEDISPLAYTYPE_GENERIC, RESOURCEDISPLAYTYPE_DOMAIN, RESOURCEDISPLAYTYPE_SERVER: AddContainer(NetRes[0]); { Share: } RESOURCEDISPLAYTYPE_SHARE: AddShare(TopContainerIndex,NetRes[0]); end; end; ERROR_NO_MORE_ITEMS: Break; else begin MessageDlg('Error #'+IntToStr(r)+' Walking Resources.',mtError,[mbOK],0); Break;

793

end; end; end; { Close enumeration handle: } WNetCloseEnum(hEnum); end; procedure TfrmMain.FormShow(Sender: TObject); begin DoEnumeration; end; { Add item to tree view; indicate that it is a container: } procedure TfrmMain.AddContainer(NetRes: TNetResource); var ItemName: String; begin ItemName:=Trim(String(NetRes.lpRemoteName)); if Trim(String(NetRes.lpComment))<>'' then begin if ItemName<>'' then ItemName:=ItemName+' '; ItemName:=ItemName+'('+String(NetRes.lpComment)+')'; end; tvResources.Items.Add(tvResources.Selected,ItemName); end; {

Add child item to container denoted as current top: } procedure TfrmMain.AddShare(TopContainerIndex: Integer; NetRes: TNetResource); var ItemName: String; begin ItemName:=Trim(String(NetRes.lpRemoteName)); if Trim(String(NetRes.lpComment))<>'' then begin if ItemName<>'' then ItemName:=ItemName+' '; ItemName:=ItemName+'('+String(NetRes.lpComment)+')'; end; tvResources.Items.AddChild(tvResources.Items[TopContainerIndex],ItemName); end; { Add child item to container denoted as current top; this just adds a string for purposes such as being unable to enumerate a container. That is, the container's shares are not accessible to us.

} procedure TfrmMain.AddShareString(TopContainerIndex: Integer; ItemName: String); begin tvResources.Items.AddChild(tvResources.Items[TopContainerIndex],ItemName); end; { Add a connection to the tree view. Mostly used for persistent and currently connected resources to be displayed.

} procedure TfrmMain.AddConnection(NetRes: TNetResource);

794

var ItemName: String; begin ItemName:=Trim(String(NetRes.lpLocalName)); if Trim(String(NetRes.lpRemoteName))<>'' then begin if ItemName<>'' then ItemName:=ItemName+' '; ItemName:=ItemName+'-> '+Trim(String(NetRes.lpRemoteName)); end; tvResources.Items.Add(tvResources.Selected,ItemName); end; { Expand all containers in the tree view: } procedure TfrmMain.mniExpandAllClick(Sender: TObject); begin tvResources.FullExpand; end; { Collapse all containers in the tree view: } procedure TfrmMain.mniCollapseAllClick(Sender: TObject); begin tvResources.FullCollapse; end; { Allow saving of tree view to a file: } procedure TfrmMain.mniSaveToFileClick(Sender: TObject); begin if dlgSave.Execute then tvResources.SaveToFile(dlgSave.FileName); end; { Allow loading of tree view from a file: } procedure TfrmMain.mniLoadFromFileClick(Sender: TObject); begin if dlgOpen.Execute then tvResources.LoadFromFile(dlgOpen.FileName); end; { Rebrowse: } procedure TfrmMain.btnOKClick(Sender: TObject); begin DoEnumeration; end; end.

Accessing Netware Usernames From: "Ryan Smith" You can try this code. I've been using it on a Netware LAN for some time now with no problems. It depends on having the NWCALLS.DLL library already on the users machine; if users have a Netware connection, then they should already have that DLL.

795

unit GetLogin; {This unit is a wrapper for several external functions in the NWCALLS.DLL} {Adapted by Ray Buck from code written by Gregory Trubetskoy} {The unit contains a function that returns the Netware User ID} {and one that returns the user's full name.} interface uses SysUtils, Messages, Dialogs; function GetUserLogin: string; function GetUserFullName( SomeUser: string): string; implementation type NWTimeStamp = record Year: byte; Month: byte; Day: byte; Hour: byte; Minute: byte; Second: byte; DayOfWeek: byte; end; {Netware API's - require NWCALLS.DLL} function NWGetDefaultConnectionID(var Connection: word): word; far; external 'NWCALLS'; function NWGetConnectionNumber(Connection: word; var ConnectionNumber: word): word; far; external 'NWCALLS'; function NWGetConnectionInformation(Connection: word; ConnectionNumber: word; ObjectName: pchar; var ObjectType: word; var ObjectID: word; var LoginTime: NWTimeStamp):word; far; external 'NWCALLS'; function NWReadPropertyValue(Connection: ObjectName: ObjectType: PropertyName: DataSetIndex: DataBuffer: var More: var Flags: far; external 'NWCALLS'; { end of Netware API stuff }

word; pChar; word; pChar; byte; pChar; byte; byte): word;

function GetUserLogin: string; var ConnectionID: word; ConnectionNumber: word; RC: word; Name: array[0..50] of Char; ObjectType: word; ObjectID: word; LoginTime: NWTimeStamp; begin RC := NWGetDefaultConnectionID(ConnectionID); RC := NWGetConnectionNumber(ConnectionID, ConnectionNumber); RC := NWGetConnectionInformation( ConnectionID, ConnectionNumber,

796

Name, ObjectType, ObjectID, LoginTime); Result := StrPas(Name); end; function GetUserFullName( SomeUser: string): string; {The real user name is a 'property' called 'IDENTIFICATON'. You have to call NWReadPropertyValue passing it (among other things) your ConnectionID, the name of the object (same as the login of the user who's full name you need) and the name property you want to retrieve, in this case 'IDENTIFICATION' (which translated from Novellish to English means 'Full Name').} var ConnectionID: word; RC: word; Name: array[0..50] of Char; ObjectType: word; PropName: array[0..14] of Char; DataSetIndex: byte; FullName: array[0..127] of Char; More: byte; Flags: byte; begin RC := NWGetDefaultConnectionID(ConnectionID); ObjectType := 256; {user} StrPCopy(PropName, 'IDENTIFICATION'); DataSetIndex := 1; StrPCopy(Name, SomeUser); RC := NWReadPropertyValue( ConnectionID, Name, ObjectType, PropName, DataSetIndex, FullName, More, Flags); if RC = 35324 then MessageDlg('No user ' + SomeUser + ' exists on this server!', mtError, [mbOK], 0); Result := StrPas(FullName); end; end.

How to Connect to a Network Drive in Delphi This document explains how to create a 'Network' button that brings up a connection dialog and then sets a drive box to point to the new drive in Delphi. The code was created in Delphi 2, but doing it in Delphi 1 should be about the same procedure. Create a command button named NetBtn, and a drive combo box named DriveBox. Then type this code in the OnClick event for the button: procedure TStartForm.NetBtnClick(Sender: TObject); var OldDrives: TStringList; i: Integer; begin OldDrives := TStringList.Create;

797

OldDrives.Assign(Drivebox.Items); // Remember old drive list // Show the connection dialog if WNetConnectionDialog(Handle, RESOURCETYPE_DISK) = NO_ERROR then begin DriveBox.TextCase := tcLowerCase; // Refresh the drive list box for i := 0 to DriveBox.Items.Count - 1 do begin if Olddrives.IndexOf(Drivebox.Items[i]) = -1 then begin // Find new Drive letter DriveBox.ItemIndex := i; // Updates the drive list box to new drive letter DriveBox.Drive := DriveBox.Text[1]; // Cascades the update to connected directory lists, etc end; end; DriveBox.SetFocus; end; OldDrives.Free; end;

You must also add the WinProcs and WinTypes units to the uses clause of your unit. The difficult part here is that the DriveComboBox lacks a refresh function. By setting the TextCase property, we force an update of the box. Copyright © 1997 by Josef Garvi

accessing network drive mapping dialog From: Edward McSweeney Try WNetConnectionDialog. This function is already pre-wrapped in Windows.pas and is specifically designed to do exactly what you want it to do.

Detect my own IP Address ? From: Andreas Hoerstemeier > How can I detect my own IP address in delphi 1? function my_ip_address:longint; const bufsize=255; var buf: pointer; RemoteHost : PHostEnt; (* No, don't free it! *) begin buf:=NIL; try getmem(buf,bufsize); winsock.gethostname(buf,bufsize); (* this one maybe without domain *) RemoteHost:=Winsock.GetHostByName(buf); if RemoteHost=NIL then my_ip_address:=winsock.htonl($07000001) (* 127.0.0.1 *) else my_ip_address:=longint(pointer(RemoteHost^.h_addr_list^)^); finally if buf<>NIL then freemem(buf,bufsize); end; result:=winsock.ntohl(result);

798

end;

This give the (first) network address of the local computer, and if not connected the 127.0.0.1 as the standard address for the local computer. You only need a winsock.dcu/winsock.pas as this one isn't included with D1; I have one together with my tcpip component pack (where I snipped out the above routine). Please email me and tell me if you liked this page. Last modified 03/12/00 12:09:27

799

Printer 63. Help on Printer Control Codes 64. How to get Paper Source? 65. Printing Rotated text...printer2 66. Stretched bitmap on TPrinter 67. How to print a bitmap? 68. Dump a text file 69. Printing a line at a time 70. Printing Tricks 71. Passthough escape function 72. How to print exact sizes 73. Windows API about Printer 74. Property changes in same printprinter11 75. Paper Formatsprinter12

Help on Printer Control Codes From: [email protected] (David Block) Vincent Lim wrote: How do I send Printer Control Codes to the printer without having them translated into unprintable characters? Not sure if it is Windows API or Delphi is the culprit. When I write the printer control codes, they are just printed as unprintable characters rather than being interpreted by the printer.

You need to use the Passthrough printer Escape function to send data directly to the printer. If you're using WriteLn, then it won't work. Here's some code to get you started: unit Passthru; interface uses printers, WinProcs, WinTypes, SysUtils; Procedure

PrintTest;

implementation Type

TPassThroughData = Record nLen : Integer; Data : Array[0..255] of byte; end;

Procedure DirectPrint(s : String); var PTBlock : TPassThroughData; Begin PTBlock.nLen := Length(s); StrPCopy(@PTBlock.Data,s); Escape(printer.handle, PASSTHROUGH,0,@PTBlock,nil); End;

800

Procedure PrintTest; Begin Printer.BeginDoc; DirectPrint(CHR(27)+'&l1O'+'Hello, World!'); Printer.EndDoc; End; end.

How to get Paper Source? 'Joe C. Hecht' Below are some code snippets to change the printer settings. Wherever the changes are made, you could instead examine the printer settings. See the documentation for ExtDeviceMode and the TDEVMODE structure as well the printer escape GETSETPAPERBINS and GetDeviceCaps(). ********************************************* One way to change printer settings at the start of a print job is to change the printers devicemode. Example: var Device : array[0..255] of char; Driver : array[0..255] of char; Port : array[0..255] of char; hDMode : THandle; PDMode : PDEVMODE; begin Printer.PrinterIndex := Printer.PrinterIndex; Printer.GetPrinter(Device, Driver, Port, hDMode); if hDMode <> 0 then begin pDMode := GlobalLock(hDMode); if pDMode <> nil then begin pDMode^.dmFields := pDMode^.dmFields or DM_COPIES; pDMode^.dmCopies := 5; GlobalUnlock(hDMode); end; GlobalFree(hDMode); end; Printer.PrinterIndex := Printer.PrinterIndex; Printer.BeginDoc; Printer.Canvas.TextOut(100,100, 'Test 1'); Printer.EndDoc;

Another way is to change TPrinter. This will enable you to change settings in mid job. You must make the change >>>between<<< pages. To do this: Before every startpage() command in printers.pas in the Source\VCL directory add something like: DevMode.dmPaperSize:=DMPAPER_LEGAL {any other devicemode settings go here} Windows.ResetDc(dc,Devmode^);

801

This will reset the pagesize. you can look up DEVMODE in the help to find other paper sizes. You will need to rebuild the vcl source for this to work, by adding the path to the VCL source directory to the beginning of the library path s tatement under tools..options.. library...libaray path. Quit Delphi then do a build all. Another quick note... When changing printers, be aware that fontsizes may not always scale properly. To ensure proper scaling set the PixelsPerInch property of the font. Here are two examples: uses Printers; var MyFile: TextFile; begin AssignPrn(MyFile); Rewrite(MyFile); Printer.Canvas.Font.Name := 'Courier New'; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.Font.PixelsPerInch:= GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY); Writeln(MyFile, 'Print this text'); System.CloseFile(MyFile); end;

uses Printers; begin Printer.BeginDoc; Printer.Canvas.Font.Name := 'Courier New'; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.Font.PixelsPerInch:= GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY); Printer.Canvas.Textout(10, 10, 'Print this text'); Printer.EndDoc; end;

Printing Rotated text... 1. From: "Peter Szymiczek"

802

procedure AngleTextOut(CV: TCanvas; const sText: String; x, y, angle:integer); var LogFont: TLogFont; SaveFont: TFont; begin SaveFont := TFont.Create; SaveFont.Assign(CV.Font); GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont); with LogFont do begin lfEscapement := angle *10; lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE; end; {with} CV.Font.Handle := CreateFontIndirect(LogFont); SetBkMode(CV.Handle, TRANSPARENT); CV.TextOut(x, y, sText); CV.Font.Assign(SaveFont); SaveFont.Free; end;

2. From: Jukka Palomäki This is how I have solved the problem: procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: String); var b1, b2: TBitmap; i, j: Integer; begin with bitmap.Canvas do begin b1 := TBitmap.Create; b1.Canvas.Font := lpYhFont; b1.Width := TextWidth(s) + 1; b1.Height := TextHeight(s) + 1; b1.Canvas.TextOut(1, 1, s); b2 := TPackedBitmap.Create; b2.Width := TextHeight(s); b2.Height := TextWidth(s); for i := 0 to b1.Width - 1 do for j := 0 to b1.Height do b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];

Draw(x, y, b2); b1.Free; b2.Free; end end;

3. From: "Dmitry" Long time ago I did so: I created font, select it in DC ... function CreateMyFont(degree: Integer): HFONT; begin CreateMyFont := CreateFont( -30, 0, degree, 0, 0, 0, 0, 0, 1, OUT_TT_PRECIS, 0, 0, 0, szFontName); end;

.... and then I used any draw text function for text output. 4. "Eric Lawrence"

803

The method (1) shown is quite slow, as it requires drawing the text, and then inefficiently rotating it. Try this instead: procedure TForm1.TextUp(aRect:tRect;aTxt:String); var LFont: TLogFont; hOldFont, hNewFont: HFont; begin GetObject(Canvas.Font.Handle,SizeOf(LFont),Addr(LFont)); LFont.lfEscapement := 900; hNewFont := CreateFontIndirect(LFont); hOldFont := SelectObject(Canvas.Handle,hNewFont); Canvas.TextOut(aRect.Left+2,aRect.Top,aTxt); hNewFont := SelectObject(Canvas.Handle,hOldFont); DeleteObject(hNewFont); end;

Stretched bitmap on TPrinter [email protected] (Alexander Wernhart) On Tue, 4 Feb 1997 20:54:43 -0300, Ruy Ponce de Leon Junior wrote: I'm writing a program that prints a bitmap to the printer via TPrinter object. The problem occurs when I "stretch" the bitmap to fit the adequate area on paper. Due to the stretching (bitblts to Printer's DC), dotted patterns appear on the bitmap regions, making them almost gray. This is an obvius undesired effect. Does anybody knows some approach to help me?

Try this: procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap); var Header, Bits: Pointer; HeaderSize: Integer; BitsSize: Longint; begin GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize); Header := MemAlloc(HeaderSize); Bits := MemAlloc(BitsSize); try GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^); StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right, DestRect.Bottom, 0, 0, ABitmap.Width, ABitmap.Height, Bits,TBitmapInfo(Header^), DIB_RGB_COLORS, SRCCOPY); { you might want to try DIB_PAL_COLORS instead, but this is well beyond the scope of my knowledge. } finally MemFree(Header, HeaderSize); MemFree(Bits, BitsSize); end; end; { Print a Bitmap using the whole Printerpage } procedure PrintBitmap(ABitmap: TBitmap); var relheight, relwidth: integer;

804

begin screen.cursor := crHourglass; Printer.BeginDoc; if ((ABitmap.width / ABitmap.height) > (printer.pagewidth /printer.pageheight)) then begin { Stretch Bitmap to width of Printerpage } relwidth := printer.pagewidth; relheight := MulDiv(ABitmap.height, printer.pagewidth,ABitmap.width); end else begin { Stretch Bitmap to height of Printerpage } relwidth := MulDiv(ABitmap.width, printer.pageheight, ABitmap.height); relheight := printer.pageheight; end; DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), ABitmap); Printer.EndDoc; screen.cursor := crDefault; end;

How to print a bitmap? Use the following code. Remember to include the Printers unit in the uses clause : Lines followed by // ** are essential. The others are to get the scaling correct otherwise you end up with extremely small images. Printer resolutions are higher than your screen resolution. procedure TForm1.Button1Click(Sender: TObject); var ScaleX, ScaleY: Integer; R: TRect; begin Printer.BeginDoc; // ** with Printer do try ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch; ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch; R := Rect(0, 0, Image1.Picture.Width * ScaleX, Image1.Picture.Height * ScaleY); Canvas.StretchDraw(R, Image1.Picture.Graphic); // ** finally EndDoc; // ** end; end;

Dump a text file From: Chris Monson Use CreateFile to get a handle to LPT1 LPTHandle := CreateFile( 'LPT1',GENERIC_WRITE, 0, PSecurityAttributes(nil), OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);

805

Then use WriteFile to send a string of characters or use While not TransmitCommChar( LPTHandle, CharToSend ) do Application.ProcessMessages;

It sends one raw character at a time to the parallel port. It waits for the recent character to get processed and then immediately sends a new one. I got it printing stuff pretty fast.

Printing a line at a time From: Peter van Lonkhuyzen > I've tried to write a D1 or D2 program that will print only one line at a time to a printer (any type), exit the program but NOT eject the page, so that the next time I run the program and it prints a line, it prints on the very next line, etc.

According to M$ this is illegal as it "defeats the multitasking nature" but I needed the same functionality. I created the following derivative of the TPrinter object. It works perfectly on dotmatrix printers. sample usage var Myprinter : TRawPrinter; oldprinter : TPrinter; begin MyPrinter:=TRawPrinter.Create; oldprinter:=setprinter(MyPrinter); try if Printdialog1.execute then begin myprinter.startraw; myprinter.write('khsdhskhkshdksd'); myprinter.writeln; myprinter.endraw; end finally setprinter(oldprinyter); myprinter.free; end end;

Here is the code for the raw printer object. unit Rawprinter; interface uses printers,windows; type TRawprinter =class(TPrinter) public dc2 : HDC; procedure startraw; procedure endraw; procedure write(const s : string); procedure writeln; end; implementation

806

uses sysutils,forms; function AbortProc(Prn: HDC; Error: Integer): Bool; stdcall; begin Application.ProcessMessages; Result := not Printer.Aborted; end; type TPrinterDevice = class Driver, Device, Port: String; constructor Create(ADriver, ADevice, APort: PChar); function IsEqual(ADriver, ADevice, APort: PChar): Boolean; end; constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar); begin inherited Create; Driver := ADriver; Device := ADevice; Port := APort; end; function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean; begin Result := (Device = ADevice) and (Port = APort); end; procedure TRawprinter.startraw; var CTitle: array[0..31] of Char; CMode : Array[0..4] of char; DocInfo: TDocInfo; r : integer; begin StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1); StrPCopy(CMode, 'RAW'); FillChar(DocInfo, SizeOf(DocInfo), 0); with DocInfo do begin cbSize := SizeOf(DocInfo); lpszDocName := CTitle; lpszOutput := nil; lpszDatatype :=CMode; end; with TPrinterDevice(Printers.Objects[PrinterIndex]) do begin DC2 := CreateDC(PChar(Driver), PChar(Device), PChar(Port), nil); end; SetAbortProc(dc2, AbortProc); r:=StartDoc(dc2, DocInfo); end; procedure TRawprinter.endraw; var r : integer; begin r:=windows.enddoc(dc2); end; type passrec = packed record l : word; s : Array[0..255] of char; end; var pass : Passrec; procedure TRawprinter.write(const s : string);

807

begin pass.l:=length(s); strpcopy(pass.s,s); escape(dc2,PASSTHROUGH,0,@pass,nil); end; procedure TRawprinter.writeln; begin pass.l:=2; strpcopy(pass.s,#13#10); escape(dc2,PASSTHROUGH,0,@pass,nil); end; end.

Printing Tricks [email protected] (Robert Gilland) "Guy Vandenberg" You are a genius. After pulling my hair out and downloading anything that had anything to do with printing in delphi on the net and getting nowhere fast. Your little piece of code actually made sence to me and was userfrindly. I put it together with other code other small hints on printing and I got the below. Use it to your delight. You were the initiator. const INCHES_PER_MILIMETER : Real type TOffset =

= 0.04;

record X,Y: Integer; end;

var FDeviceName : String; {Get the name} FPageHeightPixel, FPageWidthPixel : Integer ; {Page height and Page Width} FOrientation : TPrinterOrientation; {Orientation} FPrintOffsetPixels : TOffset; FPixelsPerMMX,FPixelsPerMMY: Real; MMSize, FPageHeightMM : Integer; TheReport, TheHead, HeadLine, RecordLine, TFname, TLname :String; procedure TMissing_Rep.GetDeviceSettings; var retval: integer; PixX, PixY: Integer; begin FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Get the name} FPageHeightPixel := Printer.PageHeight; {Page height} FPageWidthPixel := Printer.PageWidth; {Page Width} FOrientation := Printer.Orientation; {Orientation} {Get the printable area offsets} {$IFDEF WIN32} FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); {$ELSE} retval := Escape(Printer.Handle,GETPRINTINGOFFSET, 0, nil, @FPrintOffsetPixels); {$ENDIF}

808

{Get Pixels per Milimeter Ratio} PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); FPixelsPerMMX := INCHES_PER_MILIMETER * PixX; FPixelsPerMMY := INCHES_PER_MILIMETER * PixY; FPageHeightMM := Round(FPageHeightPixel/FPixelsPerMMY); end; function TMissing_Rep.PutText(mmX,mmY: Integer; S: string; LeftAlign: Boolean): boolean; var X, Y: Integer; align: WORD; begin if LeftAlign then align := SetTextAlign(Printer.Handle,TA_BOTTOM or TA_LEFT) else align := SetTextAlign(Printer.Handle,TA_BOTTOM or TA_RIGHT); result := FALSE; {Assume fail} X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X; Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y; if X < 0 then exit; if Y < 0 then exit; Printer.Canvas.TextOut(X,Y,S); result := TRUE; end; procedure TMissing_Rep.Print_ButClick(Sender: TObject); var PixelSize: Integer; begin Print_But.Enabled := False; if PrintDialog1.Execute then begin Printer.Canvas.Font := Missing_Rep.Font; PixelSize := Printer.Canvas.TextHeight('Yy'); MMSize := Round(PixelSize/FPixelsPerMMY); Printer.Title := 'Breast Cancer Project Missing Report'; Printer.BeginDoc; { begin to send print job to printer } PrintGenerator; Printer.EndDoc; { EndDoc ends and starts printing print job } end; Print_But.Enabled := True; end; procedure TMissing_Rep.PrintGenerator; Var yLoc , NumRows, TheRow :Integer; procedure Heading; begin yLoc := 20; PutText(20, 20, TheHead, TRUE); yLoc := yLoc + MMSize; PutText(20, yLoc, StringGrid1.Cells[0,0], PutText(60, yLoc, StringGrid1.Cells[1,0], PutText(100, yLoc, StringGrid1.Cells[2,0], PutText(120, yLoc, StringGrid1.Cells[3,0], PutText(150, yLoc, StringGrid1.Cells[4,0], yLoc := yLoc + MMSize; end;

TRUE); TRUE); TRUE); TRUE); TRUE);

procedure Footer; begin

809

PutText(100,FPageHeightMM,InttoStr(Printer.PageNumber), TRUE); end; begin Heading; TheRow := 1; while (TheRow < StringGrid1.RowCount) do begin if (yLoc > (FPageHeightMM - MMSize)) then begin Footer; Printer.NewPage; Heading; end; TheGauge.Progress := Round(100 * TheRow/(StringGrid1.RowCount - 1)); PutText(20, yLoc, StringGrid1.Cells[0,TheRow], TRUE); PutText(60, yLoc, StringGrid1.Cells[1,TheRow], TRUE); PutText(100, yLoc, StringGrid1.Cells[2,TheRow], TRUE); PutText(120, yLoc, StringGrid1.Cells[3,TheRow], TRUE); PutText(150, yLoc, StringGrid1.Cells[4,TheRow], TRUE); yLoc := yLoc + MMSize; TheRow := TheRow + 1; end; Footer; end;

Passthough escape function "Joe C. Hecht" Gilberto Beda wrote: > someone knows why some windows drivers don't work with a passthrough in Escape function? Is it possible to know if a driver printer support the PASSTROUGH function? I believe Dos apps in 95 use the same function if I command "copy file > lpt1" Windows95 use the predefint drivers to spool the report to printer.

Although Delphi's TPrinter unit makes it easy to interface to a given printer, there are times when you may need to drop down to the printers level and send device specific escape sequences. Under sixteen bit versions of Windows, this was as easy as opening the printer port, but under Windows NT, directly accessing the hardware is is illegal. One solution is to use the Windows "PASSTHROUGH" escape to send an escape sequence directly to the printer. In order to use the "PASSTHROUGH" escape, it must be supported by the printer driver. Be forwarned that not all printer drivers will support this feature. It's worth noting that the "PASSTHROUGH" escape is documented as obsolete for thirtytwo bit applications. It should be a number of years before this escape goes by the way, since it is used in many commercial applications. The example code presented is not targeted to any specific printer model. You will need to know the correct escape sequences to send to the printer you are interfacing to. Note that you must still call the BeginDoc and EndDoc methods of TPrinter. During the BeginDoc call, the printer driver initializes the printer as necessary, and during the EndDoc call, the printer driver will uninitialize the printer and eject the page. When you do make your escape call, the printer may be set for the current windows mapping mode if the printer supports scaling internaly. Technically, you should not do anything that would cause the printer memory to be reset, or eject a page with an escape sequence. In other words, try 810

to leave the printer in the same state it was in when you made your escape. This is more important on intellegent printers (Postscript printers), and not important at all on a standard TTY line printer, where you can do just about anything you like, including ejecting pages. Code Example: You will need to declare a structure to hold the buffer you are sending. The structure of the buffer is defined as a word containing the length of the buffer, followed by the buffer containing the data. Before making the escape call to pass the data, we will use the escape "QUERYESCSUPPORT" to determine if the "PASSTHROUGH" escape is supported by the print driver. Finally, be aware that your data will be inserted directly into the printers data stream. On some printer models (Postscript), you may need to add a space to the start and end of your data to separate your data from the printer drivers data. (Postscript is a Registered Trademark of Adobe Systems Incorporated) *) unit Esc1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation { add the printers unit } uses Printers; {$R *.DFM} { declare the "PASSTHROUGH" structure } type TPrnBuffRec = record BuffLength : word; Buffer : array [0..255] of char; end; procedure TForm1.Button1Click(Sender: TObject); var Buff : TPrnBuffRec; TestInt : integer; s : string; begin { Test to see if the "PASSTHROUGH" escape is supported } TestInt := PASSTHROUGH;

811

if Escape(Printer.Handle, QUERYESCSUPPORT, sizeof(TestInt), @TestInt, nil) > 0 then begin { Start the printout } Printer.BeginDoc; { Make a string to passthrough } s := ' A Test String '; { Copy the string to the buffer } StrPCopy(Buff.Buffer, s); { Set the buffer length } Buff.BuffLength := StrLen(Buff.Buffer); { Make the escape} Escape(Printer.Canvas.Handle, PASSTHROUGH, 0, @Buff, nil); { End the printout } Printer.EndDoc; end; end; end.

How to print exact sizes From: "Earl F. Glynn" The following sample UNIT shows how to use GetDeviceCaps to obtain much information about your printer, including the HORZRES and VERTRES (horizontal and vertical resolution in pixels) and the dimensions in inches. Or, use the LOGPIXELSX and LOGPIXELSY values for the dot density/inch in the horizontal and vertical dimensions. In addition to the info about a printer, the example below shows how to print a bitmap in its "natural" size, or at a specific location with a specific size on the page. I think this should give you some clues about how to solve your problem. The example also shows to plot a sine wave at a particular location with a given size (all in inches). Since we in the U.S. are incapable of converting inches to metric (I jest), you'll have to figure that part out yourself. unit Tstpr2fm; {Sample usage of Printer object from TPrinter Unit. below to simplify future reference.

Use verbose style

Shows values returned by GetDeviceCaps Windows API function. efg, 19 September 1996} interface

812

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Print: TButton; Image1: TImage; procedure PrintClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation USES Printers; {WINAPI GetDeviceCaps Constants from C++ windows.h and wingdi.h} {The indivdual constants are defined here CONST DRIVERVERSION = 0; TECHNOLOGY = 2; {See windows.h HORZSIZE = 4; VERTSIZE = 6; HORZRES = 8; VERTRES = 10; BITSPIXEL = 12; PLANES = 14; NUMBRUSHES = 16; NUMPENS = 18; NUMMARKERS = 20; NUMFONTS = 22; NUMCOLORS = 24; PDEVICESIZE = 26; CURVECAPS = 28; {See windows.h LINECAPS = 30; {See windows.h POLYGONALCAPS = 32; {See windows.h TEXTCAPS = 34; {See windows.h CLIPCAPS = 36; {See windows.h RASTERCAPS = 38; {See windows.h ASPECTX = 40; ASPECTY = 42; ASPECTXY = 44; LOGPIXELSX LOGPIXELSY

= =

SIZEPALETTE NUMRESERVED COLORRES

= 104; = 106; = 108;

PHYSICALWIDTH PHYSICALHEIGHT PHYSICALOFFSETX PHYSICALOFFSETY SCALINGFACTORX SCALINGFACTORY

= = = = = =

for reference only} for mask values}

for for for for for for

mask mask mask mask mask mask

values} values} values} values} values} values}

for for for for for for

definition} definition} definition} definition} definition} definition}

88; 90;

110; 111; 112; 113; 114; 115;

{See {See {See {See {See {See

wingdi.h wingdi.h wingdi.h wingdi.h wingdi.h wingdi.h

DeviceCapsString: ARRAY[1..34] OF STRING = ('DRIVERVERSION', 'TECHNOLOGY', 'HORZSIZE',

813

'VERTSIZE', 'HORZRES', 'VERTRES', 'BITSPIXEL', 'PLANES', 'NUMBRUSHES', 'NUMPENS', 'NUMMARKERS', 'NUMFONTS', 'NUMCOLORS', 'PDEVICESIZE', 'CURVECAPS', 'LINECAPS', 'POLYGONALCAPS', 'TEXTCAPS', 'CLIPCAPS', 'RASTERCAPS', 'ASPECTX', 'ASPECTY', 'ASPECTXY', 'LOGPIXELSX', 'LOGPIXELSY', 'SIZEPALETTE', 'NUMRESERVED', 'COLORRES', 'PHYSICALWIDTH', 'PHYSICALHEIGHT', 'PHYSICALOFFSETX','PHYSICALOFFSETY','SCALINGFACTORX', 'SCALINGFACTORY'); DeviceCapsIndex: ARRAY[1..34] OF INTEGER = ( 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 88, 90, 104, 106, 108, 110, 111, 112, 113, 114, 115); {$R *.DFM} FUNCTION iPosition(const i: INTEGER): INTEGER; BEGIN RESULT := Integer(i * LongInt(Printer.PageWidth) END {iPosition};

DIV 1000)

FUNCTION jPosition(const j: INTEGER): INTEGER; BEGIN RESULT := Integer(j * LongInt(Printer.PageHeight) DIV 1000) END {jPosition}; procedure TForm1.PrintClick(Sender: TObject); VAR DestinationRectangle: TRect; GraphicAspectRatio : DOUBLE; i : INTEGER; j : INTEGER; iBase : INTEGER; iPixelsPerInch : WORD; jBase : INTEGER; jDelta : INTEGER; jPixelsPerInch : WORD; OffScreen : TBitMap; PixelAspectRatio : DOUBLE; SourceRectangle : TRect; TargetRectangle : TRect; value : INTEGER; x : DOUBLE; y : DOUBLE; begin Printer.Orientation := poLandscape; Printer.BeginDoc; {Draw a rectangle to show the margins} Printer.Canvas.Rectangle(0,0, Printer.PageWidth, Printer.PageHeight); {Properties of Printer and Page} Printer.Canvas.Font.Name := 'Times New Roman'; Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iPosition(50), jPosition(40), 'Printer/Page Properties'); Printer.Canvas.Font.Style := []; Printer.Canvas.Font.Size := 10;

814

iBase := iPosition(50); jBase := 60; jDelta := 18; Printer.Canvas.TextOut(iPosition(50), jPosition(jBase), Printer.Printers.Strings[Printer.PrinterIndex]); INC (jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Pixels: ' + IntToStr(Printer.PageWidth) + ' X ' + IntToStr(Printer.PageHeight)); INC (jBase, jDelta);

+

Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Inches: ' + FormatFloat('0.000', Printer.PageWidth / Printer.Canvas.Font.PixelsPerInch) + ' X ' FormatFloat('0.000', Printer.PageHeight / Printer.Canvas.Font.PixelsPerInch)); INC (jBase, 2*jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Font: ' + Printer.Canvas.Font.Name + ' Size: IntToStr(Printer.Canvas.Font.Size)); INC (jBase, jDelta);

' +

Printer.Canvas.TextOut(iBase, jPosition(jBase), 'PixelsPerInch: ' + IntToStr(Printer.Canvas.Font.PixelsPerInch)); INC (jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), '''TEXT'': ' + IntToStr(Printer.Canvas.TextWidth('TEXT')) + ' X ' + IntToStr(Printer.Canvas.TextHeight('TEXT')) + ' pixels'); {GetDeviceCaps Values} INC (jBase, 2*jDelta); Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iBase, jPosition(jBase), 'GetDeviceCaps'); INC (jBase, jDelta); Printer.Canvas.Font.Size := 10; Printer.Canvas.Font.Style := []; FOR j := LOW(DeviceCapsIndex) TO HIGH(DeviceCapsIndex) DO BEGIN value := GetDeviceCaps(Printer.Handle, DeviceCapsIndex[j]); Printer.Canvas.TextOut(iBase, jPosition(jBase), DeviceCapsString[j]); IF (DeviceCapsIndex[j] < 28) OR (DeviceCapsIndex[j] > 38) THEN Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%-8d', [value])) ELSE Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%.4x', [value])); INC (jBase, jDelta); END; {Put image in lower left corner} Printer.Canvas.Draw (iPosition(300), jPosition(100), Form1.Image1.Picture.Graphic); {Place same image, 1" wide with appropriate height at location 4" over and 1" down from top left}

815

GraphicAspectRatio := Form1.Image1.Picture.Height / Form1.Image1.Picture.Width; iPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSX); jPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSY); PixelAspectRatio := jPixelsPerInch / iPixelsPerInch; TargetRectangle := Rect(4*iPixelsPerInch, {4"} jPixelsPerInch, {1"} 6*iPixelsPerInch, {6" -- 2" wide} jPixelsPerInch + TRUNC(2*iPixelsPerInch * GraphicAspectRatio * PixelAspectRatio)); Printer.Canvas.TextOut(4*iPixelsPerInch, jPixelsPerInch Printer.Canvas.TextHeight('X'), '2" wide at (4", 1")'); Printer.Canvas.StretchDraw (TargetRectangle, Form1.Image1.Picture.Graphic); {Write to offscreen bitmap and then copy to Printer Canvas} SourceRectangle := Rect (0,0, 3*iPixelsPerInch-1, 2*jPixelsPerInch-1); {This should not work! Rectangle = Left, Top, Right, Bottom Top and Bottom are reversed?} DestinationRectangle := Rect(4*iPixelsPerInch, 6*jPixelsPerInch, 7*iPixelsPerInch-1, 4*jPixelsPerinch-1); Printer.Canvas.TextOut(4*iPixelsPerInch, 4*jPixelsPerInch Printer.Canvas.TextHeight('X'), IntToStr(3*iPixelsPerInch) + ' pixels by ' + IntToStr(2*jPixelsPerInch) + ' pixels -- ' + '3"-by-2" at (4",4")'); OffScreen := TBitMap.Create; TRY OffScreen.Width := SourceRectangle.Right + 1; OffScreen.Height := SourceRectangle.Bottom + 1; WITH OffScreen.Canvas DO BEGIN Pen.Color := clBlack; Brush.Color := clWhite; Rectangle(0,0, 3*iPixelsPerInch-1, 2*jPixelsPerInch-1); Brush.Color := clRed; MoveTo (0,0); LineTo (3*iPixelsPerInch-1, 2*jPixelsPerInch-1); Brush.Color := clBlue; MoveTo (0,0); FOR i := 0 TO 3*iPixelsPerInch - 1 DO BEGIN x := 12*PI*(i / (3*iPixelsPerInch - 1)); y := jPixelsPerInch + jPixelsPerInch*SIN(x); LineTo (i, TRUNC(y)); END END; Printer.Canvas.CopyRect(DestinationRectangle, OffScreen.Canvas, SourceRectangle); FINALLY OffScreen.Free END; {List the fonts for this printer} iBase := iPosition(750); Printer.Canvas.Font.Name := 'Times New Roman';

816

Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iBase, jPosition(40), 'Fonts'); Printer.Canvas.Font.Style := []; Printer.Canvas.Font.Size := 10; jDelta := 16; FOR j := 0 TO Printer.Fonts.Count - 1 DO BEGIN Printer.Canvas.TextOut(iBase, jPosition(60 + jDelta*j), Printer.Fonts.Strings[j]) END; Printer.EndDoc; end; end.

Windows API about Printer From: David and Rhonda Crowder >> I want to obtain the values (left, right, top, bottom) of "unprintable area" from the printer. In August Delphi Developer "Take Control of your printer with a custom Delphi Class": To get the Left and Top Printer Margins use the Windows Escape Function with the parameter GETPRINTINGOFFSET. var pntMargins : TPoint; begin { @ means " the address of the variable" } Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins); end;

Getting the Right and Bottom Margins aren't quite so straightforward. There isn't an equivalent Escape call. You obtain these values by getting the physical width (physWidth) and height (physHeight) of the page, the printable width (PrintWidth) and height (PrintHeight) of the page, and then carrying out the following sums: RightMargin := physWidth - PrintWidth - LeftMargin BottomMargin := physHeight - PrintHeight - TopMargin

The physical page size is found using Escape, this time with the GETPHYSPAGESIZE parameter. The point pntPageSize contains the page width in pntPageSize.x and page height in pntPageSize.y var pntPageSize : TPoint; begin Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize); end;

Property changes in same print

817

"D. Bussey" How to enable printer property changes ( like paper tray, orientation, etc. ) between pages in the same print document in only six steps. (The example at the end also shows how to switch paper trays...) *** THE STEPS *** 1. Create a copy of Printers.pas and rename the copy to NewPrint.pas. ***DO NOT make these changes to Printers.pas, if you do you will get an error saying "Unable to find printers.pas" when you compile your application. (Well, that's the error I received...)*** 2. Move NewPrint.pas to the Lib directory. (Usually "C:\Program Files\Borland\Delphi 2.0\Lib" ) 3. Change the UNIT NAME in NewPrint.pas from: unit Printers; to: unit NewPrint; 4. Add the following PUBLIC METHOD declaration to the TPrinter object definition in the Interface section of NewPrint.pas: procedure NewPageDC(DM: PDevMode);

5. Add the following procedure to the Implementation section of NewPrint.pas: procedure TPrinter.NewPageDC(DM: PDevMode); begin CheckPrinting(True); EndPage(DC); {Check to see if new device mode setting were passed} if Assigned(DM) then ResetDC(DC,DM^); StartPage(DC); Inc(FPageNumber); Canvas.Refresh; end;

6. Instead of adding "Printers" to the USES clause of your application, add "NewPrint". EVERYTHING ELSE WORKS EXACTLY THE SAME (ie BeginDoc, EndDoc, NewPage, etc.) but you now have the capability of changing printer settings on the fly between pages WITHIN THE SAME PRINT DOCUMENT. (The example below shows how.) Instead of calling: Printer.NewPage;

call: Printer.NewPageDC(DevMode);

Here is the small example (with bytes of code from other print altering routines I've gathered). procedure TForm1.Button1Click(Sender: TObject); var ADevice, ADriver, APort: array [0..255] of char;

818

ADeviceMode: THandle; DevMode: PDevMode; begin with Printer do begin GetPrinter(ADevice,ADriver,APort,ADeviceMode); SetPrinter(ADevice,ADriver,APort,0); GetPrinter(ADevice,ADriver,APort,ADeviceMode); DevMode := GlobalLock(ADeviceMode); if not Assigned(DevMode) then ShowMessage('Can''t set printer.') else begin with DevMode^ do begin {Put any other settings you want here} dmDefaultSource := DMBIN_UPPER; {these codes are listed in "Windows.pas"} end; GlobalUnlock(ADeviceMode); SetPrinter(ADevice,ADriver,APort,ADeviceMode); end; end; Printer.BeginDoc; Printer.Canvas.TextOut(50,50,'This page is printing from the UPPER PAPER TRAY.'); with DevMode^ do begin {Put any other settings you want here} dmDefaultSource := DMBIN_LOWER; {these codes are listed in "Windows.pas"} end; Printer.NewPageDC(DevMode); Printer.Canvas.TextOut(50,50,'This page is printing from the LOWER PAPER TRAY.'); Printer.EndDoc; end; {************************************************************* Notes from the author: I've used this myself in applications for my job so I know it will work. These modifications were made in Delphi Client/Server 2.01 running on WinNT 4.0 but they should work with Delphi 2.0 Standard and Professional, and under Windows95 as well. I have not tried them with Delphi 3 yet... If anyone has any comments or questions, feel free to mail me... David A. Bussey ERC/RAL Developer River City Bank [email protected] ************************************************************}

Paper Formats 819

here is an example that lists the paper formats for the default printer: procedure TForm1.Button2Click(Sender: TObject); Type TPaperName = Array [0..63] of Char; TPaperNameArray = Array [1..High(Cardinal) div Sizeof( TPaperName )] of TPaperName; PPapernameArray = ^TPaperNameArray; Var Device, Driver, Port: Array [0..255] of Char; hDevMode: THandle; i, numPaperformats: Integer; pPaperFormats: PPapernameArray; begin Printer.PrinterIndex := -1; Printer.GetPrinter(Device, Driver, Port, hDevmode); numPaperformats := WinSpool.DeviceCapabilities( Device, Port, DC_PAPERNAMES, Nil, Nil ); If numPaperformats > 0 Then Begin GetMem( pPaperformats, numPaperformats * Sizeof( TPapername )); try WinSpool.DeviceCapabilities( Device, Port, DC_PAPERNAMES, Pchar( pPaperFormats ), Nil); memo1.clear; For i:= 1 To numPaperformats Do memo1.lines.add( pPaperformats^[i] ); finally FreeMem( pPaperformats ); end; End; End;


820

Report Smith 76. Passing a report variable to ReportSmith

Passing a report variable to ReportSmith M Richens "Matthew M. Boron" writes >I am having trouble passing a customer id to reportsmith to print a >specific master/detail report. I keep getting prompted by reportsmith to >enter the id for the report variable. > >Is there a way to pass this variable from Delphi into ReportSmith

This caused me a lot of grief to start with but example begin MillCardNewRep.InitialValues.Clear; {Send the Current Milling Number either just finished or the last one to ReportSmith} MillCardNewRep.InitialValues.Add('@MILLING=<'+MillingNoEdit.Text+'>') MillCardNewRep.Run; end;

I declared a report variable MILLING in RS report as a number which is entered from a box BUT notice that you MUST send the value from Delphi as the .Text not as a Value. If needed convert it to str (or PChar??) but I just read it from an edit box which was readonly as I used an AutoIncrement field. Please email me and tell me if you liked this page. Last modified 03/12/00 12:09:48

821

Screen Saver 77. How to Make a Windows Screen Saver in Delphi

How to Make a Windows Screen Saver in Delphi by Mark R. Johnson From time to time, I see questions asked about how to make a Windows screen saver in Delphi that can be selected in the Control Panel Desktop. After seeing a few general responses that only partially answered the question, I decided to give it a try myself. The code you will see here is the result: a simple Windows screen saver. The complete Delphi source code for this screen saver is available for FTP as spheres.zip (4K). Before getting into the details of the code, however, I would like to thank Thomas W. Wolf for the general screen saver tips he submitted to comp.lang.pascal, which I found helpful in writing this article.

Background A Windows screen saver is basically just a standard Windows executable that has been renamed to have a .SCR filename extension. In order to interface properly with the Control Panel Desktop, however, certain requirements must be met. In general, the program must: · maintain optional settings · provide a description of itself · distinguish between active mode and configuration mode · disallow multiple copies of itself to run · exit when the user presses a key or moves the mouse In the following description, I will try to show how each of these requirements can be met using Delphi.

Getting Started The screen saver we are going to create will blank the screen and begin drawing shaded spheres at random locations on the screen, periodically erasing and starting over. The user will be able to specify the maximum number spheres to draw before erasing, as well as the size and speed with which to draw them. To begin, start a new, blank project by selecting New Project from the Delphi File menu. (Indicate "Blank project" if the Browse Gallery appears.)

Configuration Form The first thing most people see of a screen saver is its setup dialog. This is where the user specifies values for options specific to the screen saver. To create such a form, change the properties of Form1 (created automatically when the new project was begun) as follows: BorderIcons

[biSystemMenu]

822

biSystemMenu biMinimize biMaximize BorderStyle Caption Height Name Position Visible Width

True False False bsDialog Configuration 162 CfgFrm poScreenCenter False 266

We want to be able to configure the maximum number of spheres drawn on the screen, the size of the spheres, and the speed with which they are drawn. To do this, add the following three Labels (Standard palette) and SpinEdits (Samples palette): (Note: You can select the following text, copy it to the clipboard, and paste it onto the configuration form to create the components.) object Label1: TLabel Left = 16 Top = 19 Width = 58 Height = 16 Alignment = taRightJustify Caption = 'Spheres:' end object Label2: TLabel Left = 41 Top = 59 Width = 33 Height = 16 Alignment = taRightJustify Caption = 'Size:' end object Label3: TLabel Left = 29 Top = 99 Width = 45 Height = 16 Alignment = taRightJustify Caption = 'Speed:' end object spnSpheres: TSpinEdit Left = 84 Top = 15 Width = 53 Height = 26 MaxValue = 500 MinValue = 1 TabOrder = 0 Value = 50 end object spnSize: TSpinEdit Left = 84 Top = 55 Width = 53 Height = 26 MaxValue = 250 MinValue = 50 TabOrder = 1 Value = 100 end object spnSpeed: TSpinEdit Left = 84 Top = 95 Width = 53 Height = 26 MaxValue = 10

823

MinValue = 1 TabOrder = 2 Value = 10 end

Finally, we need three buttons -- OK, Cancel, and Test. The Test button is not standard for screen saver setup dialogs, but it is convenient and easy to implement. Add the following three buttons using the BitBtn buttons of the "Additional" palette: object btnOK: TBitBtn Left = 153 Top = 11 Width = 89 Height = 34 TabOrder = 3 Kind = bkOK end object btnCancel: TBitBtn Left = 153 Top = 51 Width = 89 Height = 34 TabOrder = 4 Kind = bkCancel end object btnTest: TBitBtn Left = 153 Top = 91 Width = 89 Height = 34 Caption = 'Test...' TabOrder = 5 Kind = bkIgnore end

Once we have the form layout, we need to add some code to make it work. First, we need to be able to load and save the current configuration. To do this, we should place the Spheres, Size, and Speed values into an initialization file (*.INI) in the user's Windows directory. Delphi's TIniFile object is just the thing for this. Switch to the code view for the Setup form, and add the following uses clause to the implementation section of the configuration form's unit: uses IniFiles;

Then, add the following procedure declarations to the private section of the TCfgFrm declaration: procedure LoadConfig; procedure SaveConfig;

Now add the following procedure definitions after the uses clause in the implementation section: const CfgFile = 'SPHERES.INI'; procedure TCfgFrm.LoadConfig; var inifile : TIniFile; begin inifile := TIniFile.Create(CfgFile); try with inifile do begin spnSpheres.Value := ReadInteger('Config', 'Spheres', 50); spnSize.Value := ReadInteger('Config', 'Size', 100); spnSpeed.Value := ReadInteger('Config', 'Speed', 10); end; finally inifile.Free; end;

824

end; {TCfgFrm.LoadConfig} procedure TCfgFrm.SaveConfig; var inifile : TIniFile; begin inifile := TIniFile.Create(CfgFile); try with inifile do begin WriteInteger('Config', 'Spheres', spnSpheres.Value); WriteInteger('Config', 'Size', spnSize.Value); WriteInteger('Config', 'Speed', spnSpeed.Value); end; finally inifile.Free; end; end; {TCfgFrm.SaveConfig}

All that remains for the configuration form is to respond to a few events to properly load and save the configuration. First, we need to load the configuration automatically whenever the program starts up. We can use the setup form's OnCreate event to do this. Double- click the OnCreate field in the events section of the Object Inspector and enter the following code: procedure TCfgFrm.FormCreate(Sender: TObject); begin LoadConfig; end; {TCfgFrm.FormCreate}

Next, double-click the OK button. We need to save the current configuration and close the window whenever OK is pressed, so add the following code: procedure TCfgFrm.btnOKClick(Sender: TObject); begin SaveConfig; Close; end; {TCfgFrm.btnOKClick}

In order to simply close the form (without saving) when the Cancel button is pressed, double-click on the Cancel button and add: procedure TCfgFrm.btnCancelClick(Sender: TObject); begin Close; end; {TCfgFrm.btnCancelClick}

Finally, to test the screen saver, we will need to show the screen saver form (which we haven't yet created). Go ahead and double-click on the Test button and add the following code: procedure TCfgFrm.btnTestClick(Sender: TObject); begin ScrnFrm.Show; end; {TCfgFrm.btnTestClick}

Then add "Scrn" to the uses clause in the implementation section. Scrn refers to the screen saver form unit that we will create in the next step. In the meantime, save this form unit as "Cfg" by selecting Save File As from the File menu.

Screen Saver Form The screen saver itself will simply be a large, black, captionless form that covers the entire screen, upon which the graphics are drawn. To create the second form, select New Form from the File menu and indicate a "Blank form" if prompted by the Browse Gallery. BorderIcons biSystemMenu biMinimize biMaximize BorderStyle Color FormStyle

[] False False False bsNone clBlack fsStayOnTop

825

Name Visible

ScrnFrm False

To this form, add a single component -- a timer from the System category of the Delphi component palette. Set its properties accordingly: object tmrTick: TTimer Enabled = False OnTimer = tmrTickTimer Left = 199 Top = 122 end

No other components will be required for this form. However, we will need to add some code to handle drawing the shaded spheres. Switch to the code window accompanying the ScrnFrm form. In the TScrnFrm private section, add the following procedure declaration: procedure DrawSphere(x, y, size : integer; color : TColor);

Now, in the implementation section of the unit, add the code for this procedure: procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor); var i, dw : integer; cx, cy : integer; xy1, xy2 : integer; r, g, b : byte; begin with Canvas do begin {Fill in the pen & brush settings.} Pen.Style := psClear; Brush.Style := bsSolid; Brush.Color := color; {Prepare colors for sphere.} r := GetRValue(color); g := GetGValue(color); b := GetBValue(color); {Draw the sphere.} dw := size div 16; for i := 0 to 15 do begin xy1 := (i * dw) div 2; xy2 := size - xy1; Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255), Min(b + (i * 8), 255)); Ellipse(x + xy1, y + xy1, x + xy2, y + xy2); end; end; end; {TScrnFrm.DrawSphere}

As you can see from the code, we are given the (x,y) coordinates of the top, left corner of the sphere, as well as its diameter and base color. Then, to draw the sphere, we step through brushes of increasingly bright color, starting with the given base color. With each new brush, we draw a smaller filled circle concentric with the previous ones. You will also notice, however, that the function refers to another function, Min(). This is not a standard Delphi function, so we must add it to the unit, above the declaration for DrawSphere(). function Min(a, b : integer) : integer; begin if b < a then Result := b else Result := a; end; {Min}

In order to periodically call the DrawSphere() function, we must respond to the OnTimer event of the Timer component we added to the ScrnFrm. Double-click the Timer component on the form and fill in the automatically created procedure with the following code: procedure TScrnFrm.tmrTickTimer(Sender: TObject);

826

const sphcount : integer = 0; var x, y : integer; size : integer; r, g, b : byte; color : TColor; begin if sphcount > CfgFrm.spnSpheres.Value then begin Refresh; sphcount := 0; end; Inc(sphcount); x := Random(ClientWidth); y := Random(ClientHeight); size := CfgFrm.spnSize.Value + Random(50) - 25; x := x - size div 2; y := y - size div 2; r := Random($80); g := Random($80); b := Random($80); DrawSphere(x, y, size, RGB(r, g, b)); end; {TScrnFrm.tmrTickTimer}

This procedure keeps track of the number of spheres that have been drawn in sphcount, and refreshes (erases) the screen when we have reached the maximum number. In the meantime, it calculates the random position, size, and color for the next sphere to be drawn. (Note: The color range is limited to only the first half of the brightness spectrum in order to provide greater depth to the shading.) As you may have noticed, the tmrTickTimer() procedure references the CfgFrm form to retrieve the configuration options. In order for this reference to be recognized, add the following uses clause to the implementation section of the unit: uses Cfg;

Next, we will need a way to deactivate the screen saver when a key is pressed, the mouse is moved, or the screen saver form looses focus. One way to do this is to create an handler for the Application.OnMessage event that looks for the necessary conditions to terminate the screen saver. First, add the following variable declaration to the implementation section of the unit: var crs : TPoint;

This variable will be used to store the original position of the mouse cursor for later comparison. Now, add the following declaration to the private section of TScrnFrm: procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);

Add the corresponding code to the implementation section of the unit: procedure TScrnFrm.DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean); var done : boolean; begin if Msg.message = WM_MOUSEMOVE then done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or (Abs(HIWORD(Msg.lParam) - crs.y) > 5) else done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_ACTIVATE) or (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_NCACTIVATE); if done then Close; end; {TScrnFrm.DeactivateScrnSaver}

When a WM_MOUSEMOVE window message is received, we compare the new coordinates of the mouse to the original location. If it has moved more than our threshold (5 pixels in any direction), then we close the screen saver. Otherwise, if a key is pressed or another window or dialog box takes the focus, the screen saver closes. 827

In order for this procedure to go into effect, however, we need to set the Application.OnMessage property and get the original position of the mouse cursor. A good place to do this is in the form's OnShow event handler: procedure TScrnFrm.FormShow(Sender: TObject); begin GetCursorPos(crs); tmrTick.Interval := 1000 - CfgFrm.spnSpeed.Value * 90; tmrTick.Enabled := true; Application.OnMessage := DeactivateScrnSaver; ShowCursor(false); end; {TScrnFrm.FormShow}

Here we also specify the timer's interval and activate it, as well as hiding the mouse cursor. Most of these things should be undone, however, in the form's OnHide event handler: procedure TScrnFrm.FormHide(Sender: TObject); begin Application.OnMessage := nil; tmrTick.Enabled := false; ShowCursor(true); end; {TScrnFrm.FormHide}

Finally, we need to make sure that the screen saver form fills the entire screen when it is shown. To do this add the following code to the form's OnActivate event handler: procedure TScrnFrm.FormActivate(Sender: TObject); begin WindowState := wsMaximized; end; {TScrnFrm.FormActivate}

Take this opportunity to save the ScrnFrm form unit as "SCRN.PAS" by selecting Save File from the File menu.

The Screen Saver Description You can define the text that will appear in the Control Panel Desktop list of screen savers by adding a {$D text} directive to the project source file. The $D directive inserts the given text into the module description entry of the executable file. For the Control Panel to recognize the text you must start with the term "SCRNSAVE", followed by your description. Select Project Source from the Delphi View menu so you can edit the source file. Beneath the directive "{$R *.RES}", add the following line: {$D SCRNSAVE Spheres Screen Saver}

The text "Spheres Screen Saver" will appear in the Control Panel list of available screen savers when we complete the project.

Active Versus Configuration Mode Windows launches the screen saver program under two possible conditions: 1) when the screen saver is activated, and 2) when the screen saver is to be configured. In both cases, Windows runs the same program. It distinguishes between the two modes by adding a command line parameter -- "/s" for active mode and "/c" for configuration mode. For our screen saver to function properly with the Control Panel, it must check the command line for these switches.

Active Mode When the screen saver enters active mode (/s), we need to create and show the screen saver form. We also need create the configuration form, since it contains all of the configuration options. When the screen saver form closes, the entire program should then terminate. This fits the definition of a Delphi Main Form -- a form that starts when the program starts and signals the end of the application when the form closes.

828

Configuration Mode When the screen saver enters configuration mode (/c), we need to create and show the configuration form. We should also create the screen saver form, in case the user wishes to test configuration options. However, when the configuration form closes, the entire program should then terminate. In this case, the configuration form fits the definition of a Main Form.

Defining the Main Form Ideally, we would like to identify ScrnFrm as the Main Form when a /s appears on the command line, and CfgFrm as the Main Form in all other cases. To do this requires knowledge of an undocumented feature of the TApplication VCL object: The Main Form is simply the first form created with a call to Application.CreateForm(). Thus, to define different Main Forms according to our run-time conditions, modify the project source as follows: begin if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin {ScrnFrm needs to be the Main Form.} Application.CreateForm(TScrnFrm, ScrnFrm); Application.CreateForm(TCfgFrm, CfgFrm); end else begin {CfgFrm needs to be the Main Form.} Application.CreateForm(TCfgFrm, CfgFrm); Application.CreateForm(TScrnFrm, ScrnFrm); end; Application.Run; end.

Just by changing the order of creation, we have automatically set the Main Form for that instance. In addition, the Main Form will automatically be shown, despite the fact that we have set the Visible properties to False for both forms. As a result, we achieve the desired effect with only minimal code. (Note: for the if statement to function as shown above, the "Complete boolean eval" option should be unchecked in the Options | Project | Compiler settings. Otherwise, an error will occur if the program is invoked with no command line parameters.) In order to use the UpperCase() Delphi function, SysUtils must be included in the project file's uses clause to give something like: uses Forms, SysUtils, Scrn in 'SCRN.PAS' {ScrnFrm}, Cfg in 'CFG.PAS' {CfgFrm};

Blocking Multiple Instances One difficulty with Windows screen savers is that they must prevent multiple instances from being run. Otherwise, Windows will continue to launch a screen saver as the given time period ellapses, even when an instance is already active. To block multiple instances of our screen saver, modify the project source file to add the outer if statement shown below: begin {Only one instance is allowed at a time.} if hPrevInst = 0 then begin if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin ... end; Application.Run; end; end;

The hPrevInst variable is a global variable defined by Delphi to point to previous instances of the current program. It will be zero if there are no previous instances still running. 829

Now save the project file as "SPHERES.DPR" and compile the program. With that, you should be able to run the screen saver on its own. Without any command line parameters, the program should default to configuration mode. By giving "/s" as the first command line parameter, you can also test the active mode. (See Run | Parameters...)

Installing the Screen Saver Once you've tested and debugged your screen saver, you are ready to install it. To do so, simply copy the executable file (SPHERES.EXE) to the Windows directory, changing its filename extension to .SCR in the process (SPHERES.SCR). Then, launch the Control Panel, double-click on Desktop, and select Screen Saver | Name. You should see "Spheres Screen Saver" in the list of possible screen savers. Select it and set it up. Copyright © 1995 Mark R. Johnson. This is a Last revised September 4, 1995.

CITY ZOO production.


830

Serial Communication 78. DELPHI 2/3 79. Port command and win95, a summary. 80. Hardware port access in DELPHI 2

DELPHI 2/3 From: "Ed Lagerburg" //{$DEFINE COMM_UNIT} //Simple_comm door E.L. Lagerburg voor Delphi 2.01 Maart 1997 //Nog niet getest //Compiler maakt Simple_Comm.Dll of Simple_Com.Dcu afhankelijk van 1e Regel (COMM_UNIT) {$IFNDEF COMM_UNIT} library Simple_Comm; {$ELSE} Unit Simple_Comm; Interface {$ENDIF} Uses Windows,Messages; Const Const Const Const

M_BaudRate M_ByteSize M_Parity M_Stopbits

=1; =2; =4; =8;

{$IFNDEF COMM_UNIT} {$R Script2.Res} {$ENDIF}

//versie informatie

{$IFDEF COMM_UNIT} Function Simple_Comm_Info:PChar;StdCall; Function Simple_Comm_Open(Port:PChar;BaudRate:DWORD;ByteSize,Parity,StopBits:Byte;Mas k:Integer;WndHandle:HWND;WndCommand:UINT;Var Id:Integer):Integer;StdCall; Function Simple_Comm_Close(Id:Integer):Integer;StdCall; Function Simple_Comm_Write(Id:Integer;Buffer:PChar;Count:DWORD):Integer;StdCall; Function Simple_Comm_PortCount:DWORD;StdCall; Const M_None Const M_All

= 0; = 15;

831

Implementation {$ENDIF} Const InfoString = 'Simple_Comm.Dll (c) const MaxPorts = 5; Const bDoRun : Array[0..MaxPorts-1] =(False,False,False,False,False); Const hCommPort: Array[0..MaxPorts-1] Const hThread: Array[0..MaxPorts-1] Const dwThread: Array[0..MaxPorts-1] Const hWndHandle: Array[0..MaxPorts-1] Const hWndCommand:Array[0..MaxPorts-1] Const PortCount:Integer

by E.L. Lagerburg 1997'; of boolean of of of of of

Integer Integer Integer Hwnd UINT

=(0,0,0,0,0); =(0,0,0,0,0); =(0,0,0,0,0); =(0,0,0,0,0); =(0,0,0,0,0); = 0;

Function Simple_Comm_Info:PChar;StdCall; Begin Result:=InfoString; End; //Thread functie voor lezen compoort Function Simple_Comm_Read(Param:Pointer):Longint;StdCall; Var Count:Integer; id:Integer; ReadBuffer:Array[0..127] of byte; Begin Id:=Integer(Param); While bDoRun[id] do Begin ReadFile(hCommPort[id],ReadBuffer,1,Count,nil); if (Count > 0) then Begin if ((hWndHandle[id]<> 0) and (hWndCommand[id] >> WM_USER)) then SendMessage(hWndHandle[id],hWndCommand[id],Count,LPARAM(@ReadBuffer)); End; End; Result:=0; End; //Export functie voor sluiten compoort Function Simple_Comm_Close(Id:Integer):Integer;StdCall; Begin if (ID < 0) or (id > MaxPorts-1) or (not bDoRun[Id]) then Begin Result:=ERROR_INVALID_FUNCTION; Exit; End; bDoRun[Id]:=False; Dec(PortCount); FlushFileBuffers(hCommPort[Id]); if not PurgeComm(hCommPort[Id],PURGE_TXABORT+PURGE_RXABORT+PURGE_TXCLEAR+PURGE_RXCL EAR) then Begin Result:=GetLastError; Exit; End; if WaitForSingleObject(hThread[Id],10000) = WAIT_TIMEOUT then if not TerminateThread(hThread[Id],1) then Begin

832

Result:=GetLastError; Exit; End; CloseHandle(hThread[Id]); hWndHandle[Id]:=0; hWndCommand[Id]:=0; if not CloseHandle(hCommPort[Id]) then Begin Result:=GetLastError; Exit; End; hCommPort[Id]:=0; Result:=NO_ERROR; End; Procedure Simple_Comm_CloseAll;StdCall; Var Teller:Integer; Begin For Teller:=0 to MaxPorts-1 do Begin if bDoRun[Teller] then Simple_Comm_Close(Teller); End; End; Function GetFirstFreeId:Integer;StdCall; Var Teller:Integer; Begin For Teller:=0 to MaxPorts-1 do Begin If not bDoRun[Teller] then Begin Result:=Teller; Exit; End; End; Result:=-1; End; //Export functie voor openen compoort Function Simple_Comm_Open(Port:PChar;BaudRate:DWORD;ByteSize,Parity,StopBits:Byte;Mas k:Integer;WndHandle:HWND;WndCommand:UINT;Var Id:Integer):Integer;StdCall; Var PrevId:Integer; ctmoCommPort:TCOMMTIMEOUTS; //Lees specificaties voor de compoort dcbCommPort:TDCB; Begin if (PortCount >= MaxPorts) or (PortCount < 0) then begin result:=error_invalid_function; exit; end; result:=0; previd:=id; id:=getfirstfreeid; if id = -1 then begin id:=previd; result:=error_invalid_function; exit; end; hcommport[id]:=createfile(port,generic_read or generic_write,0,nil,open_existing,file_attribute_normal,0); if hcommport[id]= invalid_handle_value then begin

833

bdorun[id]:=false; id:=previd; result:=getlasterror; exit; end; //lees specificaties voor het comm bestand ctmocommport.readintervaltimeout:=maxdword; ctmocommport.readtotaltimeoutmultiplier:=maxdword; ctmocommport.readtotaltimeoutconstant:=maxdword; ctmocommport.writetotaltimeoutmultiplier:=0; ctmocommport.writetotaltimeoutconstant:=0; //instellen specificaties voor het comm bestand if not setcommtimeouts(hcommport[id],ctmocommport) then begin bdorun[id]:=false; closehandle(hcommport[id]); id:=previd; result:=getlasterror; exit; end; //instellen communicatie dcbcommport.dcblength:=sizeof(tdcb); if not getcommstate(hcommport[id],dcbcommport) then begin bdorun[id]:=false; closehandle(hcommport[id]); id:=previd; result:=getlasterror; exit; end; if (mask and m_baudrate <> 0) then dcbCommPort.BaudRate:=BaudRate; if (Mask and M_ByteSize <> 0) then dcbCommPort.ByteSize:=ByteSize; if (Mask and M_Parity <> 0) then dcbCommPort.Parity:=Parity; if (Mask and M_Stopbits <> 0) then dcbCommPort.StopBits:=StopBits; if not SetCommState(hCommPort[Id],dcbCommPort) then Begin bDoRun[Id]:=FALSE; CloseHandle(hCommPort[Id]); Id:=PrevId; Result:=GetLastError; Exit; End; //Thread voor lezen compoort bDoRun[Id]:=TRUE; hThread[Id]:=CreateThread(nil,0,@Simple_Comm_Read,Pointer(Id),0,dwThread[Id] ); if hThread[Id] = 0 then Begin bDoRun[Id]:=FALSE; CloseHandle(hCommPort[Id]); Id:=PrevId; Result:=GetLastError; Exit; End else Begin SetThreadPriority(hThread[Id],THREAD_PRIORITY_HIGHEST); hWndHandle[Id]:=WndHandle; hWndCommand[Id]:=WndCommand; Inc(PortCount); Result:=NO_ERROR; End; End; //Export functie voor schrijven naar compoort; Function

834

Simple_Comm_Write(Id:Integer;Buffer:PChar;Count:DWORD):Integer;StdCall; Var Written:DWORD; Begin if (Id < 0) or (id > Maxports-1) or (not bDoRun[Id]) then Begin Result:=ERROR_INVALID_FUNCTION; Exit; End; if not WriteFile(hCommPort[Id],Buffer,Count,Written,nil) then Begin Result:=GetLastError(); Exit; End; if (Count <> Written) Then Result:=ERROR_WRITE_FAULT Else Result:=NO_ERROR; End; //Aantal geopende poorten voor aanroepende applicatie Function Simple_Comm_PortCount:DWORD;StdCall; Begin Result:=PortCount; End; {$IFNDEF COMM_UNIT} Exports Simple_Comm_Info Simple_Comm_Open Simple_Comm_Close Simple_Comm_Write Simple_Comm_PortCount

Index Index Index Index index

1, 2, 3, 4, 5;

Procedure DLLMain(dwReason:DWORD); Begin If dwReason = DLL_PROCESS_DETACH then Simple_Comm_CloseAll; End; Begin DLLProc:=@DLLMain; DLLMain(DLL_PROCESS_ATTACH);//geen nut in dit geval End. {$ELSE} Initialization Finalization Simple_Comm_CloseAll; end. {$ENDIF}

From: "Lennart"
835

var ComPort: Word; implementation uses Windows, SysUtils; const CPort: array [1..4] of String =('COM1','COM2','COM3','COM4'); var Com: THandle = 0; function OpenComm(InQueue, OutQueue, Baud : LongInt): Boolean; begin if Com > 0 then CloseComm; Com := CreateFile(PChar(CPort[ComPort]), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (Com > 0) and SetCommTiming and SetCommBuffer(InQueue,OutQueue) and SetCommStatus(Baud) ; end; function SetCommTiming: Boolean; var Timeouts: TCommTimeOuts; begin with TimeOuts do begin ReadIntervalTimeout := 1; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 1; WriteTotalTimeoutMultiplier := 2; WriteTotalTimeoutConstant := 2; end; Result := SetCommTimeouts(Com,Timeouts); end; function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean; begin Result := SetupComm(Com, InQueue, OutQueue); end; function SetCommStatus(Baud: Integer): Boolean; var DCB: TDCB; begin with DCB do begin DCBlength:=SizeOf(Tdcb); BaudRate := Baud; Flags:=12305; wReserved:=0; XonLim:=600; XoffLim:=150; ByteSize:=8; Parity:=0; StopBits:=0; XonChar:=#17; XoffChar:=#19; ErrorChar:=#0; EofChar:=#0;

836

EvtChar:=#0; wReserved1:=65; end; Result := SetCommState(Com, DCB); end; function SendCommStr(S: String): Integer; var TempArray : array[1..255] of Byte; Count, TX_Count : Integer; begin for Count := 1 to Length(S) do TempArray[Count] := Ord(S[Count]); WriteFile(Com, TempArray, Length(S), TX_Count, nil); Result := TX_Count; end; function ReadCommStr(var S: String) : Integer; var TempArray : array[1..255] of Byte; Count, RX_Count : Integer; begin S := ''; ReadFile(Com, TempArray, 255, RX_Count, nil); for Count := 1 to RX_Count do S := S + Chr(TempArray[Count]); Result := RX_Count; end; procedure CloseComm; begin CloseHandle(Com); Com := -1; end; end.

Port command and win95, a summary. From: Martin Larsson

APPOLOGY This was supposed to be a quick summary. It ended up being quite long. Hope it's not too boring...

THE PROBLEM Under MS-DOS, an application has control of the entire machine. This gives the programmer a lot of freedom. To maximize speed, you can access the hardware directly if necessary. Under Windows 3.x, this freedom was somewhat limited. You were no longer allowed to write directly to the screen, among other things. The problem is obvious: since the user could have any number of applications running, there was no guarantee that they were not accessing the same hardware simultaneously. Another problem that showed up was that you had to be nice to the other applications running at the same time. Win 3.x is co-operatively multitasked, meaning that each

837

application determines when it's done and other applications can run. Hogging the CPU for longer periods of time was not considered nice. But the fact that no applications would run unless we as programmers said so, could be worked to our advantage when accessing the hardware. Since the application were guaranteed full control over the machine for as long as it wished, it could, when it got the CPU, muck with the I/O ports or memory, but not give up control until it was done. Unfortunately, progress caught up with us; now there's Win32 (Windows NT and Windows 95). T hese are true operating systems, with true pre-emptive multi-tasking. Each thread (the execution unit) gets a certain amount of time with the processor. When the time is up, or a thread with higher priority comes along, the system will switch to the next thread, even though the first thread is not done. This switching can occur between any two assembly instructions; there's no guarantee that a thread will be able to complete any number of instructions before it's pre-empted, and there might be a long time 'till the next timeslot. This brings up a real problem with direct hardware access. A typical I/O read, for instance, is composed of several assembly instructions: mov mov out jmp Wait: mov in

dx, AddressPort al, Address dx, al Wait dx, DataPort al, dx

While the state of all registers are preserved on a thread-switch, the state of the I/O ports are not. So, it is very possible that three applications have their way with 'your' I/O port between the 'out' and the 'in' instructions above.

THE DOCUMENTED WAY The solution to this problem is to somehow tell all other applications that "Currently MyProg is using port 546, and everybody else better stay in line." What's needed is a mutex. Unfortunately, to use a mutex, all applications have to agree on a name for that mutex. But even if that was possible, you'd easily get into some thorny problems. Consider two applications App1 and App2. Both wants to execute the above code. Unfortunately, they're created by different people with different views, so App1 asks for the AddressPortMutex first, while App2 asks for the DataPortMutex first. And, by a sad coincidence, App1 gets the AddressPortMutex, then the system swithes to App2, which aquires the DataPortMutex, and we're deadlocked. App2 can't get the address port, 'cause App1 has that. App1 can't get the data port, 'cause App2 has that. And we're still waiting... The correct way to solve this problem is to create a device driver that owns the port/memory area. Access to the hardware is supported through an API. A typical function would be GetIOPortData(AddressPort, DataPort : word) : Byte;

GetIOPortData would aquire a mutex that protects both (possibly all) ports, then access the ports, and finally releasing the mutex before returning to the caller. If different threads are calling this function at the same time, one will get there first, the others must wait. Writing a device driver is not easy. It must be done in assembler or C, and they are really hard to debug. And just to be safe, a device driver for Windows 95 (a VxD) isn't compatible with a device driver for Windows NT (a VDD, for virtual device driver). They are said to converge, and Windows NT 6.0 and Windows 2000 might have compatible device drivers, but until then, we're stuck with writing two separate pieces of code. For more info see (for instance): 838

Microsoft's Windows 95 Device Driver Kit Microsoft's Windows NT Device Driver Kit Microsoft Press' "Systems Programming for Windows 95" by Walter Oney Also, check out Vireo's VtoolsD library for writing VxD's in C. http://www.vireo.com/.

THE UNDOCUMENTED WAY The above problem isn't too real. An application that accesses the hardware directly, is usually using some specialized hardware. A machine-configuration like that tend to run one application only, who's sole purpose is to access that hardware. In such a scenario, writing a device driver seems too much trouble. After all, the reason the thing is running on Windows, is just to get the nice GUI for (almost) free, not that 10 applications can be running simultaneously. Fortunately, Windows 95 is built to be compatible with Windows 3.x. This means that direct I/O must be allowed, simply because a lot of Win 3.x programs uses it. To access the I/O ports, simply step down to assembly. The following code was supplied by Arthur Hoornweg ([email protected]): function getport(p:word):byte; stdcall; begin asm push edx push eax mov dx,p in al,dx mov @result,al pop eax pop edx end; end; Procedure Setport(p:word;b:byte);Stdcall; begin asm push edx push eax mov dx,p mov al,b out dx,al pop pop end; end;

eax edx

François Piette also has some direct I/O access functions at http://rtfm.netline.be/fpiette/portiofr.htm

BUT WHAT ABOUT NT? The above will not work on Windows NT. NT is a much more robust operating system, and allowing all and everybody access to the hardware anytime they wanted, would seriously endager the stability. In addition, NT is cross platform, and access to I/O ports might be wildly different on different processors. Even so, it is possible to access the I/O ports directly under NT on x86 processors. This is highly undocumented, and will probably disappear in future versions of the operating system.

839

I have not much information on the process, but an article by D. Roberts in the May, 1996 issue of Dr. Dobb's Journal looks promising: "Direct Port I/O and Windows NT." This seems to be the only DDJ I'm missing, so I can't verify it. See http://www.ddj.com for ordring of back-issues. Windows Developer's Journal does have an article on "Port I/O under Windows." It's written by Karen Hazzah, and appeared in the June 1996 issue. See http://www.wdj.com for ordering of back-issues.

RESOURCES (Note, I know very little about these resources, check them out yourself.) There are newsgroups dedicated to the topic of writing VxD's and VDD's: comp.os.ms-windows.programmer.nt.kernel-mode (VDD) comp.os.ms-windows.programmer.vxd (VxD) Dejanews (http://www.dejanews.com) turned up quite a few hits on 'device driver direct I/O access 95'. BlueWater Systems have developed OCX's for direct I/O, memory access and interrupt handling under all Win32 platforms. They also seem to offer custom built device drivers. See their page at http://www.bluewatersystems.com/. I know some other company has been advertising here for their ability to write custom VxD's. But I can't find that reference.

Hardware port access in DELPHI 2 function InPort(PortAddr: word): byte; {$IFDEF VER90} assembler; stdcall; asm mov dx,PortAddr in al,dx end; {$ELSE} begin Result := Port[PortAddr]; end; {$ENDIF} procedure OutPort(PortAddr: word; Databyte: byte); {$IFDEF VER90} assembler; stdcall; asm mov al,Databyte mov dx,PortAddr out dx,al end; {$ELSE} begin Port[PortAddr] := DataByte; end; {$ENDIF}


840

Windows 81. ???? Data segment too large ???? 82. Read the Run Minimized Checkbox 83. Cannot properly minimize a form on startup 84. Shared memory in a DLL with Delphi 2.0 85. Shell_NotifyIcon 86. How do I make completely invisible main forms?? 87. HELP !! STAY-ON-TOP !!! 88. Hiding Windows 95 Taskbar 89. A Catch-a-Maximize Command Question 90. How do you detect Windows version? 91. How can I change the wallpaper programmatically? 92. Path / directory name for 'My Computer' 93. Determining which font (Large or Small) is in use 94. Large/Small Fonts? 95. How can I restore a window to its last state when I run it again? 96. How: to determine name of StartUp group 97. Finding Boot Drive 98. How to make a window system modal ? 99. Sending Keystrokes/Text to a Window... 100. Windows Messages Basics 101. Buttons in Win95 task bar 102. Control Panel 103. Associate filetype [extension)

104.

Hide Start Buttonwindows23

105.

Greying Close Button on system menuwindows24

???? Data segment too large ???? From: [email protected] (Sundial Services) In article <[email protected]> Jean-Luc Nicoulin writes:

841

I get the message 'Data segment too large'. What is the matter and what can I do to solve the problem ?

In a Windows 3.1 application, three major data-areas share one(!) 64K memory segment: t he stack, the Windows 'local heap', and the data-segment containing all globals and initialized constants. This area can become used up extremely quickly. Consequently, W3.1 applications store almost -nothing- in the stack or in a global. Rather, they store -pointers- to them. This is why, in Delphi, 'an object is a pointer.' What you have to do is to comb your application looking for large globals and to move those into a common data block which your program allocates on startup (as an object) and destroys when done. You can see a lot about what's in the data segment by setting the 'linker map' to 'detailed' and looking for the 'DATA' segment. Whatever's in that segment is going to be trying to occupy space in the lower part of that 64K-memory segment.

Read the Run Minimized Checkbox Solution 1 Paul S. Knapp wrote: > > Does anyone know how to make as Delphi app read the Run Minimized > checkbox in the Windows 3.1 or 3.11 StartUp Group. > > I cannot get my application to run minimized when this checkbox is > checked. I would like to be able to give my users the option of > starting the application in their startup group, in either maximized or > minimized mode. Every Windows application I have ever used is able to > start in the mode selected by the checkbox in the Startup Group. I > assume Delphi applications should be able to as well, but so far I a > haven't found a way. > > Thanks in advance for your advice > Paul Knapp

Hi Paul! Use WinProcs unit and after created main form add call ShowWindow. You can use HInstance, HPrevInst, CmdShow and CmdLine global variables. program Project1; uses WinProcs, {*** use WinProcs} Forms, Unit1 in 'UNIT1.PAS' {Form1}; {$R *.RES} begin Application.CreateForm(TForm1, Form1); ShowWindow(Form1.handle, CmdShow); Application.Run; end.

Solution 2 From: Ken Kyler Here's and example, it's taken from 842

Rubenking, Neil (1996). _Delphi Programming Problem Solver_. Foster City, CA: IDG Books. ISBN:1-56884-795-5. unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormActivate(Sender: TObject); private { Private declarations } public { Public declarations } ShowHow : word ; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var SUI : TStartupInfo ; begin if CmdShow = SW_SHOWDEFAULT then begin GetStartupInfo( SUI ) ; ShowHow := SUI.wShowWindow ; end else ShowHow := CmdShow ; if ShowHow = SW_SHOWMAXIMIZED then WindowState := wsMaximized ; end; procedure TForm1.FormActivate(Sender: TObject); begin case ShowHow of SW_SHOWMINIMIZED, SW_MINIMIZE, SW_SHOWMINNOACTIVE : Application.Minimize ; end ; end; end.

Solution 3 From: [email protected] (Andreas Viebke) This works with NT 4 and Delphi 2.01. It took me one and a half hours to find out: Make your project code look like this:

843

begin Application.Initialize; Application.CreateForm(TForm1, Form1); Form1.Show; Application.Minimize; Application.Run; end.

It seems to be important that neither OnCreate nor OnShow is disturbed by a procedure that changes a window's state.

Cannot properly minimize a form on startup From: [email protected] (Abel du Plessis) I need to start my form minimized, unfortunetly it doesn't work. When I set the WindowState property of the main form to wsMinimized and run it, the form minimizes onto Win95 desktop instead of the taskbar how it properly should. Does anyone know how to fix this bug?

There was an article in The Delphi Magazine, Issue 19, March 1997 - the Delphi Clinic section which explained the problem. Here is my adaptation of the fix: unit Foobar; interface type

TfrmFoobar = class(TForm); procedure DoRestore(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end;

implementation procedure TfrmUVChannel.FormCreate(Sender: TObject); begin //Assign a temporary event handler for when the app gets restored Application.OnRestore := DoRestore; Application.Minimize; end; procedure TfrmFoobar.DoRestore(Sender: TObject); begin Application.ShowMainForm := True; //Restore the application Perform(wm_SysCommand, sc_Restore, 0); //Ensure all components draw properly Show; //Disconnect this event handler so it will not be called again Application.OnRestore := nil; end; initialization //Hide the minimized main form for now

844

Application.ShowMainForm := False; end.

Shared memory in a DLL with Delphi 2.0 From: [email protected] (John Crane) Sharing Memory Mapped Files... Check out the following code: var HMapping: THandle; PMapData: Pointer; const MAPFILESIZE = 1000; procedure OpenMap; var llInit: Boolean; lInt: Integer; begin HMapping := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, MAPFILESIZE, pchar('MY MAP NAME GOES HERE')); // Check if already exists llInit := (GetLastError() <> ERROR_ALREADY_EXISTS); if (hMapping = 0) then begin ShowMessage('Can''t Create Memory Map'); Application.Terminate; exit; end; PMapData := MapViewOfFile(HMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0); if PMapData = nil then begin CloseHandle(HMapping); ShowMessage('Can''t View Memory Map'); Application.Terminate; exit; end; if (llInit) then begin // Init block to #0 if newly created memset(PMapData, #0, MAPFILESIZE); end; end; procedure CloseMap; begin if PMapData <> nil then begin UnMapViewOfFile(PMapData); end; if HMapping <> 0 then begin CloseHandle(HMapping); end; end;

Any two or more applications or DLLs may obtain pointers to the same physical block of memory this way. PMapData will point to a 1000 byte buffer in this example, this buffer being initialized to #0's the first time in. One potential problem is synchronizing access to the memory. You may accomplish this through the use of mutexes. Here's an example of that: 845

{ Call LockMap before writing (and reading?) to the memory mapped file. to call UnlockMap immediately when done updating. }

Be sure

var HMapMutex: THandle; const REQUEST_TIMEOUT = 1000; function LockMap:Boolean; begin Result := true; HMapMutex := CreateMutex(nil, false, pchar('MY MUTEX NAME GOES HERE')); if HMixMutex = 0 then begin ShowMessage('Can''t create map mutex'); Result := false; end else begin if WaitForSingleObject(HMapMutex,REQUEST_TIMEOUT) = WAIT_FAILED then begin // timeout ShowMessage('Can''t lock memory mapped file'); Result := false; end; end; end; procedure UnlockMap; begin ReleaseMutex(HMixMutex); CloseHandle(HMixMutex); end;

Please excuse my unnecessary begin..end's. I come from a Clipper background, and I prefer to see my logic blocks capped off with end's - easier to follow.

Shell_NotifyIcon From: "Neil Clayton" <[email protected]> Rainer Perl wrote in article > > > > >

I have a question to the Shell_NotifyIcon function: I can add an icon to the taskbar I can modify an icon I can delete an icon. What I can't do: I can't receive Messages from the Icon!!

To receive messages you must add the NIF_MESSAGE flag to your notify structure and tell it what message to send and to which window. This is the code that I use: procedure TMainForm.UpdateTaskBar; area var NotifyData: TNotifyIconData; begin With NotifyData do data structure begin cbSize Wnd uID uFlags aspects to modify ...

// update the win95 taskbar icon

// set up the := SizeOf(TNotifyIconData); := MyForm.Handle; := 0; := NIF_ICON or NIF_MESSAGE or NIF_TIP;

// ... the

846

uCallbackMessage := WM_MY_MESSAGE; message to send back to us ... hIcon := hMyIcon; szTip := 'Tool Tip To Display'; tip end; Shell_NotifyIcon(dwMessage, @NotifyData); update end;

// ... the // ... and the tool // now do the

WM_MYMESSAGE is a user defined message. Usually defined as: const WM_MYMESSAGE = WM_USER + ;

How do I make completely invisible main forms?? From: [email protected] (Chris Randall) "J.J. Bakker" wrote: >Does anyone know the answer, I', trying to make an app that has an icon in the notification area with a popupmenu. However the application is still visible on the taskbar. Using Application.ShowMainForm:=False; is not enough. >

I have run into the same problem but found the answer. This little bit of code works great. procedure TMainForm.FormCreate(Sender: TObject); begin Application.OnMinimize:=AppMinimize; Application.OnRestore:=AppMinimize; Application.Minimize; AppMinimize(@Self); end; procedure TMainForm.AppMinimize(Sender: TObject); begin ShowWindow(Application.Handle, SW_HIDE); end;

HELP !! STAY-ON-TOP !!! From: "James D. Rofkar" JAAD wrote: > > I want to make a Delphi-Form to REALLY stay on top, But not only within it own application (thats simpel) No I want it to stay on top even when I am using for instance EXCEL. >

Try using the Windows API function SetWindowPos(). Something like... with MyForm do SetWindowPos(Handle,

847

HWND_TOPMOST, Left, Top, Width, Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

You may need to call this function in your Form's OnShow(), OnDeactivate(), and OnActivate() event handlers.

Hiding Windows 95 Taskbar From: "James D. Rofkar" Robert Copier wrote: > Is there a way to hide the Windows 95 statusbar when i start my application made in delphi 2.01. When the user close the application the statusbar must become visible again.

I'm guessing you're referring to the Windows 95 taskbar and system tray window, and not a statusbar. The answer: Sure you can! And what a cool idea! Here's how: 1. First declare a variable of type HWND to store the Window handle of the Windows 95 taskbar. TForm1 = class(TForm) ... private hTaskBar: HWND; ... end;

2. In your main form's OnCreate() event handler, place some code that resembles: hTaskBar := FindWindow('Shell_TrayWnd', nil); ShowWindow(hTaskBar, SW_HIDE);

3. Finally, in your main form's OnDestroy() event handler, code something like: ShowWindow(hTaskBar, SW_SHOW);

"Earl F. Glynn" PROCEDURE HideWin95TaskBar; VAR WindowHandle: hWnd; BEGIN {Hide the Windows 95 Taskbar} WindowHandle := FindWindow('Shell_TrayWnd', ''); IF WindowHandle <> 0 THEN ShowWindow(WindowHandle, SW_HIDE) END {HideWin95TaskBar}; PROCEDURE ShowWin95TaskBar; VAR WindowHandle: hWnd; BEGIN {Allow the Windows 95 Taskbar to appear} WindowHandle := FindWindow('Shell_TrayWnd', ''); IF WindowHandle <> 0

848

THEN ShowWindow(WindowHandle, SW_RESTORE) END {ShowWin95TaskBar};

A Catch-a-Maximize Command Question From: "Chami" <[email protected]> > I need to have a form in my application that zooms to half of > the screen when the Maximize button is pressed, not to full > screen. >

you could handle the WM_GETMINMAXINFO message from your form. for example, add the following declaration to the protected section of your form (interface): procedure _WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO ); wm_GetMinMaxInfo;

message

then define (implementation) the above message handler as follows (TForm1 being the name of your form of course): procedure TForm1._WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO ); begin // set the position and the size of your form when maximized: with mmInfo.minmaxinfo^ do begin ptmaxposition.x := Screen.Width div 4; ptmaxposition.y := Screen.Height div 4;

end;

ptmaxsize.x ptmaxsize.y

:= Screen.Width div 2; := Screen.Height div 2;

end;

How do you detect Windows version? From: [email protected] Check the API help In the WINPROCS unit try the function GetVersion: LongInt; The GetVersion function retrieves the current version numbers of the Windows and MSDOS operation systems. NOTE there is a error in the orginal API documentation, the major/minor Win version are reversed! As I have used it: Windows 3.1 show up as 3.1, WIN95 shows up as 3.95 Note For windows 95 and higher use the function GetVersionEx

849

How can I change the wallpaper programmatically? Solution 1 The following code comes from Loyds Help File (it can be found on most delphi web pages). I haven't tried it but I will use it in one of my apps as soon as I get the bitmap from the client. let me know if it works for you. unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; Bitmap: TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP'); end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end;

850

end; end.

Solution 2 From: "Dirk Faber " Rob Wilson wrote > Does anyone know how I can change the wallpaper at runtime using a > filename that I specifiy? procedure ChangeWallpaper(bitmap: string); *.bmp}

{bitmap contains filename:

var pBitmap : pchar; begin bitmap:=bitmap+#0; pBitmap:=@bitmap[1]; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE); end; > Also, is there a way of saving it to the INI file for next session?

1. add inifiles to the uses list. 2. create an inifile with a texteditor like this: [LastUsedBitmap] LUBitmap= c:\mybitmap.bmp

3. use a procedure like this: (supposed the inifile is like above, and is named c:\Bitmap.ini) procedure WriteToIniFile(bitmap : string); var MyIniFile : TInifile; begin MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' ); MyIniFile.WriteString( 'LastUsedBitmap', 'LUBitmap', bitmap); MyIniFile.Free; end; procedure ReadFromIniFile(var bitmap: string); var MyIniFile : TInifile; begin MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' ); bitmap:= MyIniFile.ReadString('LastUsedBitmap', 'LUBitmap'); MyIniFile.Free; end;

Path / directory name for 'My Computer' Christian Piene Gundersen

851

This is a rather complicated matter, so if it isn't vital to your application, I suggest that you spend your time better than digging into it. However, I'll try to point you in the right direction. The windows 32 operating system is based on a shell which uses virtual folders, like 'my computer', 'desktop' and 'recycle bin'. Some of these folders are part of the physical file system. That is they have a corresponding directory in the file system. This is the case with 'desktop' and 'recycle bin'. These directories can be used as InitialDir for the TOpenDialog, but first you have to get their physical location, which can be different on different computers. To get the physical location of these folders, you have to use some special API calls (see example below). Other folders, like 'my computer' and 'printers' are not part of the file system - they are only virtual. I've noticed that you can browse to these folders using the TOpenDialog, but I don't think they can be used as InitialDir. Virtual folders are (a bit simplified) of the type SHITEMID (item identifier). They are normally accessed using pointers to item identifiers list (PIDL). To get the PIDL of a special folder, you can use the SHGetSpecialFolder function. The physical location of the corresponding directory can then be obtained by passing the PIDL to the GetPathFromIDList function. If the folder is part of the file system, the function will return the path as a string (which can be used as InitialDir). But if you want the OpenDialog to start in a folder that is only virtual (like 'my computer'), you'll have to make it accept a PIDL as InitialDir, which I don't think it will. My guess is that the TOpenDialog uses PIDLs when browsing, but only accepts physical directories as InitialDir. Here is an example that shows how to get the 'recent documents' path and use it as InitialDir: procedure TForm1.Button1Click(Sender: TObject); var PIDL: Pointer; Path: LPSTR; const CSIDL_RECENT = $0008; begin Path := StrAlloc(MAX_PATH); SHGetSpecialFolderLocation(Handle, CSIDL_RECENT, @PIDL); if SHGetPathFromIDList(PIDL, Path) then // returns false if folder isn't part of file system begin OpenDialog1.InitialDir := Path; OpenDialog1.Execute; end; StrDispose(Path); end;

I think you'll have to write a wrapper for these API calls. They are found in shell32.dll. The best advice I can give you if you want to dig into this is to study the ShlObj.h file. I don't program in C myself, but I found it very useful. Some constants you may need: CSIDL_DESKTOP CSIDL_PROGRAMS CSIDL_CONTROLS CSIDL_PRINTERS CSIDL_PERSONAL CSIDL_STARTUP CSIDL_RECENT CSIDL_SENDTO CSIDL_BITBUCKET CSIDL_STARTMENU CSIDL_DESKTOPDIRECTORY CSIDL_DRIVES

= = = = = = = = = = = =

$0000; $0002; $0003; $0004; $0005; $0007; $0008; $0009; $000a; $000b; $0010; $0011;

// My Computer

852

CSIDL_NETWORK CSIDL_NETHOOD CSIDL_FONTS CSIDL_TEMPLATES

= = = =

$0012; $0013; $0014; $0015;

Determining which font (Large or Small) is in use "Greg Peterson" Try this: FUNCTION SmallFonts : BOOLEAN; {returns TRUE if small fonts are set, FALSE if using Large Fonts } VAR DC : HDC; { used to check for number of colors available } BEGIN DC := GetDC(0); Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96); { LOGPIXELSX will = 120 if large fonts are in use } ReleaseDC(0, DC); END;

Large/Small Fonts? Gene Eighmy > > > > > >

When my programs run on systems with small fonts, I often get strange output. Labels too small to hold all the text, leaving the right, or the bottom, unshown, for instance. StringGrid's which don't align as expected.

Try this. This will rescale both the form size and also reform small vs. large fonts. Call it in Form.FormCreate. Hope this helps. unit geScale; interface uses Forms, Controls; procedure geAutoScale(MForm: TForm); implementation Type TFooClass = class(TControl); { needed to get at protected } { font property } procedure geAutoScale(MForm: const cScreenWidth :integer = cScreenHeight:integer = cPixelsPerInch:integer= cFontHeight:integer =

TForm); 800; 600; 96; -11;

{Design-time value of From.Font.Height}

853

var i: integer; begin { IMPORTANT!! : Set Scaled Property of TForm to FALSE with Object Inspector. The following routine will scale the form such that it looks the same regardless of the screen size or pixels per inch. The following section determines if the screen width differs from the design-time screen size. If it differs, Scaled is set true and component positions are rescaled such that they appear in the same screen location as the design-time location. } if (Screen.width &;lt> cScreenWidth)or(Screen.PixelsPerInch <> cPixelsPerInch) then begin MForm.scaled := TRUE; MForm.height := MForm.height * screen.Height DIV cScreenHeight; MForm.width := MForm.width * screen.width DIV cScreenWidth; MForm.ScaleBy(screen.width, cScreenWidth); end; { time

This section determines if the run-time font size differs from the designtime font size. If the run-time pixelsperinch differs form the design-

pixelsperinch, the fonts must be rescaled in order for the form to appear as designed. Scaling is calculated as the ratio of the design-time font.height to run-time font.height. Font.size will not work as it may equal the designtime value yet appear physically larger crowding and overrunning other components. For instance, a form designed in 800x600 small fonts has a font.size of 8. When you run the form on in 800x600 large fonts, font.size is also 8 but the text is noticably larger than when run in small font mode. This scaling will make them both appear to be the same size. } if (Screen.PixelsPerInch <> cPixelsPerInch) then begin for i := MForm.ControlCount - 1 downto 0 do TFooClass(MForm.Controls[i]).Font.Height := (MForm.Font.Height div cFontHeight) * TFooClass(MForm.Controls[i]).Font.Height; end; end; end.

How can I restore a window to its last state when I run it again? A: Here is WindowRestorer - a window size and state restorer 854

DESCRIPTION: Ever notice how professional programs seem to remember in what condition and location you left them and their child windows? Ever notice how most RAD apps don't? You can take that ragged edge off your program with this unit. It Allows apps to save the location, size, and state of windows so that when the user reopens them, they will look as the user left them. USE: Put WINRSTOR in the uses of clause of your main form and any forms that will be saving or restoring their own state, size, or location. (If you will be doing all the saving and restoring using WinSaveChildren and WinRestoreChildren from the main form, you only need reference it in the main form's uses clause.) In MainForm.Create, initialize the global WinRestorer object as follows (it's already declared in this file, but needs to be allocated): GlobalWinRestorer := TWinRestorer.create( Application, TRUE, WHATSAVE_ALL);

Which is the same as: GlobalWinRestorer := TWinRestorer.create( Application, TRUE, [location, size, state]);

Then, in MainForm.Destroy, deallocate the global WinRestorer object as follows: GlobalWinRestorer.free;

A good place to save a form's status is in the queryclose event or else attached to a button or menu item. I usually create an item in the File Menu captioned 'Save &Workspace' which does: GlobalWinRestorer.SaveChildren(Self, [default]);

And under main form's Close event I put: GlobalWinRestorer.SaveWin(Self, [WHATSAVE_ALL]);

I have tended to restore the children's status in their own show events like this: GlobalWinRestorer.RestoreWin(Self, [default]);

though I am moving toward putting in the main form's show event: GlobalWinRestorer.RestoreWin(Self, [default]); GlobalWinRestorer.RestoreChildren(Self, [default]);

HINTS: If you set TForm.Position to poScreenCenter or anything fancy, this unit won't do what you expect. poDesigned seems to work fairly well. I could have raised an exception if you try to set top and left of a poScreenCentere'd form, but then you have to be careful using WinRestoreChildren. I opted not to check the position property and leave that up to individual developers. unit WinRstor; INTERFACE USES SysUtils, Forms; TYPE {=============================================================}

855

{-----------------------------------------------------------------Windows restorer object class and related types. -------------------------------------------------------------------} EWinRestorer = class( Exception); TWhatSave = (default, size, location, state); STWhatSave = set of TWhatSave; TWinRestorer = class(TObject) protected mIniFile: string; mIniSect: string[80]; mIsInitialized: boolean; mDefaultWhat: STWhatSave; public constructor Create( TheApp: TApplication; LocalDir: boolean; DefaultWhatSave: STWhatSave); {If localDir is true, ini dir is the app dir. Else, ini dir is the windows dir.} procedure SaveWin(TheForm: TForm; What: STWhatSave); procedure SaveChildren(TheMDIForm: TForm; What: STWhatSave); procedure RestoreWin( TheForm: TForm; What: STWhatSave); procedure RestoreChildren(TheMDIForm: TForm; What: STWhatSave); property IniFileName: string read mIniFile; end; CONST WHATSAVE_ALL = [size, location, state]; VAR GlobalWinRestorer: TWinRestorer; IMPLEMENTATION Uses IniFiles; constructor TWinRestorer.create; var fname, path: string[100]; begin inherited create; {Calculate ini file name} if default in DefaultWhatSave then raise EWinRestorer.create( 'Attempt to initialize default window position paramaters with set ' + ' containing [default] item. ' + 'Default params may contain only members of [size, location, state]. ') else mDefaultWhat := DefaultWhatSave; fname := ChangeFileExt( ExtractFileName( TheApp.exeName), '.INI'); if LocalDir then begin {parse out path and add to file name} path := ExtractFilePath(TheApp.exeName); if path[length(path)] <> '\' then path := path + '\'; fname := path + fname; end; {fill object fields} mIniFile := fname; mIniSect := 'WindowsRestorer'; {It'd be nice to write some notes to a section called [WinRestorer Notes]} end; procedure TWinRestorer.RestoreWin; var FormNm, SectionNm: string[80]; ini: TIniFile; n,l,t,w,h: integer; {Left, Top Width, Height}

856

begin ini := TIniFile.create( mIniFile); TRY SectionNm := mIniSect; FormNm := TheForm.classname; if default in What then What := mDefaultWhat; {Update Window State if Necessary} if state in What then n := ini.ReadInteger( SectionNm, FormNm + '_WindowState', 0); case n of 1: TheForm.WindowState := wsMinimized; 2: TheForm.WindowState := wsNormal; 3: TheForm.WindowState := wsMaximized; end; {Update Size and Location if necessary.} with TheForm do begin l:=left; t:=top; h:=height; w:=width; end; {Save current vals.} if size in What then begin w := ini.ReadInteger( SectionNm, FormNm + '_Width', w); h := ini.ReadInteger( SectionNm, FormNm + '_Height', h); end; if location in What then begin t := ini.ReadInteger( SectionNm, FormNm + '_Top', t); l := ini.ReadInteger( SectionNm, FormNm + '_Left', l); end; TheForm.SetBounds(l,t,w,h); FINALLY ini.free; END; end; procedure TWinRestorer.RestoreChildren; var i: integer; begin if TheMDIForm.formstyle <> fsMDIForm then raise EWinRestorer.create('Attempting to save window sizes of children for a non MDI parent window.') else for i := 0 to TheMDIForm.MDIChildCount - 1 do RestoreWin( TheMDIForm.MDIChildren[i], what); end; procedure TWinRestorer.SaveWin; var FormNm, SectionNm: string[80];

w : STWhatsave; ini: TIniFile;

begin ini := TIniFile.create( mIniFile); TRY SectionNm := mIniSect; FormNm := TheForm.ClassName; if default in What then w := mDefaultWhat else w := mDefaultWhat; if size in w then begin ini.WriteInteger( SectionNm, FormNm + '_Width', TheForm.Width); ini.WriteInteger( SectionNm, FormNm + '_Height', TheForm.Height); end; if location in w then begin ini.WriteInteger( SectionNm, FormNm + '_Top', TheForm.Top); ini.WriteInteger( SectionNm, FormNm + '_Left', TheForm.Left); end; if state in w then case TheForm.WindowState of wsMinimized: ini.WriteInteger( SectionNm, FormNm + '_WindowState', 1); wsNormal: ini.WriteInteger( SectionNm, FormNm + '_WindowState', 2);

857

wsMaximized: end; FINALLY ini.free; END; end;

ini.WriteInteger( SectionNm, FormNm + '_WindowState', 3);

procedure TWinRestorer.SaveChildren; var i: integer; begin if TheMDIForm.formstyle <> fsMDIForm then raise EWinRestorer.create('Attempting to restore window sizes of children for a non MDI parent window.') else for i := 0 to TheMDIForm.MDIChildCount - 1 do SaveWin( TheMDIForm.MDIChildren[i], what); end; INITIALIZATION END.

{ This code came from Lloyd's help file! }

How: to determine name of StartUp group From: Allan Carlton In each language version of Windows the 'StartUp' folder has als a different name. Is there any way to determine the correct name of this folder ??

There is an entry in the registry under: HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Start Menu

Which might give you the info you need

Finding Boot Drive From: "HIKI Takehito" Is there a function or API call to find the boot drive?

I found it in the Registry. HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup

"BootDir" value may be BootDrive.

How to make a window system modal ? From: "Eric Lawrence" SetSystemModalWindow(Form1.handle);

858

Sending Keystrokes/Text to a Window... From: "David Zajac" Hope this helps: unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure FormKeyPress(Sender: TObject; var Key: Char); private AppInst: THandle; AppWind: THandle; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellAPI; procedure SendShift(H: HWnd; Down: Boolean); var vKey, ScanCode, wParam: Word; lParam: longint; begin vKey:= $10; ScanCode:= MapVirtualKey(vKey, 0); wParam:= vKey or ScanCode shl 8; lParam:= longint(ScanCode) shl 16 or 1; if not(Down) then lParam:= lParam or $C0000000; SendMessage(H, WM_KEYDOWN, vKey, lParam); end; procedure SendCtrl(H: HWnd; Down: Boolean); var vKey, ScanCode, wParam: Word; lParam: longint; begin vKey:= $11; ScanCode:= MapVirtualKey(vKey, 0); wParam:= vKey or ScanCode shl 8; lParam:= longint(ScanCode) shl 16 or 1; if not(Down) then lParam:= lParam or $C0000000; SendMessage(H, WM_KEYDOWN, vKey, lParam); end;

859

procedure SendKey(H: Hwnd; Key: char); var vKey, ScanCode, wParam: Word; lParam, ConvKey: longint; Shift, Ctrl: boolean; begin ConvKey:= OemKeyScan(ord(Key)); Shift:= (ConvKey and $00020000) <> 0; Ctrl:= (ConvKey and $00040000) <> 0; ScanCode:= ConvKey and $000000FF or $FF00; vKey:= ord(Key); wParam:= vKey; lParam:= longint(ScanCode) shl 16 or 1; if Shift then SendShift(H, true); if Ctrl then SendCtrl(H, true); SendMessage(H, WM_KEYDOWN, vKey, lParam); SendMessage(H, WM_CHAR, vKey, lParam); lParam:= lParam or $C0000000; SendMessage(H, WM_KEYUP, vKey, lParam); if Shift then SendShift(H, false); if Ctrl then SendCtrl(H, false); end; function EnumFunc(Handle: HWnd; TF: TForm1): Bool; Far; begin TF.AppWind:= 0; if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then TF.AppWind:= Handle; result:= (TF.AppWind = 0); end; procedure TForm1.Button1Click(Sender: TObject); var Text: Array[0..255] of char; begin AppInst:= ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL); EnumWindows(@EnumFunc, longint(self)); AppWind:= GetWindow(AppWind, GW_CHILD); end; procedure TForm1.Button2Click(Sender: TObject); begin SendKey(AppWind, 'T'); SendKey(AppWind, 'e'); SendKey(AppWind, 's'); SendKey(AppWind, 't'); end; procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if AppWind <> 0 then SendKey(AppWind, Key); end; end.

Windows Messages Basics Can anybody out there send me some basic stuff about Windows Messages related to Delphi. All this WM_*** stuff is getting on my nerves, since I can't understand it.

[Jim Stanley, [email protected]] 860

All the Windows messages are listed in the Windows API help in your Delphi help topics. (I'm using D1, assume the same for future versions). The WM_ (and other) messages are essential to the way Windows works. You're well aware that Delphi is primarily an *event-driven* system; all those OnKeyPress, OnThis, OnThat methods. If you have the VCL source code, you'll find in there somewhere that those event handler methods are designed to *receive* particular Windows messages (and there are some threads in here showing how you can subclass a component and "teach" it to respond to other messages as well). Windows is constantly sending out those messages in response to actions performed by the user, and it's the business of the Delphi app (and of all Windows apps) to intercept them and handle them in ways you decide. Delphi puts a wrapper over most of the message system by creating the event handlers for components described above. In addition to recieving those messages, you can also *send* them as well. There are a couple of ways to work this: check out SendMessage and PostMessage (both native Win API functions), as well as the Delphi Perform method. The first two require you to use the Handle parameter of the component you're sending the message to, while Perform is a method belonging to that component. The messages go into the standard Windows message queue and are processed like every other message. Here's a trivial example: I want (for some bizarre reason) to insert a 'y' character whenever I type a '4' in a TMemo. [Think of automatically inserting a begin-end block or a closing parenthesis.) Now I could do a lot with the Memo's Lines property, but that gets pretty complex. A much simpler way of going about it is: procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin if Key = '4' then SendMessage(Memo1.Handle, WM_CHAR, Word('y'), 0); end;

Another example is something we were doing here at Jacobs that used a lot of combo boxes. We wanted them to automatically drop down when the user pressed a key, which is (unfortunately) not standard behavior. Here's what we did: procedure TFormEffortRates.ComboBoxMaterialKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var iShowing : integer; { other code, then... } begin { This tells you whether the combo is already dropped } iShowing := SendMessage((Sender as TComboBox).Handle, CB_GETDROPPEDSTATE, 0, 0); if iShowing = 0 then { drop the combo box } SendMessage((Sender as TComboBox).Handle, CB_SHOWDROPDOWN, 1,0); end;

Another good example is getting the line and column from a TMemo. You have to go into the API to do it. Here's a (not particularly efficient - no flames please!!) method of determining them: function TMDIChild.GetMemoColumn(const TheMemo : TMemo) : integer; begin Result := TheMemo.SelStart (SendMessage(TheMemo.Handle, EM_LINEINDEX, GetMemoLine(TheMemo), 0)); end;

861

function TMDIChild.GetMemoLine(const TheMemo : TMemo) : integer; begin Result := SendMessage(TheMemo.Handle, EM_LINEFROMCHAR, TheMemo.SelStart, 0); end;

Again, all these messages can be found in your API help. The instructions for using them are a little vague, but I'm sure everyone will be glad to help you should you need it. In short, API messages provide you with a way to fine-tune your applications to respond in exactly the way you want them to. I would consider it an advanced Delphi topic, but it sounds like one you're more than ready for.

Buttons in Win95 task bar Can anyone tell me of a way or a component or whatever else that will allow delphi 2 or 3 to place a button on the task bar much like what PowerDesk 2.0 Toolbar does.

[[email protected]] Here are the code snipits to do just that! // This needs to be in your public declarations @ the top of the pas file procedure TForm1.IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100;

procedure TForm1.FormCreate(Sender: TObject); var nid : TNotifyIconData; begin with nid do begin cbSize := SizeOf( TNotifyIconData ); Wnd := Form1.Handle; uID := 1; uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; uCallbackMessage := WM_USER + 100; hIcon := Application.Icon.Handle; szTip := 'This is the hint!'; end; Shell_NotifyIcon( NIM_ADD, @nid ); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); var nid : TNotifyIconData; begin with nid do begin cbSize := SizeOf( TNotifyIconData ); Wnd := Form1.Handle; uID := 1; uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; uCallbackMessage := WM_USER + 100; hIcon := Application.Icon.Handle; szTip := 'This is the hint!'; // All the above is probably not needed. end; Shell_NotifyIcon( NIM_DELETE, @nid ); end;

862

procedure TForm1.IconCallBackMessage( var Mess : TMessage ); var sEventLog : String; begin case Mess.lParam of // Do whatever you wish here. For example popup up a menu on a right click. WM_LBUTTONDBLCLK : sEventLog := 'Left Double Click'; WM_LBUTTONDOWN : sEventLog := 'Left Down'; WM_LBUTTONUP : sEventLog := 'Left Up'; WM_MBUTTONDBLCLK : sEventLog := 'M Dbl'; WM_MBUTTONDOWN : sEventLog := 'M D'; WM_MBUTTONUP : sEventLog := 'M U'; WM_MOUSEMOVE : sEventLog := 'movement'; WM_MOUSEWHEEL : sEventLog := 'Wheel'; WM_RBUTTONDBLCLK : sEventLog := 'r dbl'; WM_RBUTTONDOWN : sEventLog := 'r down'; WM_RBUTTONUP : sEventLog := 'r up'; end; end;

Control Panel From: "Hiki Takehito" >Anyone know how to put a Delphi application inside the Control Panel?

If you use Delphi3, add Cpl unit at dpr file. I show you a sample code. ----------library Project1; {Change "program" to "library"} uses Cpl, {use Cpl unit} Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} procedure ExecuteApp; begin Application.Initialize; Application.CreateForm(TForm1,Form1); Application.Run; end; {A callback function to export at Control Panel} function CPlApplet(hwndCPl: THandle; uMsg: DWORD; lParam1, lParam2: LongInt):LongInt;stdcall; var NewCplInfo:PNewCplInfo; begin Result:=0; case uMsg of {Initialization.Return True.} CPL_INIT: Result:=1; {Number of Applet.} CPL_GETCOUNT: Result:=1; {Transporting informations of this Applet to the Control Panel.}

863

CPL_NEWINQUIRE: begin NewCplInfo:=PNewCplInfo(lParam2); with NewCplInfo^ do begin dwSize:=SizeOf(TNewCplInfo); dwFlags:=0; dwHelpContext:=0; lData:=0; {An icon to display on Control Panel.} hIcon:=LoadIcon(HInstance,'MAINICON'); {Applet name} szName:='Project1'; {Description of this Applet.} szInfo:='This is a test Applet.'; szHelpFile:=''; end; end; {Executing this Applet.} CPL_DBLCLK: ExecuteApp; else Result:=0; end; end; {Exporting the function of CplApplet} exports CPlApplet; begin end.

To use this, change the extention from "dll" to "cpl". And put into the System folder. Applet means a piece of Control Panel.Display,Fonts,Mouse,System are all Applets.

Associate filetype [extension) From: Jeremy Collins Basically, you need to add two keys to the registry under HKEY_CLASSES_ROOT. Say your extension in ".ext", then the first key you add is the extension itself: HKEY_CLASSES_ROOT\ .ext\

and set the "default" string value of this key to an "internal name" for your file type - for example MyApp.Document: HKEY_CLASSES_ROOT\ .ext\ Default = "MyApp.Document"

You then create another key with this name: HKEY_CLASSES_ROOT\ MyApp.Document\

Create a sub-key of this called "shell", a sub-key of *this* called "open" and a further subkey of "open" called "command". The default value uder this key is the location and name of your your application folled by "%1" which represents the filename parameter that Windows will pass to your executable: HKEY_CLASSES_ROOT\

864

MyApp.Document\ shell\ open\ command\ Default = "C:\myapp\myapp.exe %1"

You can do this in code with the TRegistry object, or use InstallShield, which can make registry changes for you. I'd advise doing both, in case the user trashes your registry entry. From: "Rodney E Geraghty" &tt;[email protected]> The easiest way I've found to do this is to modify the Extensions section of the win.ini file that is located in the Windows directory. This also works under Win 95 and will update the registry automatically under Win95. Look at the extensions section of the win.ini to see the format you have to use. Put IniFiles in your uses clause and then use something like this: var INIFile: TIniFile; begin try INIFile := TInifile.Create('WIN.INI'); INIFile.WriteString('Extensions','txt','c:\windows\notepad.exe ^.txt'); finally INIFile.Free; end; end;

This would associate *.txt files with Windows Notepad. If you had an app named MyApp in the c:\MyApps directory and your extension was *.MAP then you would change it like this: var INIFile: TIniFile; begin try INIFile := TInifile.Create('WIN.INI'); INIFile.WriteString('Extensions','map','c:\myapps\myapp.exe ^.map'); finally INIFile.Free; end; end;

This will work in both Win 3.11 and Win 95 and saves you from having to modify the Reqistry under Win 95. Not sure about Win NT (or Win95b) since I don't have a test machine available. Note that this is only the first part of the solution though since it will open the associated application but it won't load the file you clicked. To do this you have to read ParamStr(1), which would hold the full path of the file you clicked, and run the file name through your file opening routine.

Hide Start Button From: "Carsten Paasch" Use this proc. to hide the start button: procedure hideStartbutton(visi:boolean); Var Tray, Child : hWnd;

865

C : Array[0..127] of Char; S : String; Begin Tray := FindWindow('Shell_TrayWnd', NIL); Child := GetWindow(Tray, GW_CHILD); While Child <> 0 do Begin If GetClassName(Child, C, SizeOf(C)) > 0 Then Begin S := StrPAS(C); If UpperCase(S) = 'BUTTON' then begin // IsWindowVisible(Child) startbutton_handle:=child; If Visi then ShowWindow(Child, 1) else ShowWindow(Child, 0); end; End; Child := GetWindow(Child, GW_HWNDNEXT); End; End;

Greying Close Button on system menu From: "Fred Hovey"

866

Miscellaneous 106. 107. 108. 109. 110. 111.

Compile Date How do I run a program? How to write text transparently on the canvas. using Textout Different colors for the lines in the DBCtrlGrid Overriding Virtual Methods SHAREWARE NAG EXAMPLE !!

112. 113.

Auto Scaling routine... Hint's Windowzmisc17

Compile Date Martin Larsson wrote: > It's very nice to have a number say in the about box that the > customer can read you, and you can immediately find the version. > Using date and time of compilation would be a good number.

I'm assuming you already do something like this, but for all those who haven't realised this workaround, write a program which outputs the current date to a text file and call it something like "today.inc". A DOS program works best ( run it from your autoexec.bat takes no time at all ), or stick a windows prog in you startup group/folder. "today.inc" will have the form const _day _date _month _year

: : : :

string[10] = 'Monday'; word = 12; word = 8; word = 1996;

Then, just do a {$I c:\today.inc} at the top of all your programs. Easy, although I agree - {$DATE} would be easier!

How do I run a program? From: Yeo Keng Hua 867

Check out FMXUTIL.PAS in Delphi examples: function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): THandle; var zFileName, zParams, zDir: array[0..79] of Char; begin Result := ShellExecute(Application.MainForm.Handle, nil, StrPCopy(zFileName, FileName), StrPCopy(zParams, Params), StrPCopy(zDir, DefaultDir), ShowCmd); end;

Called with the code : executeFile('maker.exe','text_file','c:\maker', SW_SHOWNORMAL);

How to write text transparently on the canvas. using Textout From: [email protected] This is a bit of code that came on a CD-ROM with a "How To Book" I bought.. The file is called "HowUtils.Pas" Fades Text in, and or out on a Canvas. function TFadeEffect.FadeInText(Target: TCanvas; X, Y: integer; FText: String): TRect; var Pic: TBitmap; W, H: integer; PicRect, TarRect: TRect; begin Pic := TBitmap.Create; Pic.Canvas.Font := Target.Font; W := Pic.Canvas.TextWidth(FText); H := Pic.Canvas.TextHeight(FText); Pic.Width := W; Pic.Height := H; PicRect := Rect(0, 0, W, H); TarRect := Rect(X, Y, X + W, Y + H); Pic.Canvas.CopyRect(PicRect, Target, TarRect); SetBkMode(Pic.Canvas.Handle, Transparent); Pic.Canvas.TextOut(0, 0, FText); FadeInto(Target, X, Y, Pic); Pic.Free; FadeInText := TarRect; end; procedure TFadeEffect.FadeOutText(Target: TCanvas; TarRect: TRect; Orig: TBitmap); var Pic: TBitmap; PicRect: TRect; begin Pic := TBitmap.Create; Pic.Width := TarRect.Right - TarRect.Left; Pic.Height := TarRect.Bottom - TarRect.Top; PicRect := Rect(0, 0, Pic.Width, Pic.Height);

868

Pic.Canvas.CopyRect(PicRect, Orig.Canvas, TarRect); FadeInto(Target, TarRect.Left, TarRect.Top, Pic); Pic.Free; end;

Different colors for the lines in the DBCtrlGrid Does anybody know how to set different colors for the lines in the DBCtrlGrid?

[Cory Lanou, [email protected]] use the drawColumnCell event. Also be sure to defautlDrawing false procedure TMain.ProjectGridDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin projectGrid.canvas.brush.color := clWindow; projectGrid.canvas.fillRect(rect); if gdSelected in state then begin projectGrid.canvas.brush.color := clHighlight; if fsBold in projectGrid.canvas.font.style then begin projectGrid.canvas.font.color := clHighlightText; projectGrid.canvas.font.style := [fsBold]; end else projectGrid.canvas.font.color := clHighlightText; end else if gdFocused in state then begin projectGrid.canvas.brush.color := clWindow; if fsBold in projectGrid.canvas.font.style then begin projectGrid.canvas.font.color := clWindowText; projectGrid.canvas.font.style := [fsBold]; end else projectGrid.canvas.font.color := clWindowText; end else if gdFixed in state then begin projectGrid.canvas.brush.color := clHighlight; if fsBold in projectGrid.canvas.font.style then begin projectGrid.canvas.font.color := clHighlightText; projectGrid.canvas.font.style := [fsBold]; end else projectGrid.canvas.font.color := clHighlightText; end; with globalDataModule.qProjects do begin // test cirteria of record. Set properties to override the default; if fieldByName('EST_COMPL_DATE').asDateTime < date then projectgrid.Canvas.font.color := clRed; if compareStr(fieldByName('STAT_CODE').asString, 'HD') = 0 then projectgrid.Canvas.font.color := clOlive; if (compareStr(fieldByName('CHANGED').asString, 'Y') = 0) and

869

(fieldByName('ASSIGN_EMP_ID').asInteger = userRecord.UserId) then projectgrid.Canvas.font.style := [fsBold]; end; projectGrid.canvas.textOut(rect.left+2, rect.top+2, column.field.text); end;

Overriding Virtual Methods Anybody know what the difference is between OVERRIDING a virtual method and REPLACING it? I'm confused on this point.

[Brian Murray, [email protected]] Say you have a class TMyObject = class (TObject)

and a subclass TOverrideObject = class (TMyObject)

Further, TMyObject has a Wiggle method: procedure Wiggle; virtual;

and TOverrideObject overrides Wiggle procedure Wiggle; override;

and you've written the implementations for both. Now, you create a TList containing a whole bunch of MyObjects and OverrideObjects in the TList.Items[n] property. The Items property is a pointer so to call your Wiggle method you have to cast Items. Now you could do this: if TObject(Items[1]) is TMyObject then TMyObject(Items[1]).Wiggle else if TObject(Items[1]) is TOverrideObject then TOverrideObject(Items[1]).Wiggle;

but the power of polymorphism (and the override directive) allows you to do this: TMyObject(Items[1]).Wiggle;

your application will look at the specific object instance pointed to by Items[1] and say "yes this is a TMyObject, but, more specifically, it is a TOverrideObject; and since the Wiggle method is a virtual method and since TOverrideObject has an overridden Wiggle method I'm going to execute the TOverrideObject.Wiggle method NOT the TMyObject.Wiggle method." Now, say you left out the override directive in the declaration of the TOverrideObject.Wiggle method and then tried TMyObject(Items[1]).Wiggle;

The application would look and see that even though Items[1] is really a TOverrideObject, it has no overridden version of the Wiggle method so the application will execute TMyObject.Wiggle NOT TOverrideObject.Wiggle (which may or may not be what you want). So, overriding a method means declaring the method with the virtual (or dynamic) directive in a base class and then declaring it with the override directive in a sub class. Replacing a method means declaring it in the subclass without the override directive. Overriden methods of a subclass can be executed even when a specific instance of the subclass is cast as its base class. Replaced methods can only be executed if the specific instance is cast as the specific class. 870

SHAREWARE NAG EXAMPLE !! From: Karsten Heitmann This here little piece of code GOT to be the quickest way to create a true shareware nag, that gives people the full functionality of the program, yet nags people big time untill they register (cruel, huh :) ) This shareware nag makes sure that the user can only execute your program ONCE every Windows session. In your FormShow event: procedure TForm1.FormShow(Sender : TObject); var atom : integer; CRLF : string; begin if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT') else begin CRLF := #10 + #13; ShowMessage('This version may only be run once for every Windows Session.' + CRLF + 'To run this program again, you need to restart Windows, or better yet:' + CRLF + 'REGISTER !!'); Close; end; end;

The advantages here are that you leave all the functionallity at the users disposal, but the moment he closes the program, its bootie-time, folks ! All you got to do is write some obscure text and save it in the Windows global atom table.

Auto Scaling routine... From: [email protected] (Randy) This routine has made life very very easy. This routine will insure that your application will look scaled at ANY resolution. Notice the 640 reference. This is because I develop apps in 640x480. You can adjust the routine to work from what YOU develop in so you dont have to worry about the odd and big screen resolutions that your users may have. Place, in the OnCreate event of the form you want auto-scaled: AdjustResolution(Self);

{ AdjustResolution ******************************************************* { This procedure scales all the children on a given form to conform to the { current screen resolution { ************************************************************************ procedure AdjustResolution(oForm:TForm); var iPercentage:integer; begin

} } } }

871

if Screen.Width > 640 then begin iPercentage:=Round(((Screen.Width-640)/640)*100)+100; oForm.ScaleBy(iPercentage,100); end; end;

Hint's Window From: Andreas Hoerstemeier The standard hintwindow doesn't allow this, but there's a way to exchange the standard one with a custom one. Below you find one which changes the font.color. unit hint; uses forms; interface type T_Hintwindow=class(THintwindow) constructor create(AOwner:TComponent); override; end; implementation constructor T_Hintwindow.Create(AOwner:TComponent); begin inherited create(AOWner); canvas.font.color:=clRed; end; initialization forms.hintwindowclass:=t_hintwindow; forms.application.showhint:=false; (* this forces application to recreate it's hintwindow *) forms.application.showhint:=true; end;


872

Miscellaneous Part 2 114. 115. 116. 117. 118. 119. 120. 121.

Moving from VB to Delphi sscanf in delphi? Supporting Cut Copy Paste Multiple icons in a Delphi exe? Credit card verification Searching text in a textfile Cool tip for hints on status bars Calling a Procedure with it's name in a variable

Moving from VB to Delphi The Graphical Gnome If you have finally taken the big stap and want to go from VB to Delphi 2 there are a few things different. Borland has a page describing the differences between Delphi and VB. It can be found at http://netserv.borland.com/delphi/papers/vb2dl/compon.html

sscanf in delphi? From: [email protected] (Barry) A kind soul sent me the following unit a while ago. I have found it quite useful, but there may be a problem with the %s tag since its use has generated errors on occasion. unit Scanf; interface uses SysUtils; type EFormatError = class(ExCeption); function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; implementation { Sscanf parses an input string. The parameters ... s - input string to parse fmt - 'C' scanf-like format string to control parsing %d - convert a Long Integer %f - convert an Extended Float %s - convert a string (delimited by spaces)

873

other char - increment s pointer past "other char" space - does nothing Pointers - array of pointers to have values assigned result - number of variables actually assigned for example with ... Sscanf('Name. Bill Time. 7:32.77 Age. 8', '. %s . %d:%f . %d', [@Name, @hrs, @min, @age]); You get ... Name = Bill

hrs = 7

min = 32.77

age = 8

}

function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; var i,j,n,m : integer; s1 : string; L : LongInt; X : Extended; function GetInt : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetFloat : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetString : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] <> ' ') and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function ScanStr(c : Char) : Boolean; begin while (s[n] <> c) and (Length(s) > n) do inc(n); inc(n); If (n <= Length(s)) then Result := True else Result := False; end;

874

function GetFmt : Integer; begin Result := -1; while (TRUE) do begin while (fmt[m] = ' ') and (Length(fmt) > m) do inc(m); if (m >= Length(fmt)) then break; if (fmt[m] = '%') then begin inc(m); case fmt[m] of 'd': Result := vtInteger; 'f': Result := vtExtended; 's': Result := vtString; end; inc(m); break; end; if (ScanStr(fmt[m]) = False) then break; inc(m); end; end; begin n := 1; m := 1; Result := 0; for i := 0 to High(Pointers) do begin j := GetFmt; case j of vtInteger : begin if GetInt > 0 then begin L := StrToInt(s1); Move(L, Pointers[i]^, SizeOf(LongInt)); inc(Result); end else break; end; vtExtended : begin if GetFloat > 0 then begin X := StrToFloat(s1); Move(X, Pointers[i]^, SizeOf(Extended)); inc(Result); end else break; end; vtString : begin if GetString > 0 then begin Move(s1, Pointers[i]^, Length(s1)+1); inc(Result); end else break; end; else break; end; end; end; end.

875

Supporting Cut Copy Paste From: "Shejchenko Andrij" I use following procedures. Call them when clicking correspondent menu items. This will work with all editable controls. But you should specially handle EDIT messages for trees. procedure TMainForm.EditUndo(Sender: TObject); var Mes:TWMUndo; begin Mes.Msg:=WM_UNDO; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCut(Sender: TObject); var Mes:TWMCut; begin Mes.Msg:=WM_CUT; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCopy(Sender: TObject); var Mes:TWMCopy; begin Mes.Msg:=WM_COPY; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditPaste(Sender: TObject); var Mes:TWMPaste; begin Mes.Msg:=WM_PASTE; Screen.ActiveControl.Dispatch(Mes); end;

Multiple icons in a Delphi exe? From: [email protected] (Jani Järvinen) Does anyone know how to get Delphi to place mutliple icons into one executable? ie so that when you set up a file type and browse your Delphi compiled application you get a number of icons, not just the single one you'd get by specifying an icon under Project|Options|Application|Icon

Just create a resource file (.res) for example with Image Editor, and store your icons there. Then link in the resource with the $R compiler directive, and your app has multiple icons.

Credit card verification From: [email protected] (Brian Near) unit Creditc; {***************************************************************************** Credit Card Number Validator Unit for Delphi

876

Version: 1.1 Date: December 20, 1996 This unit is based on the public domain program ccard by Peter Miller. It is released to the public for free of charge use, but the author reserves all rights. copyright 1996 by Shawn Wilson Harvell ( [email protected] ) usage: Add this unit to the uses clause of any unit that needs access to the validation function. IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean for example, use it in an if statement that Messages user if invalid. CardNumber is a string containing the number that you want to validate ReturnMessage is a string where the function can place any messages it may return ( meaning that it will overwrite whatever is in it ) returns true if valid, false otherwise. dashes and space in the input value are taken care of by the function, if other characters are possible, you may wish to remove them as well. The function RemoveChar will take care of this quite easily, simply pass the input string and the char you wish to delete. Users are free to modify this unit for their own use, but in distributing you should advise all users of the changes made. Use this unit at your own risk, it does not come with any warranties either express or implied. Damages resulting from the use of this unit are the sole responsibility of the user. This should work as is for Delphi versions 1 and 2, some slight modifications may be necessary for Turbo Pascal ( mainly due to use to conversion functions from the SysUtils unit ). If you do find this useful, have any comments or suggestions, please drop the author an email at [email protected] Revision History version 1.1 -- December 20, 1996 blooper with Discover cards, added their length mask to the "database" version 1.0 -- October 26, 1996 initial release *****************************************************************************} interface uses SysUtils; function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean; implementation const

877

CardPrefixes: array[ 1..19 ] of string = ( '2014', '2149', '300', '301', '302', '303', '304', '305', '34', '36', '37', '38', '4', '51', '52', '53', '54', '55', '6011' ); CardTypes: array[ 1..19 ] of String = ( 'enRoute', 'enRoute', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'American Express', 'Diner Club/Carte Blanche', 'American Express', 'Diner Club/Carte Blanche', 'Visa', 'MasterCard', 'MasterCard', 'MasterCard', 'MasterCard', 'MasterCard', 'Discover' ); function RemoveChar(const Input: String; DeletedChar: Char): String; var Index: Word; { counter variable } begin { all this function does is iterate through string looking for char, if found } { it deletes it } Result := Input; for Index := Length( Result ) downto 1 do if Result[ Index ] = DeletedChar then Delete( Result, Index, 1 ); end; function ShiftMask( Input: Integer ): Integer; begin { simply a wrapper for this left bit shift operation } result := ( 1 shl ( Input - 12 ) ); end; function ConfirmChecksum( CardNumber: String ): Boolean; var CheckSum: Integer; { Holds the value of the operation } Flag: Boolean; { used to indicate when ready } Counter: Integer; { index counter } PartNumber: String; { used to extract each digit of number } Number: Integer; { used to convert each digit to integer } begin {************************************************************************** This is probably the most confusing part of the code you will see, I know that it is some of the most confusing I have ever seen. Basically, this function is extracting each digit of the number and subjecting it to the

878

checksum formula established by the credit card companies. It works from the end to the front. **************************************************************************} { get the starting value for our counter } Counter := Length( CardNumber ); CheckSum := 0; PartNumber := ''; Number := 0; Flag := false; while ( Counter >= 1 ) do begin { get the current digit } PartNumber := Copy( CardNumber, Counter, 1 ); Number := StrToInt( PartNumber ); { convert to integer } if ( Flag ) then { only do every other digit } begin Number := Number * 2; if ( Number >= 10 ) then Number := Number - 9; end; CheckSum := CheckSum + Number; Flag := not( Flag ); Counter := Counter - 1; end; result := ( ( CheckSum mod 10 ) = 0 ); end; function GetMask( CardName: String begin { the default case } result := 0;

): Integer;

if ( CardName = 'MasterCard' ) then result := ShiftMask( 16 ); if ( CardName = 'Visa' ) then result := ( ShiftMask( 13 ) or ShiftMask( 16 ) );

if ( CardName = 'American Express' ) then result := ShiftMask( 15 ); if ( CardName = 'Diner Club/Carte Blanche' ) then result := ShiftMask( 14 ); if ( CardName = 'Discover' ) then result := ShiftMask( 16 );

end; function IsValidCreditCardNumber( Boolean; var StrippedNumber: String; chars } Index: Integer; } TheMask: Integer; } FoundIt: Boolean; } CardName: String; } PerformChecksum: Boolean; } begin

CardNumber: String; var MessageText: String ): { used to hold the number bereft of extra { general purpose counter for loops, etc { number we will use for the mask { used to indicate when something is found { stores the name of the type of card { the enRoute type of card doesn't get it

{ first, get rid of spaces, dashes } StrippedNumber := RemoveChar( CardNumber, ' ' ); StrippedNumber := RemoveChar( StrippedNumber, '-' );

879

{ if the string was zero length, then OK too } if ( StrippedNumber = '' ) then begin result := true; exit; end; { initialize return variables } MessageText := ''; result := true; { set our flag variable } FoundIt := false; { check for invalid characters right off the bat } for Index := 1 to Length( StrippedNumber ) do begin case StrippedNumber[ Index ] of '0'..'9': FoundIt := FoundIt; { non op in other words } else MessageText := 'Invalid Characters in Input'; result := false; exit; end; end; { now let's determine what type of card it is } for Index := 1 to 19 do begin if ( Pos( CardPrefixes[ Index ], StrippedNumber ) = 1 ) then begin { we've found the right one } FoundIt := true; CardName := CardTypes[ Index ]; TheMask := GetMask( CardName ); end; end; { if we didn't find it, indicates things are already ary } if ( not FoundIt ) then begin CardName := 'Unknown Card Type'; TheMask := 0; MessageText := 'Unknown Card Type '; result := false; exit; end; { check the length } if ( ( Length( StrippedNumber ) > 28 ) and result ) then begin MessageText := 'Number is too long '; result := false; exit; end; { check the length } if ( ( Length( StrippedNumber ) < 12 ) or ( ( shiftmask( length( strippednumber ) ) and themask ) = 0 ) ) then begin messagetext := 'number length incorrect'; result := false; exit; end;

880

{ check the checksum computation } if ( cardname = 'enroute' ) then performchecksum := false else performchecksum := true; if ( performchecksum and ( not confirmchecksum( strippednumber ) ) ) then begin messagetext := 'bad checksum'; result := false; exit; end; { if result is still true, then everything is ok } if ( result ) then messagetext := 'number ok: card type: ' + cardname; { if the string was zero length, then ok too } if ( strippednumber = '' ) then result := true; end; end.

Searching text in a textfile Anyone knows which is the best way (speed) to look for a string in a textFile. unit BMSearch; (* ------------------------------------------------------------------Boyer-Moore string searching. This is one of the fastest string search algorithms. See a description in: R. Boyer and S. Moore. A fast string searching algorithm. Communications of the ACM 20, 1977, Pags 762-772 ------------------------------------------------------------------- *) interface type {$ifdef WINDOWS} size_t = Word; {$else} size_t = LongInt; {$endif} type TTranslationTable = array[char] of char; TSearchBM = class(TObject) private FTranslate : TTranslationTable;

{ translation table }

{ translation table }

881

FJumpTable FShift_1 FPattern FPatternLen

);

: : : :

array[char] of Byte; integer; pchar; size_t;

{ Jumping table }

public procedure Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean procedure PrepareStr( const Pattern: string; IgnoreCase: Boolean ); function function end;

Search( Text: pchar; TextLen: size_t ): pchar; Pos( const S: string ): integer;

implementation uses

SysUtils;

(* ------------------------------------------------------------------Ignore Case Table Translation ------------------------------------------------------------------- *) procedure CreateTranslationTable( var T: TTranslationTable; IgnoreCase: Boolean ); var c: char; begin for c := #0 to #255 do T[c] := c; if not IgnoreCase then exit; for c := 'a' to 'z' do T[c] := UpCase(c); { Mapping all acented characters to their uppercase equivalent } T['Á'] T['À'] T['Ä'] T['Â']

:= := := :=

'A'; 'A'; 'A'; 'A';

T['á'] T['à'] T['ä'] T['â']

:= := := :=

'A'; 'A'; 'A'; 'A';

T['É'] T['È'] T['Ë'] T['Ê']

:= := := :=

'E'; 'E'; 'E'; 'E';

T['é'] T['è'] T['ë'] T['ê']

:= := := :=

'E'; 'E'; 'E'; 'E';

T['Í'] := 'I'; T['Ì'] := 'I';

882

T['Ï'] := 'I'; T['Î'] := 'I'; T['í'] T['ì'] T['ï'] T['î']

:= := := :=

'I'; 'I'; 'I'; 'I';

T['Ó'] T['Ò'] T['Ö'] T['Ô']

:= := := :=

'O'; 'O'; 'O'; 'O';

T['ó'] T['ò'] T['ö'] T['ô']

:= := := :=

'O'; 'O'; 'O'; 'O';

T['Ú'] T['Ù'] T['Ü'] T['Û']

:= := := :=

'U'; 'U'; 'U'; 'U';

T['ú'] T['ù'] T['ü'] T['û']

:= := := :=

'U'; 'U'; 'U'; 'U';

T['ñ'] := 'Ñ'; end;

(* ------------------------------------------------------------------Preparation of the jumping table ------------------------------------------------------------------- *) procedure TSearchBM.Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean ); var i: integer; c, lastc: char; begin FPattern := Pattern; FPatternLen := PatternLen; if FPatternLen < 1 then FPatternLen := strlen(FPattern); { This algorythm is based in a character set of 256 } if FPatternLen > 256 then exit; { 1. Preparing translating table } CreateTranslationTable( FTranslate, IgnoreCase); { 2. Preparing jumping table } for c := #0 to #255 do FJumpTable[c] := FPatternLen; for i := FPatternLen - 1 downto 0 do begin

883

c := FTranslate[FPattern[i]]; if FJumpTable[c] >= FPatternLen - 1 then FJumpTable[c] := FPatternLen - 1 - i; end; FShift_1 := FPatternLen - 1; lastc := FTranslate[Pattern[FPatternLen - 1]]; for i := FPatternLen - 2 downto 0 do if FTranslate[FPattern[i]] = lastc then begin FShift_1 := FPatternLen - 1 - i; break; end; if FShift_1 = 0 then FShift_1 := 1; end; procedure TSearchBM.PrepareStr( const Pattern: string; IgnoreCase: Boolean ); var str: pchar; begin if Pattern <> '' then begin {$ifdef Windows} str := @Pattern[1]; {$else} str := pchar(Pattern); {$endif} Prepare( str, Length(Pattern), IgnoreCase); end; end;

{ Searching Last char & scanning right to left } function TSearchBM.Search( Text: pchar; TextLen: size_t ): pchar; var shift, m1, j: integer; jumps: size_t; begin result := nil; if FPatternLen > 256 then exit; if TextLen < 1 then TextLen := strlen(Text); m1 := FPatternLen - 1; shift := 0; jumps := 0; { Searching the last character } while jumps <= TextLen do begin Inc( Text, shift); shift := FJumpTable[FTranslate[Text^]]; while shift <> 0 do begin Inc( jumps, shift); if jumps > TextLen then exit; Inc( Text, shift);

884

shift := FJumpTable[FTranslate[Text^]]; end; { Compare right to left FPatternLen - 1 characters } if jumps >= m1 then begin j := 0; while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do begin Inc(j); if j = FPatternLen then begin result := Text - m1; exit; end; end; end; shift := FShift_1; Inc( jumps, shift); end; end; function TSearchBM.Pos( const S: string ): integer; var str, p: pchar; begin result := 0; if S <> '' then begin {$ifdef Windows} str := @S[1]; {$else} str := pchar(S); {$endif} p := Search( str, Length(S)); if p <> nil then result := 1 + p - str; end; end; end.

Cool tip for hints on status bars [David Strange, [email protected]] I just figured out how to have the status bars on multiple forms display hints correctly with minimal coding. There have been a couple of solutions out there, but you had to code for each form (as far as I have seen anyway). Step 1: Place a TStatusBar on every form you want hints on. Set the SimplePanel property to True, and give them all the same name (I use SBStatus). See the comment I put in Step 4 regarding the name. Step 2: Assign all the hints as you want them. Don't forget the '|' if you want long hints. Step 3: In your startup form put this line in the FormCreate Application.OnHint := DisplayHint;

885

Step 4: Create this procedure. Please take note of the comments. procedure TFrmMain.DisplayHint(Sender: TObject); var Counter, NumComps: integer; begin with Screen.ActiveForm do begin NumComps := ControlCount - 1; for Counter := 0 to NumComps do {SBStatus is what I call all of my status bars. Change this as needed.} if (TControl(Controls[Counter]).Name = 'SBStatus') then begin if (Application.Hint = '') then {ConWorkingName is a constant that use. You can replace it with anything.} TStatusBar(Controls[Counter]).SimpleText := ConWorkingName else TStatusBar(Controls[Counter]).SimpleText := Application.Hint; break; end; end; end; {DisplayHint}

Don't forget to put 'Procedure DisplayHint(Sender: TObject) in the Public section. That's all you have to do. If you want any other forms to have hints, simply whack a TStatusBar on them and set the hints. I hope everyone likes this.

Calling a Procedure with it's name in a variable From: [email protected] (Raoul De Kezel) > > > >

Calling a Procedure with it's name in a variable How can I call a procedure whose name comes from a table, list, etc.? In other words, based on the environment I want to load a procedure name into a variable and call it. What would be the instruction?

unit ProcDict; interface type MyProc = procedure (s : String); procedure RegisterProc(procName : String; proc : MyProc); procedure ExecuteProc(procName : String; arg : String); implementation uses Classes; var ProcDict : TStringList; procedure RegisterProc(procName : String; proc : MyProc); begin ProcDict.AddObject(procName, TObject(@proc)); end; procedure ExecuteProc(procName : String; arg : String);

886

var index : Integer; begin index := ProcDict.IndexOf(ProcName); if index >= 0 then MyProc(ProcDict.objects[index])(arg); // Missing error reporting end; initialization ProcDict := TStringList.Create; ProcDict.Sorted := true; finalization ProcDict.Free; end.


887

Miscellaneous Part 3 122. 123. 124. 125. 126. 127. 128. 129. 130. 131. 132.

Avoiding using stale pointers Multi Language Applications Associated Executable MAPI and MS Exchange Constucting Object Variables Example of variable number of parameters My new TWrapGrid component: Allows word wrap in TStringGrid. Resizing panels? Background processing. Round splash screens Screensaver

Avoiding using stale pointers "David S. Becker" I've written a very simple unit, and devised some simple methods, to help prevent the usage of stale pointers. My biggest recommendation is to add an 'initialization' section to ALL UNITS WHICH CONTAIN POINTER OR OBJECT VARIABLES and set all the pointers (object variables are really pointers too) to nil. This will ensure that the pointers are all nilified before they are ever used. Then, simply reset pointers to nil after freeing them. My unit contains a Nilify() function for setting pointers to nil, as well as special versions of Free, Dispose, and FreeMem (called NilXXX) which test for nil before freeing memory, and resets the pointer to nil once it has been freed. I've also included a special version of Assigned(), called IsNil(), which takes a const parameter instead of a var parameter, which means you can use it on properties, etc. This unit, of course, does nothing to the VCL, so you can still get stale pointers back from the VCL... But strict adherence to the functions in this unit should help ensure YOU don't make a mistake. The only condition on its use/distribution is that you forward any changes or suggestions you might have to me. Use it and program in good health! unit Pointers; {

Author: David S. Becker ([email protected]) Date: 1/27/97 Copyright: None Distribution Rights: Free, unlimited use, provided you forward any and all changes or suggestions you have to me. This unit was created to aid in the managment of pointers and objects. Since the compiler does not initialize pointers or objects to nil, and does not set them to nil when freed, it is possible to accidentally reference stale pointers. For this reason, I recommend you add an 'initialization' section to all units and call Nilify() on all pointers/objects in that unit. This will ensure that all pointers/objects start off as nil. Furthermore, you should use the NilFree (for objects), NilDispose (for pointers created with New), and NilFreeMem (for pointers created with GetMem) instead of their standard counterparts. These procedures are safe to call on nil pointer/ objects, as they check for nil before performing any action. After freeing

888

}

the memory allocated to the pointer/object, they reset the pointer to nil. If you are strict in your use of these procedures, your risk of accessing stale pointer is greatly reduced. (Of course, you can still get stale pointers from the VCL as it obviously doesn't use these functions.)

{==============================================================================} interface {------------------------------------------------------------------------------} { Checks a pointer against nil } { NOTE: This function differs from Assigned() in that Assigned() requires a } { variable, whereas IsNil() does not. } function IsNil(const p: Pointer): Boolean; { Sets a pointer to nil } procedure Nilify(var p); { Frees a non-nil object, then sets it to nil } procedure NilFree(o: TObject); { Frees a non-nil pointer created by New, then sets it to nil } procedure NilDispose(var p: Pointer); { Frees a non-nil pointer, then sets it to nil } procedure NilFreeMem(var p: Pointer; size: Word); {==============================================================================} implementation {------------------------------------------------------------------------------} function IsNil(const p: Pointer): Boolean; begin Result := (p = nil); end; {------------------------------------------------------------------------------} procedure Nilify(var p); begin Pointer(p) := nil; end; {------------------------------------------------------------------------------} procedure NilFree(o: TObject); begin if not IsNil(o) then begin o.Free; Nilify(o); end; end; {------------------------------------------------------------------------------} procedure NilDispose(var p: Pointer); begin if not IsNil(p) then begin Dispose(p); Nilify(p); end; end; {------------------------------------------------------------------------------} procedure NilFreeMem(var p: Pointer; size: Word); begin if not IsNil(p) then begin FreeMem(p,size); Nilify(p); end; end; end.

889

Multi Language Applications Eddie Shipman For anyone needing to do multi-language apps and don't want to write a lot of code checking what language the program is running, see below. I compiled a stringtable resource into my exe and this is how I used it for multi-language dialogs. Instead of using the Runtime directives to check what language, I used a runtime variable to set the index for the messages into the stringtable and then load the messages from there depending upon the language. You could also create different stringtables for each language and then compiling them in by using the compile directives. Here is some example code, give it a try: unit French1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, IniFiles; type TForm1 = class(TForm) Button1: TButton; procedure FormActivate(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; StringIndex : Integer; implementation {$R *.DFM} {$R MULTLANG.RES} { Here is the way the resource file for this project looks: 1, "Attention" 2, "No Condition definition selected!" 3, "Always" 4, "Cannot delete the 'always' condition." 5, "Confirmation" 6, "Delete the condition?" 7, "Yes" 8, "No" 9, "Attention" 10, "Pas de condition Selectionnée" 11, "Toulours" 12, "Ne peux effacer la condition 'Toujours'" 13, "Confirmation" 14, "Effacer cette condition?" 15, "&Oui" 16, "&Non" }

890

procedure TForm1.FormActivate(Sender: TObject); var {inifile : TIniFile; Optional} ProgramLanguage : String; begin { Here, I just set it to French } ProgramLanguage := 'fra'; { You can optionally get the language from Win.INI:} {inifile := TInifile.Create('WIN.INI'); ProgramLanguage := inifile.ReadString('intl', 'sLanguage', 'enu'); inifile.Free;} { Forgive me if I leave out any languages, Tthese are th only ones in my setup.inf for my copy of Windows. dan nld enu eng fin fra frc deu isl ita nor ptg esp esn sve

= = = = = = = = = = = = = = =

Danish Dutch English (American) English (International) Finnish French French Canadian German Icelandic Italian Norwegian Portuguese Spanish Spanish (Modern) Swedish

} if ProgramLanguage = 'enu' then begin StringIndex := 0; end else if ProgramLanguage = 'fra' then begin StringIndex := 8; end; end; procedure TForm1.Button1Click(Sender: TObject); var i,j,k : integer; DialogForm : tform; begin Application.NormalizeTopMosts; {no Condition Selected!} DialogForm := CreateMessageDialog(LoadStr(StringIndex+2),mtWarning,[mbOK]); {Attention} DialogForm.caption := LoadStr(StringIndex + 1); DialogForm.showmodal; Application.RestoreTopMosts; {Cannot Delete the 'always' condition} DialogForm := CreateMessageDialog(LoadStr(StringIndex+4),mtWarning,[mbOK]); {Always} DialogForm.caption := LoadStr(StringIndex + 3); DialogForm.showmodal; Application.RestoreTopMosts; {Delete the condition?} DialogForm := CreateMessageDialog(LoadStr(StringIndex+6),mtInformation, [mbYes, mbNo]); {confirmation} DialogForm.caption := LoadStr(StringIndex + 5);

891

for j := 0 to DialogForm.controlCount-1 do begin if DialogForm.controls[j] is tButton then with tButton(DialogForm.controls[j]) do begin if caption = '&Yes' then caption := LoadStr(StringIndex+7); if caption = '&No' then caption := LoadStr(StringIndex+8); end; end; DialogForm.showmodal; end; end.

Associated Executable Michael Ax unit UcShell; { Author: Michael Ax http://www.axsystems.com/ Copyright (c) 1995..1997 Michael Ax. All Rights Reserved. This source code is part of TPack from HREF Tools Corp. Obtain purchasing and additional information by sending an email to [email protected] (any subject, any message)... or visit us on the web at http://www.href.com/software/ } interface uses Classes, SysUtils, Windows, ShellApi, Forms; {---------------------------------------------------------------} function WinExecutableName(const AssociatedFile:string):String; procedure WinShellOpen(const AssociatedFile:string); procedure WinShellPrint(const AssociatedFile:string); procedure WinShellExecute(const Operation,AssociatedFile:string); {---------------------------------------------------------------} implementation Const cStrBufSize= 80; {---------------------------------------------------------------} function WinExecutableName(const AssociatedFile:string):String; //HINSTANCE FindExecutable( // LPCTSTR lpFile, // pointer to string for filename // LPCTSTR lpDirectory, // pointer to string for default directory // LPTSTR lpResult // pointer to buffer for string for executable file on return // ); begin SetLength(result,cStrBufSize); //ucshell FindExecutable(pchar(AssociatedFile),'',pchar(result));

892

SetLength(result,strlen(pchar(result))); end; // procedure WinShellExecute(const Operation,AssociatedFile:string); var a1:string; begin a1:=Operation; if a1='' then a1:='open'; ShellExecute( application.handle //hWnd: HWND ,pchar(a1) //Operation: PChar ,pchar(AssociatedFile) //FileName: PChar ,'' //Parameters: PChar ,'' //Directory: PChar ,SW_SHOWNORMAL //ShowCmd: Integer ); // GetLastErrorString(0); //ucdialog end; procedure WinShellPrint(const AssociatedFile:string); begin WinShellExecute('print',AssociatedFile); end; procedure WinShellOpen(const AssociatedFile:string); begin WinShellExecute('open',AssociatedFile); end; {-----------------------------------------------------------------} end.

MAPI and MS Exchange Keith Anderson Use the following to login: MapiLogon(application.handle,nil,nil,mapi_use_default,0,@mapihandle)

Then use the following to send your message: MapiSendMail(mapihandle, 0,MapiMessage,0, 0);

Make sure the SUBJECT, RECIP and NOTTEXT fields are complete in the MapiMessage structure or the message won't be sent. Also make sure Exchange is running using the GetWindowHandle API function, and if it's not, use ShellExecute (or whatever) to launch it first.

Constucting Object Variables From: [email protected] (Coyote) 893

In the past few days there have been more than a few questions on this group indicating a lack of understanding about object instantiation. I'm guessing that these have been beginners, but in one case the questioner was taking a class on Delphi. I'd hope that an instructor would at least *try* to explain the subject. Anyway, for all of you having pointer errors, exceptions, and GPFs, take a quick look at this. When you declare a variable of some classtype such as... var MyVar: TMyClass;

....all you've asked the compiler to do is set up enough space to hold a pointer to an instance of your class on the heap. You haven't allocated memory for that class, just allocated memory for the pointer. I'd like to say that the compiler always presets this pointer to $FFFFFFFF, but that may not be accurate. Anyway, suffice it to say that it does *not* point to a valid memory location, and does *not* contain your class' information. Delphi handles all the messiness of memory allocation and disposal for you, but you do have to do a little bit of work. When you use one of Delphi's classes, or derive one of your own, you must instantiate the object. What that means is this: you must allocate the memory for it and set the pointer to that block of memory. In some languages that would be ugly; in Delphi it's as easy as... MyVar := TMyClass.Create;

It's that easy because the Create constructor method of the class TMyClass is a class method--it operates on the class, not on the individual object. When you call the constructor, Delphi allocates memory, and returns a pointer value. Take a look: doesn't it look like a function call? Well, if you weren't sure what it was returning, now you know. The call to TMyClass.Create returns a pointer to an object of type TMyClass. In the end, all you really need to remember is this... 1. Declare an object variable of some type. 2. Instantiate that object with a call to the class constructor method. 3. Use the object as normal. 4. Free the object. ==begin useless code block procedure Example; var MyObj: TMyClass; // a class that you've created MyList: TList; // a native class begin MyObj := TMyClass.Create; // now MyObj is instantiated--it means something MyList := TList.Create; // same for MyList .... do some stuff here .... MyList.Free; // MyList's resources are cleared from the heap MyObj.Free; // same for MyObj end;

894

Example of variable number of parameters From: [email protected] (Hallvard Vassbotn) program VarPar; { A simple program to demonstrate use of type-safe variable number of parameters in Delphi.

}

Written Mars 1995 by Hallvard Vassbotn [email protected]

uses WinCrt, SysUtils; { These are predefined in System: const vtInteger = 0; vtBoolean = 1; vtChar = 2; vtExtended = 3; vtString = 4; vtPointer = 5; vtPChar = 6; vtObject = 7; vtClass = 8; type TVarRec = record case Integer of vtInteger: (VInteger: Longint; VType: Byte); vtBoolean: (VBoolean: Boolean); vtChar: (VChar: Char); vtExtended: (VExtended: PExtended); vtString: (VString: PString); vtPointer: (VPointer: Pointer); vtPChar: (VPChar: PChar); vtObject: (VObject: TObject); vtClass: (VClass: TClass); end; } const TypeNames : array [vtInteger..vtClass] of PChar = ('Integer', 'Boolean', 'Char', 'Extended', 'String', 'Pointer', 'PChar', 'Object', 'Class'); { According to the on-line docs (search for TVarRec), array of const parameters are treated like array of TVarRec by the compiler. This example will work just as well if you change the declaration of TestMultiPar to: procedure TestMultiPar(const Args: array of TVarRec); This would make the implementation of the routine cleaner (no absolute variable declaration), but the interface would be less understandable to the user of the routine. The compiler looks at the parameters and builds the array directly on the stack. For each item in the array it also sets the VType field to one

895

of the pre-defined constants vtXXXX. The actual value is always sent as four bytes of information. For the Boolean and Char types, only the first byte contains useful information. So, go ahead, now you can write all those neat routines with variable number of parameters - and still keep the type safety! } function PtrToHex(P: pointer): string; begin Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4); end; procedure TestMultiPar(const Args: array of const); var ArgsTyped : array [0..$fff0 div sizeof(TVarRec)] of TVarRec absolute Args; i : integer; begin for i := Low(Args) to High(Args) do with ArgsTyped[i] do begin Write('Args[', i, '] : ', TypeNames[VType], ' = '); case VType of vtInteger: writeln(VInteger); vtBoolean: writeln(VBoolean); vtChar: writeln(VChar); vtExtended: writeln(VExtended^:0:4); vtString: writeln(VString^); vtPointer: writeln(PtrToHex(VPointer)); vtPChar: writeln(VPChar); vtObject: writeln(PtrToHex(Pointer(VObject))); vtClass: writeln(PtrToHex(Pointer(VClass))); end; end; end; var MyObj : TObject; begin Writeln('Test of type-safe variable number of parameters in Delphi:'); MyObj := TObject.Create; TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Hello, world!', true, 'X', @ShortDayNames, TObject, MyObj]); MyObj.Free; { To verify that the type-safety is used in the supplied formatting routines, try this: } writeln(Format('%d', ['hi'])); { The supplied parameter is not of the type expected. The '%d' format string signals that the parameter should be an integer value, but instead we send a string. At run-time this will generate a exception, and if you have enabled IDE-trapping of exceptions, Delphi will show you the offending line. Using c-type sprintf funtions like this will result in undefined behaviour (read: system crash, GP or whatever) } end.

896

My new TWrapGrid component: Allows word wrap in TStringGrid. From: [email protected] (Luis de la Rosa) I have finally created a custom component, TWrapGrid that allows you to use a TStringGrid, but also wrap the text in a cell. This is the beta version, so I encourage you to experiment with it, try it out, and send me comments on what you think of it. When you use it, remember to se the RowHeights (or DefaultRowHeight) large enough so that when it wraps, it shows up in the cell. To install, copy the following text and paste it into a Unit. Save it under the name 'Wrapgrid.PAS'. Then follow the directions I put in the header of the component. I'm also looking for feedback on this component, so please try it and tell me what you think. Here is the code! {

This is a custom component for Delphi. It is wraps text in a TStringGrid, thus the name TWrapGrid. It was created by Luis J. de la Rosa. E-mail: [email protected] Everyone is free to use it, distribute it, and enhance it. To use:

Go to the 'Options' - 'Install Components' menu selection in Delphi. Select 'Add'. Browse for this file, which will be named 'Wrapgrid.PAS'. Select 'OK'. You have now added this to the Samples part of your component palette. After that, you can use it just like a TStringGrid.

Please send any questions or comments to [email protected] Enjoy! A few additional programming notes: I have overridden the Create and DrawCell methods. Everything else should behave just like a TStringGrid. The Create sets the DefaultDrawing to False, so you don't need to. Also, I am using the pure block emulation style of programming, making my code easier to read. } unit Wrapgrid; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids; type TWrapGrid = class(TStringGrid) private { Private declarations } protected { Protected declarations } { This DrawCell procedure wraps text in the grid cell } procedure DrawCell(ACol, ARow : Longint; ARect : TRect; AState : TGridDrawState); override; public

897

{ Public declarations } { The Create procedure is overriden to use the DrawCell procedure by default } constructor Create(AOwner : TComponent); override; published { Published declarations } end; procedure Register; implementation constructor TWrapGrid.Create(AOwner : TComponent); begin { Create a TStringGrid } inherited Create(AOwner); { Make the drawing use our DrawCell procedure by default } DefaultDrawing := FALSE; end; { This DrawCell procedure wraps text in the grid cell } procedure TWrapGrid.DrawCell(ACol, ARow : Longint; ARect : TRect; AState : TGridDrawState); var Sentence, { What is left in the cell to output } CurWord : String; { The word we are currently outputting } SpacePos, { The position of the first space } CurX, { The x position of the 'cursor' } CurY : Integer; { The y position of the 'cursor' } EndOfSentence : Boolean; { Whether or not we are done outputting the cell } begin { Initialize the font to be the control's font } Canvas.Font := Font; with Canvas do begin { If this is a fixed cell, then use the fixed color } if gdFixed in AState then begin Pen.Color := FixedColor; Brush.Color := FixedColor; end { else, use the normal color } else begin Pen.Color := Color; Brush.Color := Color; end; { Prepaint cell in cell color } Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); end; { Start the drawing in the upper left corner of the cell } CurX := ARect.Left; CurY := ARect.Top; { Here we get the contents of the cell } Sentence := Cells[ACol, ARow]; { for each word in the cell } EndOfSentence := FALSE; while (not EndOfSentence) do begin { to get the next word, we search for a space } SpacePos := Pos(' ', Sentence); if SpacePos > 0 then begin { get the current word plus the space } CurWord := Copy(Sentence, 0, SpacePos);

898

{ get the rest of the sentence } Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos); end else begin { this is the last word in the sentence } EndOfSentence := TRUE; CurWord := Sentence; end; with Canvas do begin { if the text goes outside the boundary of the cell } if (TextWidth(CurWord) + CurX) > ARect.Right then begin { wrap to the next line } CurY := CurY + TextHeight(CurWord); CurX := ARect.Left; end; { write out the word } TextOut(CurX, CurY, CurWord); { increment the x position of the cursor } CurX := CurX + TextWidth(CurWord); end; end; end; procedure Register; begin { You can change Samples to whichever part of the Component Palette you want to install this component to } RegisterComponents('Samples', [TWrapGrid]); end; end.

Resizing panels? From: [email protected] (Dion Kurczek) Here's the source code for a resizable panel. Give the panel an align property of alClient, throw some controls on it, and watch them resize at run time when you resize the form. There is some code that prohibits resizing during design time, but this can be taken out. This may not be perfect, because I threw it together in a few minutes, but it's worked for me so far. unit Elastic; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TElasticPanel = class( TPanel ) private FHorz, FVert: boolean; nOldWidth, nOldHeight: integer; bResized: boolean; protected

899

procedure WMSize( var message: TWMSize ); message WM_SIZE; public nCount: integer; constructor Create( AOwner: TComponent ); override; published property ElasticHorizontal: boolean read FHorz write FHorz default TRUE; property ElasticVertical: boolean read FVert write FVert default TRUE; end; procedure Register; implementation constructor TElasticPanel.Create( AOwner: TComponent ); begin inherited Create( AOwner ); FHorz := TRUE; FVert := TRUE; nOldWidth := Width; nOldHeight := Height; bResized := FALSE; end; procedure TElasticPanel.WMSize( var message: TWMSize ); var bResize: boolean; xRatio: real; i: integer; ctl: TWinControl; begin Inc( nCount ); if Align = alNone then bResize := TRUE else bResize := bResized; if not ( csDesigning in ComponentState ) and bResize then begin if FHorz then begin xRatio := Width / nOldWidth; for i := 0 to ControlCount - 1 do begin ctl := TWinControl( Controls[i] ); ctl.Left := Round( ctl.Left * xRatio ); ctl.Width := Round( ctl.Width * xRatio ); end; end; if FVert then begin xRatio := Height / nOldHeight; for i := 0 to ControlCount - 1 do begin ctl := TWinControl( Controls[i] ); ctl.Top := Round( ctl.Top * xRatio ); ctl.Height := Round( ctl.Height * xRatio ); end; end; end else begin nOldWidth := Width; nOldHeight := Height; end; bResized := TRUE;

900

nOldWidth := Width; nOldHeight := Height; end; procedure Register; begin RegisterComponents('Additional', [TElasticPanel]); end; end.

Background processing. From: "David S. Becker" I'm writing a program in Delphi that is supposed to scan the size of a file in the background every hour. This is also supposed to happen when the application is inactive, it's should work as a watchdog in the background of win 95 and NT. How do you program this...??

Here is some source code that should do what you want. I just created it now, and it is completely untested, but very similar to something I've already done, so it should work. It does make one assumption that you should be aware of. It assumes that it is started at the same time as Windows is (perhaps in the startup group), so it uses GetTickCount, which returns msec since Windows was started), to perform a task once each hour that Windows is running. This may or may not be what you had in mind. Also, the value returned by GetTickCount is really a DWORD, but is stored in a LongInt in Delphi which means that some of the larger values will wind up being negative (after about 25 days). The effect this will have on my hour checking algorythm is undetermined (I haven't really considered it). Similarly, the value will recycle once every 49.7 days which could cause the check to occur twice in less than an hour once every 49.7 days. This may or may not be a problem for you. At any rate, this should get you started. Enjoy! program Project1; uses Messages, Windows; {$R *.RES} function KeepRunning: Boolean; var Msg: TMsg; begin Result := True; while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin if (Msg.Message = WM_QUIT) then Result := False; DispatchMessage(Msg); end; end; function OnTheHour: Boolean; begin { This actually checks for one second (or less) } { into the hour to allow for the possibility we } { may not get a timeslice exactly on the hour } Result := (GetTickCount mod (1{hr} * 60{min} * 60{sec} * 1000{msec}) < 1000); end;

901

const filetocheck = 'c:\somedir\somefile.ext'; magicsize = 1000000; var f: file; size: longint; begin { keep ourself alive, and wait to be shut down } while keeprunning do begin { see if we're on the hour } if onthehour then begin { open file with a record size of 1 byte } { and check its size } assignfile(f,filetocheck); reset(f,1); size := filesize(f); closefile(f); { now we check our file condition if (size >= MAGICSIZE) then begin { Do something special here } end;

}

{ Now wait until we're past our 'grace' } { period so we don't accidentally fire } { off multiple times in a row } while (KeepRunning and OnTheHour) do {nothing}; end; end; end.

Round splash screens A while ago I saw some emails about round/different splashscreens. I saved this somewhere and now I can't find it.

Also Neil Rubenking author of Delphi for Dummies and other good books posted this one one compuserve. It is donut shaped with a curved title bar and you can see and click on other programs through the hole! Create a new project and save the main unit so its name is RGNU.PAS. Paste in the following: unit rgnu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, Menus; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } rTitleBar : THandle; Center : TPoint; CapY : Integer;

902

Circum : Double; SB1 : TSpeedButton; RL, RR : Double; procedure TitleBar(Act : Boolean); procedure WMNCHITTEST(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE); message WM_NCACTIVATE; procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} CONST TitlColors : ARRAY[Boolean] OF TColor = (clInactiveCaption, clActiveCaption); TxtColors : ARRAY[Boolean] OF TColor = (clInactiveCaptionText, clCaptionText); procedure TForm1.FormCreate(Sender: TObject); VAR rTemp, rTemp2 : THandle; Vertices : ARRAY[0..2] OF TPoint; X, Y : INteger; begin Caption := 'OOOH! Doughnuts!'; BorderStyle := bsNone; {required} IF Width > Height THEN Width := Height ELSE Height := Width; {harder to calc if width <> height} Center := Point(Width DIV 2, Height DIV 2); CapY := GetSystemMetrics(SM_CYCAPTION)+8; rTemp := CreateEllipticRgn(0, 0, Width, Height); rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4), 3*(Width DIV 4), 3*(Height DIV 4)); CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF); SetWindowRgn(Handle, rTemp, True); DeleteObject(rTemp2); rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4); rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY); CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF); Vertices[0] := Point(0,0); Vertices[1] := Point(Width, 0); Vertices[2] := Point(Width DIV 2, Height DIV 2); rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE); CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND); DeleteObject(rTemp); RL := ArcTan(Width / Height); RR := -RL + (22 / Center.X); X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR)); Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR)); SB1 := TSpeedButton.Create(Self); WITH SB1 DO BEGIN Parent := Self; Left := X; Top := Y; Width := 14; Height := 14;

903

OnClick := Button1Click; Caption := 'X'; Font.Style := [fsBold]; END;

end;

procedure TForm1.Button1Click(Sender: TObject); begin Close; End; procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest); begin Inherited; WITH Msg DO WITH ScreenToClient(Point(XPos,YPos)) DO IF PtInRegion(rTitleBar, X, Y) AND (NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN Result := htCaption; end; procedure TForm1.WMNCActivate(var Msg: TWMncActivate); begin Inherited; TitleBar(Msg.Active); end; procedure TForm1.WMSetText(var Msg: TWMSetText); begin Inherited; TitleBar(Active); end; procedure TForm1.TitleBar(Act: Boolean); VAR TF : TLogFont; R : Double; N, X, Y : Integer; begin IF Center.X = 0 THEN Exit; WITH Canvas DO begin Brush.Style := bsSolid; Brush.Color := TitlColors[Act]; PaintRgn(Handle, rTitleBar); R := RL; Brush.Color := TitlColors[Act]; Font.Name := 'Arial'; Font.Size := 12; Font.Color := TxtColors[Act]; Font.Style := [fsBold]; GetObject(Font.Handle, SizeOf(TLogFont), @TF); FOR N := 1 TO Length(Caption) DO BEGIN X := Center.X-Round((Center.X-6)*Sin(R)); Y := Center.Y-Round((Center.Y-6)*Cos(R)); TF.lfEscapement := Round(R * 1800 / pi); Font.Handle := CreateFontIndirect(TF); TextOut(X, Y, Caption[N]); R := R - (((TextWidth(Caption[N]))+2) / Center.X); IF R < RR THEN Break; END; Font.Name := 'MS Sans Serif'; Font.Size := 8; Font.Color := clWindowText; Font.Style := [];

904

end; end; procedure TForm1.FormPaint(Sender: TObject); begin WITH Canvas DO BEGIN Pen.Color := clBlack; Brush.Style := bsClear; Pen.Width := 1; Pen.Color := clWhite; Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height); Arc((Width DIV 4)-1, (Height DIV 4)-1, 3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0); Pen.Color := clBlack; Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0); Arc((Width DIV 4)-1, (Height DIV 4)-1, 3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height); TitleBar(Active); END; end; end.

Screensaver From: [email protected] (Shuji Maeda) For ScreenSaver documentation, see Lucian Wischik's Page at... http://classic.physiol.cam.ac.uk/scr/SCRB_TEC.HTM or http://classic.physiol.cam.ac.uk/scr/SCRB_GEN.HTM For sample sources, download Meik Weber's Saver from... http://sunsite.icm.edu.pl/delphi/authors/a782.htm Hope this helps. Shuji [email protected] Please email me and tell me if you liked this page. Last modified 03/12/00 12:11:46

905

Api 133. 134. 135. 136. 137. 138. 139.

How Can I Prevent Multiple Instances of My Application? Performing an action when Windows shuts down a Delphi app Getting DOS Variables GetModuleFileName Setting time system with Delphi How do I execute a program and have my code wait until it is finished? ExtractAssIcon and paint into Timage?

140. 141.

ExitWindows Power saver modeapi8

How Can I Prevent Multiple Instances of My Application? Solution 1 From: "David S. Lee" This is the way I do it: In the begin..end block of the .dpr: begin if HPrevInst <>0 then begin ActivatePreviousInstance; Halt; end; end;

Here is the unit I use: unit PrevInst; interface uses WinProcs, WinTypes, SysUtils; type PHWnd = ^HWnd; function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;

906

procedure ActivatePreviousInstance; implementation function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; var ClassName : array[0..30] of char; begin Result := true; if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then begin GetClassName(Wnd, ClassName, 30); if STRIComp(ClassName,'TApplication')=0 then begin TargetWindow^ := Wnd; Result := false; end; end; end; procedure ActivatePreviousInstance; var PrevInstWnd: HWnd; begin PrevInstWnd := 0; EnumWindows(@EnumApps,LongInt(@PrevInstWnd)); if PrevInstWnd <> 0 then if IsIconic(PrevInstWnd) then ShowWindow(PrevInstWnd,SW_Restore) else BringWindowToTop(PrevInstWnd); end; end.

Solution 2 From: "The Graphical Gnome" Taken from Delphi 2 Developers Guide by Pacheco and Teixeira with heavy modifications. Usage: In the Project source change to the following if InitInstance then begin Application.Initialize; Application.CreateForm(TFrmSelProject, FrmSelProject); Application.Run; end; unit multinst; { Taken from Delphi 2 Developers Guide by Pacheco and Teixeira With heavy Modifications. Usage: In the Project source change to the following if InitInstance then begin Application.Initialize; Application.CreateForm(TFrmSelProject, FrmSelProject); Application.Run; end; That's all folks ( I hope ;() }

907

interface uses Forms, Windows, Dialogs, SysUtils; const MI_NO_ERROR = 0; MI_FAIL_SUBCLASS = 1; MI_FAIL_CREATE_MUTEX = 2; { Query this function to determine if error occurred in startup. } { Value will be one or more of the MI_* error flags. } function GetMIError: Integer; Function InitInstance : Boolean; implementation const UniqueAppStr : PChar;

{Change for every Application}

var MessageId: Integer; WProc: TFNWndProc = Nil; MutHandle: THandle = 0; MIError: Integer = 0; function GetMIError: Integer; begin Result := MIError; end; function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall; begin { If this is the registered message... } if Msg = MessageID then begin { if main form is minimized, normalize it } { set focus to application } if IsIconic(Application.Handle) then begin Application.MainForm.WindowState := wsNormal; ShowWindow(Application.Mainform.Handle, sw_restore); end; SetForegroundWindow(Application.MainForm.Handle); end { Otherwise, pass message on to old window proc } else Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam); end; procedure SubClassApplication; begin { We subclass Application window procedure so that } { Application.OnMessage remains available for user. } WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc))); { Set appropriate error flag if error condition occurred } if WProc = Nil then MIError := MIError or MI_FAIL_SUBCLASS; end; procedure DoFirstInstance; begin SubClassApplication;

908

MutHandle := CreateMutex(Nil, False, UniqueAppStr); if MutHandle = 0 then MIError := MIError or MI_FAIL_CREATE_MUTEX; end; procedure BroadcastFocusMessage; { This is called when there is already an instance running. } var BSMRecipients: DWORD; begin { Don't flash main form } Application.ShowMainForm := False; { Post message and inform other instance to focus itself } BSMRecipients := BSM_APPLICATIONS; BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0); end; Function InitInstance : Boolean; begin MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr); if MutHandle = 0 then begin { Mutex object has not yet been created, meaning that no previous } { instance has been created. } ShowWindow(Application.Handle, SW_ShowNormal); Application.ShowMainForm:=True; DoFirstInstance; result := True; end else begin BroadcastFocusMessage; result := False; end; end; initialization begin UniqueAppStr := Application.Exexname; MessageID := RegisterWindowMessage(UniqueAppStr); ShowWindow(Application.Handle, SW_Hide); Application.ShowMainForm:=FALSE; end; finalization begin if WProc <> Nil then { Restore old window procedure } SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc)); end; end.

Solution 3 From: "Jerzy A.Radzimowski" VAR MutexHandle:THandle; Var UniqueKey : string; FUNCTION IsNextInstance:BOOLEAN; BEGIN Result:=FALSE;

909

MutexHandle:=0; MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey); IF MutexHandle<>0 THEN BEGIN IF GetLastError=ERROR_ALREADY_EXISTS THEN BEGIN Result:=TRUE; CLOSEHANDLE(MutexHandle); MutexHandle:=0; END; END; END; begin CmdShow:=SW_HIDE; MessageId:=RegisterWindowMessage(zAppName); Application.Initialize; IF IsNextInstance THEN PostMessage(HWND_BROADCAST, MessageId,0,0) ELSE BEGIN Application.ShowMainForm:=FALSE; Application.CreateForm(TMainForm, MainForm); MainForm.StartTimer.Enabled:=TRUE; Application.Run; END; IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle); end.

in MainForm you need add code for process private message PROCEDURE TMainForm.OnAppMessage( VAR M:TMSG; VAR Ret:BOOLEAN ); BEGIN IF M.Message=MessageId THEN BEGIN Ret:=TRUE; // BringWindowToTop !!!!!!!! END; END; INITIALIZATION ShowWindow(Application.Handle, SW_Hide); END.

Performing an action when Windows shuts down a Delphi app From: [email protected] (Wes Jones) I did a little investigation, and here is what seems to be happening: Normally, when you exit a Delphi application by using the system menu or by calling the Form's Close method, the following event handlers are called: 12. FormCloseQuery - the default action sets the variable CanClose=TRUE so form close will continue. 13. FormClose 14. FormDestroy If the application is active and you attempt to exit Windows, the event handlers are called in the following sequence: 5. FormCloseQuery 910

6. FormDestroy The FormClose method never seems to be called. Here is the flow of events when the user chooses to end the Windows session: 1. Windows sends out a WM_QUERYENDSESSION message to all application windows one by one and awaits a response 2. Each application window receives the message and returns a non-zero value if it is OK to terminate, or 0 if it is not OK to terminate. 3. If any application returns 0, the Windows session is not ended, otherwise, Windows sends a WM_ENDSESSION message to all application windows 4. Each Application Window responds with a TRUE value indicating that Windows can terminate any time after all applications have returned from processing this message. This appears to be the location of the Delphi problem: Delphi applications seem to return TRUE and the FormDestroy method is called immediately, bypassing the FormClose method. 5. Windows exits One solution is to respond to the WM_QUERYENDSESSION message in the Delphi application and prevent Windows from exiting by returning a 0 result. This can't be done in the FormCloseQuery method because there is no way to determine the source of the request (it can either be the result of the WM_QUERYENDSESSION message or the user just simply closing the application). Another solution is to respond to the WM_QUERYENDSESSION message by calling the same cleanup procedure you call in the FormClose method. Example: unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormClose(Sender: TObject; var Action: TCloseAction); private {---------------------------------------------------------------} { Custom procedure to respond to the WM_QUERYENDSESSION message } {---------------------------------------------------------------} procedure WMQueryEndSession( var Message: TWMQueryEndSession); message WM_QUERYENDSESSION; public { Public declarations } end; var Form1 : TForm1; implementation {$R *.DFM} {---------------------------------------------------------------} { Custom procedure to respond to the WM_QUERYENDSESSION message } { The application will only receive this message in the event } { that Windows is requesing to exit. } {---------------------------------------------------------------} procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession); begin inherited; { let the inherited message handler respond first } {--------------------------------------------------------------------} { at this point, you can either prevent windows from closing... } { Message.Result:=0; } {---------------------------or---------------------------------------} { just call the same cleanup procedure that you call in FormClose... }

911

{ MyCleanUpProcedure; } {--------------------------------------------------------------------} end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin MyCleanUpProcedure; end; end.

I have not tested this code, but I think it will work correctly. Let me know how it turns out!

Getting DOS Variables From: "Bob Findley" I assume you mean environment variables? The GetEnvironmentStrings function returns the address of the environment block for the current process. Each environment variable is null terminated. The set of strings is double null terminated. The GetEnvironmentVariable function retrieves the value of the specified variable from the environment block of the calling process. The value is in the form of a null-terminated string of characters.

GetModuleFileName Here is an answer for you. I have used this on many occasions and it works well. procedure TForm1.Button1Click(Sender: TObject); var szFileName : array[0..49] of char; szModuleName : array[0..19] of char; iSize : integer; begin StrPCopy(szModuleName, 'NameOfModule'); iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName, SizeOf(szFileName)); if iSize > 0 then ShowMessage('Full path name is : ' + StrPas(szFileName)) else ShowMessage('Path of module not found'); end;

Setting time system with Delphi [email protected] (Abel du Plessis) "Vitor Martins"
with Delphi 2.0

This works for us: //****************************************************************************** //Public function SetPCSystemTime changes the system date and time. //Parameter(s): tDati The new date and time //Returns: True if successful // False if not //****************************************************************************** function SetPCSystemTime(tDati: TDateTime): Boolean;

912

var tSetDati: TDateTime; vDatiBias: Variant; tTZI: TTimeZoneInformation; tST: TSystemTime; begin GetTimeZoneInformation(tTZI); vDatiBias := tTZI.Bias / 1440; tSetDati := tDati + vDatiBias; with tST do begin wYear := StrToInt(FormatDateTime('yyyy', tSetDati)); wMonth := StrToInt(FormatDateTime('mm', tSetDati)); wDay := StrToInt(FormatDateTime('dd', tSetDati)); wHour := StrToInt(FormatDateTime('hh', tSetDati)); wMinute := StrToInt(FormatDateTime('nn', tSetDati)); wSecond := StrToInt(FormatDateTime('ss', tSetDati)); wMilliseconds := 0; end; SetPCSystemTime := SetSystemTime(tST); end;

How do I execute a program and have my code wait until it is finished? From: Noel Rice A: Here is the 16 bit version: uses Wintypes,WinProcs,Toolhelp,Classes,Forms; Function WinExecAndWait(Path : string; Visibility : word) : word; var InstanceID : THandle; PathLen : integer; begin { inplace conversion of a String to a PChar } PathLen := Length(Path); Move(Path[1],Path[0],PathLen); Path[PathLen] := #00; { Try to run the application } InstanceID := WinExec(@Path,Visibility); if InstanceID < 32 then { a value less than 32 indicates an Exec error } WinExecAndWait := InstanceID else begin Repeat Application.ProcessMessages; until Application.Terminated or (GetModuleUsage(InstanceID) = 0); WinExecAndWait := 32; end; end;

Here is the 32 bit version: function WinExecAndWait32(FileName:String; Visibility : integer):integer; var zAppName:array[0..512] of char; zCurDir:array[0..255] of char;

913

WorkDir:String; StartupInfo:TStartupInfo; ProcessInfo:TProcessInformation; begin StrPCopy(zAppName,FileName); GetDir(0,WorkDir); StrPCopy(zCurDir,WorkDir); FillChar(StartupInfo,Sizeof(StartupInfo),#0); StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := Visibility; if not CreateProcess(nil, zAppName, { pointer to command line string } nil, { pointer to process security attributes } nil, { pointer to thread security attributes } false, { handle inheritance flag } CREATE_NEW_CONSOLE or { creation flags } NORMAL_PRIORITY_CLASS, nil, { pointer to new environment block } nil, { pointer to current directory name } StartupInfo, { pointer to STARTUPINFO } ProcessInfo) then Result := -1 { pointer to PROCESS_INF } else begin WaitforSingleObject(ProcessInfo.hProcess,INFINITE); GetExitCodeProcess(ProcessInfo.hProcess,Result); end; end;

{Thanks to Pat Ritchey for these functions.} { This code came from Lloyd's help file! Ldelphi.zip }

ExtractAssIcon and paint into Timage? From: "Joe C. Hecht (Borland)" > How can I extract the associated icon (ExtractAssociatedIcon) and draw it into > a Timage or a small area of the form? uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); var IconIndex : word; h : hIcon; begin IconIndex := 0; h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex); DrawIcon(Form1.Canvas.Handle, 10, 10, h);

-----------------------------------------------------------------------------

914

ExitWindows Does anyone know how to access the function ExitWindows in User.exe. I would like to use this function to restart windows without restarting the computer.

[Mike O'Hanlon, [email protected]] Here are examples of how to restart Windows and also how to reboot the system: procedure TMainForm.RestartWindowsBtnClick(Sender: TObject); begin if not ExitWindows(EW_RestartWindows, 0) then ShowMessage('An application refused to terminate'); end;

procedure TMainForm.RebootSystemBtnClick(Sender: TObject); begin if not ExitWindows(EW_RebootSystem, 0) then ShowMessage('An application refused to terminate'); end;

The ExitWindows function has always been wrongly documented - Microsoft got it wrong in their documents and every one else followed along with the incorrect info. I believe the correct definition is: function ExitWindows (dwReturnCode: Longint; Reserved: Word): Bool;

Power saver mode From: [email protected] (AlanGLLoyd) Turn monitor off : SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Turn monitor on : SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);


915

Components 142. 143. 144. 145. 146. 147. 148. 149. 150. 151. 152. 153. 154. 155. 156. 157.

Array of components... Array of Edit boxes? how do i getting the component index at runtime How do I create a component at run-time? Create an event during Runtime? Setting read-only columns in StringGrid BMPs in a StringGrid TBitBtn control class question (change bitmap at runtime) OwnerDraw in TStatusBar Duplicating components and their children at runtime Splitter Bar How to Add Controls to TTabbedNotebook & TNotebook Saving and Loading aTstringgrid How do I synchronize two scroll boxes on different panels? Delayed scrolling / delayed OnChange? Unselectable Tab

Array of components... From: Lode Deleu <[email protected]> > Is it possible to create an array of components? I'm using a LED component for a status display, and I'd like to be able to access it via:

First of all, you'l need to declare the array: LED : array[1..10] of TLed;

(TLed being your led component type)

if you would create the LED components dynamically, you could do this during a loop like this : for counter := 1 to 10 do begin LED[counter]:= TLED.Create; LED[counter].top := ... LED[counter].Left := ... LED[counter].Parent := Mainform; end;

{or something alike}

If the components already exist on your form (visually designed), you could simply assign them to the array like this: leds := 0; for counter := 0 to Form.Componentcount do begin if (components[counter] is TLED) then begin inc(leds); LED[leds] := TLED(components[counter]); end end;

This however leaves you with a random array of LED's, I suggest you give each LED a tag in the order they should be in the array, and then fill the array using the tag : for counter := 0 to Form.Componentcount do

916

begin if (components[counter] is TLED) then begin LED[Component[counter].tag] := TLED(components[counter]); end end;

if you need a two dimensional array, you'll need to find another trick to store the index, I've used the hint property a number of times to store additional information.

Array of Edit boxes? From: "Volker Schneider"
{Notes: To find out what additional properties to set, have a look into ObjectInspector and/or view the Form in TextMode (RightClick Form, choose TextMode)

how do i getting the component index at runtime From: [email protected] (Brad Aisa) In article <[email protected]>, [email protected] (Claudio Tereso) wrote: >i need to find the component index in the parent's order. >i tried to modify prjexp.dll but with success? >does any one have an idea?

Here is a function that does this. It gets the parent control, and then iterates through its children, looking for a match. This has been tested and works. { function to return index order of a component in its parent's component collection; returns -1 if not found or no parent } function IndexInParent(vControl: TControl): integer; var ParentControl: TWinControl; begin {we "cousin" cast to get at the protected Parent property in base class } ParentControl := TForm(vControl.Parent); if (ParentControl <> nil) then begin for Result := 0 to ParentControl.ControlCount - 1 do begin if (ParentControl.Controls[Result] = vControl) then Exit; end;

917

end; { if we make it here, then wasn't found, or didn't have parent} Result := -1; end;

How do I create a component at run-time? From: [email protected] (Mark Vaughan) Var MyButton

:

TButton;

MyButton := TButton.Create(MyForm); // MyForm now "owns" MyButton with MyButton do BEGIN Parent := MyForm; // here MyForm is also the parent of MyButton height := 32; width := 128; caption := 'Here I Am!'; left := (MyForm.ClientWidth - width) div 2; top := (MyForm.ClientHeight - height) div 2; END;

Borland also publishes one of their TechInfo sheets on this subject. Look for ti2938.asc Creating Dynamic Components at Runtime which you can get from Borland's web site or ftp site.

Create an event during Runtime? From: "Hustin Olivier" Definition of memo's properties memo.onchange:=memo1Change; procedure TForm1.Memo1Change(Sender: TObject); begin panel1.caption:='Content has been changed'; end;

Setting read-only columns in StringGrid From: Mark Pritchard In the OnSelectCell event, this works fine (every even column is editable) if Col mod 2 = 0 then grd.Options := grd.Options + [goEditing] else grd.Options := grd.Options - [goEditing];

BMPs in a StringGrid From: "James D. Rofkar" Darren Clements wrote: > How can I put a Bitmap in a StringGrid cell?

In your StringGrid's OnDrawCell event handler, place some code that resembles:

918

with StringGrid1.Canvas do begin {...} Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic); {...} end;

Using the Draw() or StretchDraw() method of TCanvas should do the trick. BTW, Image1 above is a TImage with a bitmap already loaded into it.

TBitBtn control class question (change bitmap at runtime) "David Zajac" Keep in mind that when a property is an object, it has memory associated with it.When you are changing the value of a bitmap property, somehow the memory associated with the old value has to be freed, and new memory allocated. By convention in Delphi, that's what an "Assign" method does. The code below works. implementation {$R *.DFM} var n: integer;

// It'll be zero when the program starts

procedure TForm1.Button1Click(Sender: TObject); var Image: TBitmap; begin // Changes the bitmap in BitBtn1 Image:= TBitmap.Create; if n < ImageList1.Count then ImageList1.GetBitmap(n, Image); {end if} BitBtn1.Glyph.Assign(Image) property

// NOTE: Assign is used to change an object

inc(n,2); // Button Bitmaps hold two images! if n > ImageList1.Count then n:= 0; {end if} Image.Free; end; procedure TForm1.Button2Click(Sender: TObject); begin // adds a new button bitmap to ImageList1 if OpenDialog1.Execute then ImageList1.FileLoad(rtBitMap,OpenDialog1.FileName,clBtnFace); label1.Caption:= 'ImageCount = ' + IntToStr(ImageList1.Count); end;

OwnerDraw in TStatusBar From: Chris Jobson 919

Just write an OnDrawPanel handler for the StatusBar something like procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin with statusbar1.Canvas do begin Brush.Color := clRed; FillRect(Rect); TextOut(Rect.Left, Rect.Top, 'Panel '+IntToStr(Panel.Index)); end; end;

Duplicating components and their children at runtime Gary McGhee The following code provides a function called DuplicateComponents that duplicates any given component and its child components at run time. It tries to emulate copying and pasting a component at design time. The new component is created with the same parentage and owner as the original and all new component names are similar (but different) to their original. This is provided as is and may have bugs that I haven't found yet. It is provided because it contains techniques that are not commonly known and may be of use to people struggling with similar problems. This procedure is very useful when you want to design a section of an interface once that will appear n times at run time. You just design it once visually all on a TPanel or other component as a parent, and then do "newpanel := DuplicateComponents(designedpanel)". uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug; type

TUniqueReader = Class(TReader) LastRead: TComponent; procedure ComponentRead(Component: TComponent); procedure SetNameUnique( Reader: TReader; Component: TComponent; var Name: string ); end;

implementation procedure TUniqueReader.ComponentRead( Component: TComponent ); begin LastRead := Component; end; procedure TUniqueReader.SetNameUnique( // sets the name of the read component to something like "Panel2" if "Panel1" already exists Reader: TReader; Component: TComponent; // component being read

920

var Name: string

// Name to use and modify

); var i: Integer; tempname: string; begin

end;

i := 0; tempname := Name; while Component.Owner.FindComponent(Name) <> nil do begin Inc(i); Name := Format('%s%d', [tempname, i]); end;

function DuplicateComponents( AComponent: TComponent // original component ): TComponent; // returns created new component procedure RegisterComponentClasses( AComponent: TComponent ); var i : integer; begin RegisterClass(TPersistentClass(AComponent.ClassType)); if AComponent is TWinControl then if TWinControl(AComponent).ControlCount > 0 then for i := 0 to (TWinControl(AComponent).ControlCount-1) do RegisterComponentClasses(TWinControl(AComponent).Controls[i]); end; var

begin

Stream: TMemoryStream; UniqueReader: TUniqueReader; Writer: TWriter; result := nil; UniqueReader := nil; Writer := nil; try Stream := TMemoryStream.Create; RegisterComponentClasses(AComponent); try

finally end;

Writer := TWriter.Create(Stream, 4096); Writer.Root := AComponent.Owner; Writer.WriteSignature; Writer.WriteComponent(AComponent); Writer.WriteListEnd; Writer.Free;

Stream.Position := 0; try UniqueReader := TUniqueReader.Create(Stream, 4096); // create reader

// should probably move these routines into

theconstructor UniqueReader.OnSetName := UniqueReader.SetNameUnique; UniqueReader.LastRead := nil; if AComponent is TWinControl then

921

UniqueReader.ReadComponents( // read in components and sub-components TWinControl(AComponent).Owner, TWinControl(AComponent).Parent, UniqueReader.ComponentRead else

)

UniqueReader.ReadComponents( // read in components AComponent.Owner, nil, UniqueReader.ComponentRead ); result := UniqueReader.LastRead; finally UniqueReader.Free; finally

end; Stream.Free;

end;

end;

Splitter Bar From: [email protected] (Adam Redgewell) Bart Mertens wrote: Hi, I've got a form with a treeview and a memo component on it. They are both aligned to take up the entire client area. I'd like to put a splitter bar between them so I can make one wider and the other smaller or vice versa. Which control can do this or how can I do this?

Assuming your treeview is meant to be on the left and the memo on the right, you need to do the following: · Set the Align property for the TreeView to alLeft. · Cut (Ctrl-X) the memo component from your form. · Add a Panel component and set its Align property to alClient. · Click inside the panel and add another Panel component. · Set its width to about 8, and its Align property to alLeft. · Paste your memo component back into Panel1 and set its Align property to alClient. Panel2 is the divider strip: you now need to add the procedures shown below. Your code will look something like the following: type TForm1 = class(TForm) TreeView1: TTreeview; Panel1: TPanel; Panel2: TPanel; Memo1: TMemo; procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Panel1MouseMove(Sender: TObject; Shift:TShiftState; X, Y: Integer); private

922

Resizing: Boolean; public ... end; procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Resizing:=true; end; procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Resizing:=false; end; procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Resizing then begin TreeView1.Width:=TreeView1.Width+X; // Prevent occasional strange repaint errors on resize: Panel1.Invalidate; end; end;

This code can be adapted to split the screen horizontally - you get the idea...

How to Add Controls to TTabbedNotebook & TNotebook From: [email protected] (Mark R. Johnson) I have seen the question "how do you add controls to TTabbedNotebook or TNotebook at run-time?" several times here and elsewhere. Well, after finally getting a few spare minutes to check into it, I have stumbled across the solution: TTabbedNotebook Adding controls to a TTabbedNotebook during design time is a pretty simple task. All you need to do is set the PageIndex or ActivePage property to the page you want to add controls to, and begin dropping the controls onto the TTabbedNotebook. Adding controls to a TTabbedNotebook during run-time is also very simple. However, there is no mention what-so-ever in the Delphi documentation on how to do this. To make matters worse, the TTabbedNotebook source code is not included when you purchase the Delphi VCL source. Thus, we are left with a mystery. Fortunately, I have stumbled across the solution. The first step to solving this mystery was to take a look at \DELPHI\DOC\TABNOTBK.INT, the interface section of the TABNOTBK.PAS unit where TTabbedNotebook is defined. A quick examination will reveal the TTabPage class, which is described as holding the controls for a given page of the TTabbedNotebook. The second clue to solving this case comes from observation that the Pages property of TTabbedNotebook has a type of TStrings. It just so happens that Delphi's TStrings and TStringList classes provide both Strings and Objects property pairs. In other words, for every string in TStrings, there is a corresponding Objects pointer. In many cases, this extra pointer is ignored, but if you're like me, you're thinking "Ah-hah!"

923

After a quick little test in code, sure enough, the Objects property points to a TTabPage instance -- the one that corresponds to the page name in the Strings property. Bingo! Just what we were looking for. Now see what we can do: { This procedure adds places a button at a random location on the } { current page of the given TTabbedNotebook. } procedure AddButton(tabNotebook : TTabbedNotebook); var tabpage : TTabPage; button : TButton; begin with tabNotebook do tabpage := TTabPage(Pages.Objects[PageIndex]); button := TButton.Create(tabpage); try with button do begin Parent := tabpage; Left := Random(tabpage.ClientWidth - Width); Top := Random(tabpage.ClientHeight - Height); end; except button.Free; end; end;

TNotebook The process of adding controls to a TNotebook is almost exactly the same as that for TTabbedNotebook -- only the page class type is TPage instead of TTabPage. However, if you look in DELPHI\DOC\EXTCTRLS.INT for the type declaration for TPage, you won't find it. For some reason, Borland did not include the TPage definition in the DOC files that shipped with Delphi. The TPage declaration *IS* in the EXTCTRLS.PAS unit that you get when you order the VCL source, right where it should be in the interface section of the unit. Here's the TPage information they left out: TPage = class(TCustomControl) private procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected procedure ReadState(Reader: TReader); override; procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Caption; property Height stored False; property TabOrder stored False; property Visible stored False; property Width stored False; end;

Now, to make the above procedure work for adding a button to a TNotebook, all we have to do is replace "TTabbedNotebook" with "TNotebook" and "TTabPage" with "TPage", as follows: { This procedure adds places a button at a random location on the } { current page of the given TNotebook. } procedure AddButton(Notebook1 : TNotebook); var page : TPage; button : TButton;

924

begin with Notebook1 do page := TPage(Pages.Objects[PageIndex]); button := TButton.Create(page); try with button do begin Parent := page; Left := Random(page.ClientWidth - Width); Top := Random(page.ClientHeight - Height); end; except button.Free; end; end;

That's all there is to it!

Saving and Loading aTstringgrid From: "Eric Lawrence" >>How can I save an entire stringgrid with all cells to a file? Procedure SaveGrid; var f:textfile; x,y:integer; begin assignfile (f,'Filename'); rewrite (f); writeln (f,stringgrid.colcount); writeln (f,stringgrid.rowcount); For X:=0 to stringgrid.colcount-1 do For y:=0 to stringgrid.rowcount-1 do writeln (F, stringgrid.cells[x,y]); closefile (f); end; Procedure LoadGrid; var f:textfile; temp,x,y:integer; tempstr:string; begin assignfile (f,'Filename'); reset (f); readln (f,temp); stringgrid.colcount:=temp; readln (f,temp); stringgrid.rowcount:=temp; For X:=0 to stringgrid.colcount-1 do For y:=0 to stringgrid.rowcount-1 do begin readln (F, tempstr); stringgrid.cells[x,y]:=tempstr; end; closefile (f);

925

How do I synchronize two scroll boxes on different panels? By handle OnScroll event ,follow code can synchronize two scroll boxes on different panels: (You have two scrollboxes in TMainForm:ScrollBar1 and ScrollBar2) procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin ScrollBar2.Position:=ScrollPos; end; procedure TMainForm.ScrollBar2Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin ScrollBar1.Position := ScrollPos; end;

Delayed scrolling / delayed OnChange? Erik Sperling Johansen >[email protected]> Stefan Hoffmeister wrote: If the user keeps either key pressed and the change of the item (ComboBox.OnChange) takes a long(ish) time an annoying delay will be noticed. As a "work around" I would like to react to the change of the ItemIndex only after a short period of time, e.g. 100 ms.

Here's an example. Written in D2, but technique should work OK in D1 too. Just a simple form with a combo and a label. You probably should consider using Yield in addition to the call to Application.ProcessMessages, to avoid slowing down the PC when the forms message queue is empty. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; const // Just some message constant PM_COMBOCHANGE = WM_USER + 8001; // 500 ms CWantedDelay = 500; type TForm1 = class(TForm) ComboBox1: TComboBox; Label1: TLabel; procedure ComboBox1Change(Sender: TObject); private procedure PMComboChange(var message : TMessage); message PM_COMBOCHANGE; public end; var

926

Form1: TForm1; implementation {$R *.DFM} procedure TForm1.ComboBox1Change(Sender: TObject); begin PostMessage(Handle, PM_COMBOCHANGE, 0, 0); end; procedure TForm1.PMComboChange(var message : TMessage); const InProc : BOOLEAN = FALSE; StartTick : LONGINT = 0; begin if InProc then begin // Update the starting time for the delay StartTick := GetTickCount; end else begin // We're in the loop InProc := TRUE; // Initial starting time StartTick := GetTickCount; // Wait until wanted time has elapsed. // If proc gets called again, starting time will change while GetTickCount - StartTick < CWantedDelay do Application.ProcessMessages; // Increment a counter, just for illustration of when to do the actual OnChange work Label1.Caption := IntToStr ( StrToIntDef ( Label1.Caption, 0 ) + 1); // We're finished with the loop InProc := FALSE; end; end; end.

Unselectable Tab Is there any way at all of making a tab on a tabbed notebook unselectable? i.e not allowing the user to click and see its contents?

[Mike O'Hanlon, [email protected]] Yes, this is possible. The simplest way to do it is to remove the relevant page of the TabbedNotebook with something like: with TabbedNotebook do Pages.Delete(PageIndex);

and retrieve the deleted page (if necessary) by reloading the Form. Disabling (rather than deleting) is a bit trickier because you have to set up a loop in the Form's Create procedure to assign names to the tabs of the TabbedNotebook. Something like: J := 0; with TabbedNotebook do for I := 0 to ComponentCount - 1 do

927

if Components[I].ClassName = 'TTabButton' then begin Components[I].Name := ValidIdentifier(TTabbedNotebook( Components[I].Owner).Pages[J]) + 'Tab'; Inc(J); end;

where ValidIdentifier is a function which returns a valid Pascal identifier derived from the Tab string: function ValidIdentifier (theString: str63): str63; {----------------------------------------------------------} { Turns the supplied string into a valid Pascal identifier } { by removing all invalid characters, and prefixing with } { an underscore if the first character is numeric. } {----------------------------------------------------------} var I, Len: Integer; begin Len := Length(theString); for I := Len downto 1 do if not (theString[I] in LettersUnderscoreAndDigits) then Delete(theString, I, 1); if not (theString[1] in LettersAndUnderscore) then theString := '_' + theString; ValidIdentifier := theString; end; {ValidIdentifier}

A Tab of the TabbedNotebook may then be disabled with with TabbedNotebook do begin TabIdent := ValidIdentifier(Pages[PageIndex]) + 'Tab'; TControl(FindComponent(TabIdent)).Enabled := False; { Switch to the first enabled Tab: } for I := 0 to Pages.Count - 1 do begin TabIdent := ValidIdentifier(Pages[I]) + 'Tab'; if TControl(FindComponent(TabIdent)).Enabled then begin PageIndex := I; Exit; end; end; {for} end; {with TabbedNotebook}

and you could re-enable all tabs with: with TabbedNotebook do for I := 0 to Pages.Count - 1 do begin TabIdent := ValidIdentifier(Pages[I]) + 'Tab'; if not TControl(FindComponent(TabIdent)).Enabled then TControl(FindComponent(TabIdent)).Enabled := True; end; {for}

928

FONTS 158. 159. 160. 161. 162. 163.

How can my app use MY FONTS? not user's Include Font as a Resource in *.EXEfonts1 Font & Tregistry Store Fontstyle in INI Determining which font (Large or Small) is in use Font Sites

How can my app use MY FONTS? not user's From: [email protected] (Brad Choate) Can someone please tell me the neatest way to make sure my app uses fonts that I can provide, rather than the nearest font the user has installed on their system? I have tried copying a #.ttf file into the users windows\system directory but the app still can't pick it up.

The following is some Delphi 1 code that I have used for successfully installing dynamic fonts that are only loaded while the application is running. You can place the font file(s) within the application directory. It will be installed when the form loads and unloaded once the form is destroyed. You may need to modify the code to work with Delphi 2 since it calls various Windows API calls that may or may not have changed. Where you see "..." in the code, that is just to identify that other code can be placed there. Of course, substitute "MYFONT" for the name of your font file. type TForm1=class( TForm ) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); ... private { Private declarations } bLoadedFont: boolean; public { Public declarations } end; procedure TForm1.FormCreate(Sender: TObject); var sAppDir: string; sFontRes: string; begin sAppDir := Application.ExeName; sAppDir := copy( sAppDir, 1, rpos( '\', sAppDir ) ); sFontRes := sAppDir + 'MYFONT.FOT'; if not FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; sFont := sAppDir + 'MYFONT.TTF' + #0; CreateScalableFontResource( 0, @sFontRes[ 1 ], @sFont[ 1 ], nil ); end; sFontRes := sAppDir + 'MYFONT.FOT'; if FileExists( sFontRes ) then begin

929

sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; ... end; procedure TForm1.FormDestroy(Sender: TObject); var sFontRes: string; begin if bLoadedFont then begin sFontRes := sAppDir + 'MYFONT.FOT' + #0; RemoveFontResource( @sFontRes[ 1 ] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end;

From: Paul Munn I've worked with the fonts code and have some corrections for you to make it work with Delphi 2.0. I have not tried this on Delphi 3.0. Information in an InstallShield article about installing fonts reveals that you do not need a FOT file in Win95 and WinNT environments. You only need the TTF file. Resulting FormCreate code is as follows: var sAppDir, sFontRes: string; begin {...other code...} sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF'; if FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; end; {...} end; {FormCreate}

The resulting FormDestroy code is as follows: var sFontRes, sAppDir: string; begin {...other code...} if bLoadedFont then

930

begin sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF' + #0; RemoveFontResource( @sFontRes[ 1 ] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; {...other code...} end; {FormDestroy}

To simplify these, I have created a simple function which can do both of these tasks. It returns a boolean which says whether or not the loading or unloading of the font was successful. {1998-01-16 Font loading and unloading function.} function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean; var sFont, sAppDir, sFontRes: string; begin result := TRUE; if bLoadIt then begin {Load the font.} if FileExists( sFontFileName ) then begin sFontRes := sFontFileName + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then result := FALSE else SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end else begin {Unload the font.} sFontRes := sFontFileName + #0; result := RemoveFontResource( @sFontRes[1] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; {LoadFont}

Include Font as a Resource in *.EXE From: "Steve Harman" Include a font in your EXE: 15. Using your favorite text editor, create a *.rc file that describes the font: MY_FONT ANYOL1 "Bauhs93.ttf"

The first two parameters can be whatever you want. They get used in your program later. 16. Then, use the BRCC32.EXE command line compiler that ships with Delphi to create a *.res file. If your file in step 1 was MyFont.rc, the command from the DOS prompt would be:

931

BRCC32 MyFont

The program will append the .rc to the input, and create a file with the same name except it appends .res: MyFont.res 17. In your program, add a compiler directive to include your newly created file: {$R MyFont.res}

This can go right after the default {$R *.DFM} in the implementation section. 18. Add a procedure to create a file from the resource, then make the Font available for use. Example: procedure TForm1.FormCreate(Sender: TObject); var Res : TResourceStream; begin Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1')); Res.SavetoFile('Bauhs93.ttf'); Res.Free; AddFontResource(PChar('Bauhs93.ttf')); SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end;

19. You can now assign the font to whatever you wish: procedure TForm1.Button1Click(Sender: TObject); begin Button1.Font.Name := 'Bauhaus 93'; end;

Caveats: The above example provides for no error checking whatsoever. :-) Notice that the File name is NOT the same as the Font name. It's assumed that you know the font name associated with the file name. You can determine this by double clicking on the file name in the explorer window. I would recommend placing your font file in the C:\WINDOWS\FONTS folder. It's easier to find them later. Your newly installed font can be removed programatically, assuming the font is not in use anywhere: procedure TForm1.FormDestroy(Sender: TObject); begin RemoveFontResource(PChar("Bauhs93.ttf")) SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end;

Check the Win32 help for further details on the AddFontResource and RemoveFontResource.

Font & Tregistry See here

Store Fontstyle in INI See here

932

Resource File 164. 165. 166. 167.

String Tables How To Include JPEG's In Your Executable (Delphi 3) resource1 [Q] Resource files (*.res) / scripts (*.rc)<> Loading bitmaps from a resource DLL into a TImage component.resource3

String Tables From: "Joe C. Hecht" Stringtable resources are a very useful tool when your application must store a large number of strings for use at runtime. While you may be tempted to directly embed strings into your executable, using a stringtable resource offers two advantages: 1) The strings contained in the stringtable do not consume memory until they are loaded by your application. 2) Stringtables are easily edited, providing an easy path to internationaly localized versions of your application. Stringtables are compiled into a ".res" file that is attached to your application's exe file at build time. Even after you distribute your appliaction, the stringtable contained in your application's exe file can be edited with a resource editor. My favorite resource editor is Borland's Resource Workshop that ships with the RAD pack. It can produce and edit both 16 and 32 bit resources that are self contained, standalone, or embedded in a .exe or .dll in full WYSIWYG fashion. It's worth noting that all versions of Delphi ship with the Borland Resource Command Line Compiler (BRCC.EXE and BRCC32.EXE), and can be found in Delphi's Bin directory. For our example, we will build an internationalized application that displays two buttons. The buttons will have captions for "Yes" and "No" presented in English, Spanish, and Swedish. It's worth noting that if you want to build international applications using Delphi, you should take a look at Borland's Delphi Translation Suite and Language Pack software. These packages can make porting your application to international markets a snap! Example: We first must create a text file containing our string resources in the applications build directory. You may name the file anything you wish, so long as it has the file extension ".rc" and the filename without the extension is not the same as any unit or project filename. This is very important, as Delphi also will create a number of resource files for your project automatically. Here is the contents of the .rc file for our example. It contains the words "Yes" and "No" in English, Spanish, and Swedish: STRINGTABLE { 1, "&Yes" 2, "&No" 17, "&Si" 18, "&No" 33, "&Ja" 34, "&Nej" }

The file starts with the key word stringtable denoting that a string table resource will follow. Enclosed in the curly braces are the strings. Each string is listed by it's index identifier, followed by the actual string data in quotes. Each string may contain up to 255 characters. If you need to use a non-standard character, insert the character as a backslash character followed by the octal number of the character you wish to insert. The only exception is when you want to embed a backslash character, you will need to use two backslashes. Here are two examples: 933

1, "A two\012line string" 2, "c:\\Borland\\Delphi"

The Index numbers that you use are not important to the resource compiler. You should keep in mind that string tables are loaded into memory in 16 string segments. To compile the .rc file to a .res file that can be linked with your application, simply type on the dos command line the full path to the resource compiler, and the full path to the name of the .rc file to compile. Here is an example: c:\Delphi\Bin\brcc32.exe c:\Delphi\strtbl32.rc

When the compiler is finished, you should have a new file with the same name as the .rc file you've compiled, only with an extension of ".res". You can link the resource file with your application simply by adding the following statement to your application's code, substituting the name of your resource file: {$R ResFileName.RES}

Once the .res file is linked to your program, you can load the resource from any module, even if you specified the $R directive in the implementation section of a different unit. Here is an example of using the Windows API function LoadString(), to load the third string contained in a string resource into a character array: if LoadString(hInstance, 3, @a, sizeof(a)) <> 0 then ....

In this example, the LoadString() function accepts the hInstance of the module containing the resource, the string index to load, the address of the character array to load the string to, and the size of the character array. The LoadString function returns the number of characters that where actually loaded not including the null terminator. Be aware that this can differ from the number of bytes loaded when using unicode. Here is a complete example of creating an international application with Borland's Delphi. The application is compatible with both 16 and 32 bit versions of Delphi. To do this, you will need to create two identical .rc files, one for the 16 bit version, and the other for the 32 bit version, since the resources needed for each platform are different. In this example. we will create one file named STRTBL16.rc and another called STRTBL32.rc. Compile the STRTBL16.rc file using the BRCC.exe compiler found in Delphi 1.0's bin directory, and compile STRTBL32.rc using the BRCC32.exe compiler found in Delphi 2.0's bin directory. We have taken into account the language that Windows is currently using at runtime. The method for getting this information differs under 16 and 32 bit Windows. To make the code more consistant, we have borrowed the language constants from the Windows.pas file used in 32 bit versions of Delphi. {$IFDEF WIN32} {$R STRTBL32.RES} {$ELSE} {$R STRTBL16.RES} const LANG_ENGLISH = $09; const LANG_SPANISH = $0a; const LANG_SWEDISH = $1d; {$ENDIF} function GetLanguage : word; {$IFDEF WIN32} {$ELSE} var s : string; i : integer; {$ENDIF} begin {$IFDEF WIN32}

934

GetLanguage := GetUserDefaultLangID and $3ff; {$ELSE} s[0] := Char(GetProfileString('intl', 'sLanguage', 'none', @s[1], sizeof(s)-2)); for i := 1 to length(s) do s[i] := UpCase(s[i]); if s = 'ENU' then GetLanguage := LANG_ENGLISH else if s = 'ESN' then GetLanguage := LANG_SPANISH else if s = 'SVE' then GetLanguage := LANG_SWEDISH else GetLanguage := LANG_ENGLISH; {$ENDIF} end; procedure TForm1.FormCreate(Sender: TObject); var a : array[0..255] of char; StrTblOfs : integer; begin {Get the current language and stringtable offset} case GetLanguage of LANG_ENGLISH : StrTblOfs := 0; LANG_SPANISH : StrTblOfs := 16; LANG_SWEDISH : StrTblOfs := 32; else StrTblOfs := 0; end; {Load language dependent "Yes" and set the button caption} if LoadString(hInstance, StrTblOfs + 1, @a, sizeof(a)) <> 0 then Button1.Caption := StrPas(a); {Load language dependent "No" and set the button caption} if LoadString(hInstance, StrTblOfs + 2, @a, sizeof(a)) <> 0 then Button2.Caption := StrPas(a); end;

How To Include JPEG's In Your Executable (Delphi 3) From: Marko Peric I'm a Delphi beginner who's exploring this wonderful programming environment, and I just thought I'd like to share some really neat stuff I worked out. Delphi3 comes with the jpeg unit, and that's great, but did you ever wonder how to include jpeg's in your executable and then use them in your application? Well, follow this simple 5 step plan and you can't go wrong!

935

STEP ONE: Create a resource script file (*.RC) with a simple text editor like Notepad and add the following line: 1

RCDATA

"MyPic.jpg"

The first entry is simply the index of the resource. The second entry specifies that we are dealing with a user-defined resource. The third and final entry is the name of the jpeg file.

STEP TWO: Use Borland's Resource Compiler, BRCC32.EXE, to compile it into a .RES file. At the MSDOS command line: BRCC32 MyPic.RC

This will create a resource file called MyPic.RES.

STEP THREE: Add a compiler directive to the source code of your program. It should immediately follow the form directive, as shown here: {$R *.DFM} {$R MyPic.RES}

STEP FOUR: Add the following code to your project (I've created a procedure for it): procedure LoadJPEGfromEXE; var MyJPG : TJPEGImage; // JPEG object ResStream : TResourceStream; // Resource Stream object begin try MyJPG := TJPEGImage.Create; ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA); MyJPG.LoadFromStream(ResStream); // What!? Yes, that easy! Canvas.Draw(12,12,MyJPG); // draw it to see if it really worked! finally MyJPG.Free; ResStream.Free; end; end; // procedure

See the second parameter of the CreateFromID procedure of the TResourceStream component? It's simply the resource index. You can include more than one jpeg in your executable just by adding a line for each jpeg (with a different index) in the resource script (.RC) file.

STEP FIVE: Call the procedure, run the program, and voila! Now go eat some nachos.

936

[Q] Resource files (*.res) / scripts (*.rc)<> align="TOP"> From: Ken White The .RC file is simply a text file that lists resources. For most purposes (except defining dialogs for non-VCL apps), you don't need a resource editor. The file is in this format: RESOURCENAME

RESOURCETYPE

FILENAME

For example, to include a bitmap in the resource file: MyBitmap

BITMAP

MyBitmap.bmp

To include a cursor: MyCursor

CURSOR

MyCursor.cur

You use the same technique to include AVI, WAV and ICO files. For other filetypes, you can use the type RC_DATA. To use the resource script (.RC) file, you use Borland's Resource Compiler (BRCC.EXE with Delphi 1, BRCC32.EXE otherwise) which is located in the Delphi Bin directory. The syntax is: BRCC32 MyRes.RC

This creates MyRes.RES. You then add the {$R MYRES.RES} to a unit in your application to have Delphi's linker include it, and use one of the Load... API calls (or Delphi's wrappers for some components) to use the resource at runtime.

Loading bitmaps from a resource DLL into a TImage component. From: "Jason Wallace" begin hLib := LoadLibrary('Images.dll'); BMP := TBitmap.Create; with BMP do begin LoadFromResourceName(hLib, 'SPLASH'); Transparent := True; TransParentColor := clFuchsia; TransparentMode := tmFixed; Image1.Canvas.Draw(0, 0, BMP); Free; end; end;


937

Quick Report 168. 169. 170.

QuickReports FONT Problems Preview Form Caption QuickReports on different paper sizes

QuickReports FONT Problems From: [email protected] (Max Nilson) [email protected] (Bill Artemik) wrote: I'm using Delphi 2.0 and QuickReports 1.1 >I created a VERY complex (graphically, anyway) report and just found >out that ALTHOUGH it previews fine in design mode, does NOT display or >print correctly in runtime. The error appears to be that I'm running >with LARGE fonts in Windows 95! What a crock!

I too was getting this problem _very_ seriously, but only when printing from Win 95 to the office HP 4M, or when viewing the report under NT 4.0. The _exact_ same application when run under NT 3.51 SP5 worked perfectly. I had seen discussion of one other bug in the NT 4.0 GDI code, so I wasn't suprised when the above test showed that there seemed to be another. I looked very closely at the QuickReports code and noticed that the primary text output routine alters its ouput font for every field. Its does this via the following code segment in TQRCustomControl.Print: QRPrinter.Canvas.Font:=Font; QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size))); QRPrinter.Canvas.brush.Color:=Color;

Now those of us who have spent far too much time reading the VCL will know that the VCL maintains a resource cache via a handle manager in Graphics.pas, and that this attempts to lower the number of Windows resources allocated by using a reference counted approach to reusing old resource handles. The code above manages to circumvent this most excellently! Every time the printers canvas is set to the fields font, thus lowering the printer's old font resource count to zero and releasing it, and then scaling the fonts size to match the printer metrics, thus requiring a new font resource to be allocated. The upshot of all this is that _every_ field of the report was being drawn using a newly alocated font resource, and probably driving the meta file recorder into spasms trying to keep track of all this choping and changing of font resources. A quick hack where by I created a non printing label of the same size as the scaled printer font, thereby keeping the resource cached, made the bug go away! This proved that there is some sort of problem with the NT 4.0 ehnanced meta file recorder and too many font changes. A better hack has been introduced into QuickReports as follows: // MRN Save the printer font while setting new font SaveFont := TFont.Create; SaveFont.Assign(QRPrinter.Canvas.Font); QRPrinter.Canvas.Font:=Font;

938

QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size))); QRPrinter.Canvas.brush.Color:=Color; // MRN Free the saved printer font. Its done its work now. SaveFont.Free; SaveFont := nil;

This manages to ensure that the printer font is reused if the same font is selected into the printer canvas. This works perfectly and produces correct reports on NT 4.0. By some strange coincidence 8-) this also stopped the wierd bold, out sized fonts being printed under Win95. So if you have a registered version of QuickReports thaen you simply make this patch and things will run faster, smother and no more font corruptions will occur due to the limitations of the enhanced meta file code and the GDI.

Preview Form Caption Bruno Sonnino [[email protected]] You can set QRPrinter PreviewCaption to your caption like this: QRPrinter.PreviewCaption := 'My Caption';

QRPrinter is a global variable defined in Quickrep.pas

QuickReports on different paper sizes From: [email protected] Hi! Have you looked at the TPrinter-object? You can set the printer you want to use with the Printer.PrinterIndex. For example: Printer.PrinterIndex:=0; Sets the first printer you have installed Printer.PrinterIndex:=-1; Sets the printer to the default printer

Observe! That this function don't make an global change to your system, it's just for the time being. Please email me and tell me if you liked this page. Last modified 03/12/00 12:09:40

939

Strings 171. 172. 173. 174. 175. 176. 177. 178. 179. 180. 181. 182.

Equivalent of Trim$(),Mid$(), etc? String Pattern matching GetTokenstrings2 Replacing substrings Capitalize the first letter of each word in a string How do I determine if two strings sound alike? What are the values for the virtual keys? Delphi currency amount converter strings7 Remove Unwanted from String from String String Parsing? REGULR EXPRESSIONSstrings10 4 Small String Routinesstrings11

Equivalent of Trim$(),Mid$(), etc? Solution 1 From: [email protected] (Bob Swart) unit TrimStr; {$B-} { File: TrimStr Author: Bob Swart [100434,2072] Purpose: routines for removing leading/trailing spaces from strings, and to take parts of left/right of string (a la Basic). Version: 2.0 LTrim() RTrim() Trim() RightStr() LeftStr() MidStr()

-

Remove all spaces from the left side of a string Remove all spaces from the right side of a string Remove all extraneous spaces from a string Take a certain portion of the right side of a string Take a certain portion of the left side of a string Take the middle portion of a string

} interface Const Space = #$20; function function function function function function

LTrim(Const Str: String): String; RTrim(Str: String): String; Trim(Str: String): String; RightStr(Const Str: String; Size: Word): String; LeftStr(Const Str: String; Size: Word): String; MidStr(Const Str: String; Size: Word): String;

implementation function LTrim(Const Str: String): String; var len: Byte absolute Str;

940

i: Integer; begin i := 1; while (i <= len) and (Str[i] = Space) do Inc(i); LTrim := Copy(Str,i,len) end {LTrim}; function RTrim(Str: String): String; var len: Byte absolute Str; begin while (Str[len] = Space) do Dec(len); RTrim := Str end {RTrim}; function Trim(Str: String): String; begin Trim := LTrim(RTrim(Str)) end {Trim}; function RightStr(Const Str: String; Size: Word): String; var len: Byte absolute Str; begin if Size > len then Size := len; RightStr := Copy(Str,len-Size+1,Size) end {RightStr}; function LeftStr(Const Str: String; Size: Word): String; begin LeftStr := Copy(Str,1,Size) end {LeftStr}; function MidStr(Const Str: String; Size: Word): String; var len: Byte absolute Str; begin if Size > len then Size := len; MidStr := Copy(Str,((len - Size) div 2)+1,Size) end {MidStr}; end.

Solution 2 From: [email protected] (Joseph Bui) For Mid$, use Copy(S: string; start, length: byte): string; You can make copy perform Right$ and Left$ as well by doing: Copy(S, 1, Length) for left$ and Copy(S, Start, 255) for right$ Note: Start and Length are the byte positions of your starting point, get these with Pos(). Here are some functions I wrote that come in handy for me. Way down at the bottom is a trim() function that you can modify into TrimRight$ and TrimLeft$. Also, they all take pascal style strings, but you can modify them to easily null terminated. const BlackSpace = [#33..#126]; { squish() returns a string with all whitespace not inside single quotes deleted. } function squish(const Search: string): string; var Index: byte; InString: boolean; begin

941

InString:=False; Result:=''; for Index:=1 to Length(Search) do begin if InString or (Search[Index] in BlackSpace) then AppendStr(Result, Search[Index]); InString:=((Search[Index] = '''') and (Search[Index - 1] <> '\')) xor InString; end; end; {

before() returns everything before the first occurance of Find in Search. If Find does not occur in Search, Search is returned. } function before(const Search, Find: string): string; var index: byte; begin index:=Pos(Find, Search); if index = 0 then Result:=Search else Result:=Copy(Search, 1, index - 1); end; { after() returns everything after the first occurance of Find in Search. If Find does not occur in Search, a null string is returned. } function after(const Search, Find: string): string; var index: byte; begin index:=Pos(Find, Search); if index = 0 then Result:='' else Result:=Copy(Search, index + Length(Find), 255); end; { RPos() returns the index of the first character of the last occurance of Find in Search. Returns 0 if Find does not occur in Search. Like Pos() but searches in reverse. } function RPos(const Find, Search: string): byte; var FindPtr, SearchPtr, TempPtr: PChar; begin FindPtr:=StrAlloc(Length(Find)+1); SearchPtr:=StrAlloc(Length(Search)+1); StrPCopy(FindPtr,Find); StrPCopy(SearchPtr,Search); Result:=0; repeat TempPtr:=StrRScan(SearchPtr, FindPtr^); if TempPtr <> nil then if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then begin Result:=TempPtr - SearchPtr + 1; TempPtr:=nil; end else

942

TempPtr:=#0; until TempPtr = nil; end; { inside() returns the string between the most inside nested Front ... Back pair. } function inside(const Search, Front, Back: string): string; var Index, Len: byte; begin Index:=RPos(Front, before(Search, Back)); Len:=Pos(Back, Search); if (Index > 0) and (Len > 0) then Result:=Copy(Search, Index + 1, Len - (Index + 1)) else Result:=''; end; { leftside() returns what is to the left of inside() or Search. } function leftside(const Search, Front, Back: string): string; begin Result:=before(Search, Front + inside(Search, Front, Back) + Back); end; { rightside() returns what is to the right of inside() or Null. } function rightside(const Search, Front, Back: string): string; begin Result:=after(Search, Front + inside(Search, Front, Back) + Back); end; {

trim() returns a string with all right and left whitespace removed. } function trim(const Search: string): string; var Index: byte; begin Index:=1; while (Index <= Length(Search)) and not (Search[Index] in BlackSpace) do Index:=Index + 1; Result:=Copy(Search, Index, 255); Index:=Length(Result); while (Index > 0) and not (Result[Index] in BlackSpace) do Index:=Index - 1; Result:=Copy(Result, 1, Index); end;

String Pattern matching From: [email protected] (David Stidolph) There are many times when you need to compare two strings, but want to use wild cards in the match - all last names that begin with 'St', etc. The following is a piece of code I got from Sean Stanley in Tallahassee Florida in C. I translated it into Delphi an am uploading 943

it here for all to use. I have not tested it extensivly, but the original function has been tested quite thoughly. I would love feedback on this routine - or peoples changes to it. I want to forward them to Sean to get him to release more tidbits like this. { This function takes two strings and compares them. The first string can be anything, but should not contain pattern characters (* or ?). The pattern string can have as many of these pattern characters as you want. For example: MatchStrings('David Stidolph','*St*') would return True. Orignal code by Sean Stanley in C Rewritten in Delphi by David Stidolph } function MatchStrings(source, pattern: String): Boolean; var pSource: Array [0..255] of Char; pPattern: Array [0..255] of Char; function MatchPattern(element, pattern: PChar): Boolean; function IsPatternWild(pattern: PChar): Boolean; var t: Integer; begin Result := StrScan(pattern,'*') <> nil; if not Result then Result := StrScan(pattern,'?') <> nil; end; begin if 0 = StrComp(pattern,'*') then Result := True else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then Result := False else if element^ = Chr(0) then Result := True else begin case pattern^ of '*': if MatchPattern(element,@pattern[1]) then Result := True else Result := MatchPattern(@element[1],pattern); '?': Result := MatchPattern(@element[1],@pattern[1]); else if element^ = pattern^ then Result := MatchPattern(@element[1],@pattern[1]) else Result := False; end; end; end; begin StrPCopy(pSource,source); StrPCopy(pPattern,pattern); Result := MatchPattern(pSource,pPattern); end;

944

GetToken Thomas Scheffczyk I don't know if this will help you, but the following (simple) functions helped me handling substrings. Perhaps you can use them to seperate the text for each field (for i := 1 to NumToken do ...) and store it seperatly in the database-fields. function GetToken(aString, SepChar: String; TokenNum: Byte):String; { parameters: aString : the complete string SepChar : a single character used as separator between the substrings TokenNum: the number of the substring you want result : the substring or an empty string if the are less then 'TokenNum' substrings } var Token : String; StrLen : Byte; TNum : Byte; TEnd : Byte; begin StrLen := Length(aString); TNum := 1; TEnd := StrLen; while ((TNum <= TokenNum) and (TEnd <> 0)) do begin TEnd := Pos(SepChar,aString); if TEnd <> 0 then begin Token := Copy(aString,1,TEnd-1); Delete(aString,1,TEnd); Inc(TNum); end else begin Token := aString; end; end; if TNum >= TokenNum then begin GetToken1 := Token; end else begin GetToken1 := ''; end; end; function NumToken(aString, SepChar: String):Byte; { parameters: aString : the complete string SepChar : a single character used as separator between the substrings result : the number of substrings } var RChar

: Char;

945

StrLen TNum TEnd

: Byte; : Byte; : Byte;

begin if SepChar = '#' then begin RChar := '*' end else begin RChar := '#' end; StrLen := Length(aString); TNum := 0; TEnd := StrLen; while TEnd <> 0 do begin Inc(TNum); TEnd := Pos(SepChar,aString); if TEnd <> 0 then begin aString[TEnd] := RChar; end; end; NumToken1 := TNum; end;

"Hrvoje Brozovic" function CopyColumn( const s_string: string; c_fence: char; i_index: integer ): string; var i, i_left: integer; begin result := EmptyStr; if i_index = 0 then begin exit; end; i_left := 0; for i := 1 to Length( s_string ) do begin if s_string[ i ] = c_fence then begin Dec( i_index ); if i_index = 0 then begin result := Copy( s_string, i_left + 1, i - i_left - 1 ); exit; end else begin i_left := i; end; end; end; Dec( i_index ); if i_index = 0 then begin result := Copy( s_string, i_left + 1, Length( s_string )); end; end;

I know that in GetToken SepChar parameter ( c_fence in my case ) is string, not char, but comment says that he is expecting single char in that string, and it is obvious that if you send more than one char, it won't work correctly. ( Delete(aString,1,TEnd) is buggy if Length( SepChar ) > 1 ).

946

Replacing substrings From: [email protected] (Michael Bialas) Does anyone know a fast algorithm that replaces all occurences of any substring sub1 to any string sub2 in any string str.

This should do the job: function ReplaceSub(str, sub1, sub2: String): String; var aPos: Integer; rslt: String; begin aPos := Pos(sub1, str); rslt := ''; while (aPos <> 0) do begin rslt := rslt + Copy(str, 1, aPos - 1) + sub2; Delete(str, 1, aPos + Length(sub1)); aPos := Pos(sub1, str); end; Result := rslt + str; end;

Capitalize the first letter of each word in a string Erik Sperling Johansen function LowCase(ch : CHAR) : CHAR; begin case ch of 'A'..'Z' : LowCase := CHR (ORD(ch)+31); else LowCase := ch; end; end; function Proper (source, separators : STRING) : STRING; var LastWasSeparator : BOOLEAN; ndx : INTEGER; begin LastWasSeparator := TRUE; ndx := 1; while (ndx<=Length(source)) do begin if LastWasSeparator then source[ndx] := UpCase(source[ndx]) else source[ndx] := LowCase(source[ndx]); LastWasSeparator := Pos(source[ndx], separators)>0; inc(ndx); end; Result := source; end;

From: "Cleon T. Bailey" 947

Function TfrmLoadProtocolTable.ToMixCase(InString: String): String; Var I: Integer; Begin Result := LowerCase(InString); Result[1] := UpCase(Result[1]); For I := 1 To Length(InString) - 1 Do Begin If (Result[I] = ' ') Or (Result[I] = '''') Or (Result[I] = '"') Or (Result[I] = '-') Or (Result[I] = '.') Or (Result[I] = '(') Then Result[I + 1] := UpCase(Result[I + 1]); End; End;

From: "Paul Motyer" Both Tim Stannard's and Cleon T. Bailey's functions will bomb in D2 if sent an empty string (where accessing InString[1] causes an access violation, the second attempt will do the same if the last character is in the set. try this instead: function proper(s:string):string; var t:string; i:integer; newWord:boolean; begin if s='' then exit; s:=lowercase(s); t:=uppercase(s); newWord:=true; for i:=1 to length(s) do begin if newWord and (s[i] in ['a'..'z']) then begin s[i]:=t[i]; newWord:=false; continue; end; if s[i] in ['a'..'z',''''] then continue; newWord:=true; end; result:=s; end;

How do I determine if two strings sound alike? { This code came from Lloyd's help file! } Soundex function--determines whether two words sound alike. Written after reading an article in PC Magazine about the Soundex algorithm. Pass the function a string. It returns a Soundex value string. This value can be saved in a database or compared to another Soundex value. If two words have the same Soundex value, then they sound alike (more or less). Note that the Soundex algorithm ignores the first letter of a word. Thus, "won" and "one" will have different Soundex values, but "Won" and "Wunn" will have the same values. Soundex is especially useful in databases when one does not know how to spell a last name. Function Soundex(OriginalWord: string): string; var Tempstring1, Tempstring2: string; Count: integer; begin Tempstring1 := '';

948

Tempstring2 := ''; OriginalWord := Uppercase(OriginalWord); {Make original word uppercase} Appendstr(Tempstring1, OriginalWord[1]); {Use the first letter of the word} for Count := 2 to length(OriginalWord) do {Assign a numeric value to each letter, except the first} case OriginalWord[Count] of 'B','F','P','V': Appendstr(Tempstring1, '1'); 'C','G','J','K','Q','S','X','Z': Appendstr(Tempstring1, '2'); 'D','T': Appendstr(Tempstring1, '3'); 'L': Appendstr(Tempstring1, '4'); 'M','N': Appendstr(Tempstring1, '5'); 'R': Appendstr(Tempstring1, '6'); {All other letters, punctuation and numbers are ignored} end; Appendstr(Tempstring2, OriginalWord[1]); {Go through the result removing any consecutive duplicate numeric values.} for Count:=2 to length(Tempstring1) do if Tempstring1[Count-1]<>Tempstring1[Count] then Appendstr(Tempstring2,Tempstring1[Count]); Soundex:=Tempstring2; {This is the soundex value} end;

SoundAlike--pass two strings to this function. It returns True if they sound alike, False if they don't. Simply calls the Soundex function. Function SoundAlike(Word1, Word2: string): boolean; begin if (Word1 = '') and (Word2 = '') then result := True else if (Word1 = '') or (Word2 = '') then result := False else if (Soundex(Word1) = Soundex(Word2)) then result := True else result := False; end;

What are the values for the virtual keys? vk_LButton vk_RButton vk_Cancel vk_MButton vk_Back vk_Tab vk_Clear vk_Return vk_Shift vk_Control vk_Menu vk_Pause vk_Capital vk_Escape vk_Space vk_Prior vk_Next

= = = = = = = = = = = = = = = = =

$01; $02; $03; $04; $08; $09; $0C; $0D; $10; $11; $12; $13; $14; $1B; $20; $21; $22;

vk_End vk_Home vk_Left

= $23; = $24; = $25;

{ NOT contiguous with L & RBUTTON }

949

vk_Up = vk_Right = vk_Down = vk_Select = vk_Print = vk_Execute = vk_SnapShot = { vk_Copy = vk_Insert = vk_Delete = vk_Help = { vk_A thru vk_Z { vk_0 thru vk_9

$26; $27; $28; $29; $2A; $2B; $2C; $2C not used by keyboards } $2D; $2E; $2F; are the same as their ASCII equivalents: 'A' thru 'Z' } are the same as their ASCII equivalents: '0' thru '9' }

vk_NumPad0 vk_NumPad1 vk_NumPad2 vk_NumPad3 vk_NumPad4 vk_NumPad5 vk_NumPad6 vk_NumPad7 vk_NumPad8 vk_NumPad9 vk_Multiply vk_Add vk_Separator vk_Subtract vk_Decimal vk_Divide vk_F1 vk_F2 vk_F3 vk_F4 vk_F5

= = = = = = = = = = = = = = = = = = = = =

$60; $61; $62; $63; $64; $65; $66; $67; $68; $69; $6A; $6B; $6C; $6D; $6E; $6F; $70; $71; $72; $73; $74;

vk_F6 vk_F7 vk_F8 vk_F9 vk_F10 vk_F11 vk_F12 vk_F13 vk_F14 vk_F15 vk_F16 vk_F17 vk_F18 vk_F19 vk_F20 vk_F21 vk_F22 vk_F23 vk_F24 vk_NumLock vk_Scroll

= = = = = = = = = = = = = = = = = = = = =

$75; $76; $77; $78; $79; $7A; $7B; $7C; $7D; $7E; $7F; $80; $81; $82; $83; $84; $85; $86; $87; $90; $91;

{ This code came from Lloyd's help file! }

Delphi currency amount converter From: "Donald Johnson" 950

Function HundredAtATime(TheAmount:Integer):String; var TheResult : String; Begin TheResult := ''; TheAmount := Abs(TheAmount); While TheAmount > 0 do Begin If TheAmount >= 900 Then Begin TheResult := TheResult + 'Nine hundred '; TheAmount := TheAmount - 900; End; If TheAmount >= 800 Then Begin TheResult := TheResult + 'Eight hundred '; TheAmount := TheAmount - 800; End; If TheAmount >= 700 Then Begin TheResult := TheResult + 'Seven hundred '; TheAmount := TheAmount - 700; End; If TheAmount >= 600 Then Begin TheResult := TheResult + 'Six hundred '; TheAmount := TheAmount - 600; End; If TheAmount >= 500 Then Begin TheResult := TheResult + 'Five hundred '; TheAmount := TheAmount - 500; End; If TheAmount >= 400 Then Begin TheResult := TheResult + 'Four hundred '; TheAmount := TheAmount - 400; End; If TheAmount >= 300 Then Begin TheResult := TheResult + 'Three hundred '; TheAmount := TheAmount - 300; End; If TheAmount >= 200 Then Begin TheResult := TheResult + 'Two hundred '; TheAmount := TheAmount - 200; End; If TheAmount >= 100 Then Begin TheResult := TheResult + 'One hundred '; TheAmount := TheAmount - 100; End; If TheAmount >= 90 Then Begin TheResult := TheResult + 'Ninety '; TheAmount := TheAmount - 90; End; If TheAmount >= 80 Then Begin TheResult := TheResult + 'Eighty '; TheAmount := TheAmount - 80; End; If TheAmount >= 70 Then Begin TheResult := TheResult + 'Seventy '; TheAmount := TheAmount - 70; End; If TheAmount >= 60 Then Begin TheResult := TheResult + 'Sixty '; TheAmount := TheAmount - 60; End; If TheAmount >= 50 Then Begin TheResult := TheResult + 'Fifty '; TheAmount := TheAmount - 50; End; If TheAmount >= 40 Then Begin

951

TheResult := TheResult + 'Fourty '; TheAmount := TheAmount - 40; End; If TheAmount >= 30 Then Begin TheResult := TheResult + 'Thirty '; TheAmount := TheAmount - 30; End; If TheAmount >= 20 Then Begin TheResult := TheResult + 'Twenty '; TheAmount := TheAmount - 20; End; If TheAmount >= 19 Then Begin TheResult := TheResult + 'Nineteen '; TheAmount := TheAmount - 19; End; If TheAmount >= 18 Then Begin TheResult := TheResult + 'Eighteen '; TheAmount := TheAmount - 18; End; If TheAmount >= 17 Then Begin TheResult := TheResult + 'Seventeen '; TheAmount := TheAmount - 17; End; If TheAmount >= 16 Then Begin TheResult := TheResult + 'Sixteen '; TheAmount := TheAmount - 16; End; If TheAmount >= 15 Then Begin TheResult := TheResult + 'Fifteen '; TheAmount := TheAmount - 15; End; If TheAmount >= 14 Then Begin TheResult := TheResult + 'Fourteen '; TheAmount := TheAmount - 14; End; If TheAmount >= 13 Then Begin TheResult := TheResult + 'Thirteen '; TheAmount := TheAmount - 13; End; If TheAmount >= 12 Then Begin TheResult := TheResult + 'Twelve '; TheAmount := TheAmount - 12; End; If TheAmount >= 11 Then Begin TheResult := TheResult + 'Eleven '; TheAmount := TheAmount - 11; End; If TheAmount >= 10 Then Begin TheResult := TheResult + 'Ten '; TheAmount := TheAmount - 10; End; If TheAmount >= 9 Then Begin TheResult := TheResult + 'Nine '; TheAmount := TheAmount - 9; End; If TheAmount >= 8 Then Begin TheResult := TheResult + 'Eight '; TheAmount := TheAmount - 8; End; If TheAmount >= 7 Then Begin TheResult := TheResult + 'Seven '; TheAmount := TheAmount - 7; End; If TheAmount >= 6 Then Begin TheResult := TheResult + 'Six '; TheAmount := TheAmount - 6;

952

End; If TheAmount >= 5 Then Begin TheResult := TheResult + 'Five '; TheAmount := TheAmount - 5; End; If TheAmount >= 4 Then Begin TheResult := TheResult + 'Four '; TheAmount := TheAmount - 4; End; If TheAmount >= 3 Then Begin TheResult := TheResult + 'Three '; TheAmount := TheAmount - 3; End; If TheAmount >= 2 Then Begin TheResult := TheResult + 'Two '; TheAmount := TheAmount - 2; End; If TheAmount >= 1 Then Begin TheResult := TheResult + 'One '; TheAmount := TheAmount - 1; End; End; HundredAtATime := TheResult; End; Function Real2CheckAmount(TheAmount:Real):String; Var IntVal : LongInt; TmpVal : Integer; TmpStr, RetVal : String; begin TheAmount := Abs(TheAmount); { cents} TmpVal IntVal TmpStr If TmpStr RetVal If IntVal

:= Round(Frac(TheAmount) * 100); := Trunc(TheAmount); := HundredAtATime(TmpVal); = '' Then TmpStr := 'Zero '; := TmpStr + 'cents'; > 0 Then RetVal := 'dollars and ' + RetVal;

{ hundreds } TmpVal := IntVal := TmpStr := RetVal :=

Round(Frac((IntVal * 1.0) / 1000.0) * 1000); Trunc((IntVal * 1.0) / 1000.0); HundredAtATime(TmpVal); TmpStr + RetVal;

{ thousands } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' Then RetVal := TmpStr + 'Thousand ' + RetVal; { millions } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' Then RetVal := TmpStr + 'Million ' + RetVal; { billions } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal);

953

If TmpStr <> '' Then RetVal := TmpStr + 'Billion ' + RetVal; Real2CheckAmount := RetVal; end;

From: [email protected] (Nazar Aziz) Hmmm... What about this.... and some nice recursion too!!!..:))) unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) num: TEdit; spell: TEdit; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } function trans9(num: integer): string; function trans19(num: integer): string; function trans99(num: integer): string; function IntToSpell(num: integer): string; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function TForm1.IntToSpell(num: integer): string; var spell: string; hspell: string; hundred: string; thousand: string; tthousand: string; hthousand: string; million: string; begin if num ≶ 10 then spell := trans9(num); {endif} if (num < 20) and (num > 10) then spell := trans19(num); {endif} if (((num < 100) and (num > 19)) or (num = 10)) then begin hspell := copy(IntToStr(num),1,1) + '0'; spell := trans99(StrToInt(hspell)); hspell := copy(IntToStr(num),2,1); spell := spell + ' ' + IntToSpell(StrToInt(hspell)); end; if (num < 1000) and (num > 100) then begin

954

hspell := copy(IntToStr(num),1,1); hundred := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,2); hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell)); spell := hundred; end; if (num < 10000) and (num > 1000) then begin hspell := copy(IntToStr(num),1,1); thousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,3); thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell)); spell := thousand; end; if (num < 100000) and (num > 10000) then begin hspell := copy(IntToStr(num),1,2); tthousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),3,3); tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell)); spell := tthousand; end; if (num < 1000000) and (num > 100000) then begin hspell := copy(IntToStr(num),1,3); hthousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),4,3); hthousand := hthousand + ' thousand and ' + IntToSpell(StrToInt(hspell)); spell := hthousand; end; if (num < 10000000) and (num > 1000000) then begin hspell := copy(IntToStr(num),1,1); million := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,6); million := million + ' million and ' + IntToSpell(StrToInt(hspell)); spell := million; end; IntToSpell := spell; end; function TForm1.trans99(num: integer): string; var spell: string; begin case num of 10 : spell := 'ten'; 20 : spell := 'twenty'; 30 : spell := 'thirty'; 40 : spell := 'fourty'; 50 : spell := 'fifty'; 60 : spell := 'sixty'; 70 : spell := 'seventy'; 80 : spell := 'eighty'; 90 : spell := 'ninty'; end; trans99 := spell; end; function TForm1.trans19(num: integer): string;

955

var spell: string; begin case num of 11 : spell := 'eleven'; 12 : spell := 'twelve'; 13 : spell := 'thirteen'; 14 : spell := 'fourteen'; 15 : spell := 'fifteen'; 16 : spell := 'sixteen'; 17 : spell := 'seventeen'; 18 : spell := 'eighteen'; 19 : spell := 'nineteen'; end; trans19 := spell; end; function TForm1.trans9(num: integer): string; var spell : string; begin case num of 1 : spell := 'one'; 2 : spell := 'two'; 3 : spell := 'three'; 4 : spell := 'four'; 5 : spell := 'five'; 6 : spell := 'six'; 7 : spell := 'seven'; 8 : spell := 'eight'; 9 : spell := 'nine'; end; trans9 := spell; end; procedure TForm1.Button1Click(Sender: TObject); var numb: integer; begin spell.text := IntToSpell(StrToInt(num.text)); end;

Remove Unwanted from String from String "Joseph Y. Wong" procedure RemoveInvalid(what, where: string): string; // what is the string to be removed, where is the string to be removed from var tstr: string; begin tstr:=where; while pos(what, tstr)>0 do tstr:=copy(tstr,1,pos(what,tstr)-1) + copy(tstr,pos(what,tstr)+length(tstr),length(tstr)); Result:=tstr; end;

Use: NewStr:=RemoveInvalid('','This is my string and I wan to remove the word ');

956

"Laurie Bisman" Use Pascal's DELETE... using your example string, you could use code like.... Target:=''; While POS(Target,string)>0 do begin P := POS(Target,string); DELETE(string,P,Length(Target)); end;

String Parsing? From: [email protected] This is a unit where I have gathered lots of this type of routines. Some of the function names are in swedish, but maybe you can figure out what they are doing. The one you need is called stringreplaceall which takes three parameters, the string, what to search for and what to replace with and it return the changed string. But beware if you are changing something to something that contains the first. You must do it in two passes or you will end up in an endless loop. So if you have text containing the word Joe and you like all occurances to be changed to Joey you need to first do something like: text := stringreplaceall (text,'Joe','Joeey'); and then text := stringreplaceall (text,'Joeey','Joey'); unit sparfunc; interface uses sysutils,classes; function antaltecken (orgtext,soktext : string) : integer; function beginsWith (text,teststreng : string):boolean; function endsWith (text,teststreng : string):boolean; function hamtastreng (text,strt,slut : string):string; function hamtastrengmellan (text,strt,slut : string):string; function nastadelare (progtext : string):integer; function rtf2sgml (text : string) : string; Function sgml2win(text : String) : String; Function sgml2mac(text : String) : String; Function sgml2rtf(text : string) : String; function sistamening(text : string) : string; function stringnthfield (text,delim : string; vilken : integer) : string; function stringreplace (text,byt,mot : string) : string; function stringreplaceall (text,byt,mot : string) : string; function text2sgml (text : string) : string; procedure SurePath (pathen : string); procedure KopieraFil (infil,utfil : string); function LasInEnTextfil (filnamn : string) : string; implementation function LasInEnTextfil (filnamn : string) : string; var infil : textfile; temptext, filtext : string;

957

begin filtext := ''; //Öppna angiven fil och läs in den try assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname reset (infil); //Öppna filen while not eof(infil) do begin //Så länge vi inte nått slutet readln (infil,temptext); //Läs in en rad filtext := filtext+temptext; //Lägg den till variabeln SGMLTEXT end; // while finally //slutligen closefile (infil); //Stäng filen end; //try result := filtext; end; procedure KopieraFil (infil,utfil : string); var InStream : TFileStream; OutStream : TFileStream; begin InStream := TFileStream.Create(infil,fmOpenRead); try OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate); try OutStream.CopyFrom(InStream,0); finally OutStream.Free; end; finally InStream.Free; end; end; procedure SurePath (pathen : string); var temprad,del1 : string; antal : integer; begin antal := antaltecken (pathen,'\'); if antal<3 then createdir(pathen) else begin if pathen[length(pathen)] <> '\' then pathen := pathen+'\'; pathen := stringreplace(pathen,'\','/'); del1 := copy(pathen,1,pos('\',pathen)); pathen := stringreplace(pathen,del1,''); del1 := stringreplace(del1,'/','\'); createdir (del1); while pathen <> '' do begin temprad := copy(pathen,1,pos('\',pathen)); pathen := stringreplace(pathen,temprad,''); del1 := del1+ temprad; temprad := ''; createdir(del1); end; end; end; function antaltecken (orgtext,soktext : string) : integer; var i,traffar,soklengd : integer; begin traffar := 0; soklengd := length(soktext); for i := 1 to length(orgtext) do

958

begin if soktext = copy(orgtext,i,soklengd) then traffar := traffar +1; end; result := traffar; end; function nastadelare (progtext var i,j : integer; begin i := pos('.',progtext); j := pos('!',progtext); if (j0) then i := j := pos('!',progtext); if (j0) then i := j := pos('?',progtext); if (j0) then i := result := i; end;

: string):integer;

j; j; j;

function stringnthfield (text,delim : string; vilken : integer) : string; var start,slut,i : integer; temptext : string; begin start := 0; if vilken >0 then begin temptext := text; if vilken = 1 then begin start := 1; slut := pos (delim,text); end else begin for i:= 1 to vilken -1 do begin start := pos(delim,temptext)+length(delim); temptext := copy(temptext,start,length(temptext)); end; slut := pos (delim,temptext); end; if start >0 then begin if slut = 0 then slut := length(text); result := copy (temptext,1,slut-1); end else result := text; end else result := text; end; function StringReplaceAll (text,byt,mot : string ) :string; {Funktion för att byta ut alla förekomster av en sträng mot en annan sträng in en sträng. Den konverterade strängen returneras. Om byt finns i mot måste vi gå via en temporär variant!!!} var plats : integer; begin While pos(byt,text) > 0 do begin plats := pos(byt,text);

959

delete (text,plats,length(byt)); insert (mot,text,plats); end; result := text; end; function StringReplace (text,byt,mot : string ) :string; {Funktion för att byta ut den första förekomsten av en sträng mot en annan sträng in en sträng. Den konverterade strängen returneras.} var plats : integer; begin if pos(byt,text) > 0 then begin plats := pos(byt,text); delete (text,plats,length(byt)); insert (mot,text,plats); end; result := text; end; function hamtastreng (text,strt,slut : string):string; {Funktion för att hämta ut en delsträng ur en annan sträng. Om start och slut finns i text så returneras en sträng där start ingår i början och fram till tecknet före slut.} var stplats,slutplats : integer; resultat : string; begin resultat :=''; stplats := pos(strt,text); if stplats >0 then begin text := copy (text,stplats,length(text)); slutplats := pos(slut,text); if slutplats >0 then begin resultat := copy(text,1,slutplats-1); end; end; result := resultat; end; function hamtastrengmellan (text,strt,slut : string):string; {Funktion för att hämta ut en delsträng ur en annan sträng. Om start och slut finns i text så returneras en sträng där start ingår i början och fram till tecknet före slut.} var stplats,slutplats : integer; resultat : string; begin resultat :=''; stplats := pos(strt,text); if stplats >0 then begin text := copy (text,stplats+length(strt),length(text)); slutplats := pos(slut,text); if slutplats >0 then begin resultat := copy(text,1,slutplats-1); end; end; result := resultat; end; function endsWith (text,teststreng : string):boolean;

960

{Kollar om en sträng slutar med en annan sträng. Returnerar true eller false.} var textlngd,testlngd : integer; kollstreng : string; begin testlngd := length(teststreng); textlngd := length (text); if textlngd > testlngd then begin kollstreng := copy (text,(textlngd+1)-testlngd,testlngd); if kollstreng = teststreng then result := true else result := false; end else result := false; end; function beginsWith (text,teststreng : string):boolean; {Funktion för att kolla om text börjar med teststreng. Returnerar true eller false.} var textlngd,testlngd : integer; kollstreng : string; begin testlngd := length(teststreng); textlngd := length (text); if textlngd >= testlngd then begin kollstreng := copy (text,1,testlngd); if kollstreng = teststreng then result := true else result := false; end else result := false; end; function sistamening(text : string) : string; //Funktion för att ta fram sista meningen i en sträng. Söker på !?. var i:integer; begin i :=length(text)-1; while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and (copy(text,i,1)<> '?') do begin dec(i); if i =1 then break end; if i>1 then result := copy(text,i,length(text)) else result := ''; end; Function text2sgml(text : String) : String; {Funktion som byter ut alla ovanliga tecken mot entiteter. Den färdiga texten returneras.} begin text := stringreplaceall (text,'&','##amp;'); text := stringreplaceall (text,'##amp','&');

961

text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall text := stringreplaceall result := text; End;

(text,'å','å'); (text,'Å','Å'); (text,'ä','ä'); (text,'Ä','Ä'); (text,'á','á'); (text,'Á','Á'); (text,'à','à'); (text,'À','À'); (text,'æ','æ'); (text,'Æ','&Aelig;'); (text,'Â','Â'); (text,'â','â'); (text,'ã','ã'); (text,'Ã','Ã'); (text,'ç','ç'); (text,'Ç','Ç'); (text,'é','é'); (text,'É','É'); (text,'ê','ê'); (text,'Ê','Ê'); (text,'ë','ë'); (text,'Ë','Ë'); (text,'è','è'); (text,'È','È'); (text,'î','î'); (text,'Î','Î'); (text,'í','í'); (text,'Í','Í'); (text,'ì','ì'); (text,'Ì','Ì'); (text,'ï','ï'); (text,'Ï','Ï'); (text,'ñ','ñ'); (text,'Ñ','Ñ'); (text,'ö','ö'); (text,'Ö','Ö'); (text,'ò','ò'); (text,'Ò','Ò'); (text,'ó','ó'); (text,'Ó','Ó'); (text,'ø','ø'); (text,'Ø','Ø'); (text,'Ô','Ô'); (text,'ô','ô'); (text,'õ','õ'); (text,'Õ','Õ'); (text,'ü','ü'); (text,'Ü','Ü'); (text,'ú','ú'); (text,'Ú','Ú'); (text,'Ù','Ù'); (text,'ù','ù'); (text,'û','û'); (text,'Û','Û'); (text,'ý','ý'); (text,'Ý','Ý'); (text,'ÿ','ÿ'); (text,'|',' ');

Function sgml2win(text : String) : String; {Funktion som ersätter alla entiteter mot deras tecken i windows. Den färdiga strängen returneras.} begin text := stringreplaceall (text,'á','á');

962


(text,'Á','Á'); (text,'æ','æ'); (text,'&Aelig;','Æ'); (text,'à','à'); (text,'À','À'); (text,'å','å'); (text,'Å','Å'); (text,'ä','ä'); (text,'Ä','Ä'); (text,'Â' ,'Â'); (text,'â' ,'â'); (text,'ã','ã'); (text,'Ã','Ã'); (text,'ç','ç'); (text,'Ç','Ç'); (text,'é','é'); (text,'É','É'); (text,'è','è'); (text,'È','È'); (text,'ê' ,'ê'); (text,'Ê' ,'Ê'); (text,'ë' ,'ë'); (text,'Ë' ,'Ë'); (text,'î' ,'î'); (text,'Î' ,'Î'); (text,'í','í'); (text,'Í','Í'); (text,'ì','ì'); (text,'Ì','Ì'); (text,'ï' ,'ï'); (text,'Ï' ,'Ï'); (text,'ñ','ñ'); (text,'Ñ','Ñ'); (text,'ò','ò'); (text,'Ò','Ò'); (text,'ó','ó'); (text,'Ó','Ó'); (text,'ö','ö'); (text,'Ö','Ö'); (text,'ø','ø'); (text,'Ø','Ø'); (text,'Ô' ,'Ô'); (text,'ô' ,'ô'); (text,'õ','õ'); (text,'Õ','Õ'); (text,'ü','ü'); (text,'Ü','Ü'); (text,'ú','ú'); (text,'Ú','Ú'); (text,'û' ,'û'); (text,'Û' ,'Û'); (text,'Ù','Ù'); (text,'ù','ù'); (text,'ý',' ý'); (text,'Ý',' Ý'); (text,'ÿ' ,'ÿ'); (text,' ','|'); (text,'&','&');

Function sgml2mac(text : String) : String; {Funktion som ersätter alla entiteter mot deras tecken i mac. Den färdiga strängen returneras.} begin text := stringreplaceall (text,'á',chr(135));

963


(text,'Á',chr(231)); (text,'æ',chr(190)); (text,'&Aelig;',chr(174)); (text,'à',chr(136)); (text,'À',chr(203)); (text,'å',chr(140)); (text,'Å',chr(129)); (text,'Ä',chr(128)); (text,'ä',chr(138)); (text,'Â' ,chr(229)); (text,'â' ,chr(137)); (text,'ã',chr(139)); (text,'Ã',chr(204)); (text,'ç',chr(141)); (text,'Ç',chr(130)); (text,'é',chr(142)); (text,'É',chr(131)); (text,'è',chr(143)); (text,'È',chr(233)); (text,'ê' ,chr(144)); (text,'Ê' ,chr(230)); (text,'ë' ,chr(145)); (text,'Ë' ,chr(232)); (text,'î' ,chr(148)); (text,'Î' ,chr(235)); (text,'í' ,chr(146)); (text,'Í' ,chr(234)); (text,'ì' ,chr(147)); (text,'Ì' ,chr(237)); (text,'ï' ,chr(149)); (text,'Ï' ,chr(236)); (text,'ñ',chr(150)); (text,'Ñ',chr(132)); (text,'ò',chr(152)); (text,'Ò',chr(241)); (text,'ó',chr(151)); (text,'Ó',chr(238)); (text,'Ô' ,chr(239)); (text,'ô' ,chr(153)); (text,'ø',chr(191)); (text,'Ø',chr(175)); (text,'õ',chr(155)); (text,'Õ',chr(239)); (text,'ö',chr(154)); (text,'Ö',chr(133)); (text,'ü',chr(159)); (text,'Ü',chr(134)); (text,'ú',chr(156)); (text,'Ú',chr(242)); (text,'û' ,chr(158)); (text,'Û' ,chr(243)); (text,'Ù',chr(244)); (text,'ù',chr(157)); (text,'ý','y'); (text,'ÿ' ,chr(216)); (text,'Ÿ' ,chr(217)); (text,' ',' '); (text,'&',chr(38));

Function sgml2rtf(text : string) : String; {Funktion för att byta ut sgml-entiteter mot de koder som gäller i RTF-textrutorna.} begin

964

text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text text

:= := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := := :=

stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall stringreplaceall

(text,'}','#]#'); (text,'{','#[#'); (text,'\','HSALSKCAB'); (text,'HSALSKCAB','\\'); (text,'æ','\'+chr(39)+'c6'); (text,'&Aelig;','\'+chr(39)+'e6'); (text,'á','\'+chr(39)+'e1'); (text,'Á','\'+chr(39)+'c1'); (text,'à','\'+chr(39)+'e0'); (text,'À','\'+chr(39)+'c0'); (text,'å','\'+chr(39)+'e5'); (text,'Å','\'+chr(39)+'c5'); (text,'Â','\'+chr(39)+'c2'); (text,'â','\'+chr(39)+'e2'); (text,'ã','\'+chr(39)+'e3'); (text,'Ã','\'+chr(39)+'c3'); (text,'ä','\'+chr(39)+'e4'); (text,'Ä','\'+chr(39)+'c4'); (text,'ç','\'+chr(39)+'e7'); (text,'Ç','\'+chr(39)+'c7'); (text,'é','\'+chr(39)+'e9'); (text,'É','\'+chr(39)+'c9'); (text,'è','\'+chr(39)+'e8'); (text,'È','\'+chr(39)+'c8'); (text,'ê','\'+chr(39)+'ea'); (text,'Ê','\'+chr(39)+'ca'); (text,'ë','\'+chr(39)+'eb'); (text,'Ë','\'+chr(39)+'cb'); (text,'î','\'+chr(39)+'ee'); (text,'Î','\'+chr(39)+'ce'); (text,'í','\'+chr(39)+'ed'); (text,'Í','\'+chr(39)+'cd'); (text,'ì','\'+chr(39)+'ec'); (text,'Ì','\'+chr(39)+'cc'); (text,'ï' ,'\'+chr(39)+'ef'); (text,'Ï' ,'\'+chr(39)+'cf'); (text,'ñ','\'+chr(39)+'f1'); (text,'Ñ','\'+chr(39)+'d1'); (text,'ö','\'+chr(39)+'f6'); (text,'Ö','\'+chr(39)+'d6'); (text,'ó','\'+chr(39)+'f3'); (text,'Ó','\'+chr(39)+'d3'); (text,'ò','\'+chr(39)+'f2'); (text,'Ò','\'+chr(39)+'d2'); (text,'ø','\'+chr(39)+'f8'); (text,'Ø','\'+chr(39)+'d8'); (text,'Ô','\'+chr(39)+'d4'); (text,'ô','\'+chr(39)+'f4'); (text,'õ','\'+chr(39)+'f5'); (text,'Õ','\'+chr(39)+'d5'); (text,'ú','\'+chr(39)+'fa'); (text,'Ú','\'+chr(39)+'da'); (text,'û','\'+chr(39)+'fb'); (text,'Û','\'+chr(39)+'db'); (text,'Ù','\'+chr(39)+'d9'); (text,'ù','\'+chr(39)+'f9'); (text,'ü','\'+chr(39)+'fc'); (text,'Ü','\'+chr(39)+'dc'); (text,'ý','\'+chr(39)+'fd'); (text,'Ý','\'+chr(39)+'dd'); (text,'ÿ','\'+chr(39)+'ff'); (text,'£','\'+chr(39)+'a3'); (text,'#]#','\}'); (text,'#[#','\{'); (text,' ','|'); (text,'&','&');

965

result := text; End; function rtf2sgml (text : string) : string; {Funktion för att konvertera en RTF-rad till SGML-text.} var temptext : string; start : integer; begin text := stringreplaceall (text,'&','##amp;'); text := stringreplaceall (text,'##amp','&'); text := stringreplaceall (text,'\'+chr(39)+'c6','æ'); text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;'); text := stringreplaceall (text,'\'+chr(39)+'e5','å'); text := stringreplaceall (text,'\'+chr(39)+'c5','Å'); text := stringreplaceall (text,'\'+chr(39)+'e4','ä'); text := stringreplaceall (text,'\'+chr(39)+'c4','Ä'); text := stringreplaceall (text,'\'+chr(39)+'e1','á'); text := stringreplaceall (text,'\'+chr(39)+'c1','Á'); text := stringreplaceall (text,'\'+chr(39)+'e0','à'); text := stringreplaceall (text,'\'+chr(39)+'c0','À'); text := stringreplaceall (text,'\'+chr(39)+'c2','Â'); text := stringreplaceall (text,'\'+chr(39)+'e2','â'); text := stringreplaceall (text,'\'+chr(39)+'e3','ã'); text := stringreplaceall (text,'\'+chr(39)+'c3','Ã'); text := stringreplaceall (text,'\'+chr(39)+'e7','ç'); text := stringreplaceall (text,'\'+chr(39)+'c7','Ç'); text := stringreplaceall (text,'\'+chr(39)+'e9','é'); text := stringreplaceall (text,'\'+chr(39)+'c9','É'); text := stringreplaceall (text,'\'+chr(39)+'e8','è'); text := stringreplaceall (text,'\'+chr(39)+'c8','È'); text := stringreplaceall (text,'\'+chr(39)+'ea','ê'); text := stringreplaceall (text,'\'+chr(39)+'ca','Ê'); text := stringreplaceall (text,'\'+chr(39)+'eb','ë'); text := stringreplaceall (text,'\'+chr(39)+'cb','Ë'); text := stringreplaceall (text,'\'+chr(39)+'ee','î'); text := stringreplaceall (text,'\'+chr(39)+'ce','Î'); text := stringreplaceall (text,'\'+chr(39)+'ed','í'); text := stringreplaceall (text,'\'+chr(39)+'cd','Í'); text := stringreplaceall (text,'\'+chr(39)+'ec','ì'); text := stringreplaceall (text,'\'+chr(39)+'cc','Ì'); text := stringreplaceall (text,'\'+chr(39)+'ef','ï'); text := stringreplaceall (text,'\'+chr(39)+'cf','Ï'); text := stringreplaceall (text,'\'+chr(39)+'f1','ñ'); text := stringreplaceall (text,'\'+chr(39)+'d1','Ñ'); text := stringreplaceall (text,'\'+chr(39)+'f3','ó'); text := stringreplaceall (text,'\'+chr(39)+'d3','Ó'); text := stringreplaceall (text,'\'+chr(39)+'f2','ò'); text := stringreplaceall (text,'\'+chr(39)+'d2','Ò'); text := stringreplaceall (text,'\'+chr(39)+'d4','Ô'); text := stringreplaceall (text,'\'+chr(39)+'f4','ô'); text := stringreplaceall (text,'\'+chr(39)+'f5','õ'); text := stringreplaceall (text,'\'+chr(39)+'d5','Õ'); text := stringreplaceall (text,'\'+chr(39)+'f8','ø'); text := stringreplaceall (text,'\'+chr(39)+'d8','Ø'); text := stringreplaceall (text,'\'+chr(39)+'f6','ö'); text := stringreplaceall (text,'\'+chr(39)+'d6','Ö'); text := stringreplaceall (text,'\'+chr(39)+'fc','ü'); text := stringreplaceall (text,'\'+chr(39)+'dc','Ü'); text := stringreplaceall (text,'\'+chr(39)+'fa','ú'); text := stringreplaceall (text,'\'+chr(39)+'da','Ú'); text := stringreplaceall (text,'\'+chr(39)+'fb','û'); text := stringreplaceall (text,'\'+chr(39)+'db','Û'); text := stringreplaceall (text,'\'+chr(39)+'d9','Ù'); text := stringreplaceall (text,'\'+chr(39)+'f9','ù'); text := stringreplaceall (text,'\'+chr(39)+'fd','ý');

966

text := stringreplaceall (text,'\'+chr(39)+'dd','Ý'); text := stringreplaceall (text,'\'+chr(39)+'ff','ÿ'); text := stringreplaceall (text,'|',' '); text := stringreplaceall (text,'\'+chr(39)+'a3','£'); text := stringreplaceall (text,'\}','#]#'); text := stringreplaceall (text,'\{','#[#'); if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then begin result := ''; exit; end; //text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort} //temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort} //text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort} {I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog därför bort det efter \fs16 och la istället en egen tvätt av \cf0.} //temptext := hamtastreng (text,'{\rtf1','\deflang'); //text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang} text := stringreplaceall (text,'\cf0',''); temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få } text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika} text := stringreplaceall (text,'\ltrpar',''); text := stringreplaceall (text,'\ql',''); text := stringreplaceall (text,'\ltrch',''); {Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.} //text := stringreplaceall (text,'\fs16','');{8 punkter} //text := stringreplaceall (text,'\fs20','');{10 punkter} {Nu städar vi istället bort alla tvåsiffriga fontsize.} while pos ('\fs',text) >0 do begin //application.processmessages; start := pos ('\fs',text); Delete(text,start,5); end; while pos ('\f',text) >0 do begin //application.processmessages; start := pos ('\f',text); Delete(text,start,3); end; text := stringreplaceall (text,'\pard\li200200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ','
'); text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','
'); text := stringreplaceall (text, '\par
','
'); text := stringreplaceall (text, '\par
','
'); text := stringreplaceall (text,'\pard\plain ','
'); text := stringreplaceall (text,'\par \plain\b\ul ','
'); text := stringreplaceall (text,'\plain\b\ul ','
'); text := stringreplaceall (text,'\plain',''); text := stringreplaceall (text,'\par }','
'); if (pos ('\par \tab ',text)>0) or (pos ('
\tab ',text)>0) then begin text := stringreplaceall (text,'\par \tab ',''); text := stringreplaceall (text,'
\tab ','');

967

text := stringreplaceall (text,'\tab ',''); end else begin text := stringreplaceall (text,'\tab ',''); end; text := stringreplaceall (text,'\par ','
'); text := stringreplaceall (text,'#]#','}'); text := stringreplaceall (text,'#[#','{'); text := stringreplaceall (text,'\\','\'); if pos('',text)>0 then text := text+''; if pos('
',text)>0 then text := text+'
'; result := text; end; end.

REGULAR EXPRESSIONS From: [email protected] (AlanGLLoyd) In article <[email protected]>, "Darius R." writes: > I don't understand, how works REGULAR EXPRESSIONS in Delphi's Replace >dialog. R e g u l a r E x p r e s s i o n s (extracted form Brief editor help file)

Regular expressions are special characters in search or translate strings that let you specify character patterns to match, instead of just sequences of literal characters. Regular expression characters are similar to DOS wildcards, but are much more powerful. These are the regular expressions: Expression: ? * \t \n \c \\ Character: < or % > or $ @ + {} [ ] [~ ] [a-z]

Matches: Any character except a newline Zero or more characters (except newlines) Tab character Newline character Position cursor after matching Literal backslash Matches: Beginning of line End of line Zero or more of last expression One or more of last expression Either last or next expression Define a group of expressions Any one of the characters inside [ ] Any character except those in [~ ] Any character between a and z, inclusive

In replacement text, \t, \n, and \c are allowed, as well as: \

Substitute text matched by th group (0 <= n <= 9)

968

Pattern:

Result:

the {him} {her} or %alone$ stuff*between

Find the next occurrence of "the". Find the next occurrence of "him" or "her". Finds next occurrence where "alone" is alone on a line. Find next occurrence of "stuff" followed by "between" on the same line. Find next occurrence of "these" or "those". Find next capitalized word with a semicolon after it. Find one or more consecutive digits. Find any character but a space, tab, or newline.

th[eo]se [A-Z][a-z]@; [0-9]+ [~ \t\n]

Note that the *, @, and + expressions will always match as few of the expression in question as possible. Braces {} enclose a group in the Find clause which you want to transfer into the replace clause. You can have multiple groups and each group is identified in the replace by a back-slash followed by the group number (counting from 0, left to right in the find string) So for your example, using Brief regular expressions :Find FString\[{*}\] Replace Ord(FString[\0]) or Find {FString\[*\]} Replace Ord(\0)

4 Small String Routines From: Eric Strs : It does the same as Str (for integers/longints) but in a function form that makes it easier to use when assembling a string. Before : it extracts the part of a string that is before a given substring, or the entire source string if the substring is not found. After : as you might guess extracts the part of a string that is after a given substring, or an empty string if the substring is not found. FP : this function is a "C" style inline conditionnal string that returns a different string based upon the result of a boolean expression. (could be generalized for other data types, but I found it to be most useful for text output. {-----------------------------------------------------------------------------} Function Strs (I:longint) : string ; Var X : string[16] ; begin STR (I,X) ; Strs := X ; end ; {----------------------------------------------------------------------------EX : s :='Username=Mark'; Text := After ('=',s); Text := Text+fp(Text<>'',' is the #There is no

')'+ Before ('=',s);

Text contains 'Mark is the Username' if s contains 'Username' or 'Username=' then Text contains 'There is no Username' -----------------------------------------------------------------------------}

969

Function Before ( Src:string ; Var S:string ) : string ; Var F : Word ; begin F := POS (Src,S) ; if F=0 then Before := S else Before := COPY(S,1,F-1) ; end ; {-----------------------------------------------------------------------------} Function After ( Src:string ; Var S:string ) : string ; Var F : Word ; begin F := POS (Src,S) ; if F=0 then After := '' else After := COPY(S,F+length(src),length(s)) ; end ; {----------------------------------------------------------------------------FP provides an easy way to modify texts according to singular/plural, gender or any boolean conditions. Ex1 : MyText := strs(N)+' machine'+FP (N>1,'s') ; Ex2 : if Nargs<>4 then Msg :='There is too '+FP(Nargs>4,'many#few')+' arguments.'); -----------------------------------------------------------------------------} const MY_SEP : Char = '#" Function FP ( B : Boolean ; S:string ) : string ; begin if POS (MY_SEP,S)>0 then if B then S := Before (MY_SEP,S) else S := After (MY_SEP,S) else if not B then S := '' ; FP := S ; end ;


970

Menu 183. 184. 185. 186. 187.

Catch SHIFT key during menu item selection? How to dynamically create popup menus inside other popups? How do I add a bitmap to a MENU ... How do I dynamically add a MenuItem to a Menu? Hooking a procedure on to a dynamically created popup menu

188. 189.

Too long menus Help popup menu on the right side of the windowmenu6

Catch SHIFT key during menu item selection? From: "Rodney E Geraghty" Try some thing like this: procedure TForm1.Menu11Click(Sender: TObject); begin {Check if Shift key is down} if HiWord(GetKeyState(VK_SHIFT)) <> 0 then Label1.Caption := 'Shift' else {Check if Ctrl key is down} if HiWord(GetKeyState(VK_CONTROL)) <> 0 then Label1.Caption := 'Control' else {Check if Alt key is down} if HiWord(GetKeyState(VK_MENU)) <> 0 then Label1.Caption := 'Alt' else Label1.Caption := 'None'; end;

971

How to dynamically create popup menus inside other popups? From: Chris Jobson Try something like this procedure TForm1.PopupMenu2Popup(Sender: TObject); var mi, msub: TmenuItem; begin with (Sender as TPopupMenu) do begin // Delete all items // while Items.Count > 0 do Items.delete(0); // Old version had resource leak. Leak plugged by Andrew Stewart ([email protected]) while Items.Count > 0 do Items[0].Free; // Create ordinary item "First" mi := TMenuItem.Create(self); with mi do begin Caption := 'First'; OnClick := MyClick; end; Items.Insert(0, mi); // Create a submenu "Sub" with two items "Sub1" and // "Sub2" mi := TMenuItem.Create(self); with mi do begin Caption := 'Sub'; msub := TMenuItem.Create(self); with msub do begin Caption := 'Sub1'; OnClick := MyClick; end; Insert(0, msub); msub := TMenuItem.Create(self); with msub do begin Caption := 'Sub2'; OnClick := MyClick; end; Insert(1, msub); end; Items.Insert(1, mi); end; end; procedure TForm1.MyClick(Sender: TObject); begin beep; end;

972

How do I add a bitmap to a MENU ... From: [email protected] (Kurt Claeys) > How do I add bitmaps to a menu? Maybe like this : var Bmp1 : TPicture; ... Bmp1 := TPicture.Create; Bmp1.LoadFromFile('c:\where\b1.BMP'); SetMenuItemBitmaps( MenuItemTest.Handle, 0, MF_BYPOSITION, Bmp1.Bitmap.Handle, Bmp1.Bitmap.Handle); ...

Create a Picture. Load a .BMP from somewhere into the picture. Use the SetMenuItemBitmaps API call to connect the Picture to the Menu with these parameters : 7. MenuItemTest is the name given to the horizontal Menuitem 8. 0,1 ... is the position of the item on which you want to place the bitmap. (start counting with 0) The first of the two bitmap-handles is the one for the bitmap displayed for the unchecked menuitem. The second is the one for the checked menuitem. These can be the same or not. All this can by coded in the .Create of a form. Result : It works, but only the right-top of the bitmap is displayed. Rest us to change the height and/or width of the menuitem according to the bitmap

How do I dynamically add a MenuItem to a Menu? Solution 1 From: Jeff Lawton Now I'm not sure what your trying to do, add it to the top menu, or as a sub menu item, so I'll include code for both.. You can work it out from there. New Top Level Item: procedure tform1.addmainitem(s:string); var newitem : Tmenuitem; begin newitem:=tmenuitem.create(Mainmenu1); newitem.caption:=s; {if you want to assign an onclick newitem.onclick:=Dynamenuclick; }

973

{add it to the top level menu} mainmenu1.items.insert(mainmenu1.items.count,newitem); removemenu1.enabled:=true; addmenuitem1.enabled:=true; end;

Sub Menu Item: procedure tform1.addsubitem(s:string; to : integer); var newitem, toitem : Tmenuitem; begin {to = top level menu to add item to} toitem:=mainmenu1.items[to]; newitem:=tmenuitem.create(toitem); newitem.caption:=s; {if you want to assign an onclick newitem.onclick:=Dynamenuclick; } toitem.onclick:=nil; toitem.insert(toitem.count,newitem); removemenuitem1.enabled:=true; end;

Solution 2 From: [email protected] (Jani Järvinen) You should use the ready made menu functions defined in the Menus unit. The routines in D2 are as follows: function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu; function NewPopupMenu(Owner: TComponent; const AName: string; Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu; function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string; Items: array of TMenuItem): TMenuItem; function NewItem(const ACaption: string; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word; const AName: string): TMenuItem; function NewLine: TMenuItem;

This is quite messy, but using the functions is easy.

Hooking a procedure on to a dynamically created popup menu Can any body enlighten me on "How to Hooking a procedure on to a popup menu which I create dynamically?" This is what I've done fo far Procedure TTypeOfFrame.CreateAPopUpMenu; var NewItem: TMenuItem; FDragEnabledPopUpMenu : TPopUpMenu; begin NewItem := TMenuItem.Create(Self); NewItem.Caption := 'Drag';

974

FDragEnabledPopUpMenu:= TPopUpmenu.Create(Self); with FDragEnabledPopUpMenu do begin Items.Add(NewItem); end; end;

[Bruno Sonnino, [email protected]] To hook a procedure to this new item, you must create a procedure inside an object (define a private method for the form), like this: procedure MyClick(Sender : TObject);

and then when you create the item you must set its OnClick event like this: NewItem := TMenuItem.Create(Self); NewItem.Caption := 'Drag'; NewItem.OnClick := MyClick;

Too long menus From: [email protected] (Ed Vander Hoek) It will vary the number of menu items per column depending on the screen resolution. It appears to work quite well. The following code assumes that there is a menu item called mnuView, and a OnClick procedure called HandleMenuClick.. procedure TfrmMain.LoadViewMenu; var itemNum: integer; mnu: TMenuItem; menuItemHeight: integer; itemsPerColumn: integer; begin {remove any existing menu items from the View menu} while mnuView.Count > 0 do begin {freeing an item apparently deletes it from the menu} mnuView.Items[0].Free; end; {find the height of each menu item. The 2 was chosen after some experimentation} menuItemHeight := GetSystemMetrics(SM_CYMENU) + 2; {calculate the number of items per column} itemsPerColumn := screen.height div menuItemHeight; {create the items} for itemNum := 0 to 99 do begin mnu := TMenuItem.Create(self); mnu.caption := 'Item ' + inttostr(itemNum); {start a new column if necessary} if (itemNum mod itemsPerColumn = 0) and (itemNum>0) then begin mnu.break := mbBarBreak; end; {assign the method which handles the menu} mnu.OnClick := HandleMenuClick;

975

mnuView.Add(mnu); end; end;

Help popup menu on the right side of the window Matjaz Bravc Example how to put Help popup menu on the right side of the window: unit ODMenuU; interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus, StdCtrls; type TForm1 = class(TForm) MainMenu1: TMainMenu; FileItem1: TMenuItem; ExitItem1: TMenuItem; HelpItem1: TMenuItem; About1: TMenuItem; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin { Move Help menu over to the right } { Windows 95/NT 4 apps support doing it this way ... } {$IFNDEF ALTERNATIVEWAY} ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help, HelpItem1.Handle, '&Help'); {$ELSE} { ... only Win 3.xx supports this } HelpItem1.Caption := #8 + HelpItem1.Caption; {$ENDIF} end; end.

That's all! Simple? :) From: "Daniel Steiner" Even if Microsoft tells in the Windows Styles Guides not to align menu items to the right, here is how you can do it. You should check the Win32API help file for the second and the third function parameter of GetMenuItemInfo and SetMenuItemInfo. 976

procedure TForm1.FormCreate(Sender: TObject); var MMI: TMenuItemInfo; MyMenu: hMenu; Buffer: array[0..79] of Char; begin MyMenu := GetMenu(Handle); // Handle is the handle of the form that contains the menu MMI.cbSize := SizeOf(MMI); MMI.fMask := MIIM_TYPE; MMI.dwTypeData := Buffer; MMI.cch := SizeOf(Buffer); GetMenuItemInfo(MyMenu, 1, True, MMI); // (..., 1, True, ...) means that help is the second menu item. MMI.fType := MMI.fType or MFT_RIGHTJUSTIFY; SetMenuItemInfo(MyMenu, 1, True, MMI); end;


977

DELPHI NEW TRICKS by TanZ tHe AnthroX {Copyright Bloodshed Software Please send feedback to: [email protected] http://bloodshed-software.home.ml.org/ } unit Shareware; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Registry; type TShareware = class(TComponent) private FParentForm: TForm; FNumberOfDay: Integer; { Déclarations privées } protected { Déclarations protégées } public constructor Create(AOwner: TComponent); override; procedure Execute; { Déclarations publiques } published property NumberOfDay: Integer read FNumberOfDay write FNumberOfDay; end; procedure Register; implementation procedure Register; begin RegisterComponents('Bloodshed', [TShareware]); end; constructor TShareware.Create(AOwner: TComponent); begin inherited Create(AOwner); if AOwner is TForm then FParentForm := TForm(AOwner) else begin Application.MessageBox('TShareware can only be placed in a form', 'Error', mb_OK); Fail; end; {Default value of the number of days the user is allowed to use the software} FNumberOfDay:= 30; NumberOfDay:= FNumberOfDay; end; procedure TShareware.Execute; var KeyHandle: HKEY; Expired: Boolean; ExpireDate: TDateTime; ValSize: longint; begin Expired := false; { default expire date is the next 30 days } ExpireDate := Date + NumberofDay; { open registry... }

978

{ read/write the key from/to "secret" key } { in this case, Windows' global registry key! } RegOpenKeyEx(HKEY_CURRENT_CONFIG, 'Software\Microsoft\windows\CurrentVersion\', 0, KEY_ALL_ACCESS, KeyHandle); { query "secret" values... } ValSize := SizeOf(Expired); RegQueryValueEx(KeyHandle,'WinD', nil, nil, @Expired, @ValSize); ValSize := SizeOf(ExpireDate); RegQueryValueEx(KeyHandle,'WinE', nil, nil, @ExpireDate, @ValSize); { is Expire date >= today? } if Date >= ExpireDate then Expired := True; { set back "secret" values } { query "secret" values... } RegSetValueEx(KeyHandle,'WinD', 0, REG_BINARY, @Expired, SizeOf(Expired)); RegSetValueEx(KeyHandle,'WinE', 0, REG_BINARY, @ExpireDate, SizeOf(ExpireDate)); { don't forget to CLOSE it!!! } RegCloseKey(KeyHandle); { has this program expired? } if Expired then begin MessageDlg('Sorry. ' + 'This software has expired the ' + FormatDateTime('dddddd', ExpireDate) + '. ' + 'Please register it!', mtInformation, [mbOK], 0); { Bye Bye! } Application.Terminate; end else { notify the expire date } MessageDlg('This software will expired on ' + FormatDateTime('dddddd', ExpireDate), mtWarning, [mbOK], 0); end; end.

979

unit registration; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry, ComObj; type EProgramID = class(Exception); type TRegistration = class(TComponent) constructor Create(AOwner: TComponent); override; destructor Destroy; override; function Status(PID: TGUID; Days: integer; Flag: boolean): Boolean; function Verify(PID: TGUID; RGID: string):Boolean; private FDays: integer; FLicense: string; FNumber: string; FExpired: Boolean; FRegistered: Boolean; procedure Compute; protected // protected published property License: string read FLicense; property Number: string read FNumber write FNumber; property Days: Integer read FDays write FDays; property Expired: Boolean read FExpired write FExpired; property Registered: Boolean read FRegistered write FRegistered; end; procedure Register; implementation //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm procedure Register; begin RegisterComponents('Donth',[TRegistration]); end; //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm constructor TRegistration.Create(AOwner: TComponent); begin inherited Create(AOwner); FDays := 0; FLicense := ''; FNumber := ''; FExpired := TRUE; // At this point we really don't know FRegistered := FALSE; // Ditto end; //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm destructor TRegistration.Destroy; begin inherited Destroy; end; //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm

980

procedure TRegistration.Compute; const mkr = '1703730891735894587126710684391856791750134568720576153982937652'; var rslt, dx: integer; begin rslt := 0; FNumber := ''; for dx := 1 to length(FLicense) do begin if FLicense[dx] = '-' then begin FNumber := FNumber + '-'; end else begin rslt := rslt + ord(FLicense[dx]); FNumber := FNumber + mkr[(rslt mod 64)+1]; end; end; end; //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm function TRegistration.Verify(PID: TGUID; RGID: string):Boolean; var Reg: TRegistry; guid: string; begin // Make sure we have a valid GUID try Guid := GUIDToString(PID); except raise EProgramID.Create('Missing or invalid Program ID'); exit; end; if RGID = FNumber then begin Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey('\Software\CLASSES\CLSID\' + Guid + '\ProgID', TRUE); reg.WriteString('','000000'); Reg.CloseKey; Reg.free; Result := TRUE; FRegistered := TRUE; FExpired := FALSE; end else begin Result := FALSE; end; end; //mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm mmmmmmmmmm function TRegistration.Status(PID: TGUID; Days: integer; Flag:boolean): Boolean; var guid, temp: string; Reg: TRegistry; today: integer; VersionInfo: TOSVersionInfo; begin today := trunc(Date); // Get today's date // Make sure we have a valid GUID try Guid := GUIDToString(PID); except raise EProgramID.Create('Missing or invalid Program ID'); exit; end; VersionInfo.dwOSVersionInfoSize := sizeOf(TOSVersionInfo); GetVersionEx(VersionInfo);

981

Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; case VersionInfo.dwPlatformID of VER_PLATFORM_WIN32_WINDOWS: begin Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion', TRUE); temp := Reg.ReadString('ProductID'); end; VER_PLATFORM_WIN32_NT: begin Reg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion', TRUE); temp := Reg.ReadString('ProductID'); end; end; temp := copy(temp,11,7) + copy(temp,1,5); FLicense := copy(temp,1,4)+'-'+copy(temp,5,4) + '-' + copy(temp, 9, 4)+'-'+copy(Guid, length(guid)-4,4); Reg.CloseKey; Compute; // Get the Registry key Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey('\Software\CLASSES\CLSID\' + Guid + '\ProgID', TRUE); temp := Reg.ReadString(''); // If a blank, we do not have a key if Flag = TRUE then temp := ''; // We want a NEW Registration record if temp = '' then begin // Create a new record if days = 0 then temp := '000000' else temp := IntToHex(Days+today,6); Reg.WriteString('',temp); end; Reg.CloseKey; Reg.free; if temp = '000000' then begin FDays := -1; end else begin FDays := StrToInt('$'+temp) - today; if FDays < 0 then FDays := 0; end; if FDays = -1 then begin // We are registered FRegistered := TRUE; FExpired := FALSE; end else if FDays = 0 then begin // We are expired FRegistered := FALSE; FExpired := TRUE; end else begin FRegistered := FALSE; FExpired := FALSE; end; Result := FExpired; end; end. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,Spin, ExtCtrls, registration; // <<<<<<<<<<< ADD THIS LINE type TForm1 = class(TForm) GroupBox1: TGroupBox; Label6: TLabel; spinDays: TSpinEdit;

982

Label7: TLabel; chkNew: TCheckBox; Label9: TLabel; Button2: TButton; GroupBox2: TGroupBox; Label1: TLabel; edtRegistration: TEdit; Label2: TLabel; Button1: TButton; GroupBox3: TGroupBox; lblLicense: TLabel; lblRegistration: TLabel; lblDays: TLabel; lblRegistered: TLabel; lblExpired: TLabel; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button2Click(Sender: TObject); procedure UpdateData; private { Private declarations } public { Public declarations } end;

const ProgramID: TGUID = '{4736F5A0-41D5-11D3-AA01-B2A8A441DC7B}'; // <<<< ADD THIS LINE // create this line ^^^^ by typing in "const ProgramID: TGUID =" (without the quotes) // and then typing Crtl-Shift-G. Edit out the "[]" brackets... var Form1: TForm1; reg: TRegistration; // <<<<< ADD THIS LINE implementation {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject); begin reg := TRegistration.Create(Self); // <<<< ADD THIS LINE end; procedure TForm1.FormDestroy(Sender: TObject); begin reg.free; // <<<< ADD THIS LINE end; procedure TForm1.Button1Click(Sender: TObject); begin reg.verify(ProgramID, edtRegistration.text); // <<<< ADD THIS LINE UpdateData; end; procedure TForm1.Button2Click(Sender: TObject); begin reg.Status(ProgramID, spinDays.value, ChkNew.checked); // <<<< ADD THIS LINE UpdateData; end; procedure TForm1.UpdateData; begin

983

lblLicense.caption := 'License number: ' + reg.license; lblRegistration.caption := 'Registration number: ' + reg.number; lblDays.caption := 'Number of days: '+ IntToStr(reg.days); if reg.registered = TRUE then begin lblRegistered.caption := 'Program is registered'; end else begin lblRegistered.caption := 'Program is NOT registered'; end; if reg.expired = TRUE then begin lblExpired.caption := 'Program is expired'; end else begin lblExpired.caption := 'Program is NOT expired'; end; end; end.

984

unit LockDemo; { ***************************************************** LockDemo ***************************************************** © Copyright 1997 by Martin Djernæs (rel.130397) ***************************************************** } interface Uses Classes, { RegisterClass, RegisterComponents } mdSWLock, { The SWLock module - see mdSWLock.txt } LockEdit; { Another Lock editor } Type { --- TLockDemo / TmdLockDemo.About : TLockDemo --- } TLockDemo = Class(TmdSWLock) Protected Function RegIdent : TmdRegString; Override; Public Function GetStr(Code : Integer) : String; Override; end; { --- TmdLockDemo / Component which should be registered --- } TmdLockDemo = Class(TComponent) FAbout : TLockDemo; Public Constructor Create(AOwner : TComponent); Override; Destructor Destroy; Override; Published Property About : TLockDemo Read FAbout Write FAbout; end; Procedure Register; implementation

{ --- TLockDemo --- } Function TLockDemo.RegIdent : TmdRegString; Begin { This string is used to make your own unique version of the mdSWLock } { - The prefix (befor the comma) is a visible ID which will be the first part of the registration key - The suffix (after the comma) is included in the registration key so you key not looks like any others } Result := 'DEMO,Demo code'; end; Function TLockDemo.GetStr(Code : Integer) : String; Begin { Custom error/information strings - only sNotRegisteret and sCopyright exists } Case Code of sNotRegistered : Result := 'The component '+Owner.ClassName+' is not registret - '+ 'Demo component by Martin Djernæs 1997'; sCopyright : Result := Owner.ClassName+

985

' by Martin Djernæs 1997'; else Result := Inherited GetStr(Code); end; end; { --- TmdLockDemo --- } Constructor TmdLockDemo.Create(AOwner : TComponent); Begin Inherited Create(AOwner); FAbout := TLockDemo.Create(Self); { Locks the component passed as Owner } end; Destructor TmdLockDemo.Destroy; Begin FAbout.Free; { Release you memory :-) } Inherited Destroy; end; Procedure Register; Begin { Register the Demo component } RegisterComponents('mdVCL', [TmdLockDemo]); RegisterSWLock(TypeInfo(TLockDemo), { Register the property for the } TmdLockDemo, { Delphi enviroment } 'About', TfmLockEdit); { <-- Alternative editor } end; Initialization RegisterClass(TmdLockDemo); { All classes which should be detected by the mdSWLock should be registered in runtime } end.

unit Lockedit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, mdSWLock, StdCtrls, Buttons; type TfmLockEdit = class(TmdRegisterForm) BitBtn1: TBitBtn; BitBtn2: TBitBtn; Label1: TLabel; Label2: TLabel; Edit1: TEdit; Edit2: TEdit; private { Private declarations } public { Public declarations } Function Register(ASWLock : TmdSWLock) : TModalResult; Override; end; var fmLockEdit: TfmLockEdit; implementation

986

{$R *.DFM} Function TfmLockEdit.Register(ASWLock : TmdSWLock) : TModalResult; Begin If ASWLock.Registered Then Caption := 'REGISTERED - ' else Caption := 'UNREGISTERED - '; Caption := Caption + ASWLock.Owner.ClassName; Edit1.Text := ASWLock.RegName; Edit2.Text := ASWLock.RegCode; Result := Inherited Register(ASWLock); If Result = mrOK Then ASWLock.Register(Edit1.Text,'',ASWLock.Owner.ClassName,Edit2.Text); end; end.

987

unit RegisterTa; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry; type TRegister = class(TComponent) private { Déclarations privées } FPassWord:string; FTexte:string; FNomProg:string; FRegistered:boolean; FNbreJours:integer; FMess:string; FParvenir:string; function GetTexteCode:string; function GetTexteDecode:string; protected { Déclarations protégées } public { Déclarations publiques } procedure TestRegistered; property Registered:boolean read FRegistered; published { Déclarations publiées } property PassWord:string read FPassWord write FPassWord; property NomProg:string read FNomProg write FNomProg; property NbreJours:integer read FNbreJours write FNbreJours; property RegisterMessage:string read FMess write FMess; property ParvenirMessage:string read FParvenir write FParvenir; end; procedure Register; implementation function TRegister.GetTexteCode:string; var psw,txt,txtf:array[0..250] of char; posp,post,lenp,lent:integer; begin strpcopy(psw,FPassWord); strpcopy(txt,FTexte); lenp:=length(FPassWord); lent:=length(FTexte); txtf:=''; posp:=0; for post:=0 to lent-1 do begin txtf[post]:=chr(ord(psw[posp])+ord(txt[post])); inc(posp); if posp=lenp then posp:=0; end; result:=strpas(txtf); end;

function TRegister.GetTexteDecode:string;

988

var psw,txt,txtf:array[0..250] of char; posp,post,lenp,lent:integer; begin strpcopy(psw,FPassWord); strpcopy(txt,FTexte); lenp:=length(FPassWord); lent:=length(FTexte); txtf:=''; posp:=0; for post:=0 to lent-1 do begin txtf[post]:=chr(ord(txt[post])-ord(psw[posp])); inc(posp); if posp=lenp then posp:=0; end; result:=strpas(txtf); end;

procedure TRegister.TestRegistered; var MyReg:TRegistry; Code,UserID,Mess,Parvenir:string; InstDate,UsedDate:TDateTime; Reponse:word; DifJours:integer; begin if FPassWord='' then FPassWord:=InputBox('Error', 'Please enter PassWord for encryption', 'PassWord'); if FNomProg='' then FNomProg:=InputBox('Error', 'Please enter your application name', 'NomProg'); if FParvenir='' then FParvenir:=InputBox('Error', 'Please enter the address where the user can send you the registration file', 'Parvenire'); MyReg:=TRegistry.create; MyReg.LazyWrite:=False; MyReg.RootKey:=HKEY_LOCAL_MACHINE; MyReg.OpenKey('\software\'+FNomProg+'\LastUsed',true); if MyReg.ReadString('')='' then begin FTexte:=DateToStr(Date); MyReg.WriteString('',GetTexteCode); end; MyReg.CloseKey; MyReg.OpenKey('\software\'+FNomProg+'\Code',true); if (MyReg.ValueExists('')=true) and (MyReg.ReadString('')<>'') then begin FTexte:=MyReg.ReadString(''); Code:=GetTexteDecode; MyReg.CloseKey; MyReg.OpenKey('\software\microsoft\windows\currentversion',false); UserID:=MyReg.ReadString('RegisteredOwner'); if UserID<>Code then begin MessageDlg('Registration code error.',mtwarning,[mbok],0); application.terminate; end; FRegistered:=True; end else begin MyReg.CloseKey;

989

MyReg.OpenKey('\software\'+FNomProg+'\InstDate',true); if (MyReg.ValueExists('')=true) and (MyReg.ReadString('')<>'') then begin FTexte:=MyReg.ReadString(''); InstDate:=StrToDate(GetTexteDecode); DifJours:=round(abs(Date-InstDate)); MyReg.CloseKey; MyReg.OpenKey('\software\'+FNomProg+'\LastUsed',true); FTexte:=MyReg.ReadString(''); UsedDate:=StrToDate(GetTexteDecode); if UsedDate>Date then begin MessageDlg('Erreur !'+#10#13+'The computer date has been changed !!',mtWarning,[mbOK],0); application.terminate; end; if DifJours>FNbreJours then begin mess:='Your trial time is finished.'+#13#10+'Please register.'; if FMess<>'' then Mess:=Mess+#13#10+FMess; Mess:=Mess+#13#10+'Would you like to register ?'; reponse:=messagedlg(Mess,mtinformation,[mbyes,mbno],0); if reponse=mryes then begin MyReg.CloseKey; MyReg.OpenKey('\software\microsoft\windows\currentversion',false); UserID:=MyReg.ReadString('RegisteredOwner'); writeprivateprofilestring('Info','Prog',pchar(FNomProg),pchar(extractfilepath(application.exename)+'Register. dat')); writeprivateprofilestring('Info','User',pchar(userid),pchar(extractfilepath(application.exename)+'Register.dat')) ; parvenir:='The "register.dat" file which contain the informations needed for your registration has been created in its directory.'+#13#10+FParvenir; messagedlg(Parvenir,mtinformation,[mbok],0); application.terminate; end else application.terminate; end else begin mess:='Trial time : '+inttostr(FNbreJours-DifJours)+' days remaining before the registration.'+#13#10+'You should register now.'; if FMess<>'' then Mess:=Mess+#13#10+FMess; Mess:=Mess+#13#10+'Souhaitez vous vous enregistrer ?'; reponse:=messagedlg(Mess,mtinformation,[mbyes,mbno],0); if reponse=mryes then begin MyReg.CloseKey; MyReg.OpenKey('\software\microsoft\windows\currentversion',false); UserID:=MyReg.ReadString('RegisteredOwner'); writeprivateprofilestring('Info','Prog',pchar(FNomProg),pchar(extractfilepath(application.exename)+'Register. dat')); writeprivateprofilestring('Info','User',pchar(userid),pchar(extractfilepath(application.exename)+'Register.dat')) ; parvenir:='Le fichier "register.dat" contenant les informations nécessaires à votre enregistrement vient d''être créé dans le répertoire de l''application.'+#13#10+FParvenir; messagedlg(Parvenir,mtinformation,[mbok],0); end; end; end else

990

begin FTexte:=DateToStr(Date); MyReg.WriteString('',GetTexteCode); end; MyReg.CloseKey; MyReg.OpenKey('\software\'+FNomProg+'\LastUsed',true); FTexte:=DateToStr(Date); MyReg.WriteString('',GetTexteCode); FRegistered:=False; end; MyReg.CloseKey; MyReg.Free; end;

procedure Register; begin RegisterComponents('Freeware', [TRegister]); end; end. unit princ; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, Wordcap, AdvStatusBar, RegisterT, Hemibtn; type TForm1 = class(TForm) editor: TRichEdit; Button1: TButton; OpenDialog1: TOpenDialog; Edit1: TEdit; Edit2: TEdit; MSOfficeCaption1: TMSOfficeCaption; AdvStatusBar1: TAdvStatusBar; Label1: TLabel; Register1: TRegister; HemisphereButton1: THemisphereButton; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure HemisphereButton1Click(Sender: TObject); private { Déclarations privées } public { Déclarations publiques } end; var Form1: TForm1; implementation uses Info; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var fich:string; psw,prog,userid,txtf:array[0..250] of char; post,posp,lent,lenp:integer;

991

begin opendialog1.execute; fich:=opendialog1.filename; getprivateprofilestring('Info','User','Aucun',userid,250,pchar(fich)); getprivateprofilestring('Info','Prog','Aucun',prog,250,pchar(fich)); lenp:=edit1.gettextlen; edit1.gettextbuf(psw,lenp+1); posp:=0; edit2.text:=userid; lent:=edit2.gettextlen; for post:=0 to lent do begin txtf[post]:=chr(ord(userid[post])+ord(psw[posp])); inc(posp); if posp=lenp then posp:=0; end; editor.lines.add('REGEDIT4'); editor.lines.add('[HKEY_LOCAL_MACHINE\SOFTWARE\'+prog+'\Code]'); editor.lines.add('@="'+txtf+'"'); editor.lines.savetofile(extractfilepath(application.exename)+prog+'.reg'); Label1.Caption:='Fichier '+extractfilepath(application.exename)+prog+'.reg'+' créé'; end;

procedure TForm1.FormCreate(Sender: TObject); begin Register1.TestRegistered; if Register1.Registered then Label1.Caption:='Programme enregistré' else Label1.Caption:='Programme non enregistré'; end; procedure TForm1.HemisphereButton1Click(Sender: TObject); begin Infos.Show; end; end.

992

The Unofficial Newsletter of Delphi Users - by Robert Vivrette

Automatic Syntax Highlighting Using a RichEdit Control (Updated with fixes) Part 1 of "A Tale of Two RichEdits" by Jon Hogan-Doran - [email protected] Introduction As a new programmer to Delphi, with a history in C, C++, Unix shells and a little Awk and Perl, I came to it with a particular goal in mind. I wanted to implement an Editor for a Australian-4GL Databse language called cl4. Having little to no experience in Windows programming, except some dalliance in Powerbuilder and SQLExpress, it seemed a pretty imposing goal. One is often taught when learning a new language to read a few books, tryout the samples and then start some simple coding. Unfortunately I'm a bit of a sado-masochist, and love to jump in with all 10 fingers (and 10 toes) and try to implement the most difficult parts first, and all at once. Being able to print "Hello World" never caught my interest. I guess I had a bad upbringing. I started programming by jumping into a language called "C" on SCO Xenix in 1986 with no programming experience at all. Just a book by two guys called Kerningham and Ritchie and some C code that wouldn't compile (it was BSD Unix based from memory). When I managed to get it to compile after 2 weeks, I decided to port the BinkleyTerm FidoNet mailer to Unix, while concurrently getting all the associated programs ported from Dos as well (the Fido mailer, Newsgroup controller, a entire BBS Program). I think I had 5 different DOS->UNIX programs compiling on 5 different virtual consoles all at once. 12 Months later and my [DosLib] and [FossilDriver] were done, BinkleyTerm was getting me my first newsgroups (comp.os.xenix.???) from a local friendly Sysop, and I was chewing up $1,000 in overseas phone bills organising a world-wide group of programmers to try out my handiwork. So with Delphi I started on my next big challenge. I didn't want just any old editor for my old 4GL Unix database language. I wanted it all: 190. code-highlighting 191. on the spot syntax highlighting 192. code completion and suggesting 193. remote compile capabilities to my Linux box 194. jump to line with error 195. even a remote visual debugger plus lots more goodies. This is my adventure. Its a story not a traditional tutorial - the codes there if your not interested in reading my little tale. But if you are: sit back with a packet of chips and plenty of caffeine. And enjoy.... The Plan No-one wants to re-invent the wheel. The whole point of OOP (Object oriented programming) is the reusability of objects. The whole point of the Internet was the reusability of someone else's object. Luckily I had read enough about these component "things" to want to find some more. So I connected up to the Internet and went "shopping". My shopping list: 7. Internet controls (telnet, remote shell, remote execute, ftp) 8. Editor with multi-file capabilities 9. Syntax highlighter or Parser 10. Automatic Syntax highlighting I shopped at: · Delphi Super Page · Torri's page · Borland · RxLib's · RzLib's

993

· QuickReport Homepage Within 4 hour I was off the net with a number of goodies, 23 or so assorted controls, programs and Internet suites, (and plenty of stuff that had nothing to do with the current project, but I thought might be of use on my next one). Eventually I whittled the choices down to: YourPasEdit by D C AL CODA, Ken Hale and Coda Hale PasToRTF by Martin Waldenburg (included in above) TntClient by Francois Piette (and associated ICS suite) RxTools by those great Russian dudes. YourPasEdit was a great find, and its description said it all: There are three main features in YourPasEdit. First is the PAS to RTF conversion unit, contained in mwPasToRtf.pas, by Martin Waldenburg. The second shows how to create TabSheets at run time, with a RichEdit. The third are the procedures written by Andrius Adamonis, which allow YourPasEdit to be associated with files and to open those files in the running instance of YourPasEdit, creating a new TabSheet and RichEdit for the newly opened file. Unfortunately it also told me: It is not intended to be a full Delphi file editor, because it does not highlight keywords on the fly, like a syntax aware editor. But I wasn't complaining - I needed some challenge - otherwise it wouldn't be any fun! So I delved into how things were being done in YourPasEdit. To get the best from the following sections you should get your hands on at least YourPasEdit so you can follow and (more importantly) program along. Syntax highlight (YourPasEdit) In YourPasEdit, syntax highlighting was done by parsing the plain text file, dividing each line of text into separate "Tokens", working out what TokenType each token was, and formatting them based on preset Font and Color settings. The following tokens were supported, corresponding to the Token types in the Delphi 3.0 Editor: TTokenState = (tsAssembler, tsComment, tsCRLF, tsDirective, tsIdentifier, tsKeyWord, tsNumber, tsSpace, tsString, tsSymbol, tsUnknown); How these tokens were formatted (that is with what Color and Attributes) was determined by using the Delphi 3.0 Editors own settings as they are stored in the Windows Registry. Basically a line of Pascal source such as:

procedure TForm1.FormCreate(Sender: TObject); { Create the Form }

would be divided up into: procedure TForm1 . FormCreate ( Sender : TObject ); {Create Form}

tsKeyWord tsSpace tsIdentifier tsSymbol tsIdentifier tsSymbol tsIdentifier tsSymbol tsIdentifier tsSymbol tsSpace tsComment tsCRLF How is it Done?

The RichEdit control normally loads preformatted text from .RTF files by way of by of the RichEdit.Lines.LoadFromFile() function. YourPasEdit uses the RichEdit.Lines.LoadFromStream() function to load the file from a TPasConversion - a custom TMemoryStream descendant. This stream takes the plaint text Pascal source file, loads it into its internal memory buffe, and then converts it from plain text to

994

a text impregnated with RTF codes. This way when it is loaded into the RichEdit control via RichEdit.Lines.LoadFromStream the Pascal source file appears in the control color-syntax highlighted. To the main Editor, this process is transparent - the code looks something like this: begin NewRichEdit := TRichEdit.Create; PasCon.Clear; // Prepare the TPasConversion PasCon.LoadFromFile(FName); // Load the File into the Memory Stream PasCon.ConvertReadStream; // Convert the stream to RTF format NewRichEdit.Lines.BeginUpdate; NewRichEdit.Lines.LoadFromStream(PasCon); // Read from the TPasConversion NewRichEdit.Lines.EndUpdate NewRichEdit.Show; Result := NewRichEdit; end EXAMPLE - snippet of code from the NewRichEditCreate(Fname) routine As I said, it is the TMemoryStream derived TPasConversion which does all the hard work: | V Plain source loaded into memory (TPasConversion.LoadFromFile) | V Converted internally by parsing the source file (ConvertReadStream) | V Result made available (SetMemoryPointer) | V RichEdit.LoadFromStream Most of the work in TPasConversion is done by the ConvertReadStream procedure. Its purpose is to split up each line of source code into tokens (as showed previously) and then depending on its TokenType, load it into the outbuffer preceded by RTF codes to make it a particular Color, Bold, Italics etc. Here what it looks like: // prepare the Outbuf to a certain default size FOutBuffSize:= size+3; ReAllocMem(FOutBuff, FOutBuffSize); // Initialise the parser to its beginning state FTokenState := tsUnknown; FComment := csNo; FBuffPos := 0; FReadBuff := Memory; // Write leading RTF Header WriteToBuffer('{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS SansSerif;} {\f1\froman\fcharset2 Symbol;}{\f2\fmodern Courier New;}}'+#13+#10); WriteToBuffer('{\colortbl\red0\green0\blue0;}'+#13+#10); WriteToBuffer('\deflang1033\pard\plain\f2\fs20 '); // Create the INSTREAM (FReadBuff) and tokenize it Result:= Read(FReadBuff^, Size); FReadBuff[Result] := #0; if Result > 0 then begin Run:= FReadBuff; TokenPtr:= Run; while Run^ <> #0 do begin Case Run^ of #13: // Deal with CRLFs begin FComment:= csNo;

995

HandleCRLF; end; #1..#9, #11, #12, #14..#32: // Deal with various whitespaces, control codes begin while Run^ in [#1..#9, #11, #12, #14..#32] do inc(Run); FTokenState:= tsSpace; TokenLen:= Run - TokenPtr; SetString(TokenStr, TokenPtr, TokenLen); SetRTF; WriteToBuffer(Prefix + TokenStr + Postfix); TokenPtr:= Run; end; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~ much code removed ~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ end; end EXAMPLE - snippet showing the while loop that breaks up the INSTREAM into recognised tokens Most of the work is done by the [case Run^ in ... end;] section which "breaks off" a token from the INSTREAM (FReadBuf) based on the logic in the case statement. The case statement is organised in such a way that it can quickly decipher the input stream into the various TokenTypes by examining each character in turn. Having worked out which tokentype it is, the actual encoding part is relatively easy: FTokenState:= tsSpace; TokenLen:= Run - TokenPtr; SetString(TokenStr, TokenPtr, TokenLen); ScanForRTF; SetRTF; WriteToBuffer(Prefix + TokenStr + Postfix); EXAMPLE - basic steps in encoding the output stream of the TPasConversion object What’s happening here is the program: · sets FTokenState to what we believe it is (in this part of the code it is tsSpace which matches any series of Whitespaces) · the length of the token is calculated by working out how far the current memory pointer (Run) has moved since we finished with the last token (TokenPtr). · the token is then copied from the Input buffer from the starting position of it in the memory buffer (TokenPtr) for the length of the token, into the variable TokenStr. · ScanForRtf just checks through the resultant TokenStr to ensure it doesn't have any funny characters that the RichEdit would confuse as RTF commands. If it finds any, it escapes them out. · SetRTF looks at the FTokenState to populate two global variables Prefix and Postfix with the appropriate RTF codes to give the token the right Color,Font,Boldness. · WriteToBuffer than simply puts the TokenStr with the Prefix and Postfix around it into the output buffer, and the loop then continues on. Back to the topic: Syntax Highlighting (on-the-fly) No source code is necessarily 100% applicable to your needs. I was fortunate in that most of the parser applied to my 4GL command syntax (e.g Strings were strings, Numbers were numbers, similar Keywords). As well YourPasEditor had implemented most of the basic accessory tasks such as Printing, Find, Find and Replace, Multi-File editing. It was just a matter of adding in the extras I was after. PROBLEM #1 - No colours or fonts One task the Parser didn't fully implement was Colors or Different Fonts, or even fonts sizes. The reason for this (after some trial and error) was that the SetRTF procedure new nothing about how to do this. It only used the information in regards [Bold], [Italics] and [Underline] stored in the Win95 Registry for the Delphi Editors Settings to determine how to highlight each token. As for fonts - well I hadn't realised that the Delphi Editor actually uses only one Font and Fontsize for all the different tokens - so that wasn't Pas2Rtf fault. I was just being greedy. Luckily the comments in Pas2Rtt.pas told me what the other values in the Registry coded for, especially where the important foreground color was stored. This meant some changes to: 1. procedure SetDelphiRTF(S: String; aTokenState: TTokenState); Add after the try; Font.Color := StrToInt(Ed_List[0]); 2. procedure TPasConversion.SetPreAndPosFix Add after FPreFix[aTokenState] = '';

996

FPreFixList[aTokenState] := ColorToRtf(aFont.Color); The ColorToRtf codes is already present, but hadn't been used for some reasone. If you try it out you'll understand why :-). You get absolutely no change except lots of ';' in the wrong place.Change the ';' to '(space)' in ColorToRtf(), and you get rid of the ';' appearing in the RichEdit control, but no Colors anyway. My first thought was that the value in Ed_List[0] didn't convert to a proper Font.Color. The easiest way to test this was to hard code Font.Color := clGreen; and see what happens. Again no luck. The format was consistent with the RTF codes I could see in the RTF header. What the $#%#$%# was wrong with it ? It was about then that I realised I needed a crash course in RTF document structure. For this I rushed off to www.microsoft.com (please forgive me) and found a reference on RTF. After an hour of reading a Microsoft Technical Document I was even more confused. Oh well - this meant it was time to get dirty. Time to get down to real programmer stuff. Time to "cheat". What did I do? I went into WordPad (which is just a glorified RichEdit version 2.0 on steroids) and saved various files into RTF format. I then opened them in NotePad so I could see the RTF codes and compare what happened in each case: what codes were produced depending on what I did, or didn't do. A similar sort of technique was used back in the 1980s to decipher the first Paradox database format :-) Sorry Borland. blank.rtf - empty -so I could see the "plain" header line {\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}} {\colortbl\red0\green0\blue0;}\deflang1033\pard\plain\f2\fs20 \par } plaintext.rtf - too see how having any text was handled {\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}}{\colortbl\red0\green0\blue0;} \deflang1033\pard\plain\f2\fs20 this is plain text \par } difffont.rtf - different font, same size, same text {\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}{\f3\fswiss\fprq2 Arial;}}{\colortbl\red0\green0\blue0;} \deflang1033\pard\plain\f3\fs20 plain text different font\plain\f2\fs20 \par } diffsize.rtf - text set to 18 point in the default font {\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}}{\colortbl\red0\green0\blue0;} \deflang1033\pard\plain\f2\fs36 plain text different font\plain\f2\fs20 \par } diffcolor.rtf - etc. my favourite of course - blue. {\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}}{\colortbl\red0\green0\blue0;\red0\green0\blue255;} \deflang1033\pard\plain\f2\fs20\cf1 plain text different font\plain\f2\fs20 \par } Looking at the resultant codes you see how the RTF stream is formatted. It comprises a: 20. INITIAL HEADER (\rtf1\.....) 21. FONTTABLE (\f0\fswiss...) 22. COLORTABLE (\colortbl) 23. MISCELLANEOUS 24. DEFAULT FORMAT (\pard....) 25. BODY OF THE FILE. As a result of that I rewrote this code: WriteToBuffer('{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS SansSerif;}{\f1\froman\fcharset2 Symbol;}{\f2\fmodern Courier New;}}'+#13+#10); WriteToBuffer('{\colortbl\red0\green0\blue0;}'+#13+#10); WriteToBuffer('\deflang1033\pard\plain\f2\fs20 '); to become: WriteToBuffer('{\rtf1\ansi\deff0\deftab720'); WriteFontTable;

997

WriteColorTable; WriteToBuffer('\deflang1033\pard\plain\f0\fs20 '); The procedures Write[Font,Color]Table basically creates a table of fonts/colors we can reference later on. Each Font and Color type is stored by index in a TList internally. It acts as a lookup tables - by matching the Font name or Color value we can find the [num] to code into the RTF stream at the required moment: \f[num] = the index of which Font you want to use, as pre-set in the "on the fly" font table \fs[num] = point size - (for example 20 = 10point) \cf[num] = the index of which Color to use, as preset in "on the fly" color table \cb[num] = which background color to use - (ignored in RichEdit version 2.0) PROBLEM#2 Crashes in long comments or text (existing problem) There is a bug in ScanForRtf. Can you see it? procedure TPasConversion.AllocStrBuff; begin FStrBuffSize:= FStrBuffSize + 1024; ReAllocMem(FStrBuff, FStrBuffSize); FStrBuffEnd:= FStrBuff + 1023; end; { AllocStrBuff } procedure TPasConversion.ScanForRtf; var i: Integer; begin RunStr:= FStrBuff; FStrBuffEnd:= FStrBuff + 1023; for i:=1 to TokenLen do begin Case TokenStr[i] of '\', '{', '}': begin RunStr^:= '\'; inc(RunStr); end end; if RunStr >= FStrBuffEnd then AllocStrBuff; RunStr^:= TokenStr[i]; inc(RunStr); end; RunStr^:= #0; TokenStr:= FStrBuff; end; { ScanForRtf } EXAMPLE - code snippet from Pas2Rtf demonstrating the "long comment" bug The problem: if FStrBuff is enlarged using AllocStrBuff() (to make it bigger to handle a very long comment) the Windows Memory manager probably has to re-allocate it by moving the entire string buffer somewhere else in memory. RunStr however is not adjusted for this change and stillpoints to the old memory area, now unallocated. The fix: Reallocate RunStr in the AllocStrBuff routine so it points to the correct place in the new area of memory. Try and fix it yourself, or look at my garsely spaghetti code in jhdPasToRtf.pas. Automatic Syntax Highlighting (my first implementation) To understand how Automatic syntax highlighting works, you should have a close look at what happens in the Delphi 3.0 Editor. After all - if Borland was happy with it - who am I to argue :-) Take note when the "syntax" changes and what is affected. In retrospect the difficult thing is to implement a highlighter that is: 9. Fast 10. Accurate 11. Doesn't flicker 12. Isn't obvious ("the someone is chasing me phenomenon".. you'll see) 1. When should we do the re-highlighting ? In YourPasEdit the highlighting is done as the file is read in. Once this is done, the only way to make use of that technique would be to write out the file everytime it changes and read it back in again - obviously a very slow process. In my case, I basically wanted to just reformat the line(s) that have been changed, immediately after the change had been done i.e. after every new character, DELETE or BACKSPACE or

998

even Paste or DragDrop had been processed. I needed something that was triggered everytime the control was effected in such a way. What I needed then was an [Event]. 2. Which event - there's so many to choose from ? A RichEdit, like any control, has a number of [Events] triggered when you do various things to the control. What is not obvious, is that many events trigger other events in turn. So in choosing which Event(s) to hang your code off you have to ensure that (a) it catches all situations where you need to "fix" the highlighting and (b) it doesn't become re-entrant (i.e. what you do in the [Event], doesn't trigger itself again or any other [Event] that would call the "highlighting code"). From a quick look at the helpfile, I decided that [OnChange] seemed a likely candidate. According to the Delphi 3.0 Helpfile: Write an OnChange event handler to take specific action whenever the text for the edit control may have changed. Use the Modified property to see if a change actually occurred. The Text property of the edit control will already be updated to reflect any changes. This event provides the first opportunity to respond to modifications that the user types into the edit control. You may be thinking however: "Heh? What about those other things - like Methods and Properties. Can't they also change the text?" They sure can - but most end up triggering [OnChange] anyhow. 3. Is it what I want? - Rich text controls (from Delphi3 Helpfile) The rich text component is a memo control that supports rich text formatting. That is, you can change the formatting of individual characters, words, or paragraphs. It includes a Paragraphs property that contains information on paragraph formatting. Rich text controls also have printing and text-searching capabilities. By default, the rich text editor supports · Font properties, such as typeface, size, color, bold, and italic format · Format properties, such as alignment, tabs, indents, and numbering · Automatic drag-and-drop of selected text · Display in both rich text and plain text formats. (Set PlainText to True to remove formatting) type TNotifyEvent = procedure(Sender: TObject) of object; property OnChange: TNotifyEvent; 4. Is it the event I want - ie [OnChange] Event - the right one? Live dangerously, let’s give it a go and see...by testing our assumptions out: So I wrote my first [OnChange] event: 6. Create a New application 7. place on it one RichEdit (RichEdit1) and one Edit control (Edit1) 8. Code the [OnChange] for the RichEdit1 control like this: procedure TForm1.RichEdit1Change(Sender: TObject); begin TRichEdit(Sender).Tag := TRichEdit(Sender).Tag + 1; Edit1.Text := 'Tag=' + IntToStr(TRichEdit(Sender).Tag); end; In this case the Sender object is the RichEdit being changed. The code basically uses the RichEdit's Tag variable (initially 0) as a handy Control specific variable. Everytime the [OnChange] event is called, it increases the Tag by 1, and display its value in an Edit Control as Text. You should pre-set the RichEdit control with some text in it, otherwise the following may be confusing! 5.

Compile and Run...

6.

Click in the Control. Nothing...

7.

Move around in it using CursorKeys... Nothing...

8.

Click outside the control.. and then back inside.. Nothing...

9.

Press the [Space Bar].. Tag=1...

10. Press [Backspace].. Tag=2... 11. Press return.. Tag=3.. 12. Select some text.. No change.. 13. CTRL-C some text.. No change.. 14. CTRL-X some text.. Tag=4..

999

15. CTRL-V some text.. Tag=5.. As it looked good so far I then added to the Form1.OnShow event: RichEdit1.Lines.LoadFromFile('c:\winzip.log'); {Just a plain text file hanging around } to see what happened. And guess what - an [OnChange] event was called sometime and "Tag=1" was displayed in the Edit control as the proof when the Form appears for the first time. So we can see that procedures do call Events that apply to what they are doing. 5. What happens in Syntax Highlighting anyhow? Watch carefully in the Delphi Editor. Now try and reproduce it. Open a WordPad (since WordPad is a souped up RichEdit basically). Read in a source file (e.g any Unit1.pas) and do syntax highlighting manually: 1. Select a token 2. Manipulate it using the buttons provided to change Font, Size, Color, and Bold 3. Move onto the next token 4. Goto 1 So therefore in [OnChange] we'll try and write code to reproduce what we have done manually. 6. Which text do I want.. and where do I get it ? Hunting through the Delphi Helpfile on RichEdit controls we find that the actual text information in the RichEdit control is stored (or rather can be accessed from) either: RichEdit.Text Text contains a text string associated with the control. TCaption = type string; property Text: TCaption; Description Use the Text property to read the Text of the control or specify a new string for the Text value. By default, Text is the control name. For edit controls and memos, the Text appears within the control. For combo boxes, the Text is the content of the edit control portion of the combo box. RichEdit.Lines Lines contains the individual lines of text in the rich text edit control. property Lines: TStrings; Description Use Lines to manipulate the text in the rich text edit control on a line by line basis. Lines is a TStrings object, so TStrings methods may be used for Lines to perform manipulations such as counting the lines of text, adding lines, deleting lines, or replacing the text in lines. To work with the text as one chunk, use the Text property. To manipulate individual lines of text, the Lines property works better. Now Lines seemed to be what I wanted - after all I wanted the Syntax highlighting to work on a line by line basis. So let’s have a look at whats been changed. Oh.. look at what? How can I tell which line is the one that is changed? Unlike some Events, the [OnChange] isn't passed any variable's save the identity of the RichEdit control affected. The RichEdit Control doesn't have a runtime variable that tells us either. The only variables are the SelStart and SelLength - but their about selecting text aren't they? I just want to know what line I'm on :-( It was about then that I re-read the information on the Sel??? properties, and recalled my "concept" code. Selection - I realised - was the name of the game. By manipulating these variables I could reproduce what I was doing manually - selecting text - as program code. Once selected you can then manipulate the attributes of the selected text through the SelAttributes structure. Let’s get familiar with these variables (in Summary) . Position of the Cursor, or the beginning of the SelStart selected text 0 if SelStart = Cursor Pos, or length of SelLength selected Text empty if no text selected, or actual text SelText selected Default attributes if I was to start typing at the SelAttribute Cursor position OR the actual attributes of the selected text There is actually no other way to access the attributes of the text already in the Control than by programmatically accessing them via manipulating Sel variables (*if you stick to using the defined properties and methods). In the end RichEdit.Text and RichEdit.Lines are just plain old strings - not really "rich" at all. The other thing to note is that SelStart is a 0-based index on the first character of RichEdit.Text - so it looks like Richedit.Line is out the door.

1000

7. Okay implement: Select a Token Basically I wanted to start at the beginning of the line, send just that line to PasCon, and read it back in and replace the current line with the result. Trouble is RichEdit doesn't give you access to the 'RTF' representation of a single line. Plus I still can't tell when the beginning or end of the line is. Since the latter seems to be a nagging problem, we better fix that first - trouble is: How? When all else fails - WinAPI calls of course. Most visual controls in Delphi are in fact just native Windows controls encapsulate as Delphi types. You can still use Windows API functions to access the control underneath. This was it is possible to access information not accessable per Delphi public Properties, Method or Events. Time to delve through Win32.HLP and see what it has to say about RichEdit controls. Its stored in C:/Program Files/Borland/Delphi 3.0/Help if you don't have a shortcut to it. Open Win32.HLP -> [ Contents ] -> [ RichEdit controls ] -> [ Rich Edit Controls ] I spent some time getting to know the "full" capabilites of the RichEdit control hidden behind Delphi's implementation of it. Much of what I learned came in handy later on (as you'll see) and as a result I derived my second two Delphi Rules: Delphi Rule #2: If your Project hinges on the capabilities of a certain control - make sure you know everthing about it - from the beginning. Delphi Rule #3: "Reference" is not the same as "Summary" (also known as Win32.HLP Rule#1) Eventually I discovered the key in the [ Rich Edit Control Reference ] under "Lines and Scrolling". I had thought this page was simply a summary of the messages discussed in the preceding help pages. Actually it included a number of extra messages not discussed elsewhere - the exact ones I was after! Lines and Scrolling EM_LINEFROMCHAR - give them a 0-based index and they'll return the line EM_LINEINDEX - give them a line and you get the index of the first character EM_LINELENGTH - give them a line and you get the length of the line So lets start coding. (NB: To use the constants (EM-?) you'll have to manually add RichEditin the uses clause) procedure TForm1.RichEdit1Change(Sender: TObject); var WasSelStart,Row,BeginSelStart,EndSelStart: Integer; MyRe : TRichEdit; begin MyRe := TRichEdit(Sender); WasSelStart := MyRE.SelStart; Row := MyRE.Perform(EM_LINEFROMCHAR, MyRE.SelStart, 0); BeginSelStart:= MyRe.Perform(EM_LINEINDEX, Row, 0); EndSelStart := BeginSelStart + Length(MyRE.Lines.Strings[Row]); // I didn't use the EM_LINELENGTH message, as the variables was avaiable via Delphi Edit1.Text := IntToStr(WasSelstart) + '-' + IntToStr(Row) + '-' + InttoStr(BeginSelStart) + '-' + IntToStr(EndSelStart); end; To start with I used the Edit1 Control to display the results of all these variables. I then tried manipulating text in the RichEdit to see what values I got. You should do the same. Type slowly in: 123456789012345678901234567890 and see how the results are reflected in the Edit control as you do so. Then experiment - try adding stuff to the ends of lines, and in the beginning of the line, and middle of lines. You may have to refer back to the Code to work out which number represents which variable. Okay, now using the variables we have, lets try selecting the text of the current line, and display it in a new Edit Control (Edit2). Add the following code to see what happens (don’t forget to add the second edit control and make it as wide as possible): MyRe.SelStart := BeginSelStart; MyRe.SelLength := EndSelStart - BeginSelStart; Edit2.Text := MyRe.SelText; end; Run the program and try it out. OOPS - That doesn't work - the text remains selected and the original cursor position is lost. We need to reset SelStart and SelLength before we finish in the [OnChange] event. So let’s add at the end: MyRe.SelStart := WasSelStart; //back to were we started MyRe.SelLength := 0; // nothing selected end;

1001

While playing with text in the edit control I discovered something weird. If you typed [1] then then [2] the Edit1 displayed [4-1-3-4]. But there were only two characters in the display. I made a mistake. It appears that RichEdit.Text can tell you where the beginning and end of line is. Why? Because you can access the characters in the Text string. So we could have manipulated the Text property of the control to work out the beginning and end of lines by reading back and forward from SelStart to find characters. We may not have known which line we were on, but we would know where it began and ended. Nevertheless we should keep this in mind, it might come in handy later. But it doesn't matter - the EM_###### messages are a neat way of doing things. And they work. For the moment at least we'll stick with them. 7. Okay implement: Part 2 - Change the format After the line Edit2.Text := MyRe.SelText, but before the "resetting" part, lets put some logic in to turn lines RED when they are longer than a certain length: if (MyRe.SelLength > 10) then MyRe.SelAttributes.Color := clRed; You'll notice two things if you test this out. First - it does work. Second however, is that if you type a line > 10 characters, press return and type one character - its in Red. This is because it inherits the Attributes of the preceding text. Just like if you have bold on in a Word processor, it doesn't reset if you press return. So lets change the line to include an else situation: else MyRe.SelAttributes.Color := clBlack; That seems to work - except when you press return in the middle of a > 10 character line you have already typed (which is already Red) to leave a stump < 10 characters on the line above - it remains red. This is because the code leaves you on the next line, and SelStart refers to this new line, not the previous one. In our eventual code, we'll have to take care to ensure this doesn't happen - we have to catch this situation and deal with it. It wont be the only situation I'm sure.... PS: There will be a number of situation we're we'll have to be careful. Can you think of any now? Try putting a lot of text in the Control (or manipulate a loaded file) and selecting some and using the inherit Drag and Drop (move your Mouse over some selected text, press and hold down the Left MouseButton and then drag away) to move some text. This only Triggers one OnChange Event. We may also be moving multiple lines along the way. In the future we'll have to put in some code to detect this happening, and ensure the [OnChange] event can deal with the need to reformat in two different locations. That means thinking in the back of the head about how in the future we may have to deal with this kind of situation, and ensure our code to deal with the simple situation can be adapted - i.e. be "versatile". 8. Basically it all seems to kind-of work.. can't we do some real programming now? Okay, okay. But first we have a problem. Actually a rather big problem. The problem is PasCon. Why? First: It returns RTF code. Problem: We can't use RTF code. Second: its designed to work an entire stream, and then give it back to us again as a whole. Problem: We actually want greater control over it than this "all or nothing" approach. OOP to the Rescue When you have something that works in a situation, and needs to be applied in another situation were it has to do a similar, but subtly different job - you have two choices: 1. copy the function, and re-write it for the new situation, or 2. kludge around it (e.g use Pas2Rtf, and then write a RtfCodes2RtfControl procedure). Modern languages however give you an option: OOP it. "Objectify" it. This is more than just deriving something from an existing object. It is in a sense programming in a "state of mind". Controls should be created so they can be used in a variety of situations - father than situation specific. In this case all PasCon can deal with is tokenising the input stream and returning code RTF text. What we really need to do is divide it into two entitites. We need to separate the [Parsing/Recognise the Token and TokenType] from the [Encode it in RTF codes]. So lets start with ConvertReadStream, editing it so it looks something like this: function TPasConversion.ConvertReadStream: Integer; begin FOutBuffSize := size+3; ReAllocMem(FOutBuff, FOutBuffSize); FTokenState := tsUnknown; FComment := csNo; FBuffPos := 0; FReadBuff := Memory; {Write leading RTF} WriteToBuffer('{\rtf1\ansi\deff0\deftab720');

1002

WriteFontTable; WriteColorTable; WriteToBuffer('\deflang1033\pard\plain\f2\fs20 '); Result:= Read(FReadBuff^, Size); if Result > 0 then begin FReadBuff[Result] := #0; Run := FReadBuff; while Run^ <> #0 do begin Run := GetToken(Run,FTokenState,TokenStr); ScanForRTF; SetRTF; WriteToBuffer(PreFix + TokenStr + PostFix); end; {Write ending RTF} WriteToBuffer(#13+#10+'\par }{'+#13+#10); end; Clear; SetPointer(FOutBuff, fBuffPos-1) ; end; { ConvertReadStream } The code for ConvertReadStream is now much smaller, and also easier to understand. We can then take all the code that used to be in ConvertReadStream that did the tokenizing and create a new subroutine the GetToken function that just does the recognizing and labelling of the individual tokens. In the process we also loose a huge number of repeated lines of code, as well as a number of sub-routines such as HandleBorCom and HandleString. // // My Get Token routine // function TPasConversion.GetToken(Run: PChar; var aTokenState: TTokenState; var aTokenStr: string):PChar; begin aTokenState := tsUnknown; aTokenStr := ''; TokenPtr := Run; // Mark were we started Case Run^ of #13: begin aTokenState := tsCRLF; inc(Run, 2); end; #1..#9, #11, #12, #14..#32: begin while Run^ in [#1..#9, #11, #12, #14..#32] do inc(Run); aTokenState:= tsSpace; end; 'A'..'Z', 'a'..'z', '_': begin aTokenState:= tsIdentifier; inc(Run); while Run^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do inc(Run); TokenLen:= Run - TokenPtr; SetString(aTokenStr, TokenPtr, TokenLen);

1003

if IsKeyWord(aTokenStr) then begin if IsDirective(aTokenStr) then aTokenState:= tsDirective else aTokenState:= tsKeyWord; end; end; '0'..'9': begin inc(Run); aTokenState:= tsNumber; while Run^ in ['0'..'9', '.', 'e', 'E'] do inc(Run); end; '{': begin FComment := csBor; aTokenState := tsComment; while not ((Run^ = '}') or (Run^ = #0)) do inc(Run); inc(Run); end; '!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~' : begin aTokenState:= tsUnknown; while Run^ in ['!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~'] do begin Case Run^ of '/': if (Run + 1)^ = '/' then begin if (aTokenState = tsUnknown) then begin while (Run^ <> #13) and (Run^ <> #0) do inc(Run); FComment:= csSlashes; aTokenState := tsComment; break; end else begin aTokenState := tsSymbol; break; end;

1004

end; '(': if (Run + 1)^ = '*' then begin if (aTokenState = tsUnknown) then begin while (Run^ <> #0) and not ( (Run^ = ')') and ((Run - 1)^ = '*') ) do inc(Run); FComment:= csAnsi; aTokenState := tsComment; inc(Run); break; end else begin aTokenState := tsSymbol; break; end; end; end; aTokenState := tsSymbol; inc(Run); end; if aTokenState = tsUnknown then aTokenState := tsSymbol; end; #39: begin aTokenState:= tsString; FComment:= csNo; repeat Case Run^ of #0, #10, #13: raise exception.Create('Invalid string'); end; inc(Run); until Run^ = #39; inc(Run); end; '#': begin

1005

aTokenState:= tsString; while Run^ in ['#', '0'..'9'] do inc(Run); end; '$': begin FTokenState:= tsNumber; while Run^ in ['$','0'..'9', 'A'..'F', 'a'..'f'] do inc(Run); end; else if Run^ <> #0 then inc(Run); end; TokenLen := Run - TokenPtr; SetString(aTokenStr, TokenPtr, TokenLen); Result := Run end; { ConvertReadStream } ASH - Automatic Syntax highlight (Attempt 2) [Please note: I have my Delphi Editor colors set-to the [Ocean] colour speed settings for testing purposes. This setting works well on the default RichEdit white background, and most TokenTypes are in different colors from each other] Okay now to do some real work. Most of the function have been written thereabouts. As a basis for writing this ASH I'm going to use Project1.dpr which comes out of mpas2rtf.zip in the YourPasEdit zip file yrpasedit.zip. This is because it much smaller than YourPasEdit, and thus quicker to compile. I suggest you put the contents of the mpas2rtf.zip into a separate directory. Also copy mwPas2Rtf.pas to testinput.pas using the Explorer shell - we'll be using this file as a sample pascal file for benchmarking. Open Project1.dpr in Delphi, compile Project1, run it, and open the file testinput.pas by pressing [Button 1] and selecting it in the [OpenFile Dialog]. Do it a number of times, and record the time taken for each once the file is stabilised in the system cache. On my system it averages about 0.47 - 0.41 seconds once its in the cache (P133 - 16M - Win95b) Preparing Project1's Unit1.pas Now replace the contents of mpas2rtf.pas with that code in jhdpas2rtf.pas. Recompile. Now open up the testinput.pas sample file again by using [Button 1]. As you see - we get color - but it takes a "lot" longer: 1.20-1.25 seconds. Try and speed it up if you like. You can start by commenting out the pascal-code that codes in the different Font and FontSizes in TPasConversion.SetRtf. Recompile and run again. This time it improves a bit to 1.10-1.15. Now try commenting out the code for different Colors. Wow - the speed decreases down to 0.49 0.44. Hmm. This font and color stuff really packs a punch. We may need to look at this later in more detail if things end up too slow. For the moment we'll leave the code back in full working condition (so you'll need to go back and uncomment the code). Now put the following base code into the [OnChange] event of the RichEdit1 in Unit1.pas of Project1. Most of this code is just based on what we have already covered elsewhere. procedure TForm1.RichEdit1Change(Sender: TObject); var WasSelStart,WasRow,Row,BeginSelStart,EndSelStart: Integer; MyRe: TRichEdit; MyPBuff: array[0..255] of char; begin MyRe := TRichEdit(Sender); WasSelStart := MyRE.SelStart; WasRow := MyRE.Perform(EM_LINEFROMCHAR, MyRE.SelStart, 0); BeginSelStart := MyRe.Perform(EM_LINEINDEX, Row, 0); EndSelStart := BeginSelStart + Length(MyRE.Lines.Strings[Row]); Row := WasRow; end;

1006

Were going to use the GetToken() function to do all the hard work. We'll need some extra variables to pass to the GetToken function, so add to the var section: MyTokenStr:string; MyTokenState:TTokenState; MyRun:PChar; MySelStart: Integer; These are similar to the variables we used in the ConvertReadStream - in fact we want to do "exactly" the same thing, just one single line at a time. Add this code before the last end; StrPCopy(MyPBuff,MyRE.Lines.Strings[Row]); MYPBuff[Length(MyRE.Lines.Strings[Row])] := #0; MySelStart := BeginSelStart; MyRun := MyPBuff; while(MyRun^ <> #0) do begin MyRun := PasCon.GetToken(MyRun,MyTokenState,MyTokenStr); // // ScanForRtf; // SetRtf; // WriteBuffer(Prefix + TokenStr + Postfix); // end; end; NB: As we will be using PasCon you'll have to move it from being a local variable of TForm1.Button1Click to be a global variable. This will mean you'll have to move all the initialising: PasCon:=TPasConversion.Create; PasCon.UseDelphiHighlighting(3); to a TForm1.Show, and the PasCon.Free to TForm1.Close procedure. It will still work if you only move the variable definition - but not for long... :-) I've left the code from the old ConvertReadStream in the example above to show what we "logically" still need to implement in the current context - that is manipulating the RichEdit Control directly. What we have now is the ability to cut up the current line in to different tokens, and know what type they are. We now have to add these tokens to current line with the right attributes (Fonts,Colors,Bold etc). But wait. They are already on the line - well the text is anyway, but maybe not in the correct format (Color,Bold etc). So what actually could do is to select each token in its corresponding positon in the RichEdit control and just apply the appropriate attributes to them. We did this back in the beginning remeber? When we set the >10 character lines to the color red. But how do we do this now? Lets look at what we have in the variables at hand when we hit "// SetRtf" the first time:

(these example uses Uni1.pas as the input file as its more interesting)

01234567901234567890 VARIABLES unit Unit1; Lines.Strings[R0] unit Unit1; MyPBuff tsIdentifier MyTokenState unit MyTokenStr Unit1; MyRun So what we need to do is select the word 'unit' in the RichEdit control, and set its attributes. We do this by setting SelStart to the position of 'unit' in the RichEdit control, and SelLength to the length of the word 'unit'. And since 'unit' is at the beginning of the current line - thats position is BeginSelStart (which I conveninently have stored in MySelStart - you'll see why). Lets replace the "pseudo" comment code with the following:

1007

MyRe.SelStart := MySelStart; MyRe.SelLength := Length(MyTokenStr); MyRe.SelAttributes.Assign(PasCon.FParseFont[MyTokenState]); end; But remember we are in a loop - when we go around again we'll have the next token in the line, and the variables will look like this: 01234567901234567890 VARIABLES unit Unit1; Lines.Strings[R0] unit Unit1; MyPBuff tsSpace MyTokenState (space character) MyTokenStr Unit1; MyRun But (space character) isn't at BeginSelStart (#0) in the RichEdit control. Its further along (at position #4). Which just happens to be BeginSelStart + Length('unit'). We need to update MySelStart after we process the preceeding token, but before we go around the loop again: MySelStart := MySelStart + Length(MyTokenStr); end; Okay - this is where we are standing at the moment: procedure TForm1.RichEdit1Change(Sender: TObject); var WasSelStart,WasRow,Row,BeginSelStart,EndSelStart: Integer; MyRe : TRichEdit; MyPBuff: array[0..255] of char; MyTokenStr:string; MyTokenState:TTokenState; MyRun:PChar; MySelStart: Integer; begin MyRe := TRichEdit(Sender); WasSelStart := MyRE.SelStart; WasRow := MyRE.Perform(EM_LINEFROMCHAR, MyRE.SelStart, 0); Row := WasRow; BeginSelStart := MyRe.Perform(EM_LINEINDEX, Row, 0); EndSelStart := BeginSelStart + Length(MyRE.Lines.Strings[Row]); StrPCopy(MyPBuff,MyRE.Lines.Strings[Row]); MyPBuff[Length(MyRE.Lines.Strings[Row])] := #0; MySelStart := BeginSelStart; MyRun := MyPBuff; while(MyRun^ <> #0) do begin MyRun := PasCon.GetToken(MyRun,MyTokenState,MyTokenStr); MyRe.SelStart := MySelStart; MyRe.SelLength := Length(MyTokenStr); MyRe.SelAttributes.Assign(PasCon.FParseFont[MyTokenState] ); MySelStart := MySelStart + Length(MyTokenStr); end; MyRE.SelStart := WasSelStart; MyRE.SelLength := 0; end;

1008

Now: put the Debugging code on, do [Build All] and then [Run], and set a breakpoint on the first line of this Event. Open up the testinput.pas. When the debugger stops in the OnChange event, Press to continue on, and press again, and again - Do you see? We keep going back into the Event again and again (and again). What’s happening? Somehow in our event we are triggering off another [OnChange] event. This call to the [OnChange] event code is stored in the message queue. When the event were currently in is finished, a new one is just waiting on the Event queue, which executes and creates more events... a re-entrant loop. This behaviour is not surprising - after all we are actually changing the control in the process of our code, so no wonder another [OnChange] event is being triggered. The way to fix such things is to ensure our actions do not trigger of the Event. We can do this by "temporarily" storing the RichEdits.OnChange property (which contains a reference to call our procedure TForm1.RichEdit1Change) in our own internal variable, and then setting the OnChange property to nil. We then do all the processing we want to do - if it happens to trigger an [OnChange] event - there is nothing to call as OnChange is nil, and so the Event doesn't go onto the Message queue. When we're finished however we must return the OnChange property to it original value, otherwise the reprocessing want happen next time around. If we look at the Delphi Helpfile we see that the OnChange property is of a certain type, the same type we have to make our SaveOnChangeIn variable: var SaveOnChangeIn: TNotifyEvent; ~~~~~rest of code begin MyRe := TRichEdit(Sender); SaveOnChangeIn := MyRe.OnChange; MyRe.OnChange := nil; ~~~~~rest of code MyRe.OnChange := SaveOnChangeIn; end; Try it out!!! · Compile and Run · Open up Unit1.pas in the "editor" we have written · Click in the RichEdit in the center of the first lines, in the middle of "unit". · Press the [space bar] · Press the [backspace key] · Arrow to the end of the line · Press [Enter] · Press [BackSpace] · [BackSpace] away the entire line · Re-type the entire line Result: "functionally" the Control should look that same as it did before we clicked in it. The line "unit Unit1;" should highlighted properly as per your Delphi 3.0 Editor (save the background colour). However its slow and flickers a great deal. Try opening up a new line and just type a long phrase - e.g "if (RichEdit = Santa) then GetPresents('box of choclate'); " and you'll agree with me that: 4. GOOD - It is highlighting properly 5. BAD - There is flickering 6. BAD - The longer the line gets, the longer it takes to do the re-highlighting 7. BAD - you get the "someone is chasing me effect" The flickering is due to a number of components. We'll have to deal with each seperately. The most obvious is the "selecting" of each Token. Visually the control is just repeating what we were able to do manually - when a piece of text is selected it becomes highlighted by the black stripe. We need to stop this from happening. Back to the helpfile(s) again. Have a search around, and come back after a snack break with some ideas... I'm hungry :-) Death to the black stripe Marks: 5/10

1009

Most of you would have found the HideSelection property of the RichEdit control. When it is set to TRUE and the RichEdit looses the focus (the user clicks onto another control) the selection bar (the black stripe) is hidden. In fact if you try it out by selecting some text in the RichEdit1 then clicking in the Edit1 control at the top of the "editor" you'll see the selection disappears! [Tab] back into the RichEdit control and it reappears. Lets do this programmatically: begin Edit1.SetFocus; ~~~~~ MyRe.SetFocus; end; Take my word for it, but if you look closely, the black strip is gone. Pity we got stuck with a new one in the Edit1 control :-( If your programmed in Delphi you may know a little trick: Delphi Rule #4: you can't SetFocus on a disabled Control. The converse however is also true: Delphi Rule #4b: a disabled Control is not "Focused" So try instead we can just Disable (then Enable) the RichEdit control like this: begin MyRe := TRichEdit(Sender); MyRe.Enabled := False; ~~~~~~ MyRe.Enabled := True; end; Oops. I should have known. After all I said it: a disabled Control is not "Focused" - barely ten lines ago! When the RichEdit is enabled again, we also have to SetFocus back to it. Shees.. :-) begin MyRe := TRichEdit(Sender); MyRe.Enabled := False; ~~~~~~ MyRe.Enabled := True; MyRe.SetFocus; end; Try it again. This time things are working better, and we're leaving poor old Edit1 Control alone. Thats good practice, as it may have had an [OnFocus] event that does wierder things than what we're trying to do. Maybe not now, but it could in the future! Marks: 10/10 On the other kind, some of you may have found instead the EM_HIDESELECTION message in the Win32.HLP. If you had delved in, you would have found something very interesting. The Delphi HideSelection property only implements half the capabilities of this message. You can also, by calling it direct, tell it to Temporarily hide the black stripe even when the control has the focus. So instead you could use the following lines of code: begin MyRe := TRichEdit(Sender); MyRe.Perform(EM_HIDESELECTION,1,0); ~~~~~~ MyRe.Perform(EM_HIDESELECTION,0,0); end

1010

Yummy. Nice clean coding: Death to the FLICKER The next major problem is this bloody flicker. You should pop back into Delphi for a second, and types some lines in its editor, to see if it flickers at all. It does. But only when it is changing colors when it recognizes a change has occured. Otherwise it doesn't bother. Now look at what’s happening in our "editor". Do you see? The problem is that we are not "conserving" what we are doing. If something is still the same TokenType it doesn't need to be re-highlighted because it already correct on the screen. We need to check if the TokenType of each token has changed since last time we repainted this line, and only then repaint to. In fact we don't need to do even that - we can just check whether the SelAttributes (which represents the current selection's attributes) is any different from what we want to change it to i.e. FParseFont[MyTokenType]. This way if even the TokenType had changed, but the new and old TokenType shared the same display attributes, we would still conserve our drawing. Actually the problems is that the RichEdit isn't doing the conserving. In the old text based system I used to use, if you printed something to the screen, and it was the same as something already on the screen, in the same position, then the program would not rewrite it to the screen. It would "conserve" the amount of writing it did, as in the old days 1200 baud screens were SLOW, and printing the same characters was a waste of time. Huh - and people said we have come so dar with windows. Sloppy, Sloppy, Sloppy I say! :-) So lets replace: MyRe.SelAttributes.Assign(PasCon.FParseFont[MyTokenState]); with: If MyRe.SelAttributes.Name <> PasCon.FParseFont[MyTokenState].Name then MyRe.SelAttributes.Name := PasCon.FParseFont[MyTokenState].Name; If MyRe.SelAttributes.Color <> PasCon.FParseFont[MyTokenState].Color then MyRe.SelAttributes.Color := PasCon.FParseFont[MyTokenState].Color; if MyRe.SelAttributes.Style <> PasCon.FParseFont[MyTokenState].Style then MyRe.SelAttributes.Style := PasCon.FParseFont[MyTokenState].Style; And off you go and try it out... (PS. Yes the last bit of code is bad programming...) SUCCESS - (Nearly...) I think you'll agree we are pretty close. There is just a little bit of flicker. This flicker is the SelStart jumping the Cursor position around the text. We need to hide this. This "Cursor" is also known as a Caret. Looking throught Win32.Hlp again we find the lovely, and appropriately named, HideCaret() function. Lets try this then: everytime we change the value of MyRe.SelStart lets call HideCaret(MyRe.Handle) immediately before. I'll be kind - that doesn't work. I tried 2 x HideCaret(MyRe.Handle), and it still didn't work. Neither did three,four or 25x. So close - but yet - so far. I think its time for another Delphi Rule: DELPHI RULE #5 - If you bother to get your way through the atrocious index of the Win32.HLP file to find what you are looking for - make sure you really read what you found properly! The key was the last paragraph in the description of not HideCaret but ShowCaret (which I had also read as I thought we were going to need it, especially to reverse my 25x HideCaret()). You also need another Delphi Rule to understand it: The caret is a shared resource; there is only one caret in the system. A window should show a caret only when the window has the keyboard focus or is active. DELPHI RULE #6 - Everything (basically) is a Window You see the RichEdit is a windows control and is also.. in a weird sense.. a window. It has a Handle, which is why HideCaret would accept it. So re-reading the last line again we get: The caret is a shared resource; there is only one caret in the system. A [RichEdit] should show a caret only when the [RichEdit] has the keyboard focus or is active. So - in the end - we're back to were we started - we have to disable the RichEdit to stop the final bit of flickering. This also (co-incidentially) means that EM_HIDESELECTION is not needed anymore (if HideSelection is set properly during Design time). So in the end everyone gets 10/10 for marks! ASH Version 0.9b procedure TForm1.RichEdit1Change(Sender: TObject); var SaveOnChangeIn: TNotifyEvent; WasSelStart,WasRow,Row,BeginSelStart,EndSelStart: Integer;

1011

MyRe : TRichEdit; MyPBuff: array[0..255] of char; MyTokenStr:string; MyTokenState:TTokenState; MyRun:PChar; MySelStart: Integer; begin MyRe := TRichEdit(Sender); SaveOnChangeIn := MyRe.OnChange; MyRe.OnChange := nil; MyRe.Enabled := False; WasSelStart := MyRE.SelStart; WasRow := MyRE.Perform(EM_LINEFROMCHAR, MyRE.SelStart, 0); Row := WasRow; BeginSelStart := MyRe.Perform(EM_LINEINDEX, Row, 0); EndSelStart := BeginSelStart + Length(MyRE.Lines.Strings[Row]); StrPCopy(MyPBuff,MyRE.Lines.Strings[Row]); MYPBuff[Length(MyRE.Lines.Strings[Row])] := #0; MySelStart := BeginSelStart; MyRun := MyPBuff; while(MyRun^ <> #0) do begin MyRun := PasCon.GetToken(MyRun,MyTokenState,MyTokenStr); MyRE.SelStart := MySelStart; MyRE.SelLength := Length(MyTokenStr); If MyRE.SelAttributes.Name <> PasCon.FParseFont[MyTokenState].Name then MyRE.SelAttributes.Name := PasCon.FParseFont[MyTokenState].Name; If MyRE.SelAttributes.Color <> PasCon.FParseFont[MyTokenState].Color then MyRE.SelAttributes.Color := PasCon.FParseFont[MyTokenState].Color; if MyRE.SelAttributes.Style <> PasCon.FParseFont[MyTokenState].Style then MyRE.SelAttributes.Style := PasCon.FParseFont[MyTokenState].Style; MySelStart := MySelStart + Length(MyTokenStr); end; MyRE.SelStart := WasSelStart; MyRE.SelLength := 0; MyRe.OnChange := SaveOnChangeIn; MyRe.Enabled := True; MyRe.SetFocus; end; Towards - ASH Version 1.0b Couple of problems with the last version if you try it out for size: 1. Its slightly inefficient in that everytime SelAttributes is changed it forces a repaint of the same token in the control. We should instead use some variable (e.g var DoFormat:Boolean) to decided if we need to reformat, and then check the value of DoFormat at the end of this checking, and do it all then by a simple SelAttribute.Assign(FParseFont[MyTokenState]). This means we can also change the seperate "if" statements to a single if ... then .. else .. if ... then .. else which should

1012

code faster - especially if you put the various test situations in the order of likeliness to occur (e.g font changes less frequently than the color, so should be further down the if..else..if) 2. For some reason if you type a {style comment} on a line, after about 4-7 characters it reverts to different colours. I can't seem to work out yet why this happens - but I understand why its not being picked up. SelAttributes returns the value of the "initial" styling of the entire selected block. So if you select text which starts off black and then becomes blue, SelAttributes.Color will equal clBlack. We must also examine SelAttributes.ConsistentAttributes to ensure that the entire selection is consistent in the way it is highlighted. If it isn't - then we want to force it to be rehighlighted - its obviously not in the correct format. 3. Multi-line comments are a big pain e.g { words word words }. I don't have them in my 4GL so I didn't need to fix this sort of problem. However I do have muti-line strings - so I need to be able to string strings across many lines. The trouble is we have to code to program over a number of lines - but have a look at what happens in Delphi when you place a "{" anywhere in the code. The highlighting can force a repaint of the entire 2,000,000 lines of text in the control. We could catch that situation - ie if the last token on the line is a tsComment and it doesn't end in '}' we could increase SelLength until it did or we reach the end of the RichEdit.Lines. (That basically what the tokeniser does anyway with all that inc(Run).)

That easy. But what happens if you then delete the "{"? You need to go forward 2,000,000 lines and put the highlighting back again? We could decide to keep going until the if...then..else..list didn't set DoFormat := True. But what happens if we're in a colour mode were Comment highlighting style = KeyWord highlighting style. We would stop prematurely. So this "logic" wont help in all situations. 4. You can still get the "someone is chasing you effect" - except now its "someone is fleeing from you" effect. It happens when you have(* This is a comment *) and delete the first *-character. The control takes an appreciable time to rehighlight the text. 5. While looking for a fix for the last problem, I remembered the Richedit.Lines.BeginUpdate function. But that didn't help either. What we need is a Richedit.BeginUpdate. What would that do? It would increase an internal counter by one everytime it was called. RichEdit.EndUpdate would do the opposite. Then we would create our own WM_PAINT message handler. This is received everytime Windows wants the control to repaint a portion of itself. If we catch this message then we can stop processing of these message until the internal counter = 0 again. Then, and only then, will the Control repaint itself - ditching we would hope most of the intervening steps. 6. Fixing the mult-line comments:

My current idea is to use the RichEdit.Lines.Object to store the TokenType of the first token on each line. This way we could easily know how far we need to go when re-hightlighting multi-line comments. Initially this would be set to nil. I think this will work. [Editor update: This didn't actually work - as the RichEdit.Lines.Object isn't implemented in TRichEdit control. It is always nil regardless of what you assigned to it] 7. Upgrading to RichEdit98:

I'm also in the process of updating to the RichEdit98 components for Delphi 3.0-4.0. version 1.34 Author Alexander Obukhov, Minsk, Belarus. This control has a number of advances on the standard RichEdit control that ships with Delphi. Included in this are: · BeginUpdate,EndUpdate · Independant background colours · Margins · Hotspots · (Source code in full) Anyway I hope you have enjoyed the adventure.I'm sorry if not all the examples compile as written. They may need some fixing to compile if you copy straight from the Browser into the Delphi Editor. Please send any comments to [email protected]. Jon HogDog

1013

unit RegisterApp; { This used for programs that are installed with InstallShield } { InstallShield leaves Username, Companyname and Serial at } { HKEY_LOCAL_MACHINE\SOFTWARE\ } { (company)\ } { (AppName)\ } { (Version)\ } { the variables are Name, Company, Serial } { } { Programmed by Jack Bakker [email protected] } interface uses Windows, Messages, SysUtils, Controls, Classes, Dialogs, RegisterForm; type TAppInfo = record User: shortstring; Company: shortstring; Serial: shortstring; end; TRegisterApp = class(TComponent) private FName: shortstring; //Application name, provided in IS setup FCompany: shortstring; //Company name, provided in IS setup FVersion: shortstring; //Application version, provided in IS setup FDecryptKey: integer; //0..255 FBaseKey: shortstring; FLicense: shortstring; FUser: shortstring; protected function Encryption(Src:String; Encrypt: Boolean):string; procedure SetDecryptKey(value: integer); public procedure RegisterApp; //Registers an application function IsRegistered: boolean; //performs a check function ReadAppInfo: TAppInfo; //public so you can read info for aboutboxes property License: shortstring read FLicense; //Companyname for the license property User: shortstring read FUser; //Username registration published property DecryptKey: integer read FDecryptKey write SetDecryptKey; property BaseKey: shortstring read FBaseKey write FBaseKey; property AppName: shortstring read FName write FName; property AppCompany: shortstring read FCompany write FCompany; property AppVersion: shortstring read FVersion write FVersion; end; procedure Register; implementation uses Registry; procedure TRegisterApp.RegisterApp; var r: TRegistry; begin XRegisterEntryForm:=TXRegisterEntryForm.Create(Application); //creates the registration entry-form with XRegisterEntryForm do begin if ShowModal=mrOK then if (Encryption(Edit3.Text, False)=Edit1.Text) then begin r:=TRegistry.Create; r.RootKey:=HKEY_LOCAL_MACHINE;

1014

try r.OpenKey('Software', True); r.Openkey(FCompany, True); r.OpenKey(FName, True); r.OpenKey(FVersion, True); r.WriteString('Name', Edit1.Text); r.WriteString('Company', Edit2.Text); r.WriteString('Serial', Edit3.Text); ShowMessage(AppName+' was registered correctly. Restart the application to continue'); except on ERegistryException do ShowMessage('Registration could not be completed due to registry error'); end; end else ShowMessage('Serialnumber could not be confirmed'); end; XRegisterEntryForm.Free; //frees the registration entry-form end; function TRegisterApp.ReadAppInfo: TAppInfo; var r: TRegistry; a: TAppInfo; begin r:=TRegistry.Create; r.RootKey:=HKEY_LOCAL_MACHINE; r.OpenKey('Software', False); r.Openkey(FCompany, False); r.OpenKey(FName, False); r.OpenKey(FVersion, False); try a.User:=r.ReadString('Name'); a.Company:=r.ReadString('Company'); a.Serial:=r.ReadString('Serial'); except a.User:=''; a.Company:=''; a.Serial:=''; end; Result:=a; r.CloseKey; r.Free; end; procedure TRegisterApp.SetDecryptKey(value: integer); begin if value> 255 then FDecryptKey:=255; if value<0 then FDecryptKey:=0 else FDecryptKey:=value; end; function TRegisterApp.Encryption(Src:String; Encrypt: Boolean):string; var idx :integer; KeyLen :Integer; KeyPos :Integer; offset :Integer; dest :string; SrcPos :Integer; SrcAsc :Integer; TmpSrcAsc :Integer; begin if KeyLen = 0 then FBaseKey:='umbra'; KeyLen:=Length(FBaseKey); KeyPos:=0; SrcPos:=0; SrcAsc:=0;

1015

if Encrypt then begin offset:=FDecryptKey; dest:=format('%1.2x',[offset]); for SrcPos := 1 to Length(Src) do begin SrcAsc:=(Ord(Src[SrcPos]) + offset) MOD 255; if KeyPos < KeyLen then KeyPos:= KeyPos + 1 else KeyPos:=1; SrcAsc:= SrcAsc xor Ord(FBaseKey[KeyPos]); dest:=dest + format('%1.2x',[SrcAsc]); offset:=SrcAsc; end; end else begin offset:=StrToInt('$'+ copy(src,1,2)); SrcPos:=3; repeat SrcAsc:=StrToInt('$'+ copy(src,SrcPos,2)); if KeyPos < KeyLen Then KeyPos := KeyPos + 1 else KeyPos := 1; TmpSrcAsc := SrcAsc xor Ord(FBaseKey[KeyPos]); if TmpSrcAsc <= offset then TmpSrcAsc := 255 + TmpSrcAsc - offset else TmpSrcAsc := TmpSrcAsc - offset; dest := dest + chr(TmpSrcAsc); offset:=srcAsc; SrcPos:=SrcPos + 2; until SrcPos >= Length(Src); end; Result:=Dest; end; function TRegisterApp.IsRegistered: boolean; var a: TAppInfo; begin a:=ReadAppInfo; if a.Company<>'' then FLicense:=a.Company else FLicense:='Test Company'; if a.User<>'' then FUser:=a.User else FUser:='Test User'; if Encryption(a.Serial, False)=a.User then Result:=True else Result:=False; end; procedure Register; begin RegisterComponents('Samples', [TRegisterApp]); end; end.

1016

Marching Ants Source Code To re-create this application, simply create a new application, drop a Timer and 7 Labels on the form. Then paste the following text over all the existing code in the Forms source code unit. Compile and enjoy! unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Timer1: TTimer; Label1: TLabel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Label5: TLabel; Label6: TLabel; Label7: TLabel; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private X1,Y1,X2,Y2 : Integer; procedure RemoveTheRect; procedure DrawTheRect; public { Public declarations } end; var Form1: TForm1; Counter : Byte; CounterStart : Byte; Looper : LongInt; implementation {$R *.DFM} procedure MovingDots(X,Y: Integer; TheCanvas: TCanvas); stdcall; begin Inc(Looper); Counter := Counter shl 1; // Shift the bit left one if Counter = 0 then Counter := 1; // If it shifts off left, reset it if (Counter and 224) > 0 then // Are any of the left 3 bits set? TheCanvas.Pixels[X,Y] := Form1.Color // Erase the pixel else TheCanvas.Pixels[X,Y] := clBlack; // Draw the pixel end; function NormalizeRect(R: TRect): TRect; begin // This routine normalizes a rectangle. It makes sure that the Left,Top // coords are always above and to the left of the Bottom,Right coords. with R do if Left > Right then if Top > Bottom then

1017

end;

Result else Result else if Top > Result else Result

:= Rect(Right,Bottom,Left,Top) := Rect(Right,Top,Left,Bottom) Bottom then := Rect(Left,Bottom,Right,Top) := Rect(Left,Top,Right,Bottom);

procedure TForm1.FormCreate(Sender: TObject); begin X1 := 0; Y1 := 0; X2 := 0; Y2 := 0; Canvas.Pen.Color := Color; Canvas.Brush.Color := Color; CounterStart := 128; Timer1.Interval := 100; Timer1.Enabled := True; Looper := 0; end; procedure TForm1.RemoveTheRect; var R : TRect; begin R := NormalizeRect(Rect(X1,Y1,X2,Y2)); // Rectangle might be flipped InflateRect(R,1,1); // Make the rectangle 1 pixel larger InvalidateRect(Handle,@R,True); // Mark the area as invalid InflateRect(R,-2,-2); // Now shrink the rectangle 2 pixels ValidateRect(Handle,@R); // And validate this new rectangle. // This leaves a 2 pixel band all the way around // the rectangle that will be erased & redrawn UpdateWindow(Handle); end; procedure TForm1.DrawTheRect; begin // Determines starting pixel color of Rect Counter := CounterStart; // Use LineDDA to draw each of the 4 edges of the rectangle LineDDA(X1,Y1,X2,Y1,@MovingDots,LongInt(Canvas)); LineDDA(X2,Y1,X2,Y2,@MovingDots,LongInt(Canvas)); LineDDA(X2,Y2,X1,Y2,@MovingDots,LongInt(Canvas)); LineDDA(X1,Y2,X1,Y1,@MovingDots,LongInt(Canvas)); end; procedure TForm1.Timer1Timer(Sender: TObject); begin CounterStart := CounterStart shr 2; // Shl 1 will move rect slower if CounterStart = 0 then CounterStart := 128; // If bit is lost, reset it DrawTheRect; // Draw the rectangle end; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin RemoveTheRect; // Erase any existing rectangle X1 := X; Y1 := Y; X2 := X; Y2 := Y; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if ssLeft in Shift then begin

1018

RemoveTheRect; X2 := X; Y2 := Y; DrawTheRect; end;

// Erase any existing rectangle // Save the new corner where the mouse is // Draw the Rect now... don't wait for the timer!

end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var R1,R2,R3 : TRect; a : Integer; begin // Color all labels red that are in the rectangle For a := 0 to ControlCount-1 do if Controls[a] is TLabel then begin R1 := (Controls[a] as TLabel).BoundsRect; R2 := NormalizeRect(Rect(X1,Y1,X2,Y2)); if IntersectRect(R3,R1,R2) then (Controls[a] as TLabel).Font.Color := clRed else (Controls[a] as TLabel).Font.Color := clWindowText; end; end; end.

1019

Extending Paradox for Windows with Delphi Is the answer Delphi over Paradox, or Paradox over Delphi, or both Paradox and Delphi? At Para/Matrix we think the answer is to use both Paradox and Delphi to provide solutions for database applications. This presentation describes how to use Delphi objects in Paradox for Windows applications using DLL's. The major topics covered are: · Reasons to use both Paradox and Delphi · Interface options using DLL's · Basics for using DLL's in Paradox · Basics for creating DLL's in Delphi · Creating the project · Passing parameters to a DLL · Returning values from a DLL · Calling a complete module in a DLL or EXE · Summary Reasons to use both Paradox and Delphi If you are a contractor building an house, you use a variety of tools and sub-contractors to complete the home. Different tools are used for the specific tasks - plumbers use different tools than framers, framers use different tools than electricians, etc. In writing robust database applications and meeting user requirements you have the same need to use different tools. Paradox provides a feature set that can be used by both the beginner in the database arena along with experienced, knowledgeable database programmers. This allows both end-users and developers to coproduce the final product. Performance and customizability are two areas in Paradox development where there are some limitations. This is where a tool like Delphi can be used. The ability to create EXE and DLL files provides performance improvements while the option to create your own components breaks down the wall preventing complete control over the features in an application. Using DLL's also allows the functionality created in a module to be shared by not just Paradox, but other applications can call the same DLL no matter what language is used. Interface options using DLL's A DLL can be a collection of dialog boxes, stand-alone form based sub-systems, or commonly-used routines without forms. One DLL can contain multiple routines, you do not have to create a separate DLL for each module you create. You can use DLL's in any of the following ways: · Pass values to the DLL · Return values from the DLL · Call a DLL without any parameters or return values This presentations looks at a basic example for each of the above options. Before we see how to create a basic DLL in Delphi, we'll first look at how to make calls to a DLL in Paradox. Basics for using DLL's in Paradox To use DLL's in Paradox you start the same place as using custom methods in an ObjectPAL library -- the Uses window. The basic steps to use a DLL in Paradox are as follows: · Add the DLL name to a Uses block · List the routine(s) in the Uses block · Ensure the DLL is located in the correct directory · Call the DLL like a custom method You need to declare each DLL used and prototype functions and procedures used in the DLL. The basic syntax is shown below: Uses dllName outine1Name(parameterList) returnValue routine2Name(parameterList) returnValue endUses The argument dllName specifies the DLL file name. The location of the DLL depends on how your system is configured. The following is the order Windows searches for the DLL: 196. The current directory. 197. The Windows directory (most commonly found in C:\WINDOWS). 198. The Windows system directory (most commonly found in C:\WINDOWS\SYSTEM). 199. The directories specified in the PATH statement. 200. The directories mapped in a network.

1020

Each routine used in the DLL must be specified in the Uses block. If there are values passed to the routine, the parameter list must include a separate entry for each parameter and it's data type. If there is a return value from the DLL, the data type of the return value must be included. You can declare the use of multiple DLL's in the same Uses block. Each DLL used has it's file name specified and the routines in the DLL that are called from your Paradox application. Paradox requires the use of specific keywords when using calls to external routines. Table 1 lists the type of data, the keyword used in ObjectPAL and the equivalent data type in C and Pascal routines. Table 1 - Paradox keywords for external data types ObjectPAL Data type keyword C Pascal 16-bit integer CWORD int Integer 32-bit integer CLONG long Longint 64-bit floating-point CDOUBLE double Double number 80-bit floating-point CLONGDOUBLE long double Extended number pointer CPTR char far * PChar binary or graphic data CHANDLE Handle (Windows) THandle (Windows) The Uses block are the only place where these keywords are valid. The are not to be used in any other code windows in Paradox. Paradox automatically converts these data types to the variable and field data types used in ObjectPAL. Table 2 lists the corresponding ObjectPAL data type for each keyword. Table 2 - Corresponding ObjectPAL data types for each keyword ObjectPAL keyword ObjectPAL data type CWORD SmallInt CLONG LongInt CDOUBLE Number CLONGDOUBLE Number CPTR String CHANDLE Binary and Graphic Once the DLL is specified in the Uses block and the routines with their parameters are listed, calling the routines is the same as calling any custom procedure. For example, the first DLL discussed in this paper is to call a table viewer DLL. Two parameters are passed -- the name of a directory (or alias) and the name of a table. This requires two string parameters to be passed. Listing 1 shows the Uses block to call the TBLVIEW DLL. The routine called in the DLL is TableViewer. 1. Uses 2. VIEWTBL 3. ViewTable(dirName CPTR, tblName CPTR) 4. endUses Listing 1: Uses block to call a DLL passing two string values The call to the procedure in the DLL is the same as a call to a custom method. Listing 2 shows the code to call the DLL which is attached to a pushButton method in a Paradox form. 1. method pushButton(var eventInfo Event) 2. var 3. dirName, 4. tblName String 5. fbi fileBrowserInfo 6. endVar 7. 8. fbi.Alias = ":WORK:" 9. fbi.AllowableTypes = fbTable 10. fbi.SelectedType = fbTable 11. fbi.FileFilters = "*.db" 12. 13. message("Select a table name") 14. if fileBrowser(tblName,fbi) then 15. if fbi.path.isBlank() then 16. dirName = fbi.alias 17. else 18. dirName = fbi.alias+fbi.path 19. endIf 20. ViewTable(dirName,tblName) ; Call to the DLL

1021

21. endIf 22. 23. endmethod Listing 2: Calling the DLL from a push button Basics for creating DLL's in Delphi To build a DLL in Delphi you start with a project. This easiest way to get started is to create a Delphi application first then convert it to a DLL. The basic steps to create a DLL are as follows: · Create a Delphi project · Change the project file (.DPR code) · Declare the interface procedure as export · Add the interface routine in the unit file · Compile to create the DLL The first DLL example is a Delphi form to view a specified table. A database and table name are passed to the DLL which in turns uses the values to display the data in a Delphi grid. The basic steps to create the project and DLL are covered in the following paragraphs. Creating the project In Delphi we start with a new project. Three components are placed on the form: · Table · Datasource · Grid The properties of these components are set to open an existing table for testing purposes. The form is design mode is shown in Figure 1.

Figure 1: Basic table viewer form After saving the project and giving it the name VIEWTST and naming the unit file VIEWTSTU, the project code changes to that shown in Listing 3. 1. program Viewtst; 2. 3. uses 4. Forms, 5. Viewtstu in 'VIEWTSTU.PAS' {Form1}; 6. 7. {$R *.RES} 8. 9. begin 10. Application.CreateForm(TForm1, Form1); 11. Application.Run; 12. end. Listing 3: Original project code To change the project so it creates a DLL, the following changes need to be made to the project code: · change the reserved word program to library · remove the Forms, line in the uses section · remove all lines in the begin..end block

1022

·

between the uses and begin..end block add the reserved word exports and on the next line the name of the interface routine to be called from other programs. Listing 4 shows the changes made to the project code where the name of the interface routine is ViewTable. 1. program Viewtst; 2. 3. uses 4. Viewtstu in 'VIEWTSTU.PAS' {Form1}; 5. 6. {$R *.RES} 7. 8. begin 9. 10. end. Listing 4: Modified project code The next two steps deal with the unit file in the Delphi project. You need to declare the interface procedure or function in the interface section. Listing 5 shows the declaration for the table viewer example. 1. procedure ViewTable(dbName: PChar; tblName: PChar); export; Listing 5: Procedure declaration in the interface section of the unit file Two parameters are passed to the DLL. The first, dbName, is the name of the directory or alias for the table and the second, tblName, is the name of the table. Both are defined and PChar. This is required when passing strings from Paradox. The next change to the unit file is the write the ViewTable procedure. Listing 6 shows the ViewTable code. 1. procedure ViewTable(dbName: PChar; tblName: PChar); 2. begin 3. if (dbName >> nil) and (tblName >> nil) then 4. begin 5. MainForm := TMainForm.Create(Application); 6. try 7. with MainForm.tblView do 8. begin 9. Close; 10. DatabaseName := StrPas(dbName); 11. TableName := StrPas(tblName); 12. Open; 13. end; 14. MainForm.Caption := 'Table View - ' + 15. MainForm.tblView.DatabaseName + 16. MainForm.tblView.TableName; 17. MainForm.ShowModal; 18. finally 19. MainForm.Free; 20. end; 21. end; 22. end; Listing 6: ViewTable procedure in the implementation section The first check in line 3 is to ensure both the directory name and table name are passed. In this example, there is no checking for valid table and directory names since the Paradox browser is used to select both before calling the DLL. A try..finally block is used to open the table. This always frees the memory used by the form that is created at runtime. The StrPas function is used to convert the PChar data to a string data type in lines 10 and 11. This is necessary for asinine the values passed to the appropriate properties in the Table object. The form is displayed in line 17. ShowModal is used to make the form modal. This requires the user to close the form before returning to Paradox. Once this is done, line 19 removes the form and control is returned to the calling program. Once the project and unit file are created, you need to save the project using the eight character name you want for the DLL. The last step is to create the DLL. This is done using the Compile | Build All menu selection. This compiles the code and creates a DLL in the same directory where the project is stored. Passing parameters to a DLL Passing parameters to a DLL requires you to match the number of parameters to those in the DLL and to match the data types. The basics of calling a DLL where you only pass parameters was covered earlier in the Basics for using DLL's in Paradox section.

1023

Returning values from a DLL To return a value from a DLL you need to declare the routine in Delphi as a function instead of a procedure. A function allows a single value to be returned. The declaration in a Uses block in a Paradox form for this type of call to a DLL is shown in Listing 7. 1. Uses 2. MATH101 3. BasicMath(int1 CWORD, int2 CWORD) CDOUBLE 4. endUses Listing 7: Uses block for a DLL routine that returns a value In this example the DLL MATH101 is used. It takes to integer values and returns number based on the type of mathematical calculation selected in the DLL's form. Figure 2 shows the form the DLL displays.

Figure 2: DLL demo for basic mathematics When the Operator is changed, a new calculation is performed. The Operator selection specified when the OK button is clicked dictates the value returned. This value needs to be a Number data type in Paradox which corresponds to the CDOUBLE keyword in the Uses block. The code to use the MATH101 DLL is shown in Listing 8. 1. method pushButton(var eventInfo Event) 2. var 3. i1, 4. i2 SmallInt 5. retval Number 6. endVar 7. 8. i1.blank() ; Initialize variable. 9. i2.blank() ; Initialize variable. 10. i1.view("Enter the first integer:") ; Get first integer value. 11. if i1.isBlank() then 12. i1 = 5 ; Default to 5 if no value entered. 13. endIf 14. i2.view("Enter the second integer:") ; Get second integer value. 15. if i2.isBlank() then 16. i2 = 3 ; Default to 3 if no value entered. 17. endIf 18. 19. retval = BasicMath(i1,i2) 20. retval.view("The value returned is:") 21. 22. endmethod Listing 8: ObjectPAL to call the BasicMath routine in the MATH101 DLL Lines 8 through 17 initialize and prompt for the two integer values used in the demo. The ObjectPAL view method is used to simplify the example. The DLL is called in line 19. The Paradox variable retval is set to the value returned by BasicMath. The function declaration used on Delphi side to create the DLL is shown in Listing 9. 1. function BasicMath(int1: Integer;int2: Integer): Double; export; Listing 9: Function declaration in the interface section of the unit file In Delphi, the return type is declared as Double. The two parameters are defined using the Integer data type. Listing 10 shows the code for the function. 1. function BasicMath(int1: Integer; int2:Integer): Double; 2. begin 3. Result := int1 + int2; 4. try

1024

5. Form1 := TForm1.Create(Application); 6. Form1.Edit1.Text := IntToStr(int1); 7. Form1.Edit2.Text := IntToStr(int2); 8. Form1.Edit3.Text := IntToStr(int1+int2); 9. Form1.ShowModal; 10. Result := StrToFloat(Form1.Edit3.Text); 11. finally 12. Form1.Free; 13. end; 14. end; Listing 10: BasicMath function in the implementation section In Delphi, Result is reserved as a local variable to set for the value the function returns. This is used in line 3 to initially set the value returned. By default, the form starts with Addition as the default operator selected. After setting the values of the Edit objects to the two integers passed and the result of adding the two integers, the form is displayed in line 9. The actual result returned is set in line 10 based on the currently selected operator. Calling a complete module in a DLL or EXE Both DLL's and EXE's can be used to create an entire subset of an application. To call an EXE created with Delphi is no different than any other EXE. The last DLL example used to demonstrate this capability is an extension of the first DLL example. A DLL is used to display a window that is a table viewer for any table available from a user's machine. Figure 3 shows the window open without any table.

Figure 3: General Table Viewer This DLL adds the ability to open any table and view the data. To select a table, the Open speedbar button or File | Open is selected. This displays the Open dialog box shown in Figure 4.

Figure 4: Table Open dialog box Once a table is selected, the data in the table is displayed in the window. Figure 5 shows the Table Viewer after selecting the CUSTOMER.DB table form the Paradox Samples directory.

1025

Figure 5: Table Viewer showing the CUSTOMER.DB table The Uses block for this example is shown in Listing 11. 1. Uses 2. TBLVWER 3. TableViewer() 4. 5. endUses Listing 11: Uses block to call the generic table viewer In this example no parameters are passed and no values are returned. The call to the DLL is shown in Listing 12. In this example, the Paradox Desktop is minimized before the call and maximized after returning from the DLL. 1. method pushButton(var eventInfo Event) 2. var 3. app Application 4. endVar 5. 6. app.minimize() ; Minimize the Paradox Desktop. 7. 8. TableViewer() ; Call the DLL. 9. 10. app.maximize() ; Maximize the Paradox Desktop. 11. 12. endmethod Listing 12: Call to the generic table viewer DLL This type of DLL allows the viewing of any table the user has access to. Using a DLL in this fashion allows the Delphi creator to place all features in a single module which can be used from any Windows routine. Summary Delphi provides the ability to extend the capability of Paradox applications. Using DLL's and EXE's give you the ability to enhance the features included in Paradox applications at the same time it builds up the library of Delphi code for future use. It also allows you to use the routines not only in Paradox and Delphi, but any Windows application where you can call DLL's. Delphi Main Page Paradox for Windows Page Borland's Technical Acquisitions page Borland Online Borland Online | Latest News | Company Info | Tech Info Product Info | Programs and Services | Feedback | The Files Copyright © 1995 Borland International, Inc. Last modified October 27, 1995

1026

Marco Cantù, Mastering Delphi 6 (Sybex Inc.) Chapter 20 - Package MdXArr Package Structure · XArrow_TLB.pas · MdWArrow.pas XArrow_TLB.pas unit XArrow_TLB; // // // // // // // // // // // //

************************************************************************ WARNING ------The types declared in this file were generated from data read from a Type Library. If this type library is explicitly or indirectly (via another type library referring to this type library) reimported, or the 'Refresh' command of the Type Library Editor activated while editing the Type Library, the contents of this file will be regenerated and all manual modifications will be lost. ************************************************************************

// PASTLWTR : $Revision: 1.118 $ // File generated on 4/29/2001 4:21:40 PM from Type Library described below. // ************************************************************************ // // Type Lib: C:\md6code\20\XArrow\XArrow.tlb (1) // LIBID: {482B2140-4133-11D3-B9F1-00000100A27B} // LCID: 0 // Helpfile: // DepndLst: // (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb) // (2) v4.0 StdVCL, (C:\WINDOWS\system32\stdvcl40.dll) // ************************************************************************ // {$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. {$WARN SYMBOL_PLATFORM OFF} {$WRITEABLECONST ON} interface uses ActiveX, Classes, Graphics, OleCtrls, StdVcl, Variants, Windows;

// *********************************************************************// // GUIDS declared in the TypeLibrary. Following prefixes are used: // Type Libraries : LIBID_xxxx // CoClasses : CLASS_xxxx // DISPInterfaces : DIID_xxxx // Non-DISP interfaces: IID_xxxx // *********************************************************************// const // TypeLibrary Major and minor versions XArrowMajorVersion = 1; XArrowMinorVersion = 0; LIBID_XArrow: TGUID = '{482B2140-4133-11D3-B9F1-00000100A27B}'; IID_IMdWArrowX: TGUID = '{482B2141-4133-11D3-B9F1-00000100A27B}'; DIID_IMdWArrowXEvents: TGUID = '{482B2143-4133-11D3-B9F1-00000100A27B}'; CLASS_MdWArrowX: TGUID = '{482B2145-4133-11D3-B9F1-00000100A27B}'; // *********************************************************************//

1027

// Declaration of Enumerations defined in Type Library // *********************************************************************// // Constants for enum TxMdWArrowDir type TxMdWArrowDir = TOleEnum; const adUp = $00000000; adLeft = $00000001; adDown = $00000002; adRight = $00000003; // Constants for enum TxMouseButton type TxMouseButton = TOleEnum; const mbLeft = $00000000; mbRight = $00000001; mbMiddle = $00000002; type // *********************************************************************// // Forward declaration of types defined in TypeLibrary // *********************************************************************// IMdWArrowX = interface; IMdWArrowXDisp = dispinterface; IMdWArrowXEvents = dispinterface; // // // //

*********************************************************************// Declaration of CoClasses defined in Type Library (NOTE: Here we map each CoClass to its Default Interface) *********************************************************************// MdWArrowX = IMdWArrowX;

// // // // //

*********************************************************************// Interface: IMdWArrowX Flags: (4416) Dual OleAutomation Dispatchable GUID: {482B2141-4133-11D3-B9F1-00000100A27B} *********************************************************************// IMdWArrowX = interface(IDispatch) ['{482B2141-4133-11D3-B9F1-00000100A27B}'] function Get_Direction: TxMdWArrowDir; safecall; procedure Set_Direction(Value: TxMdWArrowDir); safecall; function Get_ArrowHeight: Integer; safecall; procedure Set_ArrowHeight(Value: Integer); safecall; function Get_Filled: WordBool; safecall; procedure Set_Filled(Value: WordBool); safecall; function Get_DoubleBuffered: WordBool; safecall; procedure Set_DoubleBuffered(Value: WordBool); safecall; function Get_Enabled: WordBool; safecall; procedure Set_Enabled(Value: WordBool); safecall; function Get_Visible: WordBool; safecall; procedure Set_Visible(Value: WordBool); safecall; function Get_Cursor: Smallint; safecall; procedure Set_Cursor(Value: Smallint); safecall; function Get_FillColor: Integer; safecall; procedure Set_FillColor(Value: Integer); safecall; function Get_PenColor: Integer; safecall; procedure Set_PenColor(Value: Integer); safecall; property Direction: TxMdWArrowDir read Get_Direction write Set_Direction; property ArrowHeight: Integer read Get_ArrowHeight write Set_ArrowHeight; property Filled: WordBool read Get_Filled write Set_Filled; property DoubleBuffered: WordBool read Get_DoubleBuffered write Set_DoubleBuffered; property Enabled: WordBool read Get_Enabled write Set_Enabled;

1028

property property property property end;

Visible: WordBool read Get_Visible write Set_Visible; Cursor: Smallint read Get_Cursor write Set_Cursor; FillColor: Integer read Get_FillColor write Set_FillColor; PenColor: Integer read Get_PenColor write Set_PenColor;

// // // // //

*********************************************************************// DispIntf: IMdWArrowXDisp Flags: (4416) Dual OleAutomation Dispatchable GUID: {482B2141-4133-11D3-B9F1-00000100A27B} *********************************************************************// IMdWArrowXDisp = dispinterface ['{482B2141-4133-11D3-B9F1-00000100A27B}'] property Direction: TxMdWArrowDir dispid 1; property ArrowHeight: Integer dispid 2; property Filled: WordBool dispid 3; property DoubleBuffered: WordBool dispid 4; property Enabled: WordBool dispid -514; property Visible: WordBool dispid 13; property Cursor: Smallint dispid 14; property FillColor: Integer dispid 20; property PenColor: Integer dispid 21; end;

// // // // //

*********************************************************************// DispIntf: IMdWArrowXEvents Flags: (4096) Dispatchable GUID: {482B2143-4133-11D3-B9F1-00000100A27B} *********************************************************************// IMdWArrowXEvents = dispinterface ['{482B2143-4133-11D3-B9F1-00000100A27B}'] procedure OnClick; dispid 1; procedure OnArrowDblClick; dispid 8; end;

// // // // // // // // //

*********************************************************************// OLE Control Proxy class declaration Control Name : TMdWArrowX Help String : MdWArrowX Control Default Interface: IMdWArrowX Def. Intf. DISP? : No Event Interface: IMdWArrowXEvents TypeFlags : (34) CanCreate Control *********************************************************************// TMdWArrowX = class(TOleControl) private FOnClick: TNotifyEvent; FOnArrowDblClick: TNotifyEvent; FIntf: IMdWArrowX; function GetControlInterface: IMdWArrowX; protected procedure CreateControl; procedure InitControlData; override; public property ControlInterface: IMdWArrowX read GetControlInterface; property DefaultInterface: IMdWArrowX read GetControlInterface; property DoubleBuffered: WordBool index 4 read GetWordBoolProp write SetWordBoolProp; property Enabled: WordBool index -514 read GetWordBoolProp write SetWordBoolProp; property Visible: WordBool index 13 read GetWordBoolProp write SetWordBoolProp; published property TabStop; property Align;

1029

property DragCursor; property DragMode; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnStartDrag; property Direction: TOleEnum index 1 read GetTOleEnumProp write SetTOleEnumProp stored False; property ArrowHeight: Integer index 2 read GetIntegerProp write SetIntegerProp stored False; property Filled: WordBool index 3 read GetWordBoolProp write SetWordBoolProp stored False; property Cursor: Smallint index 14 read GetSmallintProp write SetSmallintProp stored False; property FillColor: Integer index 20 read GetIntegerProp write SetIntegerProp stored False; property PenColor: Integer index 21 read GetIntegerProp write SetIntegerProp stored False; property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnArrowDblClick: TNotifyEvent read FOnArrowDblClick write FOnArrowDblClick; end; procedure Register; resourcestring dtlServerPage = 'Servers'; implementation uses ComObj; procedure TMdWArrowX.InitControlData; const CEventDispIDs: array [0..1] of DWORD = ( $00000001, $00000008); CControlData: TControlData2 = ( ClassID: '{482B2145-4133-11D3-B9F1-00000100A27B}'; EventIID: '{482B2143-4133-11D3-B9F1-00000100A27B}'; EventCount: 2; EventDispIDs: @CEventDispIDs; LicenseKey: nil (*HR:$00000000*); Flags: $00000008; Version: 401); begin ControlData := @CControlData; TControlData2(CControlData).FirstEventOfs := Cardinal(@@FOnClick) Cardinal(Self); end; procedure TMdWArrowX.CreateControl; procedure DoCreate; begin FIntf := IUnknown(OleObject) as IMdWArrowX; end; begin if FIntf = nil then DoCreate; end;

1030

function TMdWArrowX.GetControlInterface: IMdWArrowX; begin CreateControl; Result := FIntf; end; procedure Register; begin RegisterComponents('ActiveX',[TMdWArrowX]); end; end. MdWArrow.pas unit MdWArrow; interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TMdWArrowDir = (adUp, adLeft, adDown, adRight); TMdWArrow = class (TCustomControl) private fDirection: TMdWArrowDir; fArrowHeight: Integer; fFilled: Boolean; fPen: TPen; fBrush: TBrush; fArrowDblClick: TNotifyEvent; fArrowPoints: array [0..3] of TPoint; procedure ComputePoints; procedure SetDirection (Value: TMdWArrowDir); procedure SetArrowHeight (Value: Integer); procedure SetFilled (Value: Boolean); procedure SetPen (Value: TPen); procedure SetBrush (Value: TBrush); procedure RepaintRequest (Sender: TObject); procedure WMLButtonDblClk (var Msg: TWMLButtonDblClk); message wm_LButtonDblClk; protected procedure Paint; override; procedure ArrowDblClick; dynamic; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override; published property Width default 50; property Height default 20; property Direction: TMdWArrowDir read fDirection write SetDirection default adRight; property ArrowHeight: Integer read fArrowHeight write SetArrowHeight default 10; property Filled: Boolean read fFilled write SetFilled default False; property Pen: TPen read fPen write SetPen; property Brush: TBrush read fBrush write SetBrush; property OnClick; property OnDragDrop; property OnDragOver;

1031

property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnArrowDblClick: TNotifyEvent read fArrowDblClick write fArrowDblClick; end; procedure Register; implementation {R ARROW4.DCR} constructor TMdWArrow.Create (AOwner: TComponent); begin // call the parent constructor inherited Create (AOwner); // set the default values fDirection := adRight; Width := 50; Height := 20; fArrowHeight := 10; fFilled := False; // create the pen and the brush fPen := TPen.Create; fBrush := TBrush.Create; // set a handler for the OnChange event fPen.OnChange := RepaintRequest; fBrush.OnChange := RepaintRequest; end; destructor TMdWArrow.Destroy; begin // delete the two objects fPen.Free; fBrush.Free; // call the parent destructor inherited Destroy; end; procedure TMdWArrow.SetDirection (Value: TMdWArrowDir); begin if fDirection <> Value then begin fDirection := Value; ComputePoints; Invalidate; end; end; procedure TMdWArrow.SetArrowHeight (Value: Integer); begin if fArrowHeight <> Value then begin fArrowHeight := Value; ComputePoints; Invalidate; end; end; procedure TMdWArrow.SetFilled (Value: Boolean); begin

1032

if fFilled <> Value then begin fFilled := Value; Invalidate; end; end; procedure TMdWArrow.SetPen (Value: TPen); begin fPen.Assign(Value); Invalidate; end; procedure TMdWArrow.SetBrush (Value: TBrush); begin fBrush.Assign(Value); Invalidate; end; procedure TMdWArrow.RepaintRequest (Sender: TObject); begin Invalidate; end; procedure TMdWArrow.Paint; var XCenter, YCenter: Integer; begin // compute the center YCenter := (Height - 1) div 2; XCenter := (Width - 1) div 2; // use the current pen and brush Canvas.Pen := fPen; Canvas.Brush := fBrush; // draw the arrow line case fDirection of adUp: begin Canvas.MoveTo (XCenter, Height-1); Canvas.LineTo (XCenter, fArrowHeight); end; adDown: begin Canvas.MoveTo (XCenter, 0); Canvas.LineTo (XCenter, Height - 1 - fArrowHeight); end; adLeft: begin Canvas.MoveTo (Width - 1, YCenter); Canvas.LineTo (fArrowHeight, YCenter); end; adRight: begin Canvas.MoveTo (0, YCenter); Canvas.LineTo (Width - 1 - fArrowHeight, YCenter); end; end; // draw the arrow head, eventually filling it if fFilled then Canvas.Polygon (fArrowPoints) else Canvas.PolyLine (fArrowPoints); end; procedure TMdWArrow.ArrowDblClick; begin // call the handler, if available

1033

if Assigned (fArrowDblClick) then fArrowDblClick (Self); end; procedure Register; begin RegisterComponents('Md', [TMdWArrow]); end; procedure TMdWArrow.ComputePoints; var XCenter, YCenter: Integer; begin // compute the points of the arrow head YCenter := (Height - 1) div 2; XCenter := (Width - 1) div 2; // set the points depending on the direction case fDirection of adUp: begin fArrowPoints [0] := Point (0, fArrowHeight); fArrowPoints [1] := Point (XCenter, 0); fArrowPoints [2] := Point (Width-1, fArrowHeight); fArrowPoints [3] := Point (0, fArrowHeight); end; adDown: begin fArrowPoints [0] := Point (XCenter, Height - 1); fArrowPoints [1] := Point (0, Height - 1 - fArrowHeight); fArrowPoints [2] := Point (Width - 1, Height - 1 - fArrowHeight); fArrowPoints [3] := Point (XCenter, Height - 1); end; adLeft: begin fArrowPoints [0] := Point (fArrowHeight, Height - 1); fArrowPoints [1] := Point (0, YCenter); fArrowPoints [2] := Point (fArrowHeight, 0); fArrowPoints [3] := Point (fArrowHeight, Height - 1); end; adRight: begin fArrowPoints [0] := Point (Width - 1 - fArrowHeight, Height - 1); fArrowPoints [1] := Point (Width - 1 - fArrowHeight, 0); fArrowPoints [2] := Point (Width - 1, YCenter); fArrowPoints [3] := Point (Width - 1 - fArrowHeight, Height - 1); end; end; // case end; procedure TMdWArrow.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited SetBounds (ALeft, ATop, AWidth, AHeight); ComputePoints; end; procedure TMdWArrow.WMLButtonDblClk(var Msg: TWMLButtonDblClk); var HRegion: HRgn; begin // perform default handling inherited; // compute the arrow head region HRegion := CreatePolygonRgn ( fArrowPoints, 3, WINDING); try // check whether the click took place in the region if PtInRegion (HRegion, Msg.XPos, Msg.YPos) then ArrowDblClick;

1034

finally DeleteObject (HRegion); end; end; end. © Copyright Marco Cantù 2001

1035

procedure TCustomForm.MergeMenu(MergeState: Boolean); var AMergeMenu: TMainMenu; // This second variable is taken out in D5. Probably in a compile // after the restore/re-maximize code was lost, the variable // was marked as "never used" and (probably) deleted without // checking to see why it was not used. Size: Longint; begin if not (fsModal in FFormState) and (Application.MainForm <> nil) and (Application.MainForm.Menu <> nil) and (Application.MainForm <> Self) and ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then begin AMergeMenu := nil; if not (csDesigning in ComponentState) and (Menu <> nil) and (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu; with Application.MainForm.Menu do if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu); // The if-statement and its block was dropped out in D5. if MergeState and (FormStyle = fsMDIChild) and (WindowState = wsMaximized) then begin { Force MDI to put back the system menu of a maximized child } Size := ClientWidth + (Longint(ClientHeight) shl 16); SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size); SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size); end; end; end; Listing 2: The Full Routine procedure TCustomForm.MergeMenu(MergeState: Boolean); var AMergeMenu: TMainMenu; Size: Longint; FixMaximize: boolean; begin if not (fsModal in FFormState) and (Application.MainForm <> nil) and (Application.MainForm.Menu <> nil) and (Application.MainForm <> Self) and ((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <> fsMDIForm)) then begin AMergeMenu := nil; if not (csDesigning in ComponentState) and (Menu <> nil) and (Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu; FixMaximize := MergeState and (FormStyle = fsMDIChild) and (WindowState = wsMaximized); // The important change from the healthy MergeMenu from D4 // is that the Restore/RE-maximize are split up to match the // behavior described in the Win32 Help's wm_MDINext topic (at // the bottom). if FixMaximize then begin { Force MDI to put back the system menu of a maximized child } Size := ClientWidth + (Longint(ClientHeight) shl 16); SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size); end; try

1036

with Application.MainForm.Menu do if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu); finally if FixMaximize then begin Size := ClientWidth + (Longint(ClientHeight) shl 16); SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size); end; end; end; end; Listing 3: A new System Next/Prev // These vars are needed in MDIMainForm Interface. var IsNext: boolean; IsPrev: boolean; IsMaxed: boolean; F6One: string; F6Two: string; // // // //

This system message handler is needed in MDIChildForm I use VK_F16 as a "sneaker" key, but if someone has a keyboard with sixteen function keys, F16 will not act like System Next/Prev.

procedure TEditForm.WMSysCommand(var Msg: TWMSysCommand); begin Case Msg.CmdType of SC_NextWindow: begin IsNext := True; postmessage(Application.Handle, wm_KeyDown, vk_F16, 0); end; SC_PREVWINDOW: begin IsPrev := True; postmessage(Application.Handle, wm_KeyDown, vk_F16, 0); end else inherited; end; end; // On MDIMAin Form, this is your Application.OnMessage handler. procedure TFrameForm.AppMessage(var Msg: TMsg; var Handled: boolean); var Sz: TKeyboardState; begin if (IsNext or IsPrev) and (Msg.wParam = vk_F16) and (Msg.message = wm_KeyDown) then begin if IsNext then GetNext else if IsPrev then getPrev; IsNext := False; IsPrev := False; Handled := True; end; ... end; // Finally, on MDIMainForm in implementation section, these // two routines.

1037

procedure TFrameForm.GetNext; begin if MDIChildCount < 2 then begin messageBeep(0); Exit; end; LockWindowUpdate(Handle); F6One := ActiveMDIChild.Caption; if ActiveMDIChild.WindowState = wsMaximized then begin IsMaxed := True; ActiveMDIChild.WindowState := wsNormal; end; MDIChildren[1].BringToFront; if IsMaxed then begin IsMaxed := False; ActiveMDIChild.WindowState := wsMaximized; end; F6Two := ActiveMDIChild.Caption; LockWindowUpdate(0); end; procedure TFrameForm.GetPrev; var i: integer; begin if MDIChildCount < 2 then begin messageBeep(0); Exit; end; LockWindowUpdate(Handle); if ActiveMDIChild.WindowState = wsMaximized then begin IsMaxed := True; ActiveMDIChild.WindowState := wsNormal; end; for i := 0 to MDIChildCount - 1 do if MDIChildren[i].Caption = F6One then MDIChildren[i].BringToFront; for i := 0 to MDIChildCount - 1 do if MDIChildren[i].Caption = F6Two then MDIChildren[i].BringToFront; if IsMaxed then begin IsMaxed := False; ActiveMDIChild.WindowState := wsMaximized; end; LockWindowUpdate(0); end;

1038

program Password; uses Dos,crt; type Word1=record pass1:string; end; var strarray:array[1..20] of string; i:integer; str2:string; File1:File of word1; File2:Text; BufferF:Text; xstr,tstr,pstr,str1:word1; GetCB:Boolean; begin if FSearch('Openit.dat','C:\')='' then begin Assign(File1,'C:\Openit.dat'); Rewrite(File1); xstr.pass1:='0000'; Write(File1,xstr); Close(File1); Assign(File2,'C:\Autoexec.bat'); Reset(File2); Assign(BufferF,'C:\Auto.txt'); Rewrite(BufferF); while not EOF(File2) do begin Readln(File2,str2); Writeln(BufferF,str2); end; Close(BufferF); Close(File2); Assign(File2,'C:\Autoexec.bat'); Assign(BufferF,'C:\Auto.txt'); Rewrite(File2); Reset(BufferF); str2:='C:\Password.exe'; writeln(File2,str2); while not EOF(BufferF) do begin readln(BufferF,str2); writeln(File2,str2); end; Erase(BufferF); Close(File2); end; clrscr; writeln(' *************** MACHINE PROTECTOR by MACROTECH ***************'); writeln(' We are just a click away ---> http://www.macrotech.bigstep.com '); writeln; writeln(' YOUR CHOICES '); writeln(' ---------------------------------'); writeln(' CHANGE PASSWORD : 1'); writeln(' CANCEL PASSWORD : 2'); writeln; writeln('******************************************************************************'); writeln('******************* ENTER YOUR PASSWORD OR CHOICE *************************'); writeln('******************* *************************'); writeln('******************* *************************'); writeln('******************************************************************************');

1039

Assign(File1,'C:\Openit.dat'); Reset(File1); Read(File1,xstr); Close(File1); repeat gotoxy(25,12); readln(pstr.pass1); if pstr.pass1='1' then begin gotoxy(20,16); write('Enter Current Password : '); repeat gotoxy(45,16); readln(tstr.pass1); until tstr.pass1=xstr.pass1; if tstr.pass1=xstr.pass1 then begin gotoxy(20,17); write('Enter New Password : '); readln(xStr.pass1); gotoxy(25,12); Assign(File1,'C:\Openit.dat'); Rewrite(File1); write(File1,xstr); close(File1); end; end; if pstr.pass1='2' then begin gotoxy(20,16); write('Enter Current Password : '); repeat gotoxy(45,16); readln(tstr.pass1); until tstr.pass1=xstr.pass1; if tstr.pass1=xstr.pass1 then begin Assign(File2,'C:\Autoexec.bat'); Reset(File2); Assign(BufferF,'C:\Auto.txt'); Rewrite(BufferF); while not EOF(File2) do begin Readln(File2,str2); if str2<>'C:\Password.exe' then writeln(BufferF,str2); end; Close(File2); Close(BufferF); Assign(File2,'C:\autoexec.bat'); Assign(BufferF,'C:\Auto.txt'); Rewrite(File2); Reset(BufferF); while not EOF(BufferF) do begin Readln(BufferF,str2); writeln(File2,str2); end; Close(File2); erase(BufferF);

1040

Close(BufferF); tstr.pass1:=xstr.pass1; Assign(File1,'C:\Openit.dat'); Rewrite(File1); xstr.pass1:='0000'; Write(File1,xstr); erase(File1); xstr.pass1:=tstr.pass1; end; clrscr; gotoxy(25,10); writeln('Re-Enter Password'); end; until pstr.pass1=xstr.pass1; clrscr; end.

1041

Learning Assembler with Delphi Page 1: What, when, why? Article submitted by: Ian Hodger More of this Feature Abstract • Page 2: Basic The purpose of this article is to fill some of the gaps left by the operations original documentation provided with Borland's Delphi Developer, • Page 3: A proper however, at the time of writing, all of the code and concepts example discussed herewithin are fully applicable to all variants of Delphi. This • Page 4: Matrices article was originally written in 1997. • Page 5: Fast screen The Principle area of discussion will be the use of assembler within plotting Object Pascal. Nevertheless, other aspects of programming will be covered in passing, as required for the examples given. For simplicity, only a subset of Intel's instructions will be introduced, Join the Discussion thus enabling a more generalized approach with few special cases. Furthermore, all the examples of assembler given will be contained in "Post your questions, Pascal wrappers with portability in mind. Issues such as File access in concerns, views and assembler will not be covered, as this is more reliably achieved using comments to this standard Object Pascal. Indeed the document will seek to emphasis article..." Discuss! that one should only use assembler when necessary. In general, the document will take the following form. First an idea will be introduced, followed immediately by a relevent example, Related Resources concluding with an explanation of greater depth. This format is • Delphi Pascal tech. abandoned where clarity demands. articles Using Assembler in Borland's Delphi Before we start, I should like to state the level of knowledge which I • Win/API programming shall assume of the reader. Writing Object Pascal should be second nature. One should be familiar with Delphi's built in debugging facilities. Finally a general understanding of what is meant by terms such as instantiation, null pointer and memory allocation, is a must. If any of the above encourages feelings of doubt, please tread very carefully. Furthermore, only 32bit code will be discussed, and as such About Poll Delphi 2.0 is a necessity. Why use Assembler? I have always found Object Pascal to produce fast and efficient code, http://delphi.ab add to this the Rapid Development Environment of Delphi, and the 056579025 need to use assembler becomes questionable. In all of my work with This Delphi, I have come across just two situations where I have felt one [052501] article is: should consider the use of low level code. Awesome 1 (1) Processing large quantities of data. Nb. I exclude from this any (5) situation where a data query language is employed. For reasons of Great (4) 2 compatibility one should not tinker. (2) High speed display routines. Nb. I refer here to quick easy routines that sit well with pascal, not the esoteric C++ headers, Ok (3) 3 external function libraries and hardware demands of DirectX. I hope to introduce an example or two by the end of this article Not bad 4 which meet the above criteria, and in doing so demonstrate not only (2) how and when to use assembler, but also the seamless manner in which Delphi incorporates this code. Poor (1) 5 What is Assembler? I will assume that you have a rough idea of how a cpu goes about it's Submit Vote business. Basically we have a fancy calculator with a big memory. The memory is no more than an ordered sequence of binary digits arranged in blocks of eight bits, each forming a byte. Thus each byte Current Results can store an integer in the range of 0 to 255, and each byte's position in the sequence of memory gives it an unique address by which the cpu may change or recover it's value. The cpu also has a number of registers (you may like to think of these as global variables) with which to play. For example eax,ebx,ecx and edx are the general 32bit registers and throughout this article, these are the only ones we shall use. This means the largest number we can store in register eax is 2 to the power 32 minus 1, or 4294967295, for those of us brought up on 8bit machines, this is shear luxury. The cpu has the ability to manipulate the values of the registers, so to add 10 to the value of eax, one would issue the hexadecimal operation code

1042

05/0a/00/00/00 this is machine code, there being a specific 'number' for each function the cpu can implement. To say that writing machine code is tedious would be an understatement, and as for debugging ! Assembler Language is just an easy way of remembering what machine code operations are available. The job of converting to machine code is done by an Assembler. Borland's Turbo Assembler is built in to Delphi, and is rather more pleasant to use. If we look again at adding 10 to eax, the appropriate assembler instruction is add eax,10 {a := a + 10} Similarly, to subtract the value of ebx from eax sub eax,ebx {a := a - b } To save a value for a rainy day, we can move it to another register mov eax,ecx {a := c } or even better, save the value to a memory address mov [1536],eax {store the value of eax at address 1536} and of course to retrieve it mov eax,[1536] A quick aside on memory addresses, please bear in mind the size of the values you are moving about. The mov [1536],eax instruction affects not only memory address 1536, but 1537,1538 and 1539 as well, because as you will recall eax is 32bits long, or rather 4 bytes. Memory is always addressed in bytes. What does the Compiler do with all those variables ? In every program you will have written, the compiler will have had to cope with a number of variables.Consider the pascal line Count := 0; To the compiler, this is just a value it has to remember. Consequently it sets aside a memory address to store this value, and to make sure it doesn't get confused later, calls this memory address 'Count'. This means that the code generated by the compiler for this line is something like this mov eax,0 mov Count,eax The complier can't use a line such as mov Count,0 because at least one parameter of the instruction must be a register. If we were to consider the line Count := Count + 1; we would get something like this mov eax,Count add eax,1 mov Count,eax For variables of types other than integer, matters can become more complex. So more of that later, and lets use what we've learnt so far. Our first snippet of assembler. Forgive the trivial nature of this example, but we've got to start somewhere. Consider the following lines of pascal code. function Sum(X,Y:integer):integer; begin Result := X+Y; end; Object Pascal provides the asm .. end block as a method of introducing assembler to our code. So we could rewrite the function Sum thus function Sum(X,Y:integer):integer; begin asm mov eax,X add eax,Y mov Result,eax end; end; This works, but there is little point. There is no speed gain and we've lost the readability of our code. There are, however, instances where our currently limited knowledge of assembler can be put to good use. Lets say we wish to convert explicit Red,Green,and Blue values into a colour of type TColor suitable for use in Delphi. The TColor type describes a 24bit True Colour stored in the format of an integer ie. four bytes, the highest of which is zero, thereafter in the order Red, Green, Blue. function GetColour(Red,Green,Blue:integer):TColor;

1043

begin asm {ecx will hold the value of TColor} mov ecx,0 {start with the Red component} mov eax,Red {make sure Red is in range 0<=Red<=255} and eax,255 {shift the Red value to the correct position} shl eax,16 {adjust value of TColor} xor ecx,eax {same again with Green component} mov eax,Green and eax,255 shl eax,8 xor ecx,eax {and again with Blue} mov eax,Blue and eax,255 xor ecx,eax mov Result, ecx end; end; You'll have noticed that I've introduced a few binary operations. These operations are straightforward and are also defined in Object Pascal itself, but for clairity let's explicity define all the operations introduced thus far and a few more. Learning Assembler with Delphi Page 2: Basic Assembler Operations, Special cases, multiply and divide, Labels and Jumps, Controlling the flow Basic Assembler Operations More of this Feature • Page 1: What, when, Lets first define a few symbols for the purpose of this document. reg1, reg2,... refer to any of the general 32bit registers eax, ebx, ecx why? and edx. • Page 3: A proper mem1, mem2,... refers to any memory expression either explicit example [1536], implicit [edx] or pascal pointer Count. The brackets refer to • Page 4: Matrices the contents of the value, so [edx] is the memory location at address • Page 5: Fast screen edx. The compiler knows a pascal pointer is a memory expression so plotting brackets aren't required. exp1, exp2... explicit values such as 10 in decimal, 0Ah in hex. dest refers to the parameter into which the result of the operation Join the Discussion will be stored. src refers to the source of any extra data required by the operation. "Post your questions, For each operation at least one of dest and src must be a register or concerns, views and an implicit memory address, ie a memory address dependant on the comments to this article..." value of a specified register. Discuss! And now to the operations: add dest,src reg1,reg2 Related Resources reg1,mem1 • Delphi Pascal tech. reg1,exp1 articles mem1,reg1 performs integer addition on dest and src, storing the resutling value • Win/API programming in dest. and dest,src reg1,reg2 reg1,mem1 reg1,exp1 mem1,reg1 performs the logical binary operation 'and' on dest and src, storing result in dest.

1044

dec dest reg1 mem1 subtracts one from the value of dest. inc dest reg1 mem1 adds one to the value of dest. mov dest,src reg1,reg2 reg1,mem1 reg1,exp1 mem1,reg1 copy the value of src and store in dest. not dest reg1 mem1 inverts the binary value of dest and stores the result in dest. or dest,src reg1,reg2 reg1,mem1 reg1,exp1 mem1,reg1 performs an inclusive 'or' operation on dest and src storing result in dest shl dest,src reg1,exp1 shifts the binary digits of dest, src places to the left and stores the result in dest. This is a quick way to multiply by a power of two. shr dest,src reg1,exp1 shifts dest, src places to the right. Quick division by a power of two. sub dest,src reg1,reg2 reg1,mem1 reg1,exp1 mem1,reg1 subtracts the value of src from dest, storing the result in dest. xor dest,src reg1,reg2 reg1,mem1 reg1,exp1 mem1,reg1 performs an exclusive 'or' operation on dest and src storing the result in dest. Special cases, multiply and divide The operations for multiplication and division operate on the 64bit value formed by combining the values of eax and edx where the latter is the most significant value. For example if eax = AAAAAAAAh and edx = BBBBBBBBh then the 64bit value would be BBBBBBBBAAAAAAAAh. div src reg1 mem1 performs an unsigned divide on the 64bit value discussed above, the divisor being src. The quotient being stored in eax, the remainder in edx, and src is unaffected. If quotient is too large to be stored in eax or the value of src is zero, the cpu will generate an error and stop program execution. idiv src reg1 mem1 same as div but performs a signed divide. mul src reg1 mem1

1045

performs an unsigned multiplication of eax and src. The resulting 64bit value is stored in eax and edx as above. imul src reg1 mem1 same as mul but signed. Labels and Jumps This section is really no more than a precursor to the section on flow control. A label is just an address in memory, and a jump just tells the cpu to look to a different address for the next line to execute. This is best illustrated by example ... jmp @label1 { jump to label1 } ... { these } ... { next } @label2: { instructions } ... { are } jmp @label2 { never } ... { used } @label1: ... { now we start execution again } Note that the declaration of a delphi label starts with '@' and ends with ':'. The reference of a label does not include the ':'. Controlling the flow If we are going to produce really useful code, at some point we shall need to implement conditional statements such as while..do and repeat..until. Just one instruction combines the conditional possibilities available cmp dest,src reg1,reg2 reg1,mem1 reg1,exp1 and sets the result flags accordingly. What the flags are, and how they are set, will not be covered here. All you need know is the result of the following combinations of instructions. cmp dest,src je @label if dest = src then jump to @label. cmp dest,src jle @label if dest =< src then jump to @label. cmp dest,src jne @label if dest <> src then jump to @label. cmp dest,src jg @label if dest > src then jump to @label. cmp dest,src jge @label if dest => src then jump to @label. cmp dest,src jl @label if dest < src then jump to @label. cmp dest,src jz @label if dest = src then jump to @label. cmp dest,src jnz @label if dest <> src then jump to @label. Whilst the jump operations are equivalent to a goto statement, the call and its associated ret operation form the basis of procedural programming. It is common to see assembler routines of the following form ... jmp @mainroutinestart @localprocedure: {start of local procedure} {some code} ret {return from procedure} @mainroutinestart:

1046

{some code} call @localprocedure {some code} ... Furthermore, conditional calls can be constructed thus ... cmp eax,12 {if eax = 12 jump over call to procedure} je @skipcall {if eax <> 12 call procedure} call @localproc @skipcall: ... Using a combination of compare's, conditional jump's and procedural call's all of the elements of structured programming maybe implemented. Learning Assembler with Delphi Page 3: A proper example - using asm instructions. A proper example More of this Feature Until now we have achieved little substantial. However, all of the • Page 1: What, when, basic instructions have been introduced, so let's use them. why? Suppose we have to display the output of some function dependant • Page 2: Basic upon two variables. You might imagine this as a three-dimensional operations map, where the coordinates [x,y] correspond to a height h. When we • Page 4: Matrices plot the point [x,y] on the screen we need to give the impression of • Page 5: Fast screen depth. This can be achieved by using colours of differing intensity, in plotting our example, blue below sea level and green above. What is needed is a function that will convert a given height into the appropriate depth of color for a given sea level. Join the Discussion First we should plan the ranges of the variables involved. It is reasonable to use the integer type to store the height and sea level, "Post your questions, concerns, views and given the range of a 32-bit value. The true colour range available, limits us to a maximum color depth for blue and green to 256, so we comments to this will have to scale the results accordingly. If we assume a maximum article..." Discuss! height above, and depth below sea level to be 65536 feet, we can use shl and shr for some fast scaling, and we will get a change in colour depth every 256 feet. The function will of course, have to Related Resources return a TColor type to be compatible with Delphi. • Delphi Pascal tech. articles • Win/API programming

function ColorMap (Height, Sea : integer):TColor; begin asm mov eax,Height cmp eax,Sea {jump to section dealing with above sea level} jg @Above { Height is beneath Sea Level } mov ecx,Sea { ecx is depth beneath sea } sub ecx,eax { divide depth by 256 } shr ecx,8 cmp ecx, 256

1047

{ ecx should not exceed 255 } jl @NotMaxDepth mov ecx,255 @NotMaxDepth: { ecx now holds color } jmp @ColorDone @Above: { eax is height above sea level } sub eax,Sea { divide height by 256 } shr eax,8 cmp eax,256 { eax should not exceed 255 } jl @NotMaxHeight mov eax,255 @NotMaxHeight: { eax now holds green color depth } { eax now holds color } shl eax,8 { ecx now holds color for compatibility with beneath sea level routine} mov ecx,eax @ColorDone: mov Result,ecx end; end; As it happens, the above routine can be written with Delphi's assembler directive. This method of writing assembler removes a lot of the protection provided by the complier, but as compensation, speed improves. Here is the above routine using the assembler directive. function ColorMap(Height,Sea:integer):TColor;assembler; asm cmp eax,edx jg @Above sub edx,eax shr edx,8 cmp edx,256 jl @NotMaxDepth mov edx,255 @NotMaxDepth: mov eax,edx jmp @ColorDone @Above: sub eax,edx shr eax,8 cmp eax,256 jl @NotMaxHeight mov eax,255 @NotMaxHeight: shl eax,8 @ColorDone: end; At first sight it is a little difficult to see what's going on. The registers are set with certain values before entering the function or procedure. How these are set depends on how the function or procedure was defined. There are two possibilities. Stand alone, or explicitly defined procedures and functions On entry, eax holds the value of the first parameter of the function or procedure if such exists. ebx holds the address of the data block of the function or procedure. You must be careful when using ebx, for it must hold its initial value whenever you refer to a function or

1048

procedure's parameters or data in your assembler code block. Furthermore ebx must hold its initial value when exiting. The Delphi manual actually says don't touch. ecx holds the value of the third parameter. edx holds the second parameter value. On exit, eax holds the result of the function, or in the case of a procedure, convention states it holds the value of any relevant error code you may define. ebx must hold its initial value. Failure to ensure this will cause a system crash. Object method, procedures and functions On entry, eax holds the address of the parent object's data block. You don't need to maintain this value, however it is needed whenever you wish to access or change the values of the parent object's fields. ebx is the same as above. ecx holds the second parameter value. edx holds the value of the first parameter. On exit, the register values are as for a stand alone procedure or function. With the above information, you should now be able to work your way through the ColorMap function. On the face of it, we seem to have reduced the number of lines of assembler from 18 to 15, which is not much of a saving, and the code is not as readable. However this is not the whole story. The complier generates a fail-safe entry and exit code block for any function or procedure defined with the usual begin..end block. By using the assembler directive, the complier employs only minimal entry and exit code. In the case of the ColorMap function this means it's code size has roughly halved, as has its execution time. These are the levels of performance gain that make writing assembler worthwhile. Implementing local variables It is clear, that with just four registers, implementing any half serious algorithm will not be a trivial matter. If a routine is fast, this is usually because every constant used has been calculated before entering any loops. In Object Pascal, this is where local variables are used. For a procedure or function defined with the assembler directive, the same declaration format is used. For example, the following is valid, function Test:integer:assembler; var first,second,third:integer; asm {some code, remembering that ebx must be it's initial value} end; Local constants, and constant variables may also be defined just as one would in Object Pascal. The complier just reserves a block of memory, whose address is stored in ebx on entry. Thereafter the local variable names refer to an offset value from the base address of the data block. This allows the complier to use the index addressing provided by the cpu. An index address is of the form [reg1+reg2] or [reg1+exp1] for example [ebx+edx] . You will find indexing the easiest way of addressing data such as strings and arrays but more of this later. In the case of a function definition, a reference to a local variable is implemented as an indexed address irrespective of the operation, consequently the operation mov eax,second is actually mov eax,[ebx+4] where 4 is the offset to the address of the value of the second variable. You could write either, but the former offers greater clarity. I hope you are now starting to appreciate the importance of maintaining the value of ebx. There is also a quicker method of temporary value storage, and this brings us to the stack. The Stack The stack is just what it says. Think of a stack of books on a table, we can place another book on the stack or take a book off the stack. To get at the third book down, we must first remove the top two. This is what we do with register values, and there are two appropriate instructions. push reg1 place the value of reg1 on top of the stack. pop reg1 remove the top value of the stack, and place this in reg1. Windows uses the stack to pass parameters to the api functions, and as such great care must be exercised when using the stack. Each push must have an associated pop in all the code you write, get this wrong and once again the system will crash.

1049

We will use the stack, indeed it is necessary when implementing recursive functions, but generally we shall only use the stack for temporary storage. For example when using the mul and div operations there are register value changes all over the place, ... {save edx} push edx {eax := eax*ecx, edx holds any overflow} mul ecx {dump any overflow value and restore edx} pop edx ... An aside on recursion. Avoid it at all costs. Recursive functions may look elegant and appear to use very little code to achieve a great deal, but they are the signature of the inexperienced. A recursive function will commonly overload the stack because at design time you cannot be certain how many recursions are required and as such the memory demands are unknown. How do you explain to an end-user that your 100K program requires 8mb to run, when an equivalent iterative routine may produce a 500K program needing just 1mb. Furthermore, discovering the cause of a stack failure is problematic, making debugging a painful process. The only time I can think of, where recursion is justified, is in the implementation of artificial intelligence algorithms. It might also be noted that generally, I have found iteration to be quicker. Beyond integers Until now we have discussed only 32bit integer values. This would seem to impose a limitation on any code we may wish to write, but this is not so. When Object Pascal passes a string as a parameter, for example, it is a 32bit integer value that is used. In this particular case the value passed is the memory address at which the contents of the string are stored. This value is what is referred to as a pointer and is the approach used for any data type, whether string, array or user-defined object. Indeed, even floating point values are referred to in this way, as they are considered to be strings. What's in a pointer In a normal pascal procedural definition, the values of the parameters are copied to the data area of the procedure. If the value is an integer the value is passed explicitly whenever the parameter is referred to. In the case of other data structures, the pointer passed, points to the appropriate part of the data area. In neither scenario, is the value of any variable passed as a parameter changed. Object Pascal allows one to define parameters with the var directive, whence pointers to the actual variables are passed. Consequently, changes to actual variable values may be made. The same result is achieved by defining parameters to be of pointer type, each pointer pointing to the appropriate data structure. This latter approach has the advantage of coping with dynamically instantiated data, the price to pay being that care with null pointers and memory allocation should be taken.

Learning Assembler with Delphi Page 4: Matrices

1050

Project 1 - Matrices More of this Feature What follows is the definition of a new structure TMatrix. Together • Page 1: What, when, with explanations of the design decisions taken, you should find it a why? useful reference. A 2x2 matrix has been chosen because it is • Page 2: Basic adequate to illustrate the ideas involved, and can be easily expanded operations to a 4x4 which is far more useful, especially in graphics where • Page 3: A proper homogeneous coordinates are used. example First we must decide what this class is to be used for. 2x2 matrices • Page 5: Fast screen are most commonly employed in describing basic geometric plotting transformations in a 2-dimensional vector space. For simplicity we shall assume the use of a cartesian coordinate system. Given this, two data structure types are required, one for a vector or point, the other for the matrix. It will also be assumed that dynamic allocation Join the Discussion "Post your questions, of both vectors and matrices will be required. Now we have some ground rules, let's consider just one more design concerns, views and comments to this point. To implement a vector space with only integer values, transformations will be limited to a subset of translations, reflections article..." Discuss! and skews. Using real numbers is the ideal, but quite honestly it's painful and there is a speed penalty. What we must realize, is that in a digital computer a 'real' number is really an approximation made using a quotient. Having taken this on board, and given that we are Related Resources unlikely to use a plotting range in excess of -32767 to +32767 (does • Delphi Pascal tech. your monitor have a resolution in excess of 1600x1280 ?) , we shall articles store each coordinate as 65536 times its actual value. This gives us a • Win/API programming quotient with which we can approximate quite accurately the range of real values we shall use. Moreover we can implement this using the standard 32bit integer type, thus enhancing performance. Recovering the 'integer' part of a value is achieved by dividing it's value by 65536 which is easily done using shr, similarly setting a value requires multiplying by 65536 for which we use shl. If these ideas are new to you, you've just learnt one of the key approaches in code optimization. Important note, when assigning and recovering values in Delphi, we must use multiplication and division, otherwise negative values get rather upset. The type definitions are consequently straightforward. type {remember each stored value is 65536 times its actual value} PVector = ^TVector; {pointer type for dynamic instantiation} TVector = record X:integer; Y:integer; end; {the vector is of the form X } {Y} PMatrix = ^TMatrix; TMatrix = record A:integer; B:integer; C:integer; D:integer; end; {the matirx is of the form A,B } { C,D }

1051

{to avoid problems with memory allocation each of the following functions will adjust the actual value of the first parameter, the second parameter will be considered a source, as in assembler and as such remains unaffected} function VectorAdd(Vdest,Vsrc:PVector):boolean; {Vdest := Vdest + Vsrc} function VectorSub(Vdest,Vsrc:PVector):boolean; {Vdest := Vdest - Vsrc} function VectorScale(Vdest:PVector;K:integer):boolean; {Vdest := K * Vdest, Nb. K is 65536 times value again} function VectorAssign(Vdest,Vsrc:PVector):boolean; {Vdest := Vsrc} function MatrixMul(Mdest,Msrc:PMatrix):boolean; {Mdest := Msrc * Mdest, Nb. the order is important} function MatrixIdent(Mdest:PMatrix):boolean; {set Mdest to the identity matrix} function MatrixScale(Mdest:PMatrix;K:integer):boolean; {Mdest := K * Mdest, Nb K is 65536 times value again} function MatrixAssign(Mdest,Msrc:PMatrix):boolean; {Mdest := Msrc} function Transform(Vdest:PVector;Msrc:PMatrix):boolean; {Vdest := Msrc * Vdest} Before going through the implementation of these functions, we have two more points to discuss. Firstly, error trapping. If any of these functions is sent a null or invalid pointer, a memory exception error will occur unless some form of checking is used. Checking for a null pointer is easy, but discovering whether a pointer is valid, this is nigh impossible. This aside, we should not loose sight of why we are using assembler. Speed is the essence. My own view is that for such routines as these, error checking is not required, as the cause of the error will be self evident in debugging the main delphi program. However, a simple null pointer check will be implemented in the first function as a simple example. Further error checking routines will be implemented in the next project, where identifying the causes of errors will not be so easy. Secondly, as the reason for using assembler is speed, we should consider how this is best achieved. It is clear that given a generic NxN matrix, a generic algorithm capable of calculating the desired result for any element, nested in two loops, is the natural approach, and would produce a very memory efficient routine. If we were to explicitly write optimized code for each element of the matrix and tag these end to end we would avoid the time taken to execute any loop control code. Such an algorithm would only work for a given matrix size, and with even moderately sized matrices, would consume a far greater chunk memory. It would, however, be quicker. Given these two approaches, we must decide which route to take, and clearly with a 2x2 matrix the latter is preferable. It is also worth considering just how little

1052

memory is used by a line of assembler, typically 8 or 12 bytes, how many lines of assembler you are going to write for a routine, more than 1000 ?, and then look at how much memory your machine has, 16Mb+ perhaps ? You will find that in general, using more memory produces faster routines, only experience will tell you where to draw the line. The implementation of the Vector and Matrix functions. function VectorAdd (Vdest,Vsrc:PVector):boolean;assembler; asm {as this is a stand alone function eax holds the pointer Vdest and edx holds the pointer Vsrc remember ebx must be saved} {the error checking I promised} jmp @errorcheck @seterrorcode: mov eax,0 jmp @adddone {eax holds return value, 0 is equivalent to False} @errorcheck: cmp eax,0 je @seterrorcode cmp edx,0 je @seterrorcode {error checking done, now start routine} {Nb. addition and subtraction are unaffected by our multiplying the values by 65536} mov ecx,[eax] {eax holds pointer to first value of Vdest, so ecx = Vdest.X} add ecx,[edx] {ecx = Vdest.X + Vsrc.X} mov [eax],ecx {change Vdest.X} add edx,4 add eax,4 {as the X element of a Vector record is an integer it consumes four bytes of memory, thus by adding four to eax and edx, both now point to the Y element of the Vector record} mov ecx,[eax] add ecx,[edx] mov [eax],ecx {update Y element of Vdest} mov eax,1 {set return value to True} @adddone: end; function VectorSub(Vdest,Vsrc:PVector):boolean;assembler; asm {no error checking, speed gain 30+%} mov ecx,[eax] sub ecx,[edx] mov [eax],ecx add eax,4 add edx,4 mov ecx,[eax]

1053

sub ecx,[edx] mov [eax],ecx end; function VectorScale (Vdest:PVector;K:integer):boolean;assembler; asm {I'll go through this step by step, and try not to loose you} mov ecx,edx {we're going to use the mul operation, which overwrites the value of edx, since edx holds the value of K, we move the value to ecx} push eax {mul also changes eax, and we need to store the pointer Vdest} mov eax,[eax] {before we multiply let's look at what is stored where. eax = 65536 * Vdest.X ecx = 65536 * K and the pointer Vdest is on the stack} imul ecx {the 64bit result of the mul operation is 65536 * 65536 * Vdest.X * K and is stored in registers edx and eax do the arithmetic and you'll find edx = K * Vdest.X eax = the remainder of the quotient} shl edx,16 {we actually want 65536 * K * Vdest.X so multiply edx by 65536, the shl operation does this} shr eax,16 {to maintain accuracy we must add the remainder of the quotient to edx. As eax holds the 32bit remainder and we only want a 16bit remainder for edx. We divide eax by 65536 using shr} xor edx,eax {we now combine edx and eax using the binary operation xor, we could use add, but xor is generally quicker} pop eax {restore the value of eax, Vdest} {At this point it's worth looking at the register values eax = Vdest ebx = unchanged ecx = 65536 * K edx = 65536 * K * Vdest.X and the stack is clear} mov [eax],edx {update value of Vdest.X} add eax,4 {move pointer from Vdest.X to Vdest.Y and do it all again} push eax mov eax,[eax]

1054

imul ecx shl edx,16 shr eax,16 xor edx,eax pop eax mov [eax],edx end; function VectorAssign (Vdest,Vsrc:PVector):boolean;assembler; asm {by now you should be able to follow this} mov ecx,[edx] mov [eax],ecx add edx,4 add eax,4 mov ecx,[edx] mov [eax],ecx end; function MatrixMul(Mdest,Msrc:PMatrix):boolean;assembler; var nA,nB,nC,nD,dest,src:integer; {there are too many intermediary values to keep track of, which makes using the stack confusing, so we'll just define some local values for the new element values of Mdest and the pointer values of Mdest and Msrc} asm mov dest,eax mov src,ecx {save dest and src} mov eax,[eax].TMatrix.A mov ecx,[ecx].TMatrix.A {a little earlier I mentioned index addressing, these two lines ask the complier to calculate the offset required to address the 'A' field of a TMatrix record and use the appropriate index address. For example [eax].TMatrix.B = [eax].TVector.Y = [eax+4] or rather the offset to both 'B' and 'Y' is 4 bytes Otherwise nothing else new in this function because I am going to assume you know how to multiply two matrices} imul ecx shl edx,16 shr eax,16 xor edx,eax mov nA,edx mov eax,dest mov ecx,src mov eax,[eax].TMatrix.C mov ecx,[ecx].TMatrix.B imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nA mov nA,edx {new A calculated now start on new B} mov eax,dest mov ecx,src mov eax,[eax].TMatrix.B mov ecx,[ecx].TMatrix.A

1055

imul ecx shl edx,16 shr eax,16 xor edx,eax mov nB,edx mov eax,dest mov ecx,src mov eax,[eax].TMatrix.D mov ecx,[ecx].TMatrix.B imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nB mov nB,edx {new C} mov eax,dest mov ecx,src mov eax,[eax] mov ecx,[ecx].TMatrix.C imul ecx shl edx,16 shr eax,16 xor edx,eax mov nC,edx mov eax,dest mov ecx,src mov eax,[eax].TMatrix.C mov ecx,[ecx].TMatrix.D imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nC mov nC,edx {and finally D} mov eax,dest mov ecx,src mov eax,[eax].TMatrix.B mov ecx,[ecx].TMatrix.C imul ecx shl edx,16 shr eax,16 xor edx,eax mov nD,edx mov eax,dest mov ecx,src mov eax,[eax].TMatrix.D mov ecx,[ecx].TMatrix.D imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nD {finish by updating Mdest, Nb. as edx holds final value of D there is little point in updating the local variable nD} mov eax,dest mov [eax].TMatrix.D,edx mov edx,nA mov [eax].TMatrix.A,edx mov edx,nB

1056

mov [eax].TMatrix.B,edx mov edx,nC mov [eax].TMatrix.C,edx end; function MatrixIdent(Mdest:PMatrix):boolean;assembler; asm {no comments needed} mov [eax].TMatrix.A,65536 mov [eax].TMatrix.B,0 mov [eax].TMatrix.C,0 mov [eax].TMatrix.D,65536 end; function MatrixScale(Mdest:PMatrix;K:integer):boolean;assembler; asm {same as VectorScale but twice as long} mov ecx,edx push eax mov eax,[eax].TMatrix.A imul ecx shl edx,16 shr eax,16 xor edx,eax pop eax mov [eax].TMatrix.A,edx push eax mov eax,[eax].TMatrix.B imul ecx shl edx,16 shr eax,16 xor edx,eax pop eax mov [eax].TMatrix.B,edx push eax mov eax,[eax].TMatrix.C imul ecx shl edx,16 shr eax,16 xor edx,eax pop eax mov [eax].TMatrix.C,edx push eax mov eax,[eax].TMatrix.D imul ecx shl edx,16 shr eax,16 xor edx,eax pop eax mov [eax].TMatrix.D,edx end; function MatrixAssign(Mdest,Msrc:PMatrix):boolean;assembler; asm {no comments needed} mov ecx,[edx].TMatrix.A mov [eax].TMatrix.A,ecx mov ecx,[edx].TMatrix.B mov [eax].TMatrix.B,ecx mov ecx,[edx].TMatrix.C mov [eax].TMatrix.C,ecx

1057

mov ecx,[edx].TMatrix.D mov [eax].TMatrix.D,ecx end; function Transform(Vdest:PVector;Msrc:PMatrix):boolean;assembler; var nX,nY,dest,src:integer; asm {MatrixMul cut in half really} mov dest,eax mov src,edx mov eax,[eax].TVector.X mov ecx,[edx].TMatrix.A imul ecx shl edx,16 shr eax,16 xor edx,eax mov nX,edx mov eax,dest mov ecx,src mov eax,[eax].TVector.Y mov ecx,[ecx].TMatrix.B imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nX mov nX,edx {new X done} mov eax,dest mov ecx,src mov eax,[eax].TVector.X mov ecx,[ecx].TMatrix.C imul ecx shl edx,16 shr eax,16 xor edx,eax mov nY,edx mov eax,dest mov ecx,src mov eax,[eax].TVector.Y mov ecx,[ecx].TMatrix.D imul ecx shl edx,16 shr eax,16 xor edx,eax add edx,nY {new Y done update Vdest} mov eax,dest mov [eax].TVector.Y,edx mov edx,nX mov [eax].TVector.X,edx end; Using the Vector and Matrix functions is very straightforward with few points to remember. Firstly, the functions assume that a pointer is to be passed as the parameter, but you won't forget this as the complier will remind you. This means, that to create vector and matrix variables, you must first define your variable with the appropriate PVector or PMatrix type in the required var section as in the example below. procedure Example; var aVector:PVector;aMatrix:PMatrix; begin new(aVector);

1058

aVector^.X := 65536*32; aVector^.Y := 65536*21; new(aMatrix); with aMatrix^ do begin A := round(65536 * 0.5); B := round(65536 * cos(pi /3)); C := 3 * 65536; D := 65536; end; Transform(aVector,aMatrix); dispose(aVector); dispose(aMatrix); end; Pascal's new() function is used to allocate memory for the new variable, this must be done otherwise the pointer will remain null with the consequences discussed earlier. Furthermore you must tidy up after yourself, that is to say, every new() must have an associated dispose() to free the memory you have used. Otherwise dynamically allocated variables are just like any other, except one must use the '^' to access the variable's fields. It is likely you will use the PVector and PMatrix types with TList's as these deal explicitly with pointers and their manipulation. You may be asking yourself why the Vector and Matrix were defined as a record rather than as an object as one would expect with Object Pascal. The reason is that each object carries with it the overhead of a virtual method table (see Delphi documentation) thus increasing the memory requirement for data storage. Records store just the data and when one considers that a half serious vector graphics application may deal with 500,000 vectors or more saving just one byte in each record soon makes a difference. As an exercise you might like to write a function to find the inverse of a Matrix. For those of you with aspirations of writing a 3D graphics engine, you now have all the knowledge of assembler you will need to rewrite the vector and matrix definitions. All that is missing is an understanding of homogeneous equations, a good book on modern algebra will help here, and a method of fast screen access. I shall deal with the latter next. RTL reference|Glossary|Tips/Tricks|FREE App/VCL|Best'O'Net|Books|Link To Learning Assembler with Delphi Page 5: Fast screen plotting

• • • •

Page Page Page Page

1: 2: 3: 4:

What, when, why? Basic operations A proper example Matrices

Join the Discussion

"Post your questions, concerns, views and comments to this article..." Discuss!

1059

Related Resources

• Delphi Pascal tech. articles • Win/API programming

1060

Project 2 - fast screen plotting Have you ever tried to write a bitmap painting program with that fancy brush in which you've worked out how to blend and fade colors to spectacular effect, only to be let down by the speed at which Delphi's canvas pixel array operates ? You have, well read on. First, before we go any further please take time to fire up Delphi and make sure that 'aligned record fields' is switched on in the complier section of project options. It is ? Good, virtually every api function we shall use in this section demands that all data is double word aligned. That last two minutes has just saved you hours of debugging time. What makes Windows so good a programming platform, is that it acts as an interface between the programmer and the hardware. You don't need to worry about what kind of graphics or sound card is actually there you just ask windows to play a wav file or display a bitmap and it does it. No more sound card crashes because you chose the wrong interrupt. There is of course a price, to pay. That price is as ever, speed. With DirectX there are now api routines for direct screen access, however its performance is highly dependant upon the hardware fitted. Delphi's canvas is designed to hide the complexities in using the gdi to draw a square on the screen, leaving well alone the rather more esoteric nature of directX. This simplicity is once again at the price of speed. I decided some time ago that I needed a method of constructing a bitmap in memory which I could then bitblt on to a canvas. I would be able to build the bitmap using assembler routines for speed and bitblt'ing is quick. Indeed what I primarily needed at the time, was to be able to plot full 24bit color values on to a bitmap at rate of about one million pixels per second, this being for a graphical display routine. I soon discovered that attempting to unravel the torturous way in which Delphi deals with bitmaps would prove unfruitful. As such the windows gdi functions would have to provide the answer. Windows 95 provides Device Independent Bitmaps, as it's way of allowing the direct memory addressing of bitmap pixels, together with several routines to service their use. The key function in this respect, is CreateDIBSection which not only creates the appropriate structure and handle, but also provides the address of the DIB's pixel array. Given the address and size of bitmap in memory, writing routines to manipulate the image becomes almost trivial. Functions such as StretchDIBits can then be used to map the resulting bitmap on to any canvas. At this point you maybe feeling misled, after all this project is entitled 'fast screen plotting', and the method described does not

1061

TFrame = class private Bitmap : HBitmap; lpvbits : Pointer; Bitmapinfo : PBitmapinfo; {Bitmap will hold the windows handle of the DIB, lpvbits will be a pointer to the DIB's pixel array, and Bitmapinfo is a pointer to an instance of the Windows Bitmapinfo structure in which we shall describe the format of the DIB, ie. width, height and color depth} FWidth : integer; FHeight : integer; FSize : integer; FLineLen : integer; {just fields to store values of the DIB's width, height, size in bytes, and horizontal size in bytes} public constructor Create(ACanvas:TCanvas;Width,Height:integ er); destructor Destroy;override; {the size of the DIB to be created will be determined by the width and height parameters, the canvas parameter determines the palette to be used but this is best explained in 'Create's' implementation. The destructor must free up any memory allocated to the DIB. The memory usage is likely to be considerable.} function Draw(ACanvas:TCanvas;X,Y:integer):integer; procedure Plot(X,Y,Color:integer); {Draw provides a method of painting the DIB on to a Canvas. X and Y giving the canvas coordinates of the top left corner of the DIB after painting. Plot allows one to set the color of a given pixel in the DIB.} end; Before looking at the implementations we should consider how we are to define the DIB. I am not referring here to the windows api functions but rather the color depth of the DIB as this will dramatically affect our code. The windows routines are generic and can cope with any color depth from monochrome to true color. Consequently there is a speed penalty whilst format checking is carried out. By choosing a single color format, our routines can be optimized. In this case I have chosen 24bit true color as this met my needs at the time of writing and avoided the need for palette definitions. However for ultimate speed, 8bit color using the system palette is the way to go. If we now look at the implementation of each object method in turn.

1062

constructor TFrame.Create(ACanvas:TCanvas;Width,He ight:integer); var LineAdj:integer; begin FWidth := Width; FHeight := Height; FLineLen := 3*Width; LineAdj := FLineLen and 3; LineAdj := 4 - LineAdj; LineAdj := LineAdj and 3; FLineLen := FLineLen + LineAdj; FSize := FLineLen * FHeight; {Storing the values of width and height in the appropriate fields is straightforward enough, the tricky bit is calculating the size of the DIB. Each horizontal scan line of the DIB must be double word aligned, that is to say, each scan line must start at an address which is a multiple of four bytes. Windows demands this is true and will fail to create the DIB if it is not. Why this demand is made is a matter of cpu architecture and optimizing performance. This is why I asked you to check that 'aligned record fields' is switched on in the compiler. To calculate the memory required to store one horizontal scan line we multiply the width by three and then work out how many bytes we must tag on the end to make this value divisible by four. Summing these values gives us FLineLen the number of bytes required to store a single horizontal line. The total memory used by the DIB being the product of FLineLen and the number of Horizontal lines FHeight.} New(Bitmapinfo); with Bitmapinfo^.bmiHeader do begin bisize := 40; {size of the bmiHeader structure} biWidth := Width; biHeight := Height; biPlanes := 1; {must always be one} biBitCount := 24; {24bits required to store each pixel} biCompression := BI_RGB; {image uncompressed, no palette} biSizeImage := FSize; {size of image pixel array} biXPelsPerMeter := 0; {info for scaling when printing etc.} biYPelsPerMeter := 0; biClrUsed := 0; {number of colors in palatte} biClrImportant := 0; {number of important colors in palette} end; {The PBitmapinfo type is defined in Delphi's Graphics unit and encapsulates the Windows Bitmapinfo structure itself containing two record structures, bmiHeader and bmiColors. The latter defines a palette, but as we are using explicit 24bit true color values, a palette

1063

The destructor is clearly defined as follows. We just get windows to reclaim the memory allocated to the DIB and we finish by disposing of the Bitmapinfo record. destructor TFrame.Destroy; begin DeleteObject(Bitmap); Dispose(Bitmapinfo); end; The Draw method just uses StretchDIBits. By changing the parameters various scaling and image manipulation effects can be achieved. function TFrame.Draw(ACanvas:TCanvas;X,Y:intege r):integer; begin StretchDIBits(ACanvas.Handle,X,Y,FWidt h,FHeight,0,0,FWidth,FHeight, lpvbits,Bitmapinfo^,DIB_RGB_COLORS,SRC COPY); Result := GetLastError; end; Now we can get back to assembler and define a routine to change the color of a pixel in the DIB.

1064

procedure TFrame.Plot(X,Y,Color:integer);assembl er; asm push ebx mov ebx,[eax].Bitmap cmp ebx,0 je @plotdone {if the value of Bitmap is zero then no memory has been allocated to the DIB. All we can do is abort the plot.} pop ebx push ebx {recover value of ebx without affecting the stack} cmp edx,0 jl @plotdone {if X coordinate is less then zero then abort} cmp edx,[eax].FWidth jge @plotdone {if X coordinate is greater then or equal to the DIB's width then abort} cmp ecx,0 jl @plotdone cmp ecx,[eax].FHeight jge @plotdone {same checks on Y coordinate} {we need to calculate the memory offset of point X,Y in the DIB and then add the memory address of the start of the DIB to find the actual address of the point. The offset is FLineLen*Y+3*X} push eax push edx {eax = object base address, edx = X. since we are about to use the mul operation we must save these values} mov eax,[eax].FLineLen {eax = FLineLen, ecx = Y, so we can now multiply} mul ecx {eax = FLineLen*Y, edx = 0} mov edx,eax {we need to recover the values of X and the object base address from the stack, so we move the value of FLineLen*Y to edx before recovering eax's value} pop ecx pop eax {eax = object base address, edx = FLineLen*Y, ecx = X} add edx,ecx {edx = FLineLen*Y+X} shl ecx,1 {ecx = 2*X} add edx,ecx {edx = FLineLen*Y+X+2*X = FLineLen*Y+3*X, which is what we want} add edx,[eax].lpvbits {add the memory address of the start of the DIB, and edx now holds the actual address of the pixel X,Y}

1065

So, how do we use this frame buffer. The following example function illustrates the TFrame creation, the plotting of a basic fractal effect, the display of the resulting image on a form's canvas, and finally the destruction of the object. function Example; var x,y:integer;Frame:TFrame; begin Frame := TFrame.Create(Self.Canvas,400,300); {instansiate a TFrame object with a DIB 400 pixels wide 300 pixels high} for x := 0 to 399 do for y := 0 to 299 do Frame.Plot(x,y,x*y); {do some plotting, incidentally the coordinate (0,0) refers to the bottom left of the image, not the top left as in a normal bitmap} Frame.Draw(Self.Canvas,10,10); {now display the image, in this case the top left of the image will have coordinates 10,10 with respect to the Canvas chosen} Frame.Free; {finally dispose of the memory allocated to the object. In a real application you are likely to create a TFrame object at the start of processing, and only dispose of it just before exiting to windows} end; The object as shown here is pretty much as I used it. The only additional function I have found useful has been GetPixel(X,Y) returning the color value of the DIB at (X,Y). This function is of course, just the Plot routine with a couple of changes. That I have not needed to draw geometric shapes, is probably a percularity of my own requirements. I suspect however, that your own circumstances may differ, so there now follow a few more routines for the TFrame object. Incidentally, as the DIB has a valid windows handle, the gdi functions can be used to draw basic shapes.

1066

function TFrame.GetPixel(X,Y:integer):TColor;as sembler; asm push ebx mov ebx,[eax].Bitmap cmp ebx,0 je @getpixeldone pop ebx push ebx cmp edx,0 jl @getpixeldone cmp edx,[eax].FWidth jge @getpixeldone cmp ecx,0 jl @getpixeldone cmp ecx,[eax].FHeight jge @getpixeldone {we need to calculate the memory offset of point X,Y in the DIB and then add the memory address of the start of the DIB to find the actual address of the point. The offset is FLineLen*Y+3*X this is the same as the Plot routine} push eax push edx mov eax,[eax].FLineLen mul ecx mov edx,eax pop ecx pop eax add edx,ecx shl ecx,1 add edx,ecx add edx,[eax].lpvbits mov eax,[edx] and eax,0ffffffh {having got four bytes of data from the DIB, we dispose of the fourth, most significant byte, leaving just the color value of point X,Y} @getpixeldone: pop ebx end; The next routine fills the DIB with a given color.

1067

procedure TFrame.Fill(FColor:integer);assembler; var X,Y,indexY,indexP,Color:integer; asm mov ecx,[eax].Bitmap cmp ecx,0 je @filldone {check DIB exists and exit if not} mov ecx,[eax].FWidth mov X,ecx mov ecx,[eax].FHeight mov Y,ecx mov ecx,[eax].lpvbits mov indexY,ecx mov indexP,ecx and edx,0ffffffh mov Color,edx {initialize variables X and Y act as counts, each horizontal line is considered in turn indexY holding the address of point (0,Y) for a given Y. There after each iteration adds three to this value storing the result in indexP, each successive value corresponding to the address of a point on the horizontal scan line. When the count reaches zero the line has been completed, and the next scan line is considered by adding FLineLen to indexY and resetting X and indexP. When Y equals zero the fill has been completed without resorting to multiplication} @startfill: mov edx,indexP mov ecx,[edx] and ecx,0ff000000h xor ecx,Color mov [edx],ecx add edx,3 mov indexP,edx mov ecx,X dec ecx mov X,ecx cmp ecx,0 jg @startfill mov edx,indexY add edx,[eax].FLineLen mov indexY,edx mov indexP,edx mov ecx,[eax].FWidth mov X,ecx mov edx,Y dec edx mov Y,edx cmp edx,0 jg @startfill @filldone: end; A plot function utilizing our previously defined PVector pointer in place of explicit coordinates.

1068

procedure TFrame.VPlot(V:PVector;Color:integer); assembler; asm push ebx mov ebx,[eax].Bitmap cmp ebx,0 je @vplotdone {if the value of Bitmap is zero then no memory has been allocated to the DIB. All we can do is abort the plot.} pop ebx push ebx {recover value of ebx without affecting the stack} cmp edx,0 je @vplotdone {if edx = V = 0 then the vector pointer passed is undefined, so exit} mov ecx,[edx].TVector.Y mov edx,[edx].TVector.X {now move the vector coordinate values into edx and ecx and the rest of the routine is the same as Plot} cmp edx,0 jl @vplotdone cmp edx,[eax].FWidth jge @vplotdone cmp ecx,0 jl @vplotdone cmp ecx,[eax].FHeight jge @vplotdone push eax push edx mov eax,[eax].FLineLen mul ecx mov edx,eax pop ecx pop eax add edx,ecx shl ecx,1 add edx,ecx add edx,[eax].lpvbits mov ecx,[edx] and ecx,0ff000000h mov ebx,Color and ebx,0ffffffh xor ecx,ebx mov [edx],ecx @vplotdone: pop ebx end; Just for fun, here is a basic airbrush routine. It is not optimized, but does illustrate how I tend to test ideas, and uses many of the ideas discussed earlier. When used, the airbrush routine produces a circle of the desired color and radius, centred on X,Y, whose effect on the original image lessens as the perimeter of the circle is approached.

1069

procedure TFrame.AirBrush (FX,FY,Radius,Color:integer);assembler ; var X,Y,X0,Y0,X1,Y1,Xd,Yd,R2,D2,newColor:i nteger; {the variables declared are all of the constant values which will be used X,Y centre of airbrush plot X0,Y0 bottom left coordinate of square to scan = X-Radius,Y-Radius X1,Y1 top right coordinate of square to scan = X+Radius,Y+Radius Xd,Yd current point being considered R2 square of the Radius D2 square of the distance of current point Xd,Yd from centre newColor holds the color value for current point as it is being constructed} asm jmp @airstart {define subroutines} @airpointok: {checks point Xd,Yd is valid, if valid edx = address, if not edx = 0} push ecx mov ecx,Yd cmp ecx,0 jl @airpointerror cmp ecx,[eax].FHeight jge @airpointerror push eax mov eax,[eax].FLineLen mul ecx mov edx,eax pop eax mov ecx,Xd cmp ecx,0 jl @airpointerror cmp ecx,[eax].FWidth jge @airpointerror add edx,ecx shl ecx,1 add edx,ecx pop ecx add edx,[eax].lpvbits ret @airpointerror: pop ecx mov edx,0 ret @airblend: {takes the intensity of R,G or B, 0 -> 255, ecx = current value, edx = new value and blends them according to current value of D2, the square of the distance from X,Y. returns value in ecx} push eax push edx mov eax,D2 mul ecx mov ecx,eax pop edx mov eax,R2 sub eax,D2 mul edx

1070

Implementing routines for drawing squares and circles should now be within your grasp. Triangles can be tricky though. Nevertheless you have in your hands all of the tools required. Debugging your code To conclude this article a few words about debugging seem in order. It is very easy to set up watches, program break's, and traverse Delphi programs a line at a time. The same is true, even when using assembler. All one needs to do, is add the four 32bit general registers eax, ebx, ecx and edx to one's watch list, and see the effect of each line of assembler. When dealing with the stack try numbering each push, giving the same number to each corresponding pop. It is usually best to do this before running the code for the first time. Where possible break down complex algorithms into small relatively simple sub-routines, and make as much use as possible of local variables. Both these courses of action will hinder your code's performance, but you are more likely to produce code that works. And finally Enough has been covered in this article, for you to explore the possibilities of assembler. However the majority of assembler instructions actually available to you, have been ignored. Should you wish to learn more, may I suggest Borland's Turbo Assembler, just for the manuals, and Wrox's Assembly Language Master Class, which is in my opinion the finest book of its type available. Neither of these products directly address the use of assembler in Delphi, nor in Windows 95, but both give a good grounding in assembler algorithm design.

1071

Creating a Class to Access RAR Archives Peter Davies - GUI Computing The Task: Create a class to access the list of files contained in a RAR (similar to a ZIP) archive in Delphi 2.0. Keep it generic enough so that other compression types can be added in the future. The Solution: An approach, used back in the days of Borland Pascal Turbo Vision to tackle a similar task, was to use the class TCollection to store a list of file objects. Unfortunately, TCollection in Delphi has taken on a whole new look and does not really suit the requirements. Instead, the class TList in Delphi is better suited. It basically stores a list of objects of any type. The beauty of TList, over the use of the conventional array, is that it dynamically grows with the addition of new objects to the list - whereas an array must be set to a finite size before a maximum size might be actually known. TList also takes care of many of the tasks of maintaining a sequential list, such as removing items in the middle of the list, adding items in the middle of a list and so on. Certain details need to be stored about each file in the RAR archive. To do this we will create a small class that stores the details and knows how to create and destroy itself. The class will be of the following structure: TFileDetails = class Filename : PChar; CompressedSize : Longint; OriginalSize : Longint; FileDate : Longint; constructor Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); destructor Destroy; override; end; On creating an instance of TFileDetails, the information about the file (passed as parameters), is stored in the object. Many of these objects create all the information we need to know about the RAR archive. A class is required to handle the creating of each instance of TFileDetails Class. This is accomplished by the TArchive Class. This class consists of the following structure: TArchive = class private FileName : PChar; FileList : TList; ArchiveOK : boolean; ArchiveType : Longint; TotOrigSize, TotCompSize, FileDate : Longint; public constructor Create(AFileName : String); destructor Destroy; override; function GetArchiveOk : boolean; function GetTotalFiles : Integer; function GetAFileName(Index : Integer) : String; end; This class requires the filename of the RAR archive as input. An example of using this class might be: var Archive : TArchive; Counter : Integer; begin Archive := TArchive.Create('C:\TEST.RAR'); if Archive.GetArchiveOk then begin For Counter := 1 to Archive.GetTotalFiles do begin ... do something do something with the filename ... := Archive.GetAFileName(Counter) ... do something end; end; Archive.Free; end; Some tips used in the creation of the source, which may help other Delphi developers, are:

1072

201. When adding an object to the list of objects (Tlist), it is not necessary to actually create the object before adding. It can be dynamically created while adding it. Simply use the class name, then the create constructor, and the parameters required. Eg: FileList.Add(TFileDetails.Create(FName,FBlock.OrigSize,FBlock.PackSize,FBlock.FTime)); 202. When obtaining information about a particular object, in the list of objects (Tlist), it is not necessary to actually assign the object being read to an object. You can simply tell Delphi the type of object it is (type cast) and then tell it the variable/etc you wish to get the information from. Eg: sResult := StrPas(TFileDetails(FileList.Items[Index-1] ).FileName); Here is the relevant code. In future AVDF articles, this class will be expanded upon, creating many ways of accessing the data in an instance of the class. This class provides the basis for a general purpose way of accessing RAR archives.

Creating a Class to Access RAR Archives The code behind this class looks like this... {$A-} unit Archive; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; const (* List of Archive Types *) atNoArchive = 0; atZIPArchive = 1; atLZHArchive = 2; atARJArchive = 3; atPAKArchive = 4; atARCArchive = 5; atZOOArchive = 6; atSQZArchive = 7; atRARArchive = 8; type TFileDetails = class FileName : PChar; CompressedSize : Longint; OriginalSize : Longint; FileDate : Longint; constructor Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); destructor Destroy; override; end; TArchive = class private FileName FileList ArchiveType TotOrigSize, TotCompSize, FileDate ArchiveOk public constructor destructor function function

: PChar; : TList; : Longint; : Longint; : boolean; Create(AFileName : String); Destroy; override; GetTotalFiles : Integer; GetAFileName(Index : Integer) : String;

1073

function function function function procedure

GetArchiveOk : Boolean; GetArchiveType : Longint; GetTotalOriginalSize : Longint; GetTotalCompressedSize : Longint; GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec :

function function

GetDateTime : TDateTime; GetFileName : String;

word); end; implementation function GetArchiveType(FName : string) : Longint; // From the file, determine the type of archive that we are looking // at. ie zip, arj, rar, etc var hArchive : file; OldFileMode : word; ReadBuf : array[1..8] of byte; begin OldFileMode := FileMode; AssignFile(hArchive,FName); FileMode := fmOpenRead + fmShareDenyNone; // Read Only {$I-} reset(hArchive,1); GetArchiveType := atNoArchive; if (ioresult = 0) then begin if (filesize(hArchive) >= 8) then begin blockread(hArchive,ReadBuf,sizeof(ReadBuf)); if (ReadBuf[1] = $50) and (ReadBuf[2] = $4B) and (ReadBuf[3] = $03) and (ReadBuf[4] = $04) then GetArchiveType := atZIPArchive else if (ReadBuf[1] = $60) and (ReadBuf[2] = $EA) then GetArchiveType := atARJArchive else if (ReadBuf[3] = ord('-')) and (ReadBuf[4] = ord('l')) and (ReadBuf[5] = ord('h')) and (ReadBuf[7] = ord('-')) then GetArchiveType := atLZHArchive else if (ReadBuf[1] = ord('Z')) and (ReadBuf[2] = ord('O')) and (ReadBuf[3] = ord('O')) then GetArchiveType := atZOOArchive else if (ReadBuf[1] = 72) and (ReadBuf[2] = 76) and (ReadBuf[3] = 83) and (ReadBuf[4] = 81) and (ReadBuf[5] = 90) then GetArchiveType := atSQZArchive else if (ReadBuf[1] = ord('R')) and (ReadBuf[2] = ord('a')) and (ReadBuf[3] = ord('r')) and (ReadBuf[4] = ord('!')) then GetArchiveType := atRARArchive else if (ReadBuf[1] = $1A) then begin if (pos('.ARC',FName) > 0) then GetArchiveType := atARCArchive else GetArchiveType := atPAKArchive; end; end;

1074

close(hArchive); end; {$I+} OldFileMode := FileMode; end; constructor TFileDetails.Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); begin CompressedSize := ACompressedSize; OriginalSize := AOriginalSize; FileDate := AFileDate; FileName := StrAlloc(length(AFileName)+1); StrPCopy(FileName,AFileName); end; destructor TFileDetails.Destroy; begin StrDispose(FileName); inherited Destroy; end; constructor TArchive.Create(AFileName : String); procedure ReadRar; type RarBlock = record HeadCRC : Word; HeadType : Byte; HeadFlags : Word; HeadSize : Word; end; FileBlock = record PackSize : Longint; OrigSize : Longint; HostOS : Byte; FileCRC : Longint; FTime : Longint; UnpVer : Byte; Method : Byte; NameSize : Word; Attr : Longint; end; const MaxName = 250; var HdrBlock : RarBlock; NumRead : Integer; FBlock : FileBlock; FName : String[MaxName]; CName : Array[0..MaxName+1] of Char; hArchive : file; OldFileMode : Byte; procedure JumpAddSize(ShouldRead : Integer); var

ExtLen : Longint;

1075

begin if ArchiveOK then begin seek(hArchive,filepos(hArchive) + ShouldRead); if (HdrBlock.HeadFlags shr 15 > 0) then begin blockread(hArchive,ExtLen,4,NumRead); if (NumRead <> 4) then ArchiveOK := False else begin seek(hArchive,FilePos(hArchive) + Longint(HdrBlock.HeadSize + ExtLen - SizeOf(RarBlock) - 4)); end; end; end; end; begin OldFileMode := FileMode; AssignFile(hArchive,AFileName); FileMode := fmOpenRead + fmShareDenyNone; // Read Only {$I-} reset(hArchive,1); ArchiveOK := (IOResult = 0); {$I+} if (ArchiveOk) then begin // Get the datetime of the current file FileDate := FileGetDate(TFileRec(hArchive).Handle); while (not eof(hArchive)) and ArchiveOK do begin blockread(hArchive,HdrBlock,sizeof(HdrBlock),NumRead); if (NumRead <> sizeof(HdrBlock)) then ArchiveOK := False; if (HdrBlock.HeadType = $74) and (ArchiveOK) then begin blockread(hArchive,FBlock,sizeof(FBlock),NumRead); if (NumRead <> sizeof(FBlock)) then ArchiveOK := False; if (FBlock.NameSize <= MaxName) and ArchiveOK then begin blockread(hArchive,FName[1],FBlock.NameSize,NumRead); if (NumRead <> FBlock.NameSize) then ArchiveOK := false else begin // make a normal pascal style string (length first) FName[0] := chr(FBlock.NameSize); StrPCopy(CName,FName); // Adds the individual file details to the list of files FileList.Add(TFileDetails.Create(FName,FBlock.OrigSize,FBlock.PackSize,FBlock.FT ime)); TotOrigSize := TotOrigSize + FBlock.OrigSize; TotCompSize := TotCompSize + FBlock.PackSize; end; end else seek(hArchive,filepos(hArchive) + FBlock.NameSize); seek(hArchive,filepos(hArchive) + Longint(HdrBlock.HeadSizesizeof(HdrBlock)-sizeof(FBlock)-FBlock.NameSize)); if (HdrBlock.HeadFlags shr 15 > 0) then seek(hArchive,filepos(hArchive) + FBlock.PackSize); end else JumpAddSize(HdrBlock.HeadSize-NumRead); end; close(hArchive); end; FileMode := OldFileMode; end; begin

1076

ArchiveOK := True; FileList := TList.Create; FileName := StrAlloc(length(AFileName)+5); StrPCopy(FileName,AFileName); // to call a function outside of the current object, that has a method of // the same name, we simply place the units name in front of the function // eg: Archive.GetArchiveType(AFileName) ArchiveType := Archive.GetArchiveType(AFileName); TotOrigSize := 0; TotCompSize := 0; FileDate := 0; case ArchiveType of atRARArchive : ReadRAR; else ArchiveOK := False; end; end; destructor TArchive.Destroy; var nCount : Integer; begin // Free up the objects for nCount := 0 to FileList.Count-1 do begin TFileDetails(FileList.Items[nCount]).Free end; FileList.Free; StrDispose(FileName); inherited Destroy; end; function TArchive.GetTotalFiles : Integer; begin GetTotalFiles := FileList.Count; end; function TArchive.GetArchiveOk : Boolean; begin GetArchiveOk := ArchiveOk; end; function TArchive.GetArchiveType : Longint; begin GetArchiveType := ArchiveType; end; function TArchive.GetTotalOriginalSize : Longint; begin GetTotalOriginalSize := TotOrigSize; end; function TArchive.GetTotalCompressedSize : Longint; begin GetTotalCompressedSize := TotCompSize; end; function TArchive.GetFileName : String;

1077

begin GetFileName := StrPas(FileName); end; procedure TArchive.GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec : word); var DateTime : TDateTime; begin DateTime := FileDateToDateTime(FileDate); DecodeTime(DateTime,Hour,Min,Sec,MSec); DecodeDate(DateTIme,Year,Month,Day); end; function TArchive.GetDateTime : TDateTime; begin GetDateTime := FileDateToDateTime(FileDate); end; function TArchive.GetAFileName(Index : Integer) : String; var

sResult : String; FileDetails : TFileDetails;

begin IF ((Index > 0) and (Index <= FileList.Count)) then begin sResult := StrPas(TFileDetails(FileList.Items[Index-1]).FileName); end else sResult := ''; GetAFileName := sResult; end; end.

1078

Packing a Paradox or dBase Table How do I pack a Paradox (or dBase) table to optimize its indexes and space used? Wouldn't it be great for the TTable component to have a method that does this? Just open up a TTable, connected it to a table on disk, call the method, and wham! The table's packed (Hmm.... I just might have to look into that). But short of that, you have to make direct calls to the BDE to accomplish this task. For dBase tables, it's easy. There's a single function called dbiPackTable that'll pack any dBase file. For Paradox files, you have to jump through a couple of hoops first, then call dbiDoRestructure because Paradox tables can only be packed within the context of a table restructure (Note: If you've restructured a table in Paradox or the Database Desktop, you'll notice a checkbox at the bottom of the restructure dialog called "Pack Table"). Below is a simple procedure for packing tables. I took most of the code right out of the online help (yes, there's really good stuff in there if you know where look), and made some alterations. The difference between what I did and what the help file lists is that instead of the formal parameter being a TTable, I require a fully qualified file name (path/name). This allows for greater flexibility the procedure opens up its own TTable and works on it instead you having to create one yourself. I guess it might all boil down to semantics, but I still like my way better (so there!). Check out the code below: procedure PackTable(TblName : String); var tbl : TTable; cProps : CURProps; hDb : hDBIDb; TblDesc : CRTblDesc; begin tbl := TTable.Create(nil); with tbl do begin Active := False; DatabaseName := ExtractFilePath(TblName); TableName := ExtractFileName(TblName); Open; Exclusive := True; end; // Make sure the table is open exclusively so we can get the db handle... if not tbl.Active then raise EDatabaseError.Create('Table must be opened to pack'); if not tbl.Exclusive then raise EDatabaseError.Create('Table must be opened exclusively to pack'); // Get the table properties to determine table type... Check(DbiGetCursorProps(tbl.Handle, cProps)); // If the table is a Paradox table, you must call DbiDoRestructure... if (cProps.szTableType = szPARADOX) then begin // Blank out the structure... FillChar(TblDesc, sizeof(TblDesc), 0); // Get the database handle from the table's cursor handle... Check(DbiGetObjFromObj(hDBIObj(tbl.Handle), objDATABASE, hDBIObj(hDb))); // Put the table name in the table descriptor... StrPCopy(TblDesc.szTblName, tbl.TableName); // Put the table type in the table descriptor... StrPCopy(TblDesc.szTblType, cProps.szTableType); // Set the Pack option in the table descriptor to TRUE...

1079

TblDesc.bPack := True; // Close the table so the restructure can complete... tbl.Close; // Call DbiDoRestructure... Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False)); end else // If the table is a dBASE table, simply call DbiPackTable... if (cProps.szTableType = szDBASE) then Check(DbiPackTable(tbl.DBHandle, tbl.Handle, nil, szDBASE, True)) else // Pack only works on PAradox or dBASE; nothing else... raise EDatabaseError.Create('You can only pack Paradox or dBase tables!'); with tbl do begin if Active then Close; Free; end; end; See? Nothing fancy. What you should know is that all operations involving dbiDoRestructure revolve around a table descriptor type CRTblDesc. With this record type, you can set various field values, then execute dbiDoRestructure to make your changes. That's kind of the trick to making BDE calls in general. You typically work with some sort of record structure, then use that structure in one of the calls. I know I'm probably oversimplifying, but that's it in a nutshell. The point? Don't be scared of the BDE. More later! I encourage you to look at the BDE online help under any dbi- subject. There are lots of code examples that will get you on your way.

1080

Ok but I hope you know that Paradox tables normaly do not need to be packed function dgPackParadoxTable(Tbl: TTable; Db: TDatabase):DBIResult; {Packs a Paradox table by calling the BDE DbiDoRestruct function. The TTable passed as the first parameter must be closed. The TDatabase passed as the second parameter must be connected.} var TblDesc: CRTblDesc; begin Result := DBIERR_NA; FillChar(TblDesc, SizeOf(CRTblDesc), 0); StrPCopy(TblDesc.szTblName, Tbl.TableName); TblDesc.bPack := True; Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False); end;

1081

Real Time Mouse Coordinates Display By Michael Burton - Rimrock Software and Mike Tumy - AMS Services, Inc. One of the people at our local Delphi user group asked if anyone knew of an easy way to display information about a window as they dragged the mouse over it. Mike Tumy came up with the idea of using a hint window to display the information. What follows is an implementation of this idea that displays the mouse coordinates in a hint box as you move over the window and that (sometimes) removes the hint box when you leave the window. The window's OnCreate event is used to create an instance of a THintWindow, and to initialize a TPoint record that will be used to contain the coordinates from the last time the OnMouseMove event was entered. A handler for the Application's OnIdle event is also hooked up in the OnCreate event. The window's OnMouseMove event is used to calculate the current mouse position and display it in the hint window. Note that a new value is only displayed if the new value differs from the old one by more than one pixel. In order to display the hint box in the proper position, the height of the mouse cursor must be taken into account, and the window coordinates must be converted to screen coordinates, since the hint window's ActivateHint method uses screen coordinates. The application's OnIdle event is used to determine whether to remove the hint window from the display. To do this, we need get the current mouse position and convert those coordinates to client coordinates. The results are compared with zero, the client width and the client height. If either of the results fall outside the limits of the client window, the hint box is removed by calling ReleaseHandle. The only weak spot in this code is the OnIdle event. If you play with the example, you can get the mouse cursor to leave the window without removing the hint box. If anyone can think of a better method to do this (without using a TTimer component), please share it with us. To download sample code for this project, click here.

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); private { Private declarations } ptPrev: TPoint; hwHint: THintWindow; procedure HandleIdle(Sender: TObject; var Done: Boolean); public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin ptPrev.X := 0; ptPrev.Y := 0; hwHint := THintWindow.Create(self); Application.OnIdle := HandleIdle; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var

1082

pt: TPoint; sText: String; begin if (abs(x - ptPrev.X) > 1) or (abs(y - ptPrev.Y) > 1) then begin ptPrev.X := X; ptPrev.Y := Y; pt.x := x; pt.y := y + GetSystemMetrics(SM_CYCURSOR); pt := ClientToScreen(pt); sText := Format('%d,%d', [x, y]); hwHint.ActivateHint(Rect(pt.x, pt.y, pt.x + hwHint.Canvas.TextWidth(sText) + 10, pt.y + hwHint.Canvas.TextHeight(sText)), sText); end; end; procedure TForm1.HandleIdle(Sender: TObject; var Done: Boolean); var pt: TPoint; begin GetCursorPos(pt); pt := ScreenToClient(pt); if (pt.x > ClientWidth) or (pt.x < 0) or (pt.y > ClientHeight) or (pt.y < 0) then hwHint.ReleaseHandle; end; end.

1083

procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField); var i,j: LongInt; begin Table1.UpdateCursorPos; DbiGetSeqNo(Table1.Handle,i); DbiGetRecordCount(Table1.Handle,j); Panel1.Caption := 'Record '+ IntToStr(i) + ' of ' + IntToStr(j); end;

1084

Available Engine functions by type The following is a list of Borland Database Engine functions, grouped by type. Each function has a small description and possibly a jump to an example. This page is brand new so please be patient with the examples. If you are interested in seeing a specific example mail a request to BDE Administrator Download all the below BDE API Examples in HTML form. Database functions Each function listed below returns information about a specific database, available databases, or performs a database-related task, such as opening or closing a database. · DbiCloseDatabase: Closes a database and all tables associated with this database handle. · DbiGetDatabaseDesc: Retrieves the description of the specified database from the configuration file. · DbiGetDirectory: Retrieves the current working directory or the default directory. · DbiOpenDatabase: Opens a database in the current session and returns a database handle. · DbiOpenDatabaseList: Creates an in-memory table containing a list of accessible databases and their descriptions. · DbiOpenFileList: Opens a cursor on the virtual table containing all the tables accessible by the client application and their descriptions. · DbiOpenIndexList: Opens a cursor on an in-memory table listing the indexes on a specified table, along with their Descriptions. · DbiOpenTableList: Creates an in-memory table with information about all the tables accessible to the client application. Environment and configuration functions Each function listed below returns information about the client application environment, such as the supported table, field and index types for the driver type, or the available driver types. Functions in this category can also perform tasks that affect the client application environment, such as loading a driver. · DbiAddAlias: Adds an alias to the BDE configuration file (IDAPI.CFG). · DbiAddDriver: Adds a driver to the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0 · DbiAnsiToNative: Multipurpose translate function. · DbiDebugLayerOptions: Activates, deactivates, or sets options for the BDE debug layer. OBSOLETE FUNCTION BDE 4.0 · DbiDeleteAlias: Deletes an alias from the BDE configuration file (IDAPI.CFG). · DbiDeleteDriver: Deletes a driver from the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0 · DbiDllExit: Prepares the BDE to be disconnected within a DLL. NEW FUNCTION BDE 4.0 · DbiExit: Disconnects the client application from BDE. · DbiGetClientInfo: Retrieves system-level information about the client application environment. · DbiGetDriverDesc: Retrieves a description of a driver. · DbiGetLdName: Retrieves the name of the language driver associated with the specified object name (table name). · DbiGetLdObj: Retrieves the language driver object associated with the given cursor. · DbiGetNetUserName: Retrieves the user's network login name. User names should be available for all networks supported by Microsoft Windows. · DbiGetProp: Returns a property of an object. · DbiGetSysConfig: Retrieves BDE system configuration information. · DbiGetSysInfo: Retrieves system status and information. · DbiGetSysVersion: Retrieves the system version information, including the BDE version number, date, and time, and the client interface version number. · DbiInit: Initializes the BDE environment. · DbiLoadDriver: Load a given driver. · DbiNativeToAnsi: Translates a string in the native language driver to an ANSI string. · DbiOpenCfgInfoList: Returns a handle to an in-memory table listing all the nodes in the configuration file accessible by the specified path. · DbiOpenDriverList: Creates an in-memory table containing a list of driver names available to the client application.

1085

· · · · · · · · · ·

DbiOpenFieldTypesList: Creates an in-memory table containing a list of field types supported by the table type for the driver type. DbiOpenFunctionArgList: Returns a list of arguments to a data source function. DbiOpenFunctionList: Returns a description of a data source function. DbiOpenIndexTypesList: Creates an in-memory table containing a list of all supported index types for the driver type. DbiOpenLdList:Creates an in-memory table containing a list of available language drivers. DbiOpenTableList: Creates an in-memory table with information about all the tables accessible to the client application. DbiOpenTableTypesList: Creates an in-memory table listing table type names for the given driver. DbiOpenUserList: Creates an in-memory table containing a list of users sharing the same network file. DbiSetProp: Sets the specified property of an object to a given value. DbiUseIdleTime: Allows BDE to accomplish background tasks during times when the client application is idle. OBSOLETE FUNCTION BDE 4.0

Session functions Each function listed below returns information about a session or performs a task that affects the session, such as starting a session or adding a password. · DbiAddPassword: Adds a password to the current session. · DbiCheckRefresh: Checks for remote updates to tables for all cursors in the current session, and refreshes the cursors if changed. · DbiCloseSession: Closes the session associated with the given session handle. · DbiDropPassword: Removes a password from the current session. · DbiGetCallBack: Returns a pointer to the function previously registered by the client for the given callback type. · DbiGetCurrSession: Returns the handle associated with the current session. · DbiGetDateFormat: Gets the date format for the current session. · DbiGetNumberFormat: Gets the number format for the current session. · DbiGetSesInfo: Retrieves the environment settings for the current session. · DbiGetTimeFormat: Gets the time format for the current session. · DbiRegisterCallBack: Registers a callback function for the client application. · DbiSetCurrSession: Sets the current session of the client application to the session associated with hSes. · DbiSetDateFormat: Sets the date format for the current session. · DbiSetNumberFormat: Sets the number format for the current session. · DbiSetPrivateDir: Sets the private directory for the current session. · DbiSetTimeFormat: Sets the time format for the current session. · DbiStartSession: Starts a new session for the client application. Error-handling functions Each function listed below returns error handling information or performs a task that relates to error handling. · DbiGetErrorContext: After receiving an error code back from a call, enables the client to probe BDE for more specific error information. · DbiGetErrorEntry: Returns the error description of a specified error stack entry. · DbiGetErrorInfo: Provides descriptive error information about the last error that occurred. · DbiGetErrorString:Returns the message associated with a given error code. Lock functions Each function listed below returns information about lock status or acquires or releases a lock at the table or record level. · DbiAcqPersistTableLock: Acquires an exclusive persistent lock on the table preventing other users from using the table or creating a table of the same name. · DbiAcqTableLock: Acquires a table-level lock on the table associated with the given cursor. · DbiGetRecord: Record positioning functions have a lock parameter. · DbiIsRecordLocked: Checks the lock status of the current record.

1086

· · · · · · · ·

DbiIsTableLocked: Returns the number of locks of a specified type acquired on the table associated with the given session. DbiIsTableShared: Determines whether the table is physically shared or not. DbiOpenLockList: Creates an in-memory table containing a list of locks acquired on the table. DbiOpenUserList: Creates an in-memory table containing a list of users sharing the same network file. DbiRelPersistTableLock: Releases the persistent table lock on the specified table. DbiRelRecordLock: Releases the record lock on either the current record of the cursor or only the locks acquired in the current session. DbiRelTableLock: Releases table locks of the specified type associated with the current session (the session in which the cursor was created). DbiSetLockRetry: Sets the table and record lock retry time for the current session.

Cursor functions Each function listed below returns information about a cursor, or performs a task that performs a cursorrelated task such as positioning of a cursor, linking of cursors, creating and closing cursors, counting of records associated with a cursor, filtering, setting and comparing bookmarks, and refreshing all buffers associated with a cursor. · DbiActivateFilter: Activates a filter. · DbiAddFilter: Adds a filter to a table, but does not activate the filter (the record set is not yet altered). · DbiApplyDelayedUpdates: When cached updates cursor layer is active, writes all modifications made to cached data to the underlying database. · DbiBeginDelayedUpdates: Creates a cached updates cursor layer so that users can make extended changes to temporarily cached table data without writing to the actual table, thereby minimizing resource locking. · DbiBeginLinkMode: Converts a cursor to a link cursor. Given an open cursor, prepares for linked access. Returns a new cursor. · DbiCloneCursor:Creates a new cursor (clone cursor) which has the same result set as the given cursor (source cursor). · DbiCloseCursor: Closes a previously opened cursor. · DbiCompareBookMarks: Compares the relative positions of two bookmarks in the result set associated with the cursor. · DbiDeactivateFilter: Temporarily stops the specified filter from affecting the record set by turning the filter off. · DbiDropFilter: Deactivates and removes a filter from memory, and frees all resources. · DbiEndDelayedUpdates: Closes a cached updates cursor layer ending the cached updates mode. · DbiEndLinkMode: Ends linked cursor mode, and returns the original cursor. · DbiExtractKey: Retrieves the key value for the current record of the given cursor or from the supplied record buffer. · DbiForceRecordReread: Rereads a single record from the server on demand, refreshing one row only, rather than clearing the cache. · DbiForceReread: Refreshes all buffers associated with the cursor, if necessary. · DbiFormFullName: Returns the fully qualified table name. · DbiGetBookMark: Saves the current position of a cursor to the client-supplied buffer called a bookmark. · DbiGetCursorForTable: Finds the cursor for the given table. · DbiGetCursorProps: Returns the properties of the cursor. · DbiGetExactRecordCount: Retrieves the current exact number of records associated with the cursor.. NEW FUNCTION BDE 4.0 · DbiGetFieldDescs: Retrieves a list of descriptors for all the fields in the table associated with the cursor. · DbiGetLinkStatus: Returns the link status of the cursor. · DbiGetNextRecord: Retrieves the next record in the table associated with the cursor. · DbiGetPriorRecord: Retrieves the previous record in the table associated with the given cursor. · DbiGetProp: Returns a property of an object. · DbiGetRecord: Retrieves the current record, if any, in the table associated with the cursor. · DbiGetRecordCount: Retrieves the current number of records associated with the cursor. · DbiGetRecordForKey: Finds and retrieves a record matching a key and positions the cursor on that record.

1087

· · · · · · · · · · · · · · · · · · ·

DbiGetRelativeRecord: Positions the cursor on a record in the table relative to the current position of the cursor. DbiGetSeqNo: Retrieves the sequence number of the current record in the table associated with the cursor. DbiLinkDetail: Establishes a link between two tables such that the detail table has its record set limited to the set of records matching the linking key values of the master table cursor. DbiLinkDetailToExp: Links the detail cursor to the master cursor using an expression. DbiMakePermanent: Changes a temporary table created by DbiCreateTempTable into a permanent table. DbiOpenTable: Opens the given table for access and associates a cursor handle with the opened table. DbiResetRange: Removes the specified table's limited range previously established by the function DbiSetRange. DbiSaveChanges: Forces all updated records associated with the cursor to disk. DbiSetFieldMap: Sets a field map of the table associated with the given cursor. DbiSetProp: Sets the specified property of an object to a given value. DbiSetRange: Sets a range on the result set associated with the cursor. DbiSetToBegin: Positions the cursor to BOF (just before the first record). DbiSetToBookMark: Positions the cursor to the location saved in the specified bookmark. DbiSetToCursor: Sets the position of one cursor (the destination cursor) to that of another (the source cursor). DbiSetToEnd: Positions the cursor to EOF (just after the last record). DbiSetToKey: Positions an index-based cursor on a key value. DbiSetToRecordNo: Positions the cursor of a dBASE table to the given physical record number. DbiSetToSeqNo: Positions the cursor to the specified sequence number of a Paradox table. DbiUnlinkDetail: Removes a link between two cursors.

Index functions Each function listed below returns information about an index or indexes, or performs a task that affects an index, such as dropping it, deleting it, or adding it. · DbiAddIndex: Creates an index on an existing table. UPDATED EXAMPLE 9/9/98 · DbiCloseIndex: Closes the specified index on a cursor. · DbiCompareKeys: Compares two key values based on the current index of the cursor. · DbiDeleteIndex: Drops an index on a table. · DbiExtractKey: Retrieves the key value for the current record of the given cursor or from the supplied record buffer. · DbiGetIndexDesc: Retrieves the properties of the given index associated with the cursor. · DbiGetIndexDescs: Retrieves index properties. · DbiGetIndexForField: Returns the description of any useful index on the specified field. · DbiGetIndexSeqNo: Retrieves the ordinal number of the index in the index list of the specified cursor. · DbiGetIndexTypeDesc: Retrieves a description of the index type. · DbiOpenIndex: Opens the index for the table associated with the cursor. · DbiRegenIndex: Regenerates an index to make sure that it is up-to-date (all records currently in the table are included in the index and are in the index order). · DbiRegenIndexes: Regenerates all out-of-date indexes on a given table. · DbiSwitchToIndex: Allows the user to change the active index order of the given cursor. Query functions Each function listed below performs a query task, such as preparing and executing a SQL or QBE query. · DbiGetProp: Returns a property of an object. · DbiQAlloc: Allocates a new statement handle for a prepared query. · DbiQExec: Executes the previously prepared query identified by the supplied statement handle and returns a cursor to the result set, if one is generated. · DbiQExecDirect: Executes a SQL or QBE query and returns a cursor to the result set, if one is generated. · DbiQExecProcDirect: Executes a stored procedure and returns a cursor to the result set, if one is generated.

1088

· · · · · · · · ·

DbiQFree: Frees the resources associated with a previously prepared query identified by the supplied statement handle. DbiQGetBaseDescs: Returns the original database, table, and field names of the fields that make up the result set of a query. DbiQInstantiateAnswer: Creates a permanent table from the cursor to the result set. DbiQPrepare: Prepares a SQL or QBE query for execution, and returns a handle to a statement containing the prepared query. DbiQPrepareProc: Prepares and optionally binds parameters for a stored procedure. DbiQSetParams: Associates data with parameter markers embedded within a prepared query. DbiQSetProcParams: Binds parameters for a stored procedure prepared with DbiQPrepareProc. DbiSetProp: Sets the specified property of an object to a given value. DbiValidateProp: Validates a property.

Table functions Each function listed below returns information about a specific table, such as all the locks acquired on the table, all the referential integrity links on the table, the indexes open on the table, or whether or not the table is shared. Functions in this category can also perform a table-wide operation, such as copying and deleting. · DbiBatchMove: Appends, updates, subtracts, and copies records or fields from a source table to a destination table. · DbiCopyTable: Duplicates the specified source table to a destination table. · DbiCreateInMemTable: Creates a temporary, in-memory table. · DbiCreateTable: Creates a table. · DbiCreateTempTable: Creates a temporary table that is deleted when the cursor is closed, unless the call is followed by a call to DbiMakePermanent. · DbiDeleteTable: Deletes a table. · DbiDoRestructure: Changes the properties of a table. · DbiEmptyTable: Deletes all records from the table associated with the specified table cursor handle or table name. · DbiGetTableOpenCount: Returns the total number of cursors that are open on the specified table. · DbiGetTableTypeDesc: Returns a description of the capabilities of the table type for the driver type. · DbiIsTableLocked: Returns the number of locks of a specified type acquired on the table associated with the given session. · DbiIsTableShared: Determines whether the table is physically shared or not. · DbiMakePermanent: Changes a temporary table created by DbiCreateTempTable into a permanent table. · DbiOpenFamilyList: Creates an in-memory table listing the family members associated with a specified table. · DbiOpenFieldList: Creates an in-memory table listing the fields in a specified table and their descriptions. · DbiOpenIndexList: Opens a cursor on an in-memory table listing the indexes on a specified table, along with their descriptions. · DbiOpenLockList: Creates an in-memory table containing a list of locks acquired on the table associated with the cursor. · DbiOpenRintList: Creates an in-memory table listing the referential integrity links for a specified table, along with their descriptions. · DbiOpenSecurityList: Creates an in-memory table listing record-level security information about a specified table. · DbiOpenTable: Opens the given table for access and associates a cursor handle with the opened table. · DbiPackTable: Optimizes table space by rebuilding the table associated with the cursor and releasing any free space. · DbiQInstantiateAnswer: Creates a permanent table from a cursor handle. · DbiRegenIndexes: Regenerates all out-of-date indexes on a given table. · DbiRenameTable: Renames the table and all of its resources to the new name specified. · DbiSaveChanges: Forces all updated records associated with the table to disk. · DbiSortTable:Sorts an opened or closed table, either into itself or into a destination table. There are options to remove duplicates, to enable case-insensitive sorts and special sort functions, and to control the number of records sorted.

1089

Data access functions Each function listed below accesses data in a table, such as retrieving data from a specified BLOb field or from the record buffer. · DbiAppendRecord: Appends a record to the end of the table associated with the given cursor. · DbiDeleteRecord: Deletes the current record of the given cursor. · DbiFreeBlob: Closes the BLOB handle located within the specified record buffer. · DbiGetBlob: Retrieves data from the specified BLOB field. · DbiGetBlobHeading: Retrieves information about a BLOB field from the BLOB heading in the record buffer. · DbiGetBlobSize: Retrieves the size of the specified BLOB field in bytes. · DbiGetField: Retrieves the data contents of the requested field from the record buffer. · DbiGetFieldDescs: Retrieves a list of descriptors for all the fields in the table associated with the cursor. · DbiGetFieldTypeDesc: Retrieves a description of the specified field type. · DbiInitRecord: Initializes the record buffer to a blank record according to the data types of the fields. · DbiInsertRecord: Inserts a new record into the table associated with the given cursor. · DbiModifyRecord: Modifies the current record of table associated with the cursor with the data supplied. · DbiOpenBlob: Prepares the cursor's record buffer to access a BLOB field. · DbiPutBlob: Writes data into an open BLOB field. · DbiPutField: Writes the field value to the correct location in the supplied record buffer. · DbiReadBlock: Reads a specified number of records (starting from the next position of the cursor) into a buffer. · DbiSaveChanges: Forces all updated records associated with the cursor to disk. · DbiSetFieldMap:Sets a field map of the table associated with the given cursor. · DbiTruncateBlob: Shortens the size of the contents of a BLOB field, or deletes the contents of a BLOB field from the record, by shortening it to zero. · DbiUndeleteRecord: Undeletes a dBASE record that has been marked for deletion (a "soft" delete). · DbiVerifyField: Verifies that the data specified is a valid data type for the field specified, and that all validity checks in place for the field are satisfied. It can also be used to check if a field is blank. · DbiWriteBlock: Writes a block of records to the table associated with the cursor. Transaction functions Each function listed below begins, ends, or inquires about the status of a transaction. · DbiBeginTran: Begins a transaction. · DbiEndTran: Ends a transaction. · DbiGetTranInfo: Retrieves the transaction state. Capability or schema functions Each function listed below returns information about capabilities or the schema. · DbiOpenCfgInfoList: Returns a handle to an in-memory table listing all the nodes in the configuration file accessible by the specified path. · DbiOpenDatabaseList: Creates an in-memory table containing a list of accessible databases and their descriptions. · DbiOpenDriverList: Creates an in-memory table containing a list of driver names available to the client application. · DbiOpenFamilyList: Creates an in-memory table listing the family members associated with a specified table. · DbiOpenFieldList: Creates an in-memory table listing the fields in a specified table and their descriptions. · DbiOpenFieldTypesList: Creates an in-memory table containing a list of field types supported by the table type for the driver type. · DbiOpenFunctionArgList: Returns a list of arguments to a data source function. · DbiOpenFunctionList: Returns a description of a data source function. · DbiOpenIndexList: Opens a cursor on an in-memory table listing the indexes on a specified table, along with their descriptions.

1090

· · · · · · ·

DbiOpenIndexTypesList: Creates an in-memory table containing a list of all supported index types for the driver type. DbiOpenLockList: Creates an in-memory table containing a list of locks acquired on the table. DbiOpenRintList : Creates an in-memory table listing the referential integrity links for a specified table, along with their descriptions. DbiOpenSecurityList: Creates an in-memory table listing record-level security information about a specified table. DbiOpenTableList: Creates an in-memory table with information about all the tables accessible to the client application. DbiOpenTableTypesList: Creates an in-memory table listing table type names for the given driver. DbiOpenVchkList: Creates an in-memory table containing records with information about validity checks for fields within the specified table.

Date/time/number format functions Each function listed below sets or retrieves date or time, or decodes/encodes date and time into or from a timestamp. · DbiBcdFromFloat; Converts FLOAT data to binary coded decimal (BCD) format. · DbiBcdToFloat: Converts binary coded decimal (BCD) data to FLOAT format. · DbiDateDecode: Decodes DBIDATE into separate month, day and year components. · DbiDateEncode: Encodes separate date components into date for use by DbiPutField and other functions. · DbiGetDateFormat: Gets the date format for the current session. · DbiGetNumberFormat: Gets the number format for the current session. · DbiGetTimeFormat: Gets the time format for the current session. · DbiSetDateFormat: Sets the date format for the current session. · DbiSetNumberFormat: Sets the number format for the current session. · DbiSetTimeFormat: Sets the time format for the current session. · DbiTimeDecode: Decodes time into separate components (hours, minutes, milliseconds). · DbiTimeEncode: Encodes separate time components into time for use by DbiPutField and other functions. · DbiTimeStampDecode: Extracts separate encoded date and time components from the timestamp. · DbiTimeStampEncode: Encodes the encoded date and encoded time into a timestamp. DISCLAIMER: You have the right to use this technical information subject to the terms of the No-Nonsense License Statement that you received with the Borland product to which this information pertains.

1091

Below is the complete program that puts all of the individual steps together. It demonstrates each of the basic steps described in the "Basic procedure" for BDE application development. You can execute the template program and step through it to see how it works: it opens a BDE sample table, visits one record, and retrieves the value from one field in that record. Use this template program as a skeleton on which to build your own BDE programs. In this example program, the handler for the OnClick event of the TButton component Button1 executes the BDE code. The BDE code accesses a Paradox table and retrieves the value from a field in that table. The retrieved field value is assigned as the value of the Caption property of the TLabel component Label1. unit BDEProg1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, BDE; type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var hDB: hDBIDb; // Database handle hCur: hDBICur; // Handle to the data cursor szTableName: array [0..DBIMAXNAMELEN] of Char; // Table name CursorProps: CURProps; // Data cursor properties RecordBuffer: pBYTE; // Buffer into which to load a record Company: array [0..30] of Char; // Variable for Company field IsBlank: BOOL; // Variable for blank fields begin Check(DbiInit(nil)); Check(DbiOpenDatabase(nil, nil, dbiREADONLY, dbiOPENSHARED, nil, 0, nil, nil, hDB)); Check(DbiSetDirectory(hDB, 'd:\Program Files\Borland\Borland Shared\Data')); Check(DbiSetPrivateDir('c:\Temp')); szTableName := 'Customer'; Check(DbiOpenTable(hDB, szTableName, szPARADOX, nil, nil, 0, dbiREADONLY, dbiOPENSHARED, xltFIELD, False, nil, hCur)); Check(DbiGetCursorProps(hCur, CursorProps)); RecordBuffer := AllocMem(CursorProps.iRecBufSize * SizeOf(BYTE)); Check(DbiSetToBegin(hCur)); Check(DbiGetNextRecord(hCur, dbiNOLOCK, RecordBuffer, nil)); Check(DbiGetField(hCur, 2, RecordBuffer, pBYTE(@Company), IsBlank)); FreeMem(RecordBuffer); if not (hCur = nil) then Check(DbiCloseCursor(hCur)); if not (hDB = nil) then Check(DbiCloseDatabase(hDB)); Check(DbiExit); Label1.Caption := StrPas(Company);

1092

end; end.

********************************************************** Create a table with a different level, block size, and fill factor than specified in the BDE configuration. Most Delphi users should use TTable.CreateTable. This example uses the following input: fDbiCreateTable(Database1.Handle, 'TableChange', 3, @FDesc, 7, 32768, 95); procedure fDbiCreateTable(hTmpDb: hDBIDb; TableName: String; Fields: Word; pFlds: pFLDDesc; Level, BlockSize, FillFactor: Word); var pOptDesc, pOrigDesc: pFLDDesc; pOptData, pOrigData: pBYTE; TblDesc: CRTblDesc; sLevel, sBlockSize, sFillFactor: String; begin pOptDesc := AllocMem(3 * sizeof(FLDDesc)); pOrigDesc := pOptDesc; pOptData := AllocMem(20); pOrigData := pOptData; try sLevel := IntToStr(Level); sBlockSize := IntToStr(BlockSize); sFillFactor := IntToStr(FIllFactor); // Set up first parameter pOptDesc.iOffset := 0; pOptDesc.iLen := Length(sLevel) + 1; StrPCopy(pOptDesc.szName, 'LEVEL'); StrPCopy(PChar(pOptData), sLevel); Inc(pOptData, Length(sLevel) + 1); Inc(pOptDesc); // Set up second parameter pOptDesc.iOffset := Length(sLevel) + 1; pOptDesc.iLen := Length(sLevel) + 1 + Length(sBlockSize) + 1; StrPCopy(pOptDesc.szName, 'BLOCK SIZE'); StrPCopy(PChar(pOptData), sBlockSize); Inc(pOptData, Length(sBlockSize) + 1); Inc(pOptDesc); // Set up third parameter pOptDesc.iOffset := Length(sLevel) + 1 + Length(sBlockSize) + 1; pOptDesc.iLen := Length(sLevel) + 1 + Length(sBlockSize) + 1 + Length(sFillFactor) + 1; StrPCopy(pOptDesc.szName, 'FILL FACTOR'); StrPCopy(PChar(pOptData), sFillFactor); // Format the table descriptor FillChar(TblDesc, sizeof(TblDesc), #0); StrPCopy(TblDesc.szTblName, TableName); StrCopy(TblDesc.szTblType, szPARADOX); TblDesc.iOptParams := 3; TblDesc.pFldOptParams := pOrigDesc; TblDesc.pOptData := pOrigData; TblDesc.iFldCount := Fields; TblDesc.pFldDesc := pFlds; // Create the table Check(DbiCreateTable(hTmpDb, True, TblDesc)); finally FreeMem(pOrigDesc, 3 * sizeof(FLDDesc)); FreeMem(pOrigData, 20);

1093

end; end;

Example 1: Add a STANDARD database alias to the configuration file. This example uses the following input: fDbiAddAlias1('TestAlias', 'PATH:C:\BDE32\EXAMPLES\TABLES'); procedure fDbiAddAlias1(AliasName, AliasPath: string); begin Check(DbiAddAlias(nil, PChar(AliasName), nil, PChar(AliasPath), True)); end;

1094

Create, OpenKey, RootKey, WriteString, CloseKey example The following example shows how to tell Windows to relaunch your application when Windows starts up if it was running when the system shut down. When Windows starts up, it launches each application listed in the RunOnce key and then deletes the entry for that application. Therefore, you do not need to remove the entry written here. procedure TForm1.WMEndSession(var Message: TWMEndSession); var Reg: TRegistry; begin Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\RunOnce', True) then begin Reg.WriteString('MyApp','"' + ParamStr(0) + '"'); Reg.CloseKey; end; finally Reg.Free; inherited; end; end;

In order for this method to be called, it must be declared in your main form class as follows: private procedure WMEndSession(var Msg:TWMEndSession); message WM_ENDSESSION;

1095

Quick Tips This part of the corner has really quick solutions to very focused subjects. Some I learn about on my own, others are sent to me by helpful readers. If you've any quick tips, please e-mail me and they'll be posted with your name on the front page! Getting the System BIOS Date without ASM or API calls Disabling an Event Handler Once It Has Executed Once Make the Results of Query Permanent Create a Right-Aligned Edit Box Editor Keyboard Shortcut - Column Selection Preventing a User from Closing a Window Except at Shutdown or Restart Some Useful Date Calculation Routines Finding a Substring in a TStrings Accessing the OnUpClick and OnDownClick of a TSpinEdit at Runtime Resizing a JPEG File Getting System BIOS Date Here's one, courtesy of one of our readers, Rubem Rocha. {================================ The following function will retrieve the BIOS date, without built-in assembler or API calls, just Delphi native resources. ================================} function BiosDate: String; begin result := string(pchar(ptr($FFFF5))); end; Disabling an Event Handler Once It Has Executed Once Have you ever wanted to keep an event from firing once it has executed once? Simply set the event handler method to nil in the body of the method. For instance, let's say you want to disable an OnClick for a button once the user has pressed it. Here's the code to do that: procedure Button1OnClick; begin Button1.OnClick := nil; end; Make the Results of a Query Permanent This tip comes to us by way of one of our readers, Cezar Nechifor. Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can shortcircuit this process by making a couple of simple, direct calls to the BDE. //Make sure you have BDE declared in your uses section procedure MakePermTable(Qry : TQuery; PermTableName : String); var h : HDBICur; ph : PHDBICur; begin Qry.Prepare; Check(dbiQExec(Qry.StmtHandle, ph)); h := ph^; Check(DbiMakePermanent(h, PChar(PermTableName), True)); end; Create a Right-Aligned Edit Box HUH?!!! Many of you might think, "Hey! You can't do that unless you use a TMemo. Well, Matt Powell, one of our readers, proved that wrong with such an incredibly simple bit of code that you'll... Forget it, here's component code that I subclassed from TCustomEdit that will give you a rightaligned edit box: unit AlignedEdit; interface uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics;

1096

type TAlignedEdit = class(TCustomEdit) private FAlignment : TAlignment; protected procedure CreateParams(var Params : TCreateParams); override; published property Alignment : TAlignment read FAlignment write FAlignment; end; procedure Register; implementation { TAlignedEdit } procedure TAlignedEdit.CreateParams(var Params: TCreateParams); const Alignments : array[TAlignment] of Integer = (ES_LEFT, ES_RIGHT, ES_CENTER); begin inherited CreateParams(Params); //Setting this does the alignment //Note that the actual alignment will //not occur until runtime with Params do Style := Style AND (NOT 0) OR (ES_MULTILINE) OR (Alignments[FAlignment]); end; procedure Register; begin RegisterComponents('BD', [TAlignedEdit]); end; end. It never ceases to amaze me the simple, yet completely elegant solutions that people come up with. Kudos to Matt Powell for passing this along to me! Editor Keyboard Shortcut - Column Selection The Delphi editor is something we all take for granted - I know I do. In past versions of Delphi, the editor lacked features that forced many of us to do as we did with Paradox: Use another editor add-in that provided more editing features. One thing that I use a lot is column selection; that is, instead of selecting an entire block of text in the editor, I only want to select a certain number of columns over several lines. For instance, this is incredibly useful for setting up several arrays with the same element count. There are lots of uses. Column selection keyboard shorcuts are defined as follows: Shortcut Description Alt+Shift+Left Arrow Selects the column to the left of the cursor Alt+Shift+Right Arrow Selects the column to the right of the cursor Alt+Shift+Up Arrow Moves the cursor up one line and selects the column from the left of the starting cursor position Alt+Shift+Down Arrow Moves the cursor down one line and selects the column from the left of the starting cursor position Alt+Shift+Page Up Moves the cursor up one screen and selects the column from the left of the starting cursor position Alt+Shift+Page Down Moves the cursor down one line and selects the column from the right of the starting cursor position

1097

Alt+Shift+End

Selects the column from the cursor position to the end of the current line Alt+Shift+Home Selects the column from the cursor position to the start of the current line There are lots of great editor shortcuts included in the Delphi Editor. For a listing of them, search the Delphi online help for "editor shortcuts." You'll find them as useful as I do! Preventing a User from Closing a Window Except at Shutdown or Restart We all know how to prevent a window from closing: Simply write event code for the OnCloseQuery event and set CanClose to False. Once that's done, no matter what a user presses, the window won't close. Here's some code: procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose := False; end; But what if you wanted to be able to close a window only when you reboot the machine? With the scenario above, that would be impossible. Fortunately though, there is a solution, and it resides in the windows message WM_QUERYENDSESSION. WM_QUERYENDSESSION is generated by Windows when the OS is resetting: Either at a shutdown or a restart. Using this message, we can set a boolean flag variable and interrogate its value in OnCloseQuery to allow us to close the window and reset the operating system. Look at the unit code below: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); private procedure WMQueryEndSession(var Message : TWMQueryEndSession); message WM_QUERYENDSESSION; public WindowsClosing : Boolean; end; var Form1: TForm1; implementation {$R *.DFM} { TForm1 } procedure TForm1.FormCreate(Sender: TObject); begin WindowsClosing := False; end; procedure TForm1.WMQueryEndSession(var Message: TWMQUERYENDSESSION); begin WindowsClosing := True; end; procedure TForm1.FormCloseQuery(Sender: TObject;

1098

var CanClose: Boolean); begin CanClose := WindowsClosing; end; end. As you can see, I've created a public variable called WindowsClosing. When WM_QUERYENDSESSION fires, it sets the variable to True. Then in OnCloseQuery, CanClose is set to the value of WindowsClosing. Notice that I set WindowsClosing to False in OnCreate. This is purely for initialization purposes to make sure that previous attempts to close the window are foiled. Some Useful Date Calculation Routines Ever notice how some date routines are missing from SysUtils? Well as they say, necessity is the mother of invention, I've come up with some date calculation routines that you can include in your own programs that require some date calculations. If you've got any more than this, please feel free to share them! type TDatePart = (dpYear, dpMonth, dpDay); {Purpose : Return a date part.} function GetDatePart(Date : TDateTime; DatePart : TDatePart) : Word; var D, M, Y : Word; begin //Initialize Result - avoids compiler warning Result := 0; DecodeDate(Date, Y, M, D); case DatePart of dpYear : Result := Y; dpMonth : Result := M; dpDay : Result := D; end; end; {Purpose

: Extracts the date portion of a date time. Useful for seeing if two date time values fall on the same day} function ExtractDatePart(Date : TDateTime) : TDate; begin Result := Int(Date); end; {Purpose

: Gets the time portion of a date time. Like ExtractDatePart this is useful for comparing times.} function ExtractTimePart(Date : TDateTime) : TTime; begin Result := Frac(Date); end; {Purpose : Used for determining whether or not a DateTime is a weekday.} function IsWeekday(Day : TDateTime) : Boolean; begin Result := (DayOfWeek(Day) >= 2) AND (DayOfWeek(Day) <= 6); end; {Purpose

:

Function returns the date of the relative day of a month/year combo such as the date of the "Third Monday of January." The formal parameters depart a bit from the MS SQL Server Schedule agent constants in that the RelativeFactor parameter (Freq_Relative_Interval in MS-SQL), takes integer values from 1 to 5 as opposed to integer values from 2 to the 0th to 2 to the 4th power.

Formal Parameters ========================================================================== ============= Year : Year in question Month : Month in question

1099

RelativeFactor Day

: 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last : 1 - 7, day starting on Sunday; 8 = Day; 9 = Weekday; 10 = Weekend Day

} function GetRelativeDate(Year, Month, RelativeFactor, Day : Integer) : TDateTime; var TempDate : TDateTime; DayIndex : Integer; begin TempDate := EncodeDate(Year, Month, 1); DayIndex := 0; //Now, if you're looking for the last day, just go to the last //day of the month, and count backwards until you hit the day //you're interested in. if (RelativeFactor = 5) then begin TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]); case Day of 1..7 : if (DayOfWeek(TempDate) = Day) then Result := TempDate else begin while (DayOfWeek(TempDate) <> Day) do TempDate := TempDate - 1; Result := TempDate; end; 9 : begin if IsWeekday(TempDate) then Result := TempDate else begin while NOT IsWeekday(TempDate) do TempDate := TempDate - 1; Result := TempDate; end; end; 10 : begin if NOT IsWeekday(TempDate) then Result := TempDate else begin while IsWeekday(TempDate) do TempDate := TempDate - 1; Result := TempDate; end; end; else //This only happens if you're going after the very last day of the month Result := TempDate; end; end else //Otherwise, you have to go through the month day by day until you get //to the day you want. Since the relative week is a power of 2, just //see if the day exponent is a case Day of 1..7 : begin while (DayIndex < RelativeFactor) do begin

1100

if (DayOfWeek(TempDate) = Day) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; 9 : begin while (DayIndex < RelativeFactor) do begin if IsWeekDay(TempDate) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; 10 : begin while (DayIndex < RelativeFactor) do begin if NOT IsWeekDay(TempDate) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; else Result := TempDate + RelativeFactor; end; end; type TDecimalTimeType = (dtSecond, dtMinute, dtHour); {Purpose : Returns hours, minutes, or seconds in decimal format for use in date time calculations} function GetDecimalTime(Count : Integer; DecimalTimeType : TDecimalTimeType) : Double; const Second = 1/86400; Minute = 1/1440; Hour = 1/24; begin //Initialize result Result := 0; case DecimalTimeType of dtSecond : Result := Count * Second; dtMinute : Result := Count * Minute; dtHour : Result := Count * Hour; end; end; {Purpose : Converts a MS-style integer time to a TTime} function IntTimeToTime(Time : Integer) : TTime; var S : String; begin S := IntToStr(Time); //String must be 5 or 6 character long if (Length(S) < 5) OR (Length(S) > 6) then Result := 0 else begin if (Length(S) = 5) then //A morning time S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2) else //Afternoon, evening time S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2);

1101

Result := StrToTime(S); end; end; Finding a Substring in a TStrings The IndexOf function in TStrings is great because it lets you quickly get the index of Item that holds the string in question. Unfortunately, it doesn't work for sub-strings. In that case, I've put together a neat little function called IndexOfSubString where you pass in the TStrings descendant you want to search on and a search value, and it'll return the index. Check it out: {Purpose : Binary search algorithm for a TStrings object. Finds the first occurence of any substring within a TStrings object or descendant} function IndexOfSubString(List : TStrings; SubString : String) : Integer; var I, LowIdx, HighIdx : Integer; Found : boolean; begin Found := false; Result := -1; {This type of search uses the first half of the TStrings list, so initialize the LowIdx and HighIdx to the first and approximate half of the list, respectively.} LowIdx := 0; HighIdx := List.Count div 2; {Note that Found and the LowIdx are used as conditionals. It's obvious why Found is used, but less apparent why LowIdx is used instead of HighIdx. The reason for this is that the way I've set it up here, HighIdx will never exceed (List.Count - 2), whereas LowIdx can equal (List.Count - 1) by nature of the assignment if Found remains false after the for loop.} while not Found and (LowIdx < (List.Count - 1)) do begin for I := LowIdx to HighIdx do if (Pos(SubString, List[I]) > 0) and not Found then begin Found := true; Result := I; end; if not Found then begin LowIdx := HighIdx + 1; HighIdx := HighIdx + ((List.Count - HighIdx) div 2); end; end; end; Accessing OnUpClick and OnDownClick of TSpinEdit This one comes from our Forum SysOp, Chris Bray! I have just answered a question for another Forum which I had to research quite carefully, and as it relates to compound components (wrapper components if you prefer) I thought the answer might be relevant to the Tips section. The questioner wanted to access the OnUpClick and OnDownClick events of the SpinButton which is part of the SpinEdit component from the samples page of the pallette.

1102

My answer was as follows: You have two choices: either create your own component surfacing the OnUpClick or OnDownClick properties, or call the OnUpClick property of the updown button on the SpinEdit. Assuming you will not want to create your own component, sample code to access the button from a form follows: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Spin; type TForm1 = class(TForm) SpinEdit1: TSpinEdit; procedure FormCreate(Sender: TObject); public procedure OnButtonUpClick(Sender: TObject); end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin SpinEdit1.Button.OnUpClick := OnButtonUpClick; end; procedure TForm1.OnButtonUpClick(Sender: TObject); begin MessageDlg('Up Button was clicked.', mtInformation, [mbOk], 0); end; end. To expand the example, simply add additional procedures for the DownClick and any other properties you wish to surface at runtime. Note that the source code for the spin edit is provided in the Pro and Client Server versions of Delphi, and should be located in the Source folder in a file called Spin.pas. A Note from Brendan: You might be wondering about what Chris did here and why does it work? Put simply, all events are method pointers, or more fundamentally, procedural types. A procedural type is Delphi type that is defined as a function or procedure that can be assigned to variables or passed to other procedures or functions as arguments. For example, the following is an example of procedural type: type TExtendedFunction = function(A, B : Extended) : Extended; With that in mind, we can define a variable to be of type TExtendedFunction, then assign a function to it to "assign" it a value: function MyExtendedFunction(A, B : Extended) : Extended; var F : TExtendedFunction; begin F := MyExtendedFunction; ... //Now "use" F

1103

F(23.100, 4.00234); Method pointers, like events, differ from procedural pointers only with respect to how they're declared. If TExtendedFunction were a method pointer, the declaration would be followed by of object to indicate that the function belongs to an instance of an object. Okay, now what does that have to do with the current discussion? Actually, everything. Since events are essentially variables, we have the freedom in Delphi to re-assign their "values" to something else. What Chris did above was to simple re-assign the OnUpClick of the TSpinEdit to his own "variable definition." In Windows parlance, this is called subclassing. Pretty slick, and it's a good demonstration of the power and flexibility of Delphi. Be forewarned though, that you shouldn't do this unless you absolutely have to. Most events are surfaced in the Object Inspector at design time (they're published properties), and you can define most of your events there. It's only when events aren't surfaced, or you want to affect different behavior at runtime does this methodology become valid. So use with care! Re-sizing a JPEG file JPEG files can be handled easily in Delphi by adding the JPEG unit to the uses clause and then using its methods to manipulate a JPEG image. However a TJPEGImage does not have a Canvas, so you cannot draw on it, and it does not provide any access to the internal bitmap it uses so you cannot manipulate that. So how can you change the size of a JPEG graphic? The following simple code provides the answer by creating a new JPEG file exactly half the size of the original: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtDlgs; type TForm1 = class(TForm) Button1: TButton; OpenPictureDialog1: TOpenPictureDialog; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses JPEG; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var Jpeg1, Jpeg2: TJPEGImage; TempBitmap: TBitmap; CanvasRect: TRect; begin if OpenPictureDialog1.Execute then begin // Create a Bitmap and two JPEG's TempBitmap := TBitmap.Create; Jpeg1 := TJPEGImage.Create; Jpeg2 := TJPEGImage.Create; try // Load the picture to shrink into the first Jpeg Jpeg1.LoadFromFile(OpenPictureDialog1.FileName);

1104

// Set the bitmap width to the new size TempBitmap.Width := JPeg1.Width div 2; TempBitmap.Height := JPeg1.Height div 2; // Create a TRect with the canvas co-ordinates CanvasRect := Rect(0, 0, TempBitmap.Width, TempBitmap.Height); // Draw the JPEG on the Canvas MyBitMap.Canvas.StretchDraw(CanvasRect, JPeg1); // Assign the bitmap to the second Jpeg Jpeg2.Assign(TempBitmap); // Save the second Jpeg in a renamed file Jpeg2.SaveToFile(ExtractFilePath(OpenPictureDialog1.FileName)+ 'Small '+ExtractFileName(OpenPictureDialog1.FileName)); finally // Tidy up the stuff you created before leaving TempBitmap.Free; Jpeg1.Free; Jpeg2.Free; end; end; end; end. Although we do not have access to the inner bitmap of the JPEG object, we can use standard TGraphic methods with it. Basically all we are doing is drawing the image at the new size and then assigning the resulting bitmap to a new JPEG object. If you want to make the new file a different size simply change the size of the intermediate TBitmap. However, bear in mind that you should always use the same percentage of both height and width of the original in order to maintain the aspect ratio. Chris Bray.

1105

Get HDD Serial

var SerialNum : DWord; a, b : dword; Buffer : array [0..255] of char; Num:string; begin GetVolumeInformation('c:\', nil,0,@SerialNum, a, b, nil, 0); Num:=IntToHex(HiWord(SerialNum),4)+'--'+ IntToHex(LoWord(SerialNum),4); Edit1.Text := (Num); end;

1106

Get File From the Net Create a Delphi application that downloads files from the Internet; add an auto-update feature to your programs. If your program relies on Packages or DLLs than deploying new versions of your libraries certainly takes some time. The Internet now provides a fairly easy way to accomplish this task. Adding an auto-update option to your applications could be the best way to keep your Delphi applications up to date. Let's see how to create the most important peace of code in any FTP application. Delphi gives us full access to the WinInet API (wininet.pas) which we can use to connect to and retrieve files from any Web site that uses either Hypertext Transfer Protocol (HTTP) or File Transfer Protocol (FTP). For example, we could use the functions inside the WinInet API to: add an FTP browser to any application, create an application that automatically downloads files from a public FTP site or search the Internet site for references to graphics and download only the graphics. GetInetFile function uses Wininet; function GetInetFile (const fileURL, FileName: String): boolean; const BufferSize = 1024; var hSession, hURL: HInternet; Buffer: array[1..BufferSize] of Byte; BufferLen: DWORD; f: File; sAppName: string; begin Result:=False; sAppName := ExtractFileName(Application.ExeName); hSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); try hURL := InternetOpenURL(hSession, PChar(fileURL), nil,0,0,0); try AssignFile(f, FileName); Rewrite(f,1); repeat InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen); BlockWrite(f, Buffer, BufferLen) until BufferLen = 0; CloseFile(f); Result:=True; finally InternetCloseHandle(hURL) end finally InternetCloseHandle(hSession) end end;

Note: In order to provide some visual feedback to the user you could add a line like FlashWindow(Application.Handle,True) in the body of the repeat/until block. The FlashWindow API call flashes the caption of your applications name in the task bar.

1107

Usage To call the GetInetFile function you could use the next peace of code:

var FileOnNet, LocalFileName: string begin FileOnNet:= 'http://delphi.about.com/library/forminbpl.zip'; LocalFileName:='File Downloaded From the Net.zip' if GetInetFile(FileOnNet,LocalFileName)=True then ShowMessage('Download successful') else ShowMessage('Error in file download') end;

This code will get the 'forminbpl.zip' file from this site, download it, and save it as 'File Downloaded From the Net.zip'. Note: Depending on vhich version of Delphi you have, several components can be found on the Internet page of the VCL palette that are designed to ease the task of Internet enabling your applications. For an example of a FTP component look for TNMFTP in the FastNet VCL page.

1108

Integrating Winzip to your Applications by Fernando Vicaria - [email protected] It's a fact for all of us Delphi developers that from time to time we will find ourselves in a position where we have to decide whether to buy a particular component or to roll our sleeves up and design it ourselves. Especially when that component adds that desired extra feature to our application. The reasons to take one approach or the other may vary from time constraints to pure cost. I will not go into this path, at least not today. Most of the time we can find a freeware component that does exactly what we want. Unfortunately it's also common that those components will not come with source or will be, hmm… let's say… less than perfect. Well, if you are like me you will never add anything to your application that doesn't come with source code or that hasn't been fully tested. Compress/decompress components If one of those extra features that you're looking for is the capability to compress or decompress files using the industry standard format (*.ZIP) then you're lucky… Winzip 7.0 has recently launched it's own command line support. This incredibly useful add-on is available for download from Nico Mak Computing Inc. website at: www.winzip.com Setting the stage As with every new piece of software we have to first learn how to setup and use it properly… First of all we need to install Winzip 7.0, if you already have any other version of Winzip, upgrades can be downloaded for free from the same address mentioned above. The next step is to download and install the command line add-on. One last think… once you have both applications installed, make sure it has been added to your path. Ok, I think by know most of you have that grin on your faces and are thinking… "If I could build a component to call the command line program and pass the right instructions to execute Winzip, that would reduce the problem of compressing and decompressing files in my application to a simple act of dropping a component in a form". You're absolutely right. This is a typical example of what OOP and more specifically Delphi is all about. Let's have a look at one of the many possible ways to implement such a component: TZipState = (zsCompress, zsDecompress); This type will let us switch between the two possible actions of our component. Now we have to declare the component's class itself: TFVWinZip = class(TComponent) private { Private declarations } FFileName: string; FUseFileList: boolean; FFileList: TStringList; FZipFileName: string; FZipState: TZipState; FOnExecute: TNotifyEvent; function GetFileList: TStringList; procedure SetFileList(value: TStringList); procedure CreateCompressBat; published { Published declarations } property FileName: string read FFileName write FFileName; property UseFileList: boolean read FUseFileList write FUseFileList default False; property FileList: TStringList read GetFileList write SetFileList; property ZipState: TZipState read FZipState write FZipState; property ZipFileName: string read FZipFileName write FZipFileName; property OnExecute: TNotifyEvent read FOnExecute write FOnExecute; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute; end; Most of its properties and methods should be self-explanatory. You can find the full implementation in the file FVWinZip.pas and modify it according to your own needs. If you look at the beginning of the implementation section of the code you will see the following: {$R FVWinZip.res}

1109

const BatchFile = 'tfvzip.bat'; Zip = 'wzzip'; UnZip = 'wzunzip'; ListName = 'zipit.lst'; The first line should be very familiar for those used to creating their own components. It specifies the resource file that contains the icon for our component. You can create and design your own icons using any resource editor (in Delphi the default is Imagedit.exe and it can be found in the bin directory). The constants declared here will help us deal with the various files used in the process of creating or extracting our zip files. BatchFile is the name of the batch file that will be created by our component. This file will have the responsibility of calling one of the zip files (Zip for compress or Unzip for decompressing). The last one is ListName, this is the name of a text file that contains a list of the files to be added to the Zip file as well as commands for the command line program (much like you would do in a batch file and DOS). ListName is only used when the property UseFileList of our Zip component is set to true and a valid list of files is entered in the FileList property. As I mentioned earlier this is only one of the possible implementations for this component and there's definitely room for improvement to what you can do. Have a look at the online help file that comes with the Winzip Command Line Support Add-on for more information. An example showing how to use most of the features explained here has been included in the source code. Before we go for our first test drive of our component I'd like to quickly go through two of the methods declared for the TFVWinZip object. The first one is the procedure CreateCompressBat. In this procedure we create a batch file based on the user's requirement, it specifies the action to take (compress/decompress), the name of the file to compress, the name of the zip file and if we are using a list file or not. procedure TFVWinZip.CreateCompressBat; var F: TextFile; Command: string; begin try if FZipState=zsCompress then Command:= Zip else Command:= UnZip; { Create compress batch file } AssignFile(F, BatchFile); Rewrite(F); Writeln(F, '@ECHO OFF'); Writeln(F, 'REM *** TFVWinZip for Delphi 4 by F Vicaria ***'); if UseFileList then Writeln(F, Command+' "'+ZipFileName+'" "'+' @zipit.lst'+'"') else Writeln(F, Command+' "'+ZipFileName+'" "'+FileName+'"'); Writeln(F, 'cd\'); Writeln(F, 'cls'); finally CloseFile(F); end; end; The second one is the heart of our component. The Execute method will initiate a separate process that will run the batch file which, will in its turn, call Winzip's command line. This will avoid any sort of dependency on the speed of the machine running the program. To do this I use 2 API functions, CreateProcess and WaitForSingleObject (check the Windows API Help file for more details on how to use these functions). Clean after yourself After executing the batch file and consequently Winzip the Execute method will get rid of all the internally created files for you. Once the method returns all you are left with is the zip file you created or the files you extracted. Finally Using our object couldn't be easier: Just call the Execute method after having created it and set some of its properties with the appropriated values (see example app). In the simplest case of compressing a single file this means setting only two properties: ZipFileName and FileName before calling Execute. Caveat A couple of warnings before I finish…

1110

You will need to make sure that the two files that come with the Winzip Command Line Add-on (WZZIP.EXE and WZUNZIP.EXE) are in your path or you will need to move them to your system directory. The other thing to remember is that these files are free only for those who have bought Winzip. In my opinion this can barely be considered a drawback nowadays, Winzip has become the industry standard archive utility for Windows environment and it's very difficult to find anyone who does not use it. If you have any questions or comments please let me know. I can be reached at [email protected] or visit mail webpage at http://www.venon.com.

1111

Creating a Class to Access RAR Archives Peter Davies - GUI Computing The Task: Create a class to access the list of files contained in a RAR (similar to a ZIP) archive in Delphi 2.0. Keep it generic enough so that other compression types can be added in the future. The Solution: An approach, used back in the days of Borland Pascal Turbo Vision to tackle a similar task, was to use the class TCollection to store a list of file objects. Unfortunately, TCollection in Delphi has taken on a whole new look and does not really suit the requirements. Instead, the class TList in Delphi is better suited. It basically stores a list of objects of any type. The beauty of TList, over the use of the conventional array, is that it dynamically grows with the addition of new objects to the list - whereas an array must be set to a finite size before a maximum size might be actually known. TList also takes care of many of the tasks of maintaining a sequential list, such as removing items in the middle of the list, adding items in the middle of a list and so on. Certain details need to be stored about each file in the RAR archive. To do this we will create a small class that stores the details and knows how to create and destroy itself. The class will be of the following structure: TFileDetails = class Filename : PChar; CompressedSize : Longint; OriginalSize : Longint; FileDate : Longint; constructor Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); destructor Destroy; override; end; On creating an instance of TFileDetails, the information about the file (passed as parameters), is stored in the object. Many of these objects create all the information we need to know about the RAR archive. A class is required to handle the creating of each instance of TFileDetails Class. This is accomplished by the TArchive Class. This class consists of the following structure: TArchive = class private FileName : PChar; FileList : TList; ArchiveOK : boolean; ArchiveType : Longint; TotOrigSize, TotCompSize, FileDate : Longint; public constructor Create(AFileName : String); destructor Destroy; override; function GetArchiveOk : boolean; function GetTotalFiles : Integer; function GetAFileName(Index : Integer) : String; end; This class requires the filename of the RAR archive as input. An example of using this class might be: var Archive : TArchive; Counter : Integer; begin Archive := TArchive.Create('C:\TEST.RAR'); if Archive.GetArchiveOk then begin For Counter := 1 to Archive.GetTotalFiles do begin ... do something do something with the filename ... := Archive.GetAFileName(Counter) ... do something end; end; Archive.Free; end; Some tips used in the creation of the source, which may help other Delphi developers, are:

1112

203. When adding an object to the list of objects (Tlist), it is not necessary to actually create the object before adding. It can be dynamically created while adding it. Simply use the class name, then the create constructor, and the parameters required. Eg: FileList.Add(TFileDetails.Create(FName,FBlock.OrigSize,FBlock.PackSize,FBlock.FTime)); 204. When obtaining information about a particular object, in the list of objects (Tlist), it is not necessary to actually assign the object being read to an object. You can simply tell Delphi the type of object it is (type cast) and then tell it the variable/etc you wish to get the information from. Eg: sResult := StrPas(TFileDetails(FileList.Items[Index-1] ).FileName);

samp_ archive Here is the relevant code. In future AVDF articles, this class will be expanded upon, creating .html many ways of accessing the data in an instance of the class. This class provides the basis for a samp_ general purpose way of accessing RAR archives. archive .html

1113

Creating a Class to Access RAR Archives The code behind this class looks like this... {$A-} unit Archive; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; const (* List of Archive Types *) atNoArchive = 0; atZIPArchive = 1; atLZHArchive = 2; atARJArchive = 3; atPAKArchive = 4; atARCArchive = 5; atZOOArchive = 6; atSQZArchive = 7; atRARArchive = 8; type TFileDetails = class FileName : PChar; CompressedSize : Longint; OriginalSize : Longint; FileDate : Longint; constructor Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); destructor Destroy; override; end; TArchive = class private FileName FileList ArchiveType TotOrigSize, TotCompSize, FileDate ArchiveOk public constructor destructor function function function function function function procedure word); function function end;

: PChar; : TList; : Longint; : Longint; : boolean; Create(AFileName : String); Destroy; override; GetTotalFiles : Integer; GetAFileName(Index : Integer) : String; GetArchiveOk : Boolean; GetArchiveType : Longint; GetTotalOriginalSize : Longint; GetTotalCompressedSize : Longint; GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec : GetDateTime : TDateTime; GetFileName : String;

implementation function GetArchiveType(FName : string) : Longint; // From the file, determine the type of archive that we are looking // at. ie zip, arj, rar, etc

1114

var hArchive : file; OldFileMode : word; ReadBuf : array[1..8] of byte; begin OldFileMode := FileMode; AssignFile(hArchive,FName); FileMode := fmOpenRead + fmShareDenyNone; // Read Only {$I-} reset(hArchive,1); GetArchiveType := atNoArchive; if (ioresult = 0) then begin if (filesize(hArchive) >= 8) then begin blockread(hArchive,ReadBuf,sizeof(ReadBuf)); if (ReadBuf[1] = $50) and (ReadBuf[2] = $4B) and (ReadBuf[3] = $03) and (ReadBuf[4] = $04) then GetArchiveType := atZIPArchive else if (ReadBuf[1] = $60) and (ReadBuf[2] = $EA) then GetArchiveType := atARJArchive else if (ReadBuf[3] = ord('-')) and (ReadBuf[4] = ord('l')) and (ReadBuf[5] = ord('h')) and (ReadBuf[7] = ord('-')) then GetArchiveType := atLZHArchive else if (ReadBuf[1] = ord('Z')) and (ReadBuf[2] = ord('O')) and (ReadBuf[3] = ord('O')) then GetArchiveType := atZOOArchive else if (ReadBuf[1] = 72) and (ReadBuf[2] = 76) and (ReadBuf[3] = 83) and (ReadBuf[4] = 81) and (ReadBuf[5] = 90) then GetArchiveType := atSQZArchive else if (ReadBuf[1] = ord('R')) and (ReadBuf[2] = ord('a')) and (ReadBuf[3] = ord('r')) and (ReadBuf[4] = ord('!')) then GetArchiveType := atRARArchive else if (ReadBuf[1] = $1A) then begin if (pos('.ARC',FName) > 0) then GetArchiveType := atARCArchive else GetArchiveType := atPAKArchive; end; end; close(hArchive); end; {$I+} OldFileMode := FileMode; end; constructor TFileDetails.Create(AFileName : String;ACompressedSize : Longint; AOriginalSize : Longint;AFileDate : Longint); begin CompressedSize := ACompressedSize; OriginalSize := AOriginalSize; FileDate := AFileDate; FileName := StrAlloc(length(AFileName)+1);

1115

StrPCopy(FileName,AFileName); end; destructor TFileDetails.Destroy; begin StrDispose(FileName); inherited Destroy; end; constructor TArchive.Create(AFileName : String); procedure ReadRar; type RarBlock = record HeadCRC : Word; HeadType : Byte; HeadFlags : Word; HeadSize : Word; end; FileBlock = record PackSize : Longint; OrigSize : Longint; HostOS : Byte; FileCRC : Longint; FTime : Longint; UnpVer : Byte; Method : Byte; NameSize : Word; Attr : Longint; end; const MaxName = 250; var HdrBlock : RarBlock; NumRead : Integer; FBlock : FileBlock; FName : String[MaxName]; CName : Array[0..MaxName+1] of Char; hArchive : file; OldFileMode : Byte; procedure JumpAddSize(ShouldRead : Integer); var

ExtLen : Longint;

begin if ArchiveOK then begin seek(hArchive,filepos(hArchive) + ShouldRead); if (HdrBlock.HeadFlags shr 15 > 0) then begin blockread(hArchive,ExtLen,4,NumRead); if (NumRead <> 4) then ArchiveOK := False else begin seek(hArchive,FilePos(hArchive) + Longint(HdrBlock.HeadSize + ExtLen - SizeOf(RarBlock) - 4)); end; end; end; end;

1116

begin OldFileMode := FileMode; AssignFile(hArchive,AFileName); FileMode := fmOpenRead + fmShareDenyNone; // Read Only {$I-} reset(hArchive,1); ArchiveOK := (IOResult = 0); {$I+} if (ArchiveOk) then begin // Get the datetime of the current file FileDate := FileGetDate(TFileRec(hArchive).Handle); while (not eof(hArchive)) and ArchiveOK do begin blockread(hArchive,HdrBlock,sizeof(HdrBlock),NumRead); if (NumRead <> sizeof(HdrBlock)) then ArchiveOK := False; if (HdrBlock.HeadType = $74) and (ArchiveOK) then begin blockread(hArchive,FBlock,sizeof(FBlock),NumRead); if (NumRead <> sizeof(FBlock)) then ArchiveOK := False; if (FBlock.NameSize <= MaxName) and ArchiveOK then begin blockread(hArchive,FName[1],FBlock.NameSize,NumRead); if (NumRead <> FBlock.NameSize) then ArchiveOK := false else begin // make a normal pascal style string (length first) FName[0] := chr(FBlock.NameSize); StrPCopy(CName,FName); // Adds the individual file details to the list of files FileList.Add(TFileDetails.Create(FName,FBlock.OrigSize,FBlock.PackSize,FBlock.FT ime)); TotOrigSize := TotOrigSize + FBlock.OrigSize; TotCompSize := TotCompSize + FBlock.PackSize; end; end else seek(hArchive,filepos(hArchive) + FBlock.NameSize); seek(hArchive,filepos(hArchive) + Longint(HdrBlock.HeadSizesizeof(HdrBlock)-sizeof(FBlock)-FBlock.NameSize)); if (HdrBlock.HeadFlags shr 15 > 0) then seek(hArchive,filepos(hArchive) + FBlock.PackSize); end else JumpAddSize(HdrBlock.HeadSize-NumRead); end; close(hArchive); end; FileMode := OldFileMode; end; begin ArchiveOK := True; FileList := TList.Create; FileName := StrAlloc(length(AFileName)+5); StrPCopy(FileName,AFileName); // to call a function outside of the current object, that has a method of // the same name, we simply place the units name in front of the function // eg: Archive.GetArchiveType(AFileName) ArchiveType := Archive.GetArchiveType(AFileName); TotOrigSize := 0; TotCompSize := 0; FileDate := 0; case ArchiveType of atRARArchive : ReadRAR; else ArchiveOK := False;

1117

end; end; destructor TArchive.Destroy; var nCount : Integer; begin // Free up the objects for nCount := 0 to FileList.Count-1 do begin TFileDetails(FileList.Items[nCount]).Free end; FileList.Free; StrDispose(FileName); inherited Destroy; end; function TArchive.GetTotalFiles : Integer; begin GetTotalFiles := FileList.Count; end; function TArchive.GetArchiveOk : Boolean; begin GetArchiveOk := ArchiveOk; end; function TArchive.GetArchiveType : Longint; begin GetArchiveType := ArchiveType; end; function TArchive.GetTotalOriginalSize : Longint; begin GetTotalOriginalSize := TotOrigSize; end; function TArchive.GetTotalCompressedSize : Longint; begin GetTotalCompressedSize := TotCompSize; end; function TArchive.GetFileName : String; begin GetFileName := StrPas(FileName); end; procedure TArchive.GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec : word); var DateTime : TDateTime; begin DateTime := FileDateToDateTime(FileDate); DecodeTime(DateTime,Hour,Min,Sec,MSec); DecodeDate(DateTIme,Year,Month,Day); end;

1118

function TArchive.GetDateTime : TDateTime; begin GetDateTime := FileDateToDateTime(FileDate); end; function TArchive.GetAFileName(Index : Integer) : String; var

sResult : String; FileDetails : TFileDetails;

begin IF ((Index > 0) and (Index <= FileList.Count)) then begin sResult := StrPas(TFileDetails(FileList.Items[Index-1]).FileName); end else sResult := ''; GetAFileName := sResult; end; end.

1119

A Hint Window That Follows The Mouse By John KNIPPER - [email protected] - http://members.xoom.com/knipjo/ How to show a hint that follows the mouse and that hides properly... This seems to be the problem of the month. I can see that I'm not the only one who had that problem. What follows here is more an extension to Michael Burton and Mike Tumy's article (Real Time Mouse Coordinates Display) because Mott Adler (Using OnHint for Real-Time Mouse Coordinates) provides a nice work around that has the strength of simplicity. Those two solutions share the same problem : when you have other controls on the form the hint is behaving strangely. Either it is waiting for the cursor to leave the component or it is immediately showing the component hint. The problem is not here, I think that you noticed the fact and that it was not the point in your article. Ok, we can show a hint that follows the mouse. But we have two problems. The first and most important is to hide the hint when the cursor is leaving the form. The second is to hide the hint when the cursor is over a component and act normal again. I don't know if we can handle the first problem with windows 95 or NT 3.5 or less. But windows 98 and NT 4 or greater bring to us a new function called TrackMouseEvent. This is the only way I can see for us to know each time that the cursor left the form. This is how to use it : evtTrack: tagTRACKMOUSEEVENT; with evtTrack do begin cbSize := sizeOf(tagTRACKMOUSEEVENT); dwFlags := TME_LEAVE; hwndTrack := form1.Handle; dwHoverTime := HOVER_DEFAULT; end; if not isTracking then begin if not TrackMouseEvent(evtTrack) then MessageDlg('Sorry, I' + #39 + 'm not in the mood of tracking' + #13 + #10 + 'your stupid events.', mtError, [mbOK], 0); isTracking := True; end; The TME_LEAVE flag asks windows to post us WM_MOUSELEAVE message. We keep track with the isTracking := True that we have already asked windows. I don't know if it matters. So next time the cursor leaves the form we get the message. We handle it with the following proc : private { Private declarations } procedure MouseLeavesTheForm(var m: TMessage); message WM_MOUSELEAVE; procedure TForm1.MouseLeavesTheForm(var m: TMessage); begin inherited; hwHint.ReleaseHandle; //we release the hint here isTracking := False; m.Result := 1; end; Sorry, but I don't know if I have to call inherited and if I shall tell with m.Result := 1 that I handled the message. Here we are. The first problem is solved. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var pt: TPoint; sText: string; begin if not isTracking then begin if not TrackMouseEvent(evtTrack) then MessageDlg('Sorry, I' + #39 + 'm not in the mood of tracking' + #13 + #10 + 'your stupid events.', mtError, [mbOK], 0); isTracking := True; end; getCursorPos(pt); sText := Format('%d,%d', [pt.x, pt.y]);

1120

hwHint.ActivateHint(Rect(pt.x + 10, pt.y + 10, pt.x + hwHint.Canvas.TextWidth(sText) + 19, pt.y + hwHint.Canvas.TextHeight(sText) + 10), sText); UpdateTracking; end; You may have noticed the UpdateTracking procedure ? This is something I snipped from the method used is speedbuttons to look if the cursor is over the speedbutton. This will help us to release the hint whenever the mouse is not over the nude background but still inside of the form. //check if the cursor is no longer over the background //e.g.. he is over a button or something procedure TForm1.UpdateTracking; var P: TPoint; begin GetCursorPos(P); if not (FindDragTarget(P, True) = Self) then Perform(WM_MOUSELEAVE, 0, 0); end; When the cursor leaves the background we post us a WM_MOUSELEAVE message, the speedbutton is using a CM_MOUSELEAVE. That way the hint is working properly over the other controls. Unfortunately the MSDN help file says : not for windows 95. This is sad because many of you are still using it I suppose. The work around is to use a TTimer, but this is not very clean. Another solution would be to use the SetCapture function to capture mouse events even when the mouse is not over the form. Click here for the source code for a demo illustrating this technique.

1121

Plain Vanilla Threads How can I implement threads in my programs without using the VCL TThread object? I've done extensive work in multi-threaded applications. And in my experience, there have been times when a particular program I'm writing should be written as a multi-threaded application, but using the TThread object just seems like overkill. For instance, I write a lot of single function programs; that is, the entire functionality (beside the user interface portion) of the program is contained in one single execution procedure or function. Usually, this procedure contains a looping mechanism (e.g. FOR, WHILE, REPEAT) that operates on a table or an incredibly large text file (for me, that's on the order of 500MB-plus!). Since it's just a single procedure, using a TThread is just too much work for my preferences. For those experienced Delphi programmers, you know what happens to the user interface when you run a procedure with a loop in it: The application stops receiving messages. The most simple way of dealing with this situation is to make a call to Application.ProcessMessages within the body of the loop so that the application can still receive messages from external sources. And in many, if not most, cases, this is a perfectly valid thing to do. However, if some or perhaps even one of the steps within the loop take more than a couple of seconds to complete processing — as in the case of a query — Application.ProcessMessages is practically useless because the application will only receive messages at the time the call is made. So what you ultimately achieve is intermittent response at best. Using a thread, on the other hand, frees up the interface because the process is running completely separate from the main thread of the program where the interface resides. So regardless of what you execute within a loop that is running in a separate thread, your interface will never get locked up. Don't confuse the discussion above with multi-threaded user interfaces. What I'm talking about is executing long background threads that won't lock up your user interface while they run. This is an important distinction to make because it's not really recommended to write multi-user interfaces, because each thread that is created in the system has its own message queue. Thus, a message loop must be created to fetch messages out of the queue so they can be dispatched appropriately. The TApplication object that controls the UI would be the natural place to set up message loops for background threads, but it's not set up to detect when other threads are executed. The gist of all this is that the sole reason you create threads is to distribute processing of independent tasks. Since the UI and controls are fairly integrated, threads just don't make sense here because in order to make the separate threads work together, you have to synchronize them to work in tandem, which practically defeats threading altogether! I mentioned above that the TThread object is overkill for really simple threaded stuff. This is strictly an opinion, but experience has made me lean that way. In any case, what is the alternative to TThread in Delphi? The solution isn't so much an alternative as it is going a bit more low-level into the Windows API. I've said this several times before: The VCL is essentially one giant wrapper around the Windows API and all its complexities. But fortunately for us, Delphi provides a very easy way to access lower-level functionality beyond the wrapper interface with which it comes. And even more fortunate for us, we can create threads using a simple Windows API function called CreateThread to bypass the TThread object altogether. As you'll see below, creating threads in this fashion is incredibly easy to do. Setting Yourself Up There are two distinct steps for creating a thread: 1)Create the thread itself, then 2) Provide a function that will act as the thread entry point. The thread function or thread entry point is the function (actually the address of the function) that tells your thread where to start. Unlike a regular function, there are some specific requirements regarding the thread function that you have to obey: 205. You can give the function any name you want, but it must be a function name (ie. function MyThreadFunc) 206. The function must have a single formal parameter of type Pointer (I'll discuss this below) 207. The function return type is always LongInt 208. Its declaration must always be preceded by the stdcall directive. This tells the compiler that the function will be passing parameters in the standard Windows convention. Whew! That seems like a lot but it's really not as complicated as it might seem from the description above. Here's an example declaration: function MyThreadFunc(Ptr : Pointer) : LongInt; stdcall; That's it! Hope I didn't get you worried. The CreateThread call is a bit more involved, but it too is not very complicated once you understand how to call it. Here's its declaration, straight out of the help file: function CreateThread (lpThreadAttributes: Pointer; //Address of thread security attributes dwStackSize: DWORD; //Thread stack size lpStartAddress: TFNThreadStartRoutine;//Address of the thread function lpParameter: Pointer; //Input parameter for the thread dwCreationFlags: DWORD; //Creation flags

1122

var lpThreadId: DWORD): //ThreadID reference THandle; stdcall; //Function returns a handle to the thread This is not as complicated as it seems. First of all, you rarely have to set security attributes, so that can be set to nil. Secondly, in most cases, your stack size can be 0 (actually, I've never found an instance where I have to set this to a value higher than zero). You can optionally pass a parameter through the lpParameter argument as a pointer to a structure or address of a variable, but I've usually opted to use global variables instead (I know, this breaking a cardinal rule of structured programming, but it sure eases things). Lastly, I've rarely had to set creation flags unless I want my thread to start in a suspended state so I can do some preprocessing. For the most part, I set this value as zero. Now that I've thoroughly confused you, let's look at an example function that creates a thread: procedure TForm1.Button1Click(Sender: TObject); var thr : THandle; thrID : DWORD; begin FldName := ListBox1.Items[ListBox1.ItemIndex]; thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID) ; if (thr = 0) then ShowMessage('Thread not created'); end; Embarrassingly simple, right? It is. To make the thread in the function above, I declared two variables, thr and thrID, which stand for the handle of the thread and its identifier, respectively. I set a global variable that the thread function will access immediately before the call to CreateThread, then make the declaration, assigning the return value of the function to thr and inputting the address of my thread function, and the thread ID variable. The rest of the parameters I set to nil or 0. Not much to it. Notice that the procedure that actually makes the call is an OnClick handler for a button on a form. You can pretty much create a thread anywhere in your code as long as you set up properly. Here's the entire unit code for my program; you can use it for a template. This program is actually fairly simple. It adds an incremental numeric key value to a table called RecID, based on the record number (which makes things really easy). Browse the code; we'll discuss it below: unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB, DBTables, StdCtrls, ComCtrls, Buttons; type TForm1 = class(TForm) Edit1: TEdit; Label1: TLabel; OpenDialog1: TOpenDialog; SpeedButton1: TSpeedButton; Label2: TLabel; StatusBar1: TStatusBar; Button1: TButton; ListBox1: TListBox; procedure SpeedButton1Click(Sender: TObject); procedure Button1Click(Sender: TObject); end; var Form1: TForm1; TblName : String; FldName : String; implementation {$R *.DFM} function CreateRecID(P : Pointer) : LongInt; stdcall; var

1123

tbl : TTable; I : Integer; ses : TSession; msg : String; begin Randomize; //Initialize random number generator I := 0; {Disable the Execute button so another thread can't be executed while this one is running} EnableWindow(Form1.Button1.Handle, False); {If you're going to access any data in a thread, you have to create a separate } ses := TSession.Create(Application); ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000)); tbl := TTable.Create(Application); with tbl do begin Active := False; SessionName := ses.SessionName; DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler Open; First; try {Start looping structure} while NOT EOF do begin if (State <> dsEdit) then Edit; msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount); {Display message in status bar} SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg))); FieldByName(FldName).AsInteger := RecNo; Next; end; finally Free; ses.Free; EnableWindow(Form1.Button1.Handle, True); end; end; msg := 'Operation Complete!'; SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg))); end; procedure TForm1.SpeedButton1Click(Sender: TObject); var tbl : TTable; I : Integer; begin with OpenDialog1 do if Execute then begin Edit1.Text := FileName; TblName := FileName; tbl := TTable.Create(Application); with tbl do begin Active := False; DatabaseName := ExtractFilePath(TblName); TableName := ExtractFileName(TblName); Open; LockWindowUpdate(Self.Handle); for I := 0 to FieldCount - 1 do begin ListBox1.Items.Add(Fields[I].FieldName); end;

1124

LockWindowUpdate(0); Free; end; end;

end;

procedure TForm1.Button1Click(Sender: TObject); var thr : THandle; thrID : DWORD; begin FldName := ListBox1.Items[ListBox1.ItemIndex]; thr := CreateThread(nil, 0, @CreateRecID, nil, 0, thrID); if (thr = 0) then ShowMessage('Thread not created'); end; end. The most important function here, obviously, is the thread function, CreateRecID. Let's take a look at it: function CreateRecID(P : Pointer) : LongInt; stdcall; var tbl : TTable; I : Integer; ses : TSession; msg : String; begin Randomize; //Initialize random number generator I := 0; {Disable the Execute button so another thread can't be executed while this one is running} EnableWindow(Form1.Button1.Handle, False); {If you're going to access any data in a thread, you have to create a separate } ses := TSession.Create(Application); ses.SessionName := 'MyRHSRecIDSession' + IntToStr(Random(1000)); tbl := TTable.Create(Application); with tbl do begin Active := False; SessionName := ses.SessionName; DatabaseName := ExtractFilePath(TblName); //TblName is a global variable set TableName := ExtractFileName(TblName); //in the SpeedButton's OnClick handler Open; First; try {Start looping structure} while NOT EOF do begin if (State <> dsEdit) then Edit; msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount); {Display message in status bar} SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg))); FieldByName(FldName).AsInteger := RecNo; Next; end; finally Free; ses.Free; EnableWindow(Form1.Button1.Handle, True); end; end; msg := 'Operation Complete!'; SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg)));

1125

end; This is a pretty basic function. I'll leave it up to you to follow the flow of execution. However, let's look at some very interesting things that are happening in the thread function. First of all, notice that I created a TSession object before I created the table I was going to access. This is to ensure that the program will behave itself with the BDE. This is required any time you access a table or other data source from within the context of a thread. I've explained this in more detail in another article called How Can I Run Queries in Threads? Directly above that, I made a call to the Windows API function EnableWindow to disable the button that executes the code. I had to do this because since the VCL is not thread-safe, there's no guarantee I'd be able to successfully access the button's Enabled property safely. So I had to disable it using the Windows API call that performs enabling and disabling of controls. Moving on, notice how I update the caption of a status bar that's on the bottom of the my form. First, I set the value of a text variable to the message I want displayed: msg := 'Record ' + IntToStr(RecNo) + ' of ' + IntToStr(RecordCount); Then I do a SendMessage, sending the WM_SETTEXT message to the status bar: SendMessage(Form1.StatusBar1.Handle, WM_SETTEXT, 0, LongInt(PChar(msg))); SendMessage will send a message directly to a control and bypass the window procedure of the form that owns it. Why did I go to all this trouble? For the very same reason that I used EnableWindow for the button that creates the thread. But unfortunately, unlike the single call to EnableWindow, there's no other way to set the text of a control other than sending it the WM_SETTEXT message. The point to all this sneaking behind the VCL is that for the most part, it's not safe to access VCL properties or procedures in threads. In fact, the objects that are particularly dangerous to access from threads are those descended from TComponent. These comprise a large part of the VCL, so in cases where you have to perform some interaction with them from a thread, you'll have to use a roundabout method. But as you can see from the code above, it's not all that difficult. Of the thousands of functions in the Windows API, CreateThread is one of the most simple and straightforward. I spent a lot of time explaining things here, but there's a lot of ground I didn't cover. Use this example as a template for your thread exploration. Once you get the hang of it, you'll use threads in practically everything you do.

1126

How can I run queries in threads? I have several programs that run large queries, and would like to move the query processing to one or more background threads. How can I implement this in my program? NOTE: It's tough to discuss this subject without providing some background information. Threaded programming is so new to many programmers, I'd be remiss in my duties as The Delphi Pro if I didn't cover the most fundamental subjects of threaded programming. If you already have a good idea of the fundamentals of creating and running threads with the TThread component, you can skip to the section that deals with running queries in threads. -- The Delphi Pro Process and Thread Basics Many programmers, especially those new to programming with multiple threads, believe threads are the sole domain of programming gurus. But it's all a matter of understanding some fundamental concepts about how threads work in Delphi and how you can apply threads in your code. If what you're programming has to do with the User Interface, you don't want to use multiple threads because threads require resources. In fact, every time you create a thread, it gets the same size stack as the main thread of a program (we'll discuss this below). If you have a lot of threads, you'll take up a lot of resources. So the idea is to be judicious in your use of threads. It may be tempting to create a bunch of threads to handle a bunch of different tasks because creating threads, as you will see, is fairly easy. But you don't want to create threads just for the sake of creating threads. In addition to taking up resources, every executing thread creates another time slice on the CPU, forcing it to handle more tasks. The net result is that the computer will slow way down. But there are some instances in which running background threads makes a lot of sense: It's ideal to create background threads when: · your program will execute a long process like a huge query or complex calculation that will take several seconds or minute to execute. In single-threaded programs in Win16 and Win32 alike, the interface becomes totally unresponsive if you execute a long process. Creating a separate thread of execution to run in the background frees up the user interface. · your program runs in a multi-processor system. Windows NT, for example, has the ability to work SMP systems. With multi-threaded programs, individual threads may be executed on different processors, which means you take full advantage of balancing processor load. · your program will need to execute a few processes at a time. One caveat: If you're running on a single CPU system and if the processes your program will be executing are pretty complex and will require lots of CPU cycles, it doesn't make sense to have several simultaneous threads running. However, I've found that with smaller operations that can execute in a few seconds, it's a pretty nice feature to have. In Windows 95 and NT (I'll refer to both systems as Win32 throughout this article), every program loaded into memory is called a process. Many people new to threads (including myself) make the mistake of believing that the definition of a process is interchangeable with that of a thread. It's not. Processes are their own entities. Though the name "processes" implies a form of activity, a process does nothing. It is merely a memory address placeholder for its threads and a space where executable code gets loaded. A process' thread is what actually does the work in a program. When a process is created in Win32, it automatically has an execution thread associated with it. This is called the main thread of the program. Other threads can be instantiated within a process, but you won't see many programs using multiple threads of execution. A thread can only be associated with one process, but a process can have many threads. Therefore, there is a distinct one-way, one-to-many relationship between processes and threads. The TThread Object Traditionally, processes (executing programs) are created in Win32 using the WinAPI CreateProcess and threads are created using CreateThread. In fact, many advanced Delphi and Windows programmers I've spoken with say that using the WinAPI call is their method of preference. With Delphi 2.0, the Delphi team created a wrapper class called TThread that encapsulates the WinAPI thread calls. TThread provides developers with a programmatic interface for creating multiple threads of execution in their programs. It also makes the job of creating and maintaining threads easier than directly using WinAPI calls. Does this come at a price? I don't know. I have several multithreaded applications using both straight WinAPI calls and the TThread object and haven't noticed any significant differences. But my test arena was not as wide as it should have been to accurately gauge performance differences. Most of the VCL is not thread-safe -- it's very important to take this into consideration when creating multiple threads of execution. If you call a VCL object from within a thread, most likely you'll raise an exception, because many of the VCL objects were not written with any type of synchronization code to ensure data integrity when called at random times from anything but the main thread. Essentially, they can only receive messages from a single thread. If they get a message from another thread, they'll hiccup, and your program will probably crash. Fortunately, TThread has a very simple way of safely making calls into the VCL that we'll discuss in a bit.

1127

Let's look at the TThread's structure. Here's the declaration for the TThread object: TThread = class private FHandle: THandle; FThreadID: THandle; FTerminated: Boolean; FSuspended: Boolean; FMainThreadWaiting: Boolean; FFreeOnTerminate: Boolean; FFinished: Boolean; FReturnValue: Integer; FOnTerminate: TNotifyEvent; FMethod: TThreadMethod; FSynchronizeException: TObject; procedure CallOnTerminate; function GetPriority: TThreadPriority; procedure SetPriority(Value: TThreadPriority); procedure SetSuspended(Value: Boolean); protected procedure DoTerminate; virtual; procedure Execute; virtual; abstract; procedure Synchronize(Method: TThreadMethod); property ReturnValue: Integer read FReturnValue write FReturnValue; property Terminated: Boolean read FTerminated; public constructor Create(CreateSuspended: Boolean); destructor Destroy; override; procedure Resume; procedure Suspend; procedure Terminate; function WaitFor: Integer; property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate; property Handle: THandle read FHandle; property Priority: TThreadPriority read GetPriority write SetPriority; property Suspended: Boolean read FSuspended write SetSuspended; property ThreadID: THandle read FThreadID; property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate; end; Its structure is quite simple -- and simple is good In most components there are only a few procedures and properties you need to think about; this is not an exception with TThread. The only methods you'll need to worry about are Execute, Create, and Synchronize; and the only property that you'll usually need to access is FreeOnTerminate. Key Methods and Properties of TThread The key methods and property of TThread are listed below in Table 1. Table 1 -- Key Attributes of TThread Attribute: Create Parameters: CreateSuspended: Boolean The Create method allocates memory, starts the thread and specifies the thread function in CreateThread as the Execute procedure. Here, as in any Create method, you can initialize vars and perform some preliminary operations. However, unlike a normal Create method, the thread is already executing by the time the method ends. Usually this isn't a problem because you'll just create the object and forget about it. But if you have to do any processing before the thread starts executing, set the CreateSuspended parameter to False. This allocates memory for the thread and sets it up, but the thread will not execute until you make a call to the Resume procedure. This is useful, especially if you need to set up values your thread will need over the course of its lifetime. Attribute: Execute

Parameters: None

Execute is your TThread's central execution method. It's fairly synonymous with a main processing or central control procedure or function you might use to execute all the procedures in a particular unit. The only difference is that with a TThread object, the first method that is called must be called Execute. This doesn't mean that you can't call another procedure which acts in that capacity from Execute. It's definitely more

1128

convenient to put your execution code here because that's Execute's purpose. One important note: If you look in the object declaration of TThread, you'll see that it is declared as a virtual; abstract; method. This means it's not implemented in any way, shape or form; therefore, it's up to you to provide the code. And there's no inherited functionality, so you'll never make a call to inherited Execute; in your own implementation. Attribute: Synchronize

Parameters: Method: TThreadMethod

Synchronize is your key to safely accessing the VCL in your thread. When Synchronize executes, your thread becomes a part of the main thread of the program, and in the process, suspends the operation of the main thread. This means the VCL can't receive messages from other threads other than the one you're synchronizing to the main thread, which in turn makes it safe to execute any VCL calls. Think of Synchronize as a middleman in a transaction. You have a buyer, which is the main thread of the program, and a seller of services, which is another thread of execution created within the same process. The seller would like to sell the buyer some goods -- in our case, do some operation on the VCL components running in the main thread -- but the buyer doesn't really know the seller, and is appalled at how the seller actually performs his service, so is afraid the seller's service may have a negative effect on him. So the seller enlists the help of an agent (the Synchronize procedure) to smooth things out, take the buyer out to lunch so the seller can do his thing. The seller is a procedure that performs the action on behalf of the thread. It doesn't have to be a specific type, but it must be a method of the thread. Say I have a long process running in a background thread that at certain times must update the text in a TPanel on the main form to give feedback about the thread's current status to the user. If I wrote in my code Form1.Panel1.Caption := 'This is my update message', I'd raise an exception -- most likely an access violation error. But if I encapsulate the call in a procedure, then call Synchronize, the message will be sent and text will be updated. Synchronize acted as a middleman so my status message could be passed to the TPanel. I've may have confused rather than enlightened you! Just remember this: When you want to call VCL objects from another thread, create a wrapper procedure for the operations you want to carry out, then use Synchronize to synchronize your thread with the main thread so your call can be safely executed. Synchronize is meant to be used really quickly. Execute it, then get out of it as soon as you can. While Synchronize is running, you essentially have only one thread working. The main thread is suspended. Attribute: FreeOnTerminate

Parameters: Set property to Boolean value

This is a really useful property. Typically, once your execute procedure finishes, the Terminated Boolean property is set to False. However, the thread still exists. It's not running, but it's taking up space, and it's up to you to free the thread. But by setting this property in the Create constructor to True, the thread is immediately freed -- and with it, all the resources it took up -- after it's finished executing. A Real-life Example Most people get more out of seeing code examples to implement a certain concept. Below are code excerpts from a program that I wrote that performs a bunch of queries in sequence. First we have the type declaration: type TEpiInfoProc = class(TThread) {Base processing class for Episode Information processing} private FStatMsg : String; FSession : TSession; tblPrimary, tblHistory, tblSymmetry : String;

1129

FIter : Integer; property Iteration : Integer read FIter write FIter; procedure eiCreateEpiTemp1; //Performs initial joins procedure eiCreateEpiTemp2; //Creates new table of summarized info procedure eiGetClassifications(clState, //'AMI', 'Asthma', etc. clName, //'H1', 'H2', etc. priFld, //Join field from Primary hstFld : String; //Join field from History bMode : TBatchMode); //Batch Mode (will always be //batCopy 1st time); procedure eiCreateEpiInfoTable(clSrc, clDst, clName : String); procedure eiCreateHistory(HistIndicator : String); //Generic processing methods procedure EnableBtns; procedure GetTableNames; procedure UpdStatus; procedure IndexTbl(dbName, tblName, idxName, fldName : String; idxOpts : TIndexOptions); protected procedure Execute; override; public constructor Create; end; The above is like anything you see in Delphi when you declare a descendant of a class. You declare your variables, properties, and methods just like anything else. Here's the Create constructor for the thread: Create constructor constructor TEpiInfoProc.Create; begin inherited Create(True); FSession := TSession.Create(Application); with FSession do begin SessionName := 'EpiInfoSession'; NetFileDir := Session.NetFileDir; PrivateDir := 'D:\EpiPriv'; end; FreeOnTerminate := True; Resume; end; Notice I'm creating a new TSession instance. When we discuss running queries in threads, I'll go into more depth about this. At this point the important thing to note is that I create the thread in a suspended state by calling the inherited Create and setting its CreateSuspended parameter to True. This allows me to perform the code immediately below the inherited Create before the thread code actually starts running. Now, on to the Execute procedure. procedure TEpiInfoProc.Execute; var N, M : Integer; begin try Synchronize(EnableBtns); //Set enabled property of buttons to opposite of current state Synchronize(GetTableNames);//Get Names FStatMsg := 'Now performing initial summarizations'; Synchronize(UpdStatus); ShowMessage('Did it!'); Exit; eiCreateEpiTemp1; eiCreateEpiTemp; {Create H1 - H9 tables} for N := 0 to 8 do for M := 0 to 5 do begin FStatMsg := 'Now performing '+ arPri[M] + ' field extract for ' + arDis[N];

1130

Synchronize(UpdStatus); Iteration := M; //first iteration must be a batCopy, then batAppend thereafter if (M = 0) then eiGetClassifications(arDis[N], arCls[N], arPri[M], arHst[M], batCopy) else eiGetClassifications(arDis[N], arCls[N], arPri[M], arHst[M], batAppend); end; {Now do Outer Joins} for N := 0 to 8 do begin FStatMsg := 'Now creating ' + arDst[N]; Synchronize(UpdStatus); eiCreateEpiInfoTable(arSrc[N], arDst[N], arCls[N]); end; IndexTbl('EPIINFO', 'EpiInfo', 'Primary', 'Episode',[ixPrimary]); for N := 0 to 8 do eiCreateHistory(arCls[N]); FStatMsg := 'Operation Complete!'; Synchronize(UpdStatus); Synchronize(EnableBtns); except Terminate; Abort; end; end; Notice all my calls to Synchronize, especially the synchronized call to UpdStatus. Immediately preceding this call, I set a variable called FStatMsg to some text. UpdStatus uses this text to set the SimpleText of a TStatusBar on the main form of the program. Why not just pass this as a string variable parameter to UpdStatus? Because synchronized methods cannot have parameters. If you need to pass parameters, you must either set them in variables or create a structure to hold values your synchronized method can then access and pass to your main form. Also take note of the looping structures I've written. You might be tempted to run a loop within a synchronized method. Although your code will work, this defeats the purpose of multiple threads because of what we discussed above. Synchronization makes your thread part of the main thread during the time it is executing, meaning you have only one thread actually running. This reduces your program to a single thread of execution. And if you have a potentially long process like several sequential queries executed from within a loop like I have above, forget it! Your program will act just like a single-threaded application until you're out the loop. Running Queries in Threads In order to successfully run queries in threads, you must follow a few cardinal rules: 209. For each thread you create that will be executing queries, you must have a separate instance of a TSession created along with the thread. (See Create constructor above) Simply put, TSessions essentially define the multi-threadness of the BDE. The BDE requires separate TSessions to allow multiple access to shared resources. Failing to do this will cause some very strange things to occur in your program (it will crash with an BDE exception of some sort.) 210. Every data-access VCL component you instantiate within a thread must have its SessionName property set to that of the SessionName of the TSession created with your thread. If you don't do this, the data-access component will default to the TSession created along with the main thread; this could have serious ramifications. If you assign components to a new TSession and forget to do so for others, when the components interact with each other with let's say a TBatchMove moving data from a query to a TTable, you'll get an error that says you're trying to perform an operation on objects in different sessions. Not good. So just to ensure that everything is safe, keep the data-access components you create in separate threads distinct by assigning the SessionNames to the SessionName of the TSession you create along with your thread. 211. You must create synchronized methods for any operation that will be accessing data-access components embedded on a form. I can't stress enough the importance of performing any call that will access VCL components within a Synchronize call. You're looking for trouble if you don't. Let's say you run a background query that will provide information in a visual form in a TDBGrid. Running the query is the easy part. But once you're finished, you have to have a way of manipulating a TDataSource so that its DataSet property

1131

will point to the query you've run in the thread. Setting this must be done in a call to a synchronized method that does the setting for you. 212. Building on the previous rule, queries that will be providing data for data-aware components such as a TDBGrid must be persistent. Once you free a thread, its resources are freed too. If you create a TQuery within the context of a TThread, your query is gone once the thread terminates and frees. The easiest thing to do then is to drop a TQuery on a form and run it from within the thread. That way, its handle remains valid even though the thread has finished its work. Of the above rules, 1 and 2 are the most important elements for successfully running queries in separate threads of execution. While rules 3 and 4 are important, under certain conditions your queries will not run if you don't obey rules 1 and 2. "Visual" and Non-visual Background Queries Now that we've established ground rules regarding running queries in threads, we must take into consideration a couple of implementation paths. I put the visual in quotes above to denote queries whose results will be displayed in a data-aware component of some sort. Non-visual background queries don't provide any visual result. They just run, write to persistent data stores and return. How you implement these methods is significantly different -- we'll discuss them in separate sections below. In either of these cases, the aim is to free up the user interface. One of my biggest frustrations with writing programs that process a lot of information is that once I've started execution, I can't do anything with the interface. I can't minimize or maximize the application; I can't move the window. Ever since I've learned to implement threaded technology in my programs, I need not worry about that. It's a real boon to my productivity. Running Totally Background Queries This method is a challenge; you have to code everything yourself. It's not a lot of code, but there are certain things to consider that you can take for granted when you drop VCL components onto a form. This method is very useful for "Data Mining" types of programs, in which you're querying huge tables and coming up with highly refined, summarized result sets. The operations that typify this type of application are several queries performed in succession. Were you to run this kind of application in a single-threaded program, you can effectively kiss your productivity goodbye because your user interface will be locked. The example I'll be using for this discussion is the example I used above because that application is a data mining type of application. It was built to run several sequential queries against Paradox tables with hundreds of thousands of records (pretty big for Paradox tables). Let's revisit the type declaration of thread: type TEpiInfoProc = class(TThread) {Base processing class for Episode Information processing} private FStatMsg : String; FSession : TSession; tblPrimary, tblHistory, tblSymmetry : String; FIter : Integer; property Iteration : Integer read FIter write FIter; procedure eiCreateEpiTemp1; //Performs initial joins procedure eiCreateEpiTemp2; //Creates new table of summarized info procedure eiGetClassifications(clState, //'AMI', 'Asthma', etc. clName, //'H1', 'H2', etc. priFld, //Join field from Primary hstFld : String; //Join field from History bMode : TBatchMode); //Batch Mode (will always be //batCopy 1st time); procedure eiCreateEpiInfoTable(clSrc, clDst, clName : String); procedure eiCreateHistory(HistIndicator : String); //Generic processing methods procedure EnableBtns; procedure GetTableNames; procedure UpdStatus; procedure IndexTbl(dbName, tblName, idxName, fldName : String; idxOpts : TIndexOptions); protected

1132

procedure Execute; override; public constructor Create; end; There's something in the type declaration that I didn't bring up previously. Notice the second private variable FSession. Then, look at the constructor Create code below: constructor TEpiInfoProc.Create; begin inherited Create(True); FSession := TSession.Create(Application); with FSession do begin SessionName := 'EpiInfoSession'; NetFileDir := Session.NetFileDir; PrivateDir := 'D:\EpiPriv'; end; FreeOnTerminate := True; Resume; end; I simply instantiate a new session in my Create constructor for my queries and tables to point to during the course of execution. If you don't have the latest update to Delphi and you look in the help file under TSession, you're warned not to create a TSession on the fly. Why? Truthfully, I don't know. I broke the rules anyway when I originally saw this warning because after looking at the VCL source for the TSession object in the DB.PAS file, I didn't see anything in the TSession object that would lead me to believe that I couldn't instantiate a TSession object on the fly. This changed in 2.01 -- the help file makes no such warning -- so it's not an issue. Of all the things that I'm doing in the thread, creating this TSession is the absolute key operation because it provides a common ground for all the data access components that I instantiate in the thread. During the course of execution, I make calls to several procedures that perform queries on several different tables. However, they all operate similarly, so it's only necessary to list one of the procedures to illustrate how you should do your queries in a thread. Here's an example procedure: procedure TEpiInfoProc.eiCreateEpiTemp1; var sqlEI : TEnhQuery; begin sqlEI := TEnhQuery.Create(Application); with sqlEI do begin SessionName := FSession.SessionName; DatabaseName := 'Primary'; DestDatabaseName := 'PRIVATE'; DestinationTable := 'epitemp1.db'; DestBatchMoveMode := batCopy; DoBatchMove := True; with SQL do begin Clear; Add('SELECT DISTINCT d.Episode, d.PatientID, d.Paid AS TotPd, d.Charge AS TotChg, D1.Start'); Add('FROM "' + tblPrimary + '" d LEFT OUTER JOIN "'+ tblSymmetry+'" D1 '); Add('ON (D1.Episode = d.Episode)'); Add('ORDER BY d.Episode, d.PatientID, d.Paid, d.Charge, D1.Start'); end; try try Execute; except raise; Abort; end; finally Free; end; end; end; The important thing to notice in the code example above is that the first property I set for the query I create is its SessionName property. This falls in line with obeying rules 1 and 2 that I mentioned above. I did this

1133

first so I'd be in compliance with them right away, though you can set properties in any order. The whole point to this is that looking at the procedure, it's no different from any type of procedure you'd use to create a query and execute it in code. The only difference is that you don't rely on the default TSession; you use the one you created at construction time. While I can't release what the application above actually does, I'll give you some gory details. On the average, the application requires three to four hours to execute completely, based on the size of the client database. Most of the client databases are several hundred megabytes in size, and all are in excess of 600MB per table, so you can imagine that with the enormity of the data sets, a single threaded application would just sit there and appear to be locked. But running the queries in the background frees the interface, so status messages can be supplied quite easily, and the form remains active during the run. I took an easy way out in this program to prevent multiple threads from executing. Typically what you'll do is use a system mutex or a semaphore to provide a mechanism signaling that you have a process running. But I found it much easier to just disable all the buttons on the form, so the user could still move the form around and even enter selection criteria but couldn't execute the new process until the current process has finished. It took much less code to implement a disabling feature than to implement a system mutex. Running Background Queries that will Produce Visible Result Sets You won't need to do this often because typically, queries run to display data in a grid or some other dataaware component are usually run against smaller tables and execute fairly quickly, so you can get away with running a single thread of execution. There are some instances in which you might need to query a couple of unrelated tables at the same time, so running the queries in separate threads of execution makes a lot of sense. Below is unit code from a test unit I wrote to illustrate this purpose. On my form I've dropped two of each of the following components: TQuery, TSession, TDataSource and a TDBGrid. I also have a button that will perform the thread creation. Let's look at the code, then discuss it: unit thrtest; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB, DBTables, Grids, DBGrids, StdCtrls; type TForm1 = class(TForm) DataSource1: TDataSource; Query1: TQuery; DBGrid1: TDBGrid; Button1: TButton; DataSource2: TDataSource; Query2: TQuery; DBGrid2: TDBGrid; Session1: TSession; Session2: TSession; procedure Button1Click(Sender: TObject); end; //Thread class declaration - very simple TQThread = class(TThread) private FQuery: TQuery; protected procedure Execute; override; public constructor Create(Query: TQuery); end; var Form1: TForm1; implementation {$R *.DFM} constructor TQThread.Create(Query: TQuery);

1134

begin inherited Create(True); prepare vars FQuery := Query; FreeOnTerminate := True; Resume; end; procedure TQThread.Execute; begin FQuery.Open; end;

// Create thread in a suspendend state so we can //Set up local query var to be executed. //Free thread when finished executing

//Perform the query

procedure TForm1.Button1Click(Sender: TObject); begin TQThread.Create(Query1); TQThread.Create(Query2); end; end. I've made the thread intentionally easy. The only thing you pass to the constructor is a query. The rest is all taken care of. Before I did any coding of the above, I did the following with the components on the form: · DataSource1 and DataSource2 have their DataSet properties set to Query1 and Query2, respectively. Likewise, DBGrid1 and DBGrid2 have their DataSource properties set to DataSource1 and DataSource2, respectively. · Query1 and Query2 have their SessionName property set to the SessionName property of Session1 and Session2, respectively. · Both TQuerys have their DatabaseName properties set to DBDEMOS. Query1's SQL is simple : 'SELECT * FROM "employee.db".' Query2's SQL is simple as well: 'SELECT * FROM "customer.db".' This is a really simplistic example that works amazingly well. When the user presses the button, the program creates two new threads of type TQThread. Since we pass in the query we want to execute, the thread knows which one to operate on. Notice that I didn't put any synchronization code in this example. Some might think that you have to do this for a DataSource component, but the DataSource is Session-less, so it's impossible. Besides, the DataSource is merely a conduit between the Query and the DBGrid. It's fairly inert. As in any program, you can make this much more complex. For example, you can set the DatabaseName and SQL of the TQuerys at runtime, making this a really flexible display tool. You can add a batchmove facility at the tail-end of the run so that in addition to displaying the results in a DBGrid, the program will also write to result tables. Play around with this to see how you can expand on the concept. Conclusion Multi-threading is a breakthrough and revolutionary programming technology for many programmers. Note, that on Unix systems, multithreading has existed for several years. But for Windows platforms, this hasn't been the case until a few years ago. Also, I didn't cover some of the really advanced stuff that you can do with threads. For that, you'll have to refer to advanced-level Win32 development books. But hopefully, in the course of this discussion, you've reached a level of understanding that will get you on your way to constructing your own multi-threaded applications.

1135

Delphi threading by example - by Wim De Cleen Abstract:An example using the Windows API. Delphi threading by example An example with the Windows API By Wim De Cleen, Software Engineer with Electromatic Sint-Niklaas NV (Belgium) Threads are somewhat overwhelming until you have written some threading code and gotten experience with their ins and outs. This article will introduce you to the art of threading and synchronization. I use the Windows API calls to show you how it really works -- the hard truth. I wrote an example that searches for a specific string in multiple files. As the threads search, real-time synchronized information is sent to the main form. Of course, the data could also be sendtto another thread or application. The more you think about it, the more you see the power of threading. Why synchronize? When a thread is running, it runs on its own without wondering what other threads are doing. That is why one thread can calculate a sum of two numbers -- let's say a and b, while another thread comes to life and changes the value of a. This is not what we want! So we need a shell around the global variables so that no other thread can access them. Then, when the calculations are done, we might remove the shell to give other threads in the system access to the data once more. The easiest way to construct such a shell is to use critical sections. We will use these as a start. (Incidentally, synchronization bugs like this can bite you when you are using VCL components, which are generally not thread-safe. When you start updating controls from different threads everything may seem fine...but the bug will present itself some time in the future. Then it is up to you to find the synchronization bug. Believe me, this can take a while. Debugging threads is really frustrating! Getting started Delphi's TThread class has a method called synchronize, and if it did everything we wanted then there would be no need for this article. TThread lets you specify a method that needs to be synchronized with the main thread (the thread of the VCL). This is handy if you can afford to spend time waiting for synchronization, but in systems where milliseconds are crucial you can't use this method: It halts the execution of the thread during synchronization. My alternative method is based on messages. With the function PostMessage you can deliver messages to any thread in the system without waiting for the result. The message is just placed onto the message queue of the receiving thread and stays there until the receiving thread comes to life. At that time the message is handled. All that time your thread continues to run. Critical sections Critical sections are the simplest synchronizers possible. They are fast because they can be used only within the same process. A critical section can be used to protect global variables but you must perform the coordination yourself. You can't bind a variable to a critical section programmatically; it must be done logically. Let's say we want to protect any access to the variables a and b. Here's how to do it with the critical sections approach: //global variables var CriticalSection: TRTLCriticalSection; a, b: integer; //before the threads starts InitializeCriticalSection(CriticalSection); //in the thread EnterCriticalSection(CriticalSection); //From now on, you can safely make //changes to the variables. inc(a); inc(b); //End of safe block LeaveCriticalSection(CriticalSection); See? Nothing to it. This approach lets you create multiple threads without worrying about the effect on global variables. Starting the thread When creating a thread without the TThread class, always use the BeginThread function from the SysUtils unit. It is specifically written to use Pascal functions and it encapsulates the CreateThread winapi call. Let's take a look at the declaration and step through the parameters.

1136

BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; var ThreadId: LongWord): Integer; · SecurityAttributes: a pointer to a security record, used only in windows NT, fill in nil · StackSize: the initial stack size of the thread. The default value is 1MB. If you think this is too small fill in the desired size, otherwise if not fill in 0. · ThreadFunc: This is the function that will be executed while the thread is running. This is mostly a function with a while loop inside. The prototype is function(Parameter: Pointer): Integer · Parameter: This is a pointer to a parameter, which can be anything you like. It will be passed to the thread function as the parameter pointer. · CreationFlags: This flag determines whether the thread starts immediately or it is suspended until ResumeThread is called. Use CREATE_SUSPENDED for suspended and 0 for an immediate start. · ThreadID: This is a var parameter that will return the ThreadID of the thread. Handling the messages Handling messages sent to a form is simple in Delphi. You just have to declare a procedure with the following prototype: procedure(var Message:TMessage). This procedure must be declared as a method of your form class. By using the message directive you bind a message to the function. In the form declaration it looks like this: const TH_MESSAGE = WM_USER + 1; type Form1 = class(TForm) private procedure HandleMessage(var Message: TMessage); message TH_MESSAGE; public end; From now on every message sent to the form with the message parameter TH_MESSAGE will invoke the HandleMessage procedure. We can send a message with the PostMessage function which looks like the following" PostMessage (Handle: HWND; Message: Cardinal; WParam: integer; LParam:integer) · Handle: The handle of the receiving thread or receiving form. · Message: The messageconstant. · WParam: An optional parameter. · LParam: An optional parameter. Putting things together. The example program uses messages to deliver information to the main form from within threads. First I declared the message constants and the submessage constants. Submessages will be passed through the LParam. const TH_MESSAGE = WM_USER + 1; //Thread message TH_FINISHED = 1; //Thread SubMessage //End of thread //WParam = ThreadID TH_NEWFILE = 2; //Thread Submessage //Started new file TH_FOUND = 3; //Thread Submessage //Found search string in File TH_ERROR = 4; //Thread SubMessage //Error -- WParam = Error Then the information records, which will be passed through WParam: type //Record for found items, will occur when //LParam = TH_FOUND, WParam will be //PFoundRecord PFoundRecord = ^TFoundRecord; TFoundRecord = record ThreadID: Cardinal; Filename: string; Position: Cardinal;

1137

end; //Record for new files, will occur when //LParam = TH_NEWFILE, WParam will be //PNewFileRecord PNewFileRecord = ^TNewFileRecord; TNewFileRecord = record ThreadID: Cardinal; Filename: string; end; Since we need some information about the threads we declare an info record for them: //Record to hold the information from one thread TThreadInfo = record Active: Boolean; ThreadHandle: integer; ThreadId: Cardinal; CurrentFile: string; end; Finally we declare the TMainForm class, which contains the message handler: //The Main form of the application TMainForm = class(TForm) btSearch: TButton; Memo: TMemo; OpenDialog: TOpenDialog; edSearch: TEdit; StringGrid: TStringGrid; Label1: TLabel; procedure btSearchClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure edSearchChange(Sender: TObject); private ThreadInfo: array[0..4] of TThreadInfo; //Holds the information of the threads procedure ThreadMessage(var Message: TMessage); message TH_MESSAGE; //MessageHandler function ThreadIDToIndex(ThreadID: Cardinal): integer; public end; In the implementation section we declare our global variables, the critical section, a search string, and the list of files we will be searching. var CriticalSection: TRTLCriticalSection; //Critical section protects the filelist FileList: TStringList; //List of filenames to be searched SearchString: string; //String to be searched in every file Then follows the thread function, this is the function that delivers all the work for the thread. It will be passed to the begin thread function. function FindInFile(data: Pointer): Integer; var FileStream: TFileStream; Ch: char; Current,Len: Integer; FoundRecord: PFoundRecord; NewFileRecord: PNewFileRecord; Filename: string; Search: string; FilesDone: Boolean; begin Result:= 0; FilesDone:= False; while not FilesDone do begin Current:= 1; EnterCriticalSection(CriticalSection);

1138

//Try to catch the critical section Search:= SearchString; //Access the shared variables //Are there still files available if FileList.Count = 0 then begin //Leave the critical section //when there are no files left LeaveCriticalSection(CriticalSection); //Leave the while loop break; end else begin //Read the filename Filename:= FileList.Strings[0]; //Delete the file from the list FileList.Delete(0); //Leave the critical section LeaveCriticalSection(CriticalSection); //Inform MainForm of New File New(NewFileRecord); NewFileRecord^.Filename:= Filename; NewFileRecord^.ThreadID:= GetCurrentThreadID; PostMessage(MainForm.Handle, TH_MESSAGE, TH_NEWFILE, Integer(NewFileRecord)); Len:= Length(Search); try FileStream:= TFileStream.Create( Filename, fmOpenRead or fmShareExclusive); except PostMessage(MainForm.Handle, TH_MESSAGE, TH_ERROR, ERROR_COULD_NOT_OPEN_FILE); continue; end; //The search algorithm, pretty simple, //the example is not about searching while FileStream.Read(Ch,1)= 1 do begin If Ch = Search[Current] then begin Inc(Current); if Current > Len then begin //Found the search string, //inform MainForm of our success New(FoundRecord); FoundRecord^.Filename:= Filename; FoundRecord^.Position:= FileStream.Position; FoundRecord^.ThreadID:= GetCurrentThreadID; PostMessage(MainForm.Handle, TH_MESSAGE, TH_FOUND, Integer(FoundRecord)); end; end else begin FileStream.Position:= FileStream.Position - (Current - 1); Current:= 1; end; end;

1139

FileStream.Free; end; end; //All done inform MainForm of ending PostMessage(MainForm.Handle, TH_MESSAGE, TH_FINISHED, GetCurrentThreadID); end; Another important procedure is the message handler, which -- drum roll, please -- handles the messages. It also frees the record pointers. procedure TMainForm.ThreadMessage(var Message: TMessage); var FoundRecord: PFoundRecord; NewFileRecord: PNewFileRecord; ThreadIndex: integer; Counter: integer; Ended: boolean; begin case Message.WParam of TH_FINISHED: begin ThreadIndex:= ThreadIDToIndex(Message.LParam); if ThreadIndex = -1 then Exit; //Invalid threadID should never appear CloseHandle(ThreadInfo[ThreadIndex].ThreadHandle); //Free the thread memoryspace StringGrid.Cells[3,ThreadIndex+1]:= 'False'; //Update the stringgrid Threadinfo[ThreadIndex].Active:= False; //Update the ThreadInfo array Ended:= True; for counter:= 0 to 4 do if ThreadInfo[ThreadIndex].Active then begin Ended:= False; break; end; if Ended then btSearch.Enabled:= True; end; TH_NEWFILE: begin NewFileRecord:= PNewFileRecord(Message.LParam); ThreadIndex:= ThreadIDToIndex (NewFileRecord^.ThreadID); if ThreadIndex = -1 then Exit; //Invalid threadID should never appear StringGrid.Cells[2,ThreadIndex+1]:= NewFileRecord^.Filename; //Update StringGrid ThreadInfo[ThreadIndex].CurrentFile:= NewFileRecord^.Filename; //Update ThreadInfo Dispose(NewFileRecord); //All information is used now free the pointer end; TH_FOUND: begin FoundRecord:= PFoundRecord(Message.LParam); ThreadIndex:= ThreadIDToIndex(FoundRecord^.ThreadID); if ThreadIndex = -1 then Exit; //Invalid threadID should never appear Memo.Lines.Add(FoundRecord^.Filename + ' Position:' + IntToStr(FoundRecord^.Position)); Dispose(FoundRecord); //All information is used now free the pointer end; TH_ERROR: begin ThreadIndex:= ThreadIDToIndex(Message.LParam); if ThreadIndex = -1 then Exit;

1140

//Invalid threadID should never appear Memo.Lines.Add('Error: Could not open file ' + ThreadInfo[ThreadIndex].CurrentFile); end; end; end; You don't need to worry about pasting the functions and classes together. I have included the complete example in a Zip file so you can see it working right away. This is not a complete explanation of threading. It's barely a beginning. But I hope it will serve as a starting point for your own exploration. I wish I had had an example to guide me when I started working with threads!

1141

Quick Tips

This part of the corner has really quick solutions to very focused subjects. Some I learn about on my own, others are sent to me by helpful readers. If you've any quick tips, please e-mail me and they'll be posted with your name on the front page! Getting the System BIOS Date without ASM or API calls Disabling an Event Handler Once It Has Executed Once Make the Results of Query Permanent Create a Right-Aligned Edit Box Editor Keyboard Shortcut - Column Selection Preventing a User from Closing a Window Except at Shutdown or Restart Some Useful Date Calculation Routines Finding a Substring in a TStrings Accessing the OnUpClick and OnDownClick of a TSpinEdit at Runtime Resizing a JPEG File Getting System BIOS Date Here's one, courtesy of one of our readers, Rubem Rocha. {================================ The following function will retrieve the BIOS date, without built-in assembler or API calls, just Delphi native resources. ================================} function BiosDate: String; begin result := string(pchar(ptr($FFFF5))); end;

Disabling an Event Handler Once It Has Executed Once Have you ever wanted to keep an event from firing once it has executed once? Simply set the event handler method to nil in the body of the method. For instance, let's say you want to disable an OnClick for a button once the user has pressed it. Here's the code to do that: procedure Button1OnClick; begin Button1.OnClick := nil; end;

Make the Results of a Query Permanent This tip comes to us by way of one of our readers, Cezar Nechifor. Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can short-circuit this process by making a couple of simple, direct calls to the BDE. //Make sure you have BDE declared in your uses section procedure MakePermTable(Qry : TQuery; PermTableName : String); var h : HDBICur; ph : PHDBICur; begin Qry.Prepare; Check(dbiQExec(Qry.StmtHandle, ph)); h := ph^; Check(DbiMakePermanent(h, PChar(PermTableName), True)); end;

1142

Create a Right-Aligned Edit Box HUH?!!! Many of you might think, "Hey! You can't do that unless you use a TMemo. Well, Matt Powell, one of our readers, proved that wrong with such an incredibly simple bit of code that you'll... Forget it, here's component code that I subclassed from TCustomEdit that will give you a right-aligned edit box: unit AlignedEdit; interface uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics; type TAlignedEdit = class(TCustomEdit) private FAlignment : TAlignment; protected procedure CreateParams(var Params : TCreateParams); override; published property Alignment : TAlignment read FAlignment write FAlignment; end; procedure Register; implementation { TAlignedEdit } procedure TAlignedEdit.CreateParams(var Params: TCreateParams); const Alignments : array[TAlignment] of Integer = (ES_LEFT, ES_RIGHT, ES_CENTER); begin inherited CreateParams(Params); //Setting this does the alignment //Note that the actual alignment will //not occur until runtime with Params do Style := Style AND (NOT 0) OR (ES_MULTILINE) OR (Alignments[FAlignment]); end; procedure Register; begin RegisterComponents('BD', [TAlignedEdit]); end; end. It never ceases to amaze me the simple, yet completely elegant solutions that people come up with. Kudos to Matt Powell for passing this along to me!

Editor Keyboard Shortcut - Column Selection The Delphi editor is something we all take for granted - I know I do. In past versions of Delphi, the editor lacked features that forced many of us to do as we did with Paradox: Use another editor add-in that provided more editing features. One thing that I use a lot is column selection; that is, instead of selecting an entire block of text in the editor, I only want to select a certain number of columns over several lines. For instance, this is incredibly useful for setting up several arrays with the same element count. There are lots of uses. Column selection keyboard shorcuts are defined as follows:

1143

Shortcut Description Alt+Shift+Left Arrow Selects the column to the left of the cursor Alt+Shift+Right Arrow Selects the column to the right of the cursor Alt+Shift+Up Arrow Moves the cursor up one line and selects the column from the left of the starting cursor position Alt+Shift+Down Arrow Moves the cursor down one line and selects the column from the left of the starting cursor position Alt+Shift+Page Up Moves the cursor up one screen and selects the column from the left of the starting cursor position Alt+Shift+Page Down Moves the cursor down one line and selects the column from the right of the starting cursor position Alt+Shift+End Selects the column from the cursor position to the end of the current line Alt+Shift+Home Selects the column from the cursor position to the start of the current line There are lots of great editor shortcuts included in the Delphi Editor. For a listing of them, search the Delphi online help for "editor shortcuts." You'll find them as useful as I do!

Preventing a User from Closing a Window Except at Shutdown or Restart We all know how to prevent a window from closing: Simply write event code for the OnCloseQuery event and set CanClose to False. Once that's done, no matter what a user presses, the window won't close. Here's some code: procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose := False; end; But what if you wanted to be able to close a window only when you reboot the machine? With the scenario above, that would be impossible. Fortunately though, there is a solution, and it resides in the windows message WM_QUERYENDSESSION. WM_QUERYENDSESSION is generated by Windows when the OS is resetting: Either at a shutdown or a restart. Using this message, we can set a boolean flag variable and interrogate its value in OnCloseQuery to allow us to close the window and reset the operating system. Look at the unit code below: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); private procedure WMQueryEndSession(var Message : TWMQueryEndSession); message WM_QUERYENDSESSION; public WindowsClosing : Boolean; end; var Form1: TForm1; implementation {$R *.DFM}

1144

{ TForm1 } procedure TForm1.FormCreate(Sender: TObject); begin WindowsClosing := False; end; procedure TForm1.WMQueryEndSession(var Message: TWMQUERYENDSESSION); begin WindowsClosing := True; end; procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose := WindowsClosing; end; end. As you can see, I've created a public variable called WindowsClosing. When WM_QUERYENDSESSION fires, it sets the variable to True. Then in OnCloseQuery, CanClose is set to the value of WindowsClosing. Notice that I set WindowsClosing to False in OnCreate. This is purely for initialization purposes to make sure that previous attempts to close the window are foiled.

Some Useful Date Calculation Routines Ever notice how some date routines are missing from SysUtils? Well as they say, necessity is the mother of invention, I've come up with some date calculation routines that you can include in your own programs that require some date calculations. If you've got any more than this, please feel free to share them! type TDatePart = (dpYear, dpMonth, dpDay); {Purpose : Return a date part.} function GetDatePart(Date : TDateTime; DatePart : TDatePart) : Word; var D, M, Y : Word; begin //Initialize Result - avoids compiler warning Result := 0; DecodeDate(Date, Y, M, D); case DatePart of dpYear : Result := Y; dpMonth : Result := M; dpDay : Result := D; end; end; {Purpose : Extracts the date portion of a date time. Useful for seeing if two date time values fall on the same day} function ExtractDatePart(Date : TDateTime) : TDate; begin Result := Int(Date); end; {Purpose : Gets the time portion of a date time. Like ExtractDatePart this is useful for comparing times.} function ExtractTimePart(Date : TDateTime) : TTime; begin Result := Frac(Date); end;

1145

{Purpose : Used for determining whether or not a DateTime is a weekday.} function IsWeekday(Day : TDateTime) : Boolean; begin Result := (DayOfWeek(Day) >= 2) AND (DayOfWeek(Day) <= 6); end; {Purpose : Function returns the date of the relative day of a month/year combo such as the date of the "Third Monday of January." The formal parameters depart a bit from the MS SQL Server Schedule agent constants in that the RelativeFactor parameter (Freq_Relative_Interval in MS-SQL), takes integer values from 1 to 5 as opposed to integer values from 2 to the 0th to 2 to the 4th power. Formal Parameters ================================================================================== ===== Year : Year in question Month : Month in question RelativeFactor : 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last Day : 1 - 7, day starting on Sunday; 8 = Day; 9 = Weekday; 10 = Weekend Day } function GetRelativeDate(Year, Month, RelativeFactor, Day : Integer) : TDateTime; var TempDate : TDateTime; DayIndex : Integer; begin TempDate := EncodeDate(Year, Month, 1); DayIndex := 0; //Now, if you're looking for the last day, just go to the last //day of the month, and count backwards until you hit the day //you're interested in. if (RelativeFactor = 5) then begin TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]); case Day of 1..7 : if (DayOfWeek(TempDate) = Day) then Result := TempDate else begin while (DayOfWeek(TempDate) <> Day) do TempDate := TempDate - 1; Result := TempDate; end; 9 : begin if IsWeekday(TempDate) then Result := TempDate else begin while NOT IsWeekday(TempDate) do TempDate := TempDate - 1; Result := TempDate; end; end; 10 : begin if NOT IsWeekday(TempDate) then Result := TempDate else begin

1146

while IsWeekday(TempDate) do TempDate := TempDate - 1; Result := TempDate; end; end; else //This only happens if you're going after the very last day of the month Result := TempDate; end; end else //Otherwise, you have to go through the month day by day until you get //to the day you want. Since the relative week is a power of 2, just //see if the day exponent is a case Day of 1..7 : begin while (DayIndex < RelativeFactor) do begin if (DayOfWeek(TempDate) = Day) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; 9: begin while (DayIndex < RelativeFactor) do begin if IsWeekDay(TempDate) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; 10 : begin while (DayIndex < RelativeFactor) do begin if NOT IsWeekDay(TempDate) then Inc(DayIndex); TempDate := TempDate + 1; end; Result := TempDate - 1; end; else Result := TempDate + RelativeFactor; end; end; type TDecimalTimeType = (dtSecond, dtMinute, dtHour); {Purpose : Returns hours, minutes, or seconds in decimal format for use in date time calculations} function GetDecimalTime(Count : Integer; DecimalTimeType : TDecimalTimeType) : Double; const Second = 1/86400; Minute = 1/1440; Hour = 1/24; begin //Initialize result Result := 0; case DecimalTimeType of dtSecond : Result := Count * Second;

1147

dtMinute : Result := Count * Minute; dtHour : Result := Count * Hour; end; end; {Purpose : Converts a MS-style integer time to a TTime} function IntTimeToTime(Time : Integer) : TTime; var S : String; begin S := IntToStr(Time); //String must be 5 or 6 character long if (Length(S) < 5) OR (Length(S) > 6) then Result := 0 else begin if (Length(S) = 5) then //A morning time S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2) else //Afternoon, evening time S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2); Result := StrToTime(S); end; end;

Finding a Substring in a TStrings The IndexOf function in TStrings is great because it lets you quickly get the index of Item that holds the string in question. Unfortunately, it doesn't work for sub-strings. In that case, I've put together a neat little function called IndexOfSubString where you pass in the TStrings descendant you want to search on and a search value, and it'll return the index. Check it out: {Purpose : Binary search algorithm for a TStrings object. Finds the first occurence of any substring within a TStrings object or descendant} function IndexOfSubString(List : TStrings; SubString : String) : Integer; var I, LowIdx, HighIdx : Integer; Found : boolean; begin Found := false; Result := -1; {This type of search uses the first half of the TStrings list, so initialize the LowIdx and HighIdx to the first and approximate half of the list, respectively.} LowIdx := 0; HighIdx := List.Count div 2; {Note that Found and the LowIdx are used as conditionals. It's obvious why Found is used, but less apparent why LowIdx is used instead of HighIdx. The reason for this is that the way I've set it up here, HighIdx will never exceed (List.Count - 2), whereas LowIdx can equal (List.Count - 1) by nature of the assignment if Found remains false after the for loop.} while not Found and (LowIdx < (List.Count - 1)) do begin for I := LowIdx to HighIdx do

1148

if (Pos(SubString, List[I]) > 0) and not Found then begin Found := true; Result := I; end; if not Found then begin LowIdx := HighIdx + 1; HighIdx := HighIdx + ((List.Count - HighIdx) div 2); end; end; end;

Accessing OnUpClick and OnDownClick of TSpinEdit This one comes from our Forum SysOp, Chris Bray! I have just answered a question for another Forum which I had to research quite carefully, and as it relates to compound components (wrapper components if you prefer) I thought the answer might be relevant to the Tips section. The questioner wanted to access the OnUpClick and OnDownClick events of the SpinButton which is part of the SpinEdit component from the samples page of the pallette. My answer was as follows: You have two choices: either create your own component surfacing the OnUpClick or OnDownClick properties, or call the OnUpClick property of the updown button on the SpinEdit. Assuming you will not want to create your own component, sample code to access the button from a form follows: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Spin; type TForm1 = class(TForm) SpinEdit1: TSpinEdit; procedure FormCreate(Sender: TObject); public procedure OnButtonUpClick(Sender: TObject); end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin SpinEdit1.Button.OnUpClick := OnButtonUpClick; end; procedure TForm1.OnButtonUpClick(Sender: TObject); begin

1149

MessageDlg('Up Button was clicked.', mtInformation, [mbOk], 0); end; end. To expand the example, simply add additional procedures for the DownClick and any other properties you wish to surface at runtime. Note that the source code for the spin edit is provided in the Pro and Client Server versions of Delphi, and should be located in the Source folder in a file called Spin.pas. A Note from Brendan: You might be wondering about what Chris did here and why does it work? Put simply, all events are method pointers, or more fundamentally, procedural types. A procedural type is Delphi type that is defined as a function or procedure that can be assigned to variables or passed to other procedures or functions as arguments. For example, the following is an example of procedural type: type TExtendedFunction = function(A, B : Extended) : Extended; With that in mind, we can define a variable to be of type TExtendedFunction, then assign a function to it to "assign" it a value: function MyExtendedFunction(A, B : Extended) : Extended; var F : TExtendedFunction; begin F := MyExtendedFunction; ... //Now "use" F F(23.100, 4.00234); Method pointers, like events, differ from procedural pointers only with respect to how they're declared. If TExtendedFunction were a method pointer, the declaration would be followed by of object to indicate that the function belongs to an instance of an object. Okay, now what does that have to do with the current discussion? Actually, everything. Since events are essentially variables, we have the freedom in Delphi to re-assign their "values" to something else. What Chris did above was to simple re-assign the OnUpClick of the TSpinEdit to his own "variable definition." In Windows parlance, this is called subclassing. Pretty slick, and it's a good demonstration of the power and flexibility of Delphi. Be forewarned though, that you shouldn't do this unless you absolutely have to. Most events are surfaced in the Object Inspector at design time (they're published properties), and you can define most of your events there. It's only when events aren't surfaced, or you want to affect different behavior at runtime does this methodology become valid. So use with care!

Re-sizing a JPEG file JPEG files can be handled easily in Delphi by adding the JPEG unit to the uses clause and then using its methods to manipulate a JPEG image. However a TJPEGImage does not have a Canvas, so you cannot draw on it, and it does not provide any access to the internal bitmap it uses so you cannot manipulate that. So how can you change the size of a JPEG graphic? The following simple code provides the answer by creating a new JPEG file exactly half the size of the original: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtDlgs; type TForm1 = class(TForm) Button1: TButton;

1150

OpenPictureDialog1: TOpenPictureDialog; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses JPEG; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var Jpeg1, Jpeg2: TJPEGImage; TempBitmap: TBitmap; CanvasRect: TRect; begin if OpenPictureDialog1.Execute then begin // Create a Bitmap and two JPEG's TempBitmap := TBitmap.Create; Jpeg1 := TJPEGImage.Create; Jpeg2 := TJPEGImage.Create; try // Load the picture to shrink into the first Jpeg Jpeg1.LoadFromFile(OpenPictureDialog1.FileName); // Set the bitmap width to the new size TempBitmap.Width := JPeg1.Width div 2; TempBitmap.Height := JPeg1.Height div 2; // Create a TRect with the canvas co-ordinates CanvasRect := Rect(0, 0, TempBitmap.Width, TempBitmap.Height); // Draw the JPEG on the Canvas MyBitMap.Canvas.StretchDraw(CanvasRect, JPeg1); // Assign the bitmap to the second Jpeg Jpeg2.Assign(TempBitmap); // Save the second Jpeg in a renamed file Jpeg2.SaveToFile(ExtractFilePath(OpenPictureDialog1.FileName)+ 'Small '+ExtractFileName(OpenPictureDialog1.FileName)); finally // Tidy up the stuff you created before leaving TempBitmap.Free; Jpeg1.Free; Jpeg2.Free; end; end; end; end. Although we do not have access to the inner bitmap of the JPEG object, we can use standard TGraphic methods with it. Basically all we are doing is drawing the image at the new size and then assigning the resulting bitmap to a new JPEG object.

1151

If you want to make the new file a different size simply change the size of the intermediate TBitmap. However, bear in mind that you should always use the same percentage of both height and width of the original in order to maintain the aspect ratio. Chris Bray.

1152

Dynamic SQL Creation: Using a TStrings Descendant to Create a SQL Statement on the Fly How do I retrieve the text from a list box to add to the SQL property of a TQuery then create both a Paradox and dBase table? One thing I love about Delphi is that since it's object oriented, you can perform a lot of quick and dirty code tricks that wouldn't be possible with other languages. For instance, the ability to assign values of like properties from one object to another saves so much coding time. Take a list box, for example, as in your question. What you essentially want to do is create a SQL statement from fields listed in a list box. If you think about it, a list box's Items property and a TQuery's SQL property are both TStrings descendants. This means that you can do a direct assignation between the two. Actually, that's only half true. You have to format the fields into a proper SQL statement format first, and that requires an intermediate TStrings object. Luckily though, we can easily accomplish the conversion for field list to SQL statement with a simple function. The function listed below takes a list of fields, a Boolean value to determine whether or not the query is a DISTINCT select, and a table name, and puts all of those together into a valid SQL statement that can easily be assigned to a TQuery's SQL property. Here's the listing: {========================================================== This function will create a SELECT or SELECT DISTINCT SQL statement given input from a TStrings descendant like a list. It will properly format the list into field declarations of a SQL statement then, using the supplied TableNm parameter, will construct an entire statement that can be assigned to the SQL property of a TQuery. Params:

Distinct TableNm

SELECT DISTINCT or regular SELECT Table name: Should either be a fully qualified table name, or preceeded by an alias (ie, ':DbName:MyTable.db') FieldList Any TStrings descendant will work here, like the Items property of a TListBox. ==========================================================} function CreateSelect(Distinct : Boolean; TableNm : String; const FieldList : TStrings) : TStrings; var Sql : TStringList; I : Integer; buf, QueryType : String; begin //First, instantiate the SQL lines list Sql := TStringList.Create; //Determine whether or //or a SELECT DISTINCT if Distinct then QueryType := 'SELECT else QueryType := 'SELECT

no this is a regular SELECT query. ' DISTINCT ';

buf := QueryType; try //Now add the fields to the select statement //Notice that if we're on the last item, //we don't want to add a trailing comma. for I := 0 to (FieldList.Count - 1) do if (I <> FieldList.Count - 1) then buf := buf + FieldList[I] + ', ' else buf := buf + FieldList[I];

1153

//Now, put the query together Sql.Add(buf); Sql.Add('FROM "' + TableNm + '"'); Result := Sql; finally Sql.Free; end; end; To use this, let's say you have a list box call ListBox1, and a query called Query1. You also have a TEdit called Edit1 that holds the table name value. Here's how you'd make the call: with Query1 do begin Active := False; SQL.Clear; //This will create a SELECT DISTINCT statement SQL := CreateSelect(True, Edit1.Text, ListBox1.Items); Open; Okay, now that we've finished creating the statement and running the query, we have to move the answers to both Paradox an dBase. This is easily accomplished with a TBatchMove component. Building on the previous example,. let's say you have a TBatchMove component embedded on your form. We'll call it BatchMove1. To move the answer to a Paradox and a dBase table, you need to use the BatchMove to move the contents of the answer from Query1 to two new tables. The listing below lists an entire procedure that will accomplish this: procedure GetFieldsAndMove; var tblPdox, tbldBas : TTable; begin with Query1 do begin Active := False; SQL.Clear; //This will create a SELECT DISTINCT statement SQL := CreateSelect(True, Edit1.Text, ListBox1.Items); Open; end; tblPdox := TTable.Create(nil); with tblPdox do begin Active := False; DatabaseName := ExtractFilePath(Application.EXEName); TableName := 'MyPdoxTable'; TableType := ttParadox; end; tbldBas := TTable.Create(nil); with tbldBase do begin Active := False; DatabaseName := ExtractFilePath(Application.EXEName); TableName := 'MydBaseTable'; TableType := ttDBase; end; try with BatchMove1 do begin Source := Query1; Destination := tblPdox; Execute; end; with BatchMove1 do begin Source := Query1;

1154

Destination := tbldBase; Execute; end; finally tblPdox.Free; tbldBase.Free; end; end; Again, this is pretty straight-forward stuff. If you need more information on the TBatchMove component, it is well-documented in the online help.

1155

Packing a Paradox or dBase Table How do I pack a Paradox (or dBase) table to optimize its indexes and space used? Wouldn't it be great for the TTable component to have a method that does this? Just open up a TTable, connected it to a table on disk, call the method, and wham! The table's packed (Hmm.... I just might have to look into that). But short of that, you have to make direct calls to the BDE to accomplish this task. For dBase tables, it's easy. There's a single function called dbiPackTable that'll pack any dBase file. For Paradox files, you have to jump through a couple of hoops first, then call dbiDoRestructure because Paradox tables can only be packed within the context of a table restructure (Note: If you've restructured a table in Paradox or the Database Desktop, you'll notice a checkbox at the bottom of the restructure dialog called "Pack Table"). Below is a simple procedure for packing tables. I took most of the code right out of the online help (yes, there's really good stuff in there if you know where look), and made some alterations. The difference between what I did and what the help file lists is that instead of the formal parameter being a TTable, I require a fully qualified file name (path/name). This allows for greater flexibility - the procedure opens up its own TTable and works on it instead you having to create one yourself. I guess it might all boil down to semantics, but I still like my way better (so there!). Check out the code below: procedure PackTable(TblName : String); var tbl : TTable; cProps : CURProps; hDb : hDBIDb; TblDesc : CRTblDesc; begin tbl := TTable.Create(nil); with tbl do begin Active := False; DatabaseName := ExtractFilePath(TblName); TableName := ExtractFileName(TblName); Exclusive := True; Open; end; // Added 23/7/2000 to make sure that the current path is the same as the table //see note below SetCurrentDir(ExtractFilePath(TblName)); // Make sure the table is open exclusively so we can get the db handle... if not tbl.Active then raise EDatabaseError.Create('Table must be opened to pack'); if not tbl.Exclusive then raise EDatabaseError.Create('Table must be opened exclusively to pack'); // Get the table properties to determine table type... Check(DbiGetCursorProps(tbl.Handle, cProps)); // If the table is a Paradox table, you must call DbiDoRestructure... if (cProps.szTableType = szPARADOX) then begin // Blank out the structure... FillChar(TblDesc, sizeof(TblDesc), 0); // Get the database handle from the table's cursor handle... Check(DbiGetObjFromObj(hDBIObj(tbl.Handle), objDATABASE, hDBIObj(hDb))); // Put the table name in the table descriptor... StrPCopy(TblDesc.szTblName, tbl.TableName); // Put the table type in the table descriptor... StrPCopy(TblDesc.szTblType, cProps.szTableType); // Set the Pack option in the table descriptor to TRUE... TblDesc.bPack := True; // Close the table so the restructure can complete... tbl.Close; // Call DbiDoRestructure... Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False)); end

1156

else // If the table is a dBASE table, simply call DbiPackTable... if (cProps.szTableType = szDBASE) then Check(DbiPackTable(tbl.DBHandle, tbl.Handle, nil, szDBASE, True)) else // Pack only works on Paradox or dBASE; nothing else... raise EDatabaseError.Create('You can only pack Paradox or dBase tables!'); with tbl do begin if Active then Close; Free; end; end; See? Nothing fancy. What you should know is that all operations involving dbiDoRestructure revolve around a table descriptor type CRTblDesc. With this record type, you can set various field values, then execute dbiDoRestructure to make your changes. That's kind of the trick to making BDE calls in general. You typically work with some sort of record structure, then use that structure in one of the calls. I know I'm probably oversimplifying, but that's it in a nutshell. The point? Don't be scared of the BDE. More later! I encourage you to look at the BDE online help under any dbi- subject. There are lots of code examples that will get you on your way. NOTE: I received an email from Stewart Nightingale who said "When running PackTable straight after saving something to floppy it became obvious that packing a table must use the current directory for temporary tables and things - the current directory was "a:" and it came up with an error saying "No Disk in Drive a:". I put in the line "SetCurrentDir(ExtractFilePath(TblName));" at the top of the procedure so it would work properly ." I have added this line to the code sample shown above - use it if you wish, leave it out if you do not...........

1157

Putting a TDBLookupComboBox in a Grid How do I display a DBLookupComboBox in a Grid? Woll2Woll's InfoPower wwDBGrid enables you to do this, but how do I do it myself in Delphi? Note: Some of you old hats at Delphi might immediately exclaim, "What's the use of this article? In Delphi 3 and above, we have the capability of specifying a cell in a DBGrid to be a drop-down edit." Well, that's the thing, isn't it? You have to fill in the values of the Items property yourself. What I'm suggesting here is adding a TDBLookupComboBox that will enable you to look up information from another data source. This isn't available in ANY version of Delphi. By the way, this isn't my original idea, and in fact, the technique has been around since Delphi 1. But it's valid and applicable to later versions of Delphi. The TDBGrid is an interesting component in that it's not really a "grid;" rather, it's more or less a collection of rectangles that are dynamically drawn to display data. The operative word here is "dynamic." If you take a look at the events of a TDBGrid, you'll see an event handler called OnDrawDataCell. Without going into a lot of technical mumbo-jumbo, this event is responsible for drawing data (or whatever) in the "cell" of a grid. The default action, obviously, is to display the underlying data of the grid, but since it's visible, we have the opportunity of adding some enhanced functionality. And that's exactly what we do to display a drop-down edit box. Now some of you might be thinking at this point that if we're adding our own functionality to the OnDrawDataCell, are we actually manipulating the grid itself? The answer to that is no. What we're actually doing in this case is drawing OVER the cell to make it look like the cell is a drop-down. Okay, let's get to specifics... Setting Up Your Application> The sample application that we'll be building is going to be a simple order entry screen. For simplicity's sake, we'll be using the the Orders.db and Customer.db tables from the DBDEMOS database that gets installed with Delphi, though you easily transfer what you do here to any other application where you need a lookup. For our application, we'll be using the Orders table as the data entry table, and the Customer table as the lookup to retrieve customer identifications. Okay, here we go... The first thing you need to do is to create a new application in Delphi. On the main form of the application, drop the following components: 213. Two (2) TTable Components 214. Two (2) TDatasource Components 215. One (1) TDBGrid 216. One (1) TDBLookupComboBox (You can drop this anywhere, we'll be positioning it at runtime) To make things easier, set both TTables' DatabaseName properties to "DBDEMOS." Point the first table (Table1) to ORDERS.DB, and the second table (Table2) to CUSTOMER.DB (this will be our lookup table). Point DataSource1 to Table1 and DataSource2 to Table2. In plain english, you're setting DataSource1 and Table1 to point to the data entry table, while DataSource2 and Table2 point to the lookup data table. From there it's a matter of setting DBGrid1 to point to DataSource1. Now with the TDBLookupComboBox, you've got to set a few properties, which is why I separated its setup from the other components. Besides, setting the properties of a TDBLookupComboBox has caused more than enough consternation among developers over time. From my point of view, or at least from what I remember when I wanted to just use this component by itself, one of the most confusing things about it was the way the properties were listed in the object inspector. But I guess that's neither here nor there. In any case here's what you do: 11. Set the DataSource property to DataSource1 (the same one that the DBGrid points to). 12. Set the DataField property to the CustNo field (this is the field that you're going to put lookup information into). 13. Now, set the ListSource property to DataSource2 14. Set the ListField property to the CustNo field. 15. This one's important: Drop down the KeyField property field and select CustNo from the list (It's the only field available). This will form the link between the two tables. 16. Finally, set the Visible property of the component to False - I'll explain that in a bit. Once you're done with the steps above, set the Active properties of both tables to True. If you've done everything right, data should be displaying in the grid and you should see a value appear in the DBLookupComboBox. Now on to coding... Making It Work As I mentioned above, in order to make it appear that the DBGrid has a drop-down lookup, we use the OnDrawDataCell to draw the lookup combo box over the cell in which we want to get lookup information. In order to make this totally seamless to the user, we have to fulfill a few criteria: 26. Move and size the DBLookupComboBox over the cell in which we want to look up information. 27. Handle the lookup's visibility as the user scrolls from cell to cell in grid. 28. Handle focus control when the user enters the lookup cell. 29. Handle movement out of the DBLookupComboBox

1158

The first and second criteria are easily met by writing code for OnDrawDataCell and OnColExit event handlers on the grid: procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); begin //Regardless of cell, do we have input focus? Also, //is the field we're on the same as the data field //pointed to by the DBLookupComboBox? If so, then //Move the component over the cell. if ((gdFocused in State) AND (Field.FieldName = DBLookupComboBox1.DataField)) then with DBLookupComboBox1 do begin Left := Rect.Left + DBGrid1.Left; Top := Rect.Top + DBGrid1.Top; Width := Rect.Right - Rect.Left; if ((Rect.Bottom - Rect.Top) > Height) then Height := Rect.Bottom - Rect.Top; Visible := True; end; end; procedure TForm1.DBGrid1ColExit(Sender: TObject); begin //Are we leaving the field in the grid that //is also the data field for our lookup? with DBGrid1, DBLookupComboBox1 do if (SelectedField.FieldName = DataField) then Visible := False; end; As you can see above, the OnDrawDataCell event handles the movement and sizing of the DBLookupComboBox and sets its visibility to True, while the OnColExit sets its visibility to False. In both cases, the conditional statement includes a comparison between the grid's field and the data field pointed to by the combo box. If they're the same, then they act. In the case of the OnDrawDataCell event though, the conditional also includes an evaluation of the State parameter. This is incredibly important because we only want to perform the drawing if a cell has input focus. If we were to remove this conditional, the component would be continuously drawn, causing an irritating strobe. Not good. The third criteria exists because the DBLookupComboBox is not really part of the grid; it merely floats above it. Furthermore, since we're controlling the combo's behavior from the grid, it really doesn't ever receive input focus. The net result is that keystrokes don't get sent to the combo box, they get sent to the grid, even if the combo is displaying above the cell and is highlighted! If you tried typing a new customer number into the DBLookupComboBox at this point, nothing would appear to be happening. The combo box would remain highlighted. Actually, there is something happening - the grid's cell is actually getting updated. But you can't see it. In that case, what we have to do is make the grid give focus to the combo box as keys are pressed, and the place you do this is in the OnKeyPress event of the grid: //If you edit the value in the lookup field, the grid actually //has focus, so unless the keystroke is a Tab, then we need to //send keystrokes to the LookupCombo procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char); begin if (Key <> Chr(9)) then with DBGrid1, DBLookupComboBox1 do if (SelectedField.FieldName = DataField) then begin SetFocus; SendMessage(Handle, WM_CHAR, Word(Key), 0); end; end; The code above first checks the keypress to see if it isn't a Tab. If it was, it's ignored, and the user can move to an adjacent cell. But for any other key, we do our conditional to see if the field in the cell is the same as the data field for the combo. In that case, focus is set to the DBLookupComboBox and we send the keystroke message to it using the Win API SendMessage function. As much as possible, you want to avoid going to the Win API, but in this case, it's the only way to send a message. Building on the third criteria, once you give focus control to the DBLookupCombo, it keeps focus. That's not bad in and of itself, but there's a catch. When you Tab out of the box, what happens is that focus is returned

1159

to the grid, but focus is also returned to the underlying cell. This means that in order to move to the next field, the user is forced to press Tab twice! There's no way to get around this phenomenon. However, there is a bit of trickery you can perform that will programmatically send another Tab to the grid. You do this in the OnKeyUp event of the DBGrid: //If you choose an item from the lookup, you give focus //control to it. The net result is that it takes two //Tabs to move to the next cell. In that case, we need //to send another Tab keystroke to the grid so that only //one keystroke is needed to move to the next cell. procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key in [VK_TAB]) and InBox then begin SendMessage(DBGrid1.Handle, WM_KEYDOWN, Key, 0); InBox := False; end; end; Notice the variable that's being set here: InBox. This is an implemenation-level variable that is used to determine whether or not the user has entered the CustNo cell. It's set to True in the OnEnter event of the combo box. Then in the OnKey up, if InBox is true and the keypress was a Tab, then we send the keystroke again. Otherwise, it's ignored. Here's the OnEnter of the DBLookupComboBox: procedure TForm1.DBLookupComboBox1Enter(Sender: TObject); begin InBox := True; end; Pretty straight forward.... But there is just one more tidbit that I have to throw at you to make this work problem-free. One Last Tidbit There's an option in the options property of the TDBGrid called dgCancelOnExit. This option is defined as follows in the online help: When the user exits the grid from an inserted record to which the user made no modifications, the inserted record is not posted to the dataset. This prevents the inadvertent posting of empty records. What does this have to do with what we're doing here? Well, let's say you insert a new record into the grid. If you immediately click on the CustNo lookup combo, your new record will disappear. Why? Well, based upon the definition above and based upon the code presented here, if you went to the CustNo field immediately following an insert, the grid would lose input focus! When dgCancelOnExit is set to True, if the grid loses focus before the record has been posted, the new row is deleted. Luckily, setting this option to False alleviates the problem. Putting It All Together To make the job of performing this technique easier, here's the full code listing of the form I used for the sample application: unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, DBCtrls, Db, DBTables; type TForm1 = class(TForm) Table1: TTable; DataSource1: TDataSource; DataSource2: TDataSource; Table2: TTable; Table1OrderNo: TFloatField; Table1CustNo: TFloatField; Table1SaleDate: TDateTimeField; Table1ShipDate: TDateTimeField; Table1EmpNo: TIntegerField; Table1AmountPaid: TCurrencyField; Table2CustNo: TFloatField; DBLookupComboBox1: TDBLookupComboBox; DBGrid1: TDBGrid; procedure DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;

1160

Field: TField; State: TGridDrawState); procedure DBGrid1ColExit(Sender: TObject); procedure DBGrid1KeyPress(Sender: TObject; var Key: Char); procedure DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure DBLookupComboBox1Enter(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation var InBox : Boolean; {$R *.DFM} procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); begin //Regardless of cell, do we have input focus? Also, //is the field we're on the same as the data field //pointed to by the DBLookupComboBox? If so, then //Move the component over the cell. if (gdFocused in State) AND (Field.FieldName = DBLookupComboBox1.DataField) then with DBLookupComboBox1 do begin Left := Rect.Left + DBGrid1.Left; Top := Rect.Top + DBGrid1.Top; Width := Rect.Right - Rect.Left; if ((Rect.Bottom - Rect.Top) > Height) then Height := Rect.Bottom - Rect.Top; Visible := True; end; end; procedure TForm1.DBGrid1ColExit(Sender: TObject); begin //Are we leaving the field in the grid that //is also the data field for our lookup? with DBGrid1, DBLookupComboBox1 do if (SelectedField.FieldName = DataField) then Visible := False; end; //If you edit the value in the lookup field, the grid actually //has focus, so unless the keystroke is a Tab, then we need to //send keystrokes to the LookupCombo procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char); begin if (Key <> Chr(9)) then with DBGrid1, DBLookupComboBox1 do if (SelectedField.FieldName = DataField) then begin SetFocus; SendMessage(Handle, WM_CHAR, Word(Key), 0); end; end; //If you choose an item from the lookup, you give focus //control to it. The net result is that it takes two //Tabs to move to the next cell. In that case, we need //to send another Tab keystroke to the grid so that only

1161

//one keystroke is needed to move to the next cell. procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key in [VK_TAB]) and InBox then begin SendMessage(DBGrid1.Handle, WM_KEYDOWN, Key, 0); InBox := False; end; end; procedure TForm1.DBLookupComboBox1Enter(Sender: TObject); begin InBox := True; end; end. So now, you have everything you need to "drop" a TDBLookupComboBox onto a grid. By the way, you can use this technique for ANY windowed component; that is, any component that has a Handle property. This includes forms, panels, memos, etc.. Try it out!

1162

Defining a BDE Alias in Code

This Technical Information document will help step thru concepts regarding the creation and use of ALIASES within your Delphi Applications. Typically, you use the BDE Configuration Utility BDECFG.EXE to create and configure aliases outside of Delphi. However, with the use of the TDatabase component, you have the ability to create and use this ALIAS within your application-- not pre-defined in the IDAPI.CFG. The ability to create Aliases that are only available within your application is important. Aliases specify the location of database tables and connection parameters for database servers. Ultimately, you can gain the advantages of using ALIASES within your applications-- without having to worry about the existance of a configuration entry in the IDAPI.CFG when you deploy your application. Summary of Examples: Example #1: Example #1 creates and configures an Alias to use STANDARD (.DB, .DBF) databases. The Alias is then used by a TTable component. Example #2: Example #2 creates and configures an Alias to use an INTERBASE database (.gdb). The Alias is then used by a TQuery component to join two tables of the database. Example #3: Example #3 creates and configures an Alias to use STANDARD (.DB, .DBF) databases. This example demonstrates how user input can be used to configure the Alias during run-time. Example #1: Use of a .DB or .DBF database (STANDARD) 217. Create a New Project. 218. Place the following components on the form: - TDatabase, TTable, TDataSource, TDBGrid, and TButton. 219. Double-click on the TDatabase component or choose Database Editor from the TDatabase SpeedMenu to launch the Database Property editor. 220. Set the Database Name to 'MyNewAlias'. This name will serve as your ALIAS name used in the DatabaseName Property for dataset components such as TTable, TQuery, TStoredProc. 221. Select STANDARD as the Driveer Name. 222. Click on the Defaults Button. This will automatically add a PATH= in the Parameter Overrides section. 223. Set the PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA) 224. Click the OK button to close the Database Dialog. 225. Set the TTable DatabaseName Property to 'MyNewAlias'. 226. Set the TDataSource's DataSet Property to 'Table1'. 227. Set the DBGrid's DataSource Property to 'DataSource1'. 228. Place the following code inside of the TButton's OnClick event. procedure TForm1.Button1Click(Sender: TObject); begin Table1.Tablename:= 'CUSTOMER'; Table1.Active:= True; end; 229. Run the application. *** If you want an alternative way to steps 3 - 11, place the following code inside of the TButton's OnClick event. procedure TForm1.Button1Click(Sender: TObject); begin Database1.DatabaseName:= 'MyNewAlias'; Database1.DriverName:= 'STANDARD'; Database1.Params.Clear; Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA'); Table1.DatabaseName:= 'MyNewAlias'; Table1.TableName:= 'CUSTOMER'; Table1.Active:= True; DataSource1.DataSet:= Table1; DBGrid1.DataSource:= DataSource1;

1163

end; Example #2: Use of a INTERBASE database 17. Create a New Project. 18. Place the following components on the form: - TDatabase, TQuery, TDataSource, TDBGrid, and TButton. 19. Double-click on the TDatabase component or choose Database Editor from the TDatabase SpeedMenu to launch the Database Property editor. 20. Set the Database Name to 'MyNewAlias'. This name will serve as your ALIAS name used in the DatabaseName Property for dataset components such as TTable, TQuery, TStoredProc. 21. Select INTRBASE as the Driver Name. 22. Click on the Defaults Button. This will automatically add the following entries in the Parameter Overrides section. SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB USER NAME=MYNAME OPEN MODE=READ/WRITE SCHEMA CACHE SIZE=8 LANGDRIVER= SQLQRYMODE= SQLPASSTHRU MODE=NOT SHARED SCHEMA CACHE TIME=-1 PASSWORD= 23. Set the following parameters SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB USER NAME=SYSDBA OPEN MODE=READ/WRITE SCHEMA CACHE SIZE=8 LANGDRIVER= SQLQRYMODE= SQLPASSTHRU MODE=NOT SHARED SCHEMA CACHE TIME=-1 PASSWORD=masterkey 24. Set the TDatabase LoginPrompt Property to 'False'. If you supply the PASSWORD in the Parameter Overrides section and set the LoginPrompt to 'False', you will not be prompted for the password when connecting to the database. WARNING: If an incorrect password in entered in the Parameter Overrides section and LoginPrompt is set to 'False', you are not prompted by the Password dialog to re-enter a valid password. 25. Click the OK button to close the Database Dialog. 26. Set the TQuery DatabaseName Property to 'MyNewAliias'. 27. Set the TDataSource's DataSet Property to 'Query1'. 28. Set the DBGrid's DataSource Property to 'DataSource1'. 29. Place the following code inside of the TButton's OnClick event. procedure TForm1.Button1Click(Sender: TObject); begin Query1.SQL.Clear; Query1.SQL.ADD( 'SELECT DISTINCT * FROM CUSTOMER C, SALES S WHERE (S.CUST_NO = C.CUST_NO) ORDER BY C.CUST_NO, C.CUSTOMER'); Query1.Active:= True; end; 30. Run the application. Example #3: User-defined Alias Configuration This example brings up a input dialog and prompts the user to enter the directory to which the ALIAS is to be configured to. The directory, servername, path, database name, and other neccessary Alias parameters can be read into the application from use of an input dialog or .INI file. 30. Follow the steps (1-11) in Example #1. 31. Place the following code inside of the TButton's OnClick event. procedure TForm1.Buttton1Click(Sender: TObject); var NewString: string; ClickedOK: Boolean; begin NewString := 'C:\'; ClickedOK := InputQuery('Database Path',

1164

'Path: --> C:\DELPHI\DEMOS\DATA', NewString); if ClickedOK then begin Database1.DatabaseName:= 'MyNewAlias'; Database1.DriverName:= 'STANDARD'; Database1.Params.Clear; Database1.Params.Add('Path=' + NewString); Table1.DatabaseName:= 'MyNewAlias'; Table1.TableName:= 'CUSTOMER'; Table1.Active:= True; DataSource1.DataSet:= Table1; DBGrid1.DataSource:= DataSource1; end; end; 32. Run the Application. BDE alias info From: "Sven Lindhardt" > > Does anyone know how to interrogate the IDAPI configuration to get the directory mapping for an alias? > Take a look at the GetAliasParams Method of TSession. The returned stringlist will contain the path. I use the following function: uses

DbiProcs, DBiTypes;

function GetDataBaseDir(const Alias : string): String; (* Will return the directory of the database given the alias (without trailing backslash) *) var sp : PChar; Res : pDBDesc; begin try New(Res); sp := StrAlloc(length(Alias)+1); StrPCopy(sp,Alias); if DbiGetDatabaseDesc(sp,Res) = 0 then Result := StrPas(Res^.szPhyName) else Result := ''; finally StrDispose(sp); Dispose(Res); end; end;

1165

FONTS

230. 231. 232. 233. 234. 235.

How can my app use MY FONTS? not user's Include Font as a Resource in *.EXEfonts1 Font & Tregistry Store Fontstyle in INI Determining which font (Large or Small) is in use Font Sites

How can my app use MY FONTS? not user's

From: [email protected] (Brad Choate) Can someone please tell me the neatest way to make sure my app uses fonts that I can provide, rather than the nearest font the user has installed on their system? I have tried copying a #.ttf file into the users windows\system directory but the app still can't pick it up. The following is some Delphi 1 code that I have used for successfully installing dynamic fonts that are only loaded while the application is running. You can place the font file(s) within the application directory. It will be installed when the form loads and unloaded once the form is destroyed. You may need to modify the code to work with Delphi 2 since it calls various Windows API calls that may or may not have changed. Where you see "..." in the code, that is just to identify that other code can be placed there. Of course, substitute "MYFONT" for the name of your font file. type TForm1=class( TForm ) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); ... private { Private declarations } bLoadedFont: boolean; public { Public declarations } end; procedure TForm1.FormCreate(Sender: TObject); var sAppDir: string; sFontRes: string; begin sAppDir := Application.ExeName; sAppDir := copy( sAppDir, 1, rpos( '\', sAppDir ) ); sFontRes := sAppDir + 'MYFONT.FOT'; if not FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; sFont := sAppDir + 'MYFONT.TTF' + #0; CreateScalableFontResource( 0, @sFontRes[ 1 ], @sFont[ 1 ], nil ); end; sFontRes := sAppDir + 'MYFONT.FOT'; if FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then

1166

bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; ... end; procedure TForm1.FormDestroy(Sender: TObject); var sFontRes: string; begin if bLoadedFont then begin sFontRes := sAppDir + 'MYFONT.FOT' + #0; RemoveFontResource( @sFontRes[ 1 ] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; From: Paul Munn I've worked with the fonts code and have some corrections for you to make it work with Delphi 2.0. I have not tried this on Delphi 3.0. Information in an InstallShield article about installing fonts reveals that you do not need a FOT file in Win95 and WinNT environments. You only need the TTF file. Resulting FormCreate code is as follows: var sAppDir, sFontRes: string; begin {...other code...} sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF'; if FileExists( sFontRes ) then begin sFontRes := sFontRes + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then bLoadedFont := false else begin bLoadedFont := true; SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; end; {...} end; {FormCreate} The resulting FormDestroy code is as follows: var sFontRes, sAppDir: string; begin {...other code...} if bLoadedFont then begin sAppDir := extractfilepath(Application.ExeName); sFontRes := sAppDir + 'MYFONT.TTF' + #0; RemoveFontResource( @sFontRes[ 1 ] );

1167

SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; {...other code...} end; {FormDestroy} To simplify these, I have created a simple function which can do both of these tasks. It returns a boolean which says whether or not the loading or unloading of the font was successful. {1998-01-16 Font loading and unloading function.} function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean; var sFont, sAppDir, sFontRes: string; begin result := TRUE; if bLoadIt then begin {Load the font.} if FileExists( sFontFileName ) then begin sFontRes := sFontFileName + #0; if AddFontResource( @sFontRes[ 1 ] ) = 0 then result := FALSE else SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end else begin {Unload the font.} sFontRes := sFontFileName + #0; result := RemoveFontResource( @sFontRes[1] ); SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); end; end; {LoadFont}

Include Font as a Resource in *.EXE

From: "Steve Harman" Include a font in your EXE: 33. Using your favorite text editor, create a *.rc file that describes the font: MY_FONT ANYOL1 "Bauhs93.ttf" The first two parameters can be whatever you want. They get used in your program later. 34. Then, use the BRCC32.EXE command line compiler that ships with Delphi to create a *.res file. If your file in step 1 was MyFont.rc, the command from the DOS prompt would be: BRCC32 MyFont The program will append the .rc to the input, and create a file with the same name except it appends .res: MyFont.res 35. In your program, add a compiler directive to include your newly created file:

1168

{$R MyFont.res} This can go right after the default {$R *.DFM} in the implementation section. 36. Add a procedure to create a file from the resource, then make the Font available for use. Example: procedure TForm1.FormCreate(Sender: TObject); var Res : TResourceStream; begin Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1')); Res.SavetoFile('Bauhs93.ttf'); Res.Free; AddFontResource(PChar('Bauhs93.ttf')); SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end; 37. You can now assign the font to whatever you wish: procedure TForm1.Button1Click(Sender: TObject); begin Button1.Font.Name := 'Bauhaus 93'; end; Caveats: The above example provides for no error checking whatsoever. :-) Notice that the File name is NOT the same as the Font name. It's assumed that you know the font name associated with the file name. You can determine this by double clicking on the file name in the explorer window. I would recommend placing your font file in the C:\WINDOWS\FONTS folder. It's easier to find them later. Your newly installed font can be removed programatically, assuming the font is not in use anywhere: procedure TForm1.FormDestroy(Sender: TObject); begin RemoveFontResource(PChar("Bauhs93.ttf")) SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0); end; Check the Win32 help for further details on the AddFontResource and RemoveFontResource. Font & Tregistry See here Store Fontstyle in INI See here Determining which font (Large or Small) is in use See here Font Sites This does not really belong to the UDDF, but I use a font or two in my applications, so I wanted to add it here any way. I'm still building this part, so the Free buttons are not all included yet. The Font Empire

http://members.aol.com/JR9er/index.html

True Type Resource

http://fontempire.host4u.com

Frontation Fontfusion

http://users.skynet.be/micheyva/ http://www.ccse.net/~harris/

1169

FA - PC ****MANY Truetype Links Create 8 · Fonts

Floor 13: TT font arch. Previews OMEGA Font Labs

Scriptorium Home Page Brain Stew Font Archive Vernalex Fonts (a few dozen ttf) Choose your font ! ...STYLEsolutions

sokrates' useful links sokratype main - food for your typewriter fontastic! - overview

http://home1.gte.net/tiaralyn/pctt.htm http://thomas.simplenet.com/fonts/

http://freespace.virgin.net/james.devlin/frame. htm http://members.tripod.com/~DrNimbus/

http://ragnarokpress.com/scriptorium/ http://home.industrynet.net/brainstew/archive. html http://www.geocities.com/TimesSquare/6864/f onts.html http://prinz.hannover.sghnet.de/~mischulz/fonts.html

http://www.datacomm.ch/sokrates/useful.html http://www.datacomm.ch/sokrates/sokratype/f ontsmain.html http://rover.wiesbaden.netsurf.de/~kikita/font. htm

All Good Thing Typography - Redsun Home Page http://www.redsun.com/ http://www.ora.com/homepages/comp.fonts/if Internet Font Archives a/index.htm Softy TT editor http://home.iclweb.com/icl1/d.w.emmett/ Kemosabe's Font Source -- from a.b.f http://magnagraphics.com/fonts/ retype - typefaces by christopher houston http://users.iafrica.com/c/ch/chouston/ emerald city fontwerks http://www.speakeasy.org/~ecf/ http://freespace.virgin.net/james.devlin/ http://www.freeyellow.com/members2/neatca p/ RudynFluffy's World: some fonts http://www.geocities.com/SoHo/Studios/5424/ http://www.sentex.net/~jmartz/attack/fonts.ht Robotic Attack Fonts - The Fonts ml http://www.bitstream.net/chankstore/table.htm The Chankstore l Chank: gas - monkies - tacos - fonts http://www.chank.com/fuelfonts/free.htm http://web.idirect.com/~experts/cheops/fonts.h Cheops Fonts: !original tml Cheops Font Utilities http://web.idirect.com/~experts/cheops/utils.ht Font Garden ml

1170

http://web.idirect.com/~experts/font/index.html http://lothlorien.simplenet.com/fonts/fontdepot/font depot.html ACiD Productions Home Page Janda Web!: fonts, graphics

gaston yagmourian : type: T1!, Dali-inspired, etc wonderweb free font site

http://www.acid.org/apps/apps.html http://www.acid.org/ http://www.geocities.com/~jandaweb/

http://tausystems.com/gaston/type-index.html http://www.mabb.com/library.htm No longer available (only Netscape supported)

1171

http://www.angelfire.com/ok/markandstacey

1172

236. 237. 238. 239. 240. 241. 242. 243.

MDI Forms Hiding MDI Child Forms Just 1 MDI-childwindow ? Making MDI Forms 'more' 3D Tile Image in a MDI Form Remove title bar in MDI child form MDI Children Menus MDIChild Close problem MDI Parent Background

244. Creating MDI child forms in a DLL and calling them from an MDI parent executable...? mdifrm8 Hiding MDI Child Forms Ian Foster wrote: > > Can anyone help me with a way to hide MDIChild forms in an MDI application. Ideally I would not like to have a minimised form on the parent form as the default, but perhaps have an icon displayed on the parent form. This is a feature of Win 95. It's how minimized MDI childs are supposed to look. But, try to override WM_PAINT (or maybe you need WM_NCPAINT), check IsIconized, and draw your icon as you please. > Currently if I just try to hide the child, I get an error that tells me that it's an invalid method on a child form. Try ShowWindow(MdiChild1.Handle, SW_HIDE), and see what happens. Just 1 MDI-childwindow ? Solution 1 From: [email protected] (Bill Brown) If you want to limit an MDI application to only one child window open at any given time, look at the MDIChildCount property of the MDI parent form. If it is greater than 0, don't create the new child. If you want to allow multiple MDI children forms but no duplicates of any particular type of form (ie: only one invoice form, only one sales rep form, etc.), you will could loop through the MDI children to see if the one about to be created already exists. Again, the key to this is in the MDI parent form. Example code: ChildIndex := 0 while (ChildIndex < frmMDIParent.ChildCount) and (frmMDIParent.MDIChildren[ChildIndex].Name <> frmNewChild.Name) do Inc(ChildIndex); if ChildIndex = frmMDIParent.ChildCount then {create new child here} begin Create it... if no exception occurred, then show it... end else {child form already exists so just bring it to the top} frmMDIParent.MDIChildren[ChildIndex].BringToFront; Solution 2 From: "Carl Clark" How about, if Form1 <> nil then begin Form1 := TForm1.Create(Application); Form1.Show;

1173

end; Then in Form1's OnClose: Action := caFree; Form1 := nil; Making MDI Forms 'more' 3D

From: [email protected] (KIM GREVE) CF>How do I make an MDI Form appear 'more' 3D (like M$ progs)? This is from the Tips & Tricks section in The Delphi Magazine. constructor TMainForm.Create(AOwner: TComponent); begin Inherited Create(AOwner); SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle, GWL_EXSTYLE) or WS_EX_CLIENTEDGE); SetWindowPos(ClientHandle, 0, 0, 0, 0, 0, swp_DrawFrame or swp_NoMove or swp_NoSize or swp_NoZOrder); end; Tile Image in a MDI Form

Michael Ax >Hello to All! > >Does somebody know how to put an image in a MDI form and make >Tile with her? yes. that's the easy part.. procedure TForm.OnPaint(Sender: TObject); procedure Tile(c:TCanvas;b:TBitMap); var x,y,h,w,i,j:integer; begin with b do begin h:=b.height; w:=b.width; end; y:=0; with c.Cliprect do begin i:=bottom-top-1; //height j:=right-left-1; //width end; while y
1174

Remove title bar in MDI child form

Solution 1 From: [email protected] We were able to kill the title bar of an MDI child by doing the following: type TForm2 = class(TForm) { other stuff above } procedure CreateParams(var Params: TCreateParams); override; { other stuff below } end; procedure TForm2.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER end; Solution 2 From: [email protected] (Andy McFarland) For an MDI child form, setting the BorderStyle to bsNone does NOT remove the title bar. (This is mentioned in the help). This does it: Procedure tMdiChildForm.CreateParams( var Params : tCreateParams ) ; Begin Inherited CreateParams( Params ) ; Params.Style := Params.Style and (not WS_CAPTION) ; End ; MDI Children Menus

From: [email protected] You can set a number to indicate the position of the menu in the new menu bar that is compiled from the menues in the MDI form and the menues in the child form. This is called the group index. It only works for the menu items visible on the menu line. So for example if your MDI menu has: File View About (with the group index values of 1 5 10) (It does not matter exactly what numbers you chose, they are only used for sorting.) And your child menu has: File Edit (and they have the values 1 and 3) When you open a child window the child File menu item will replace the MDI form menu item. The Edit menu item will be inserted before View and About from the MDI form. This is quite useful since you can have lesser choices on the File menu of the MDI form compared to what should be there when you have a child window open. You do not need Save or Close on the MDI form File menu but you need Open and New for example. But you have to enter all menu lines on the File menu in the child menu control since that will replace the File menu from the MDI parent. You can still use the code from the parent in the child. So if you have a procedure "parent.open1click" You can call that from the child file menu open event. MDIChild Close problem

From: [email protected] (Roy H. Jennings, Jr.) Don't attempt to destroy the form from within itself. Setting action to caFree in the form close event will cause the parent window to destroy the form.

1175

You probably need to implement the closequery event to prevent the form from closing when table1 is in edit mode or at least all the user the option of abandoning changes. The MDIparent window should have a menu option that closes the currently active mdi child window. If not you can add one and execute the following from the click method: ActiveMDIChild.Close; Try something like the following: procedure TFrmServers.FormClose(Sender:TObject; var Action:TCloseAction); begin Action := caFree; end; procedure TFrmServers.FormDestroy begin Table1.Close; end; procedure TFrmServers.FormCloseQuery begin if table1.state in [dsEdit,dsInsert] then begin // warn user that changes will be lost and // ask if ok to close if not UserSaysOk then CanClose := False; end; end; MDI Parent Background From: Dave Horacek Here's some code that may prove useful. It is for either a normal form or an MDI form and tiles a bitmap or produces gradients. The only tricky part is establishing the window message handler for the ClientHandle of the window that actually manages the child forms. That's where the bitmaps and graphics actually appear in an MDI form. Just load a bitmap into imgTile at design time and you're ready to go. unit UMain; interface uses Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms, Dialogs, ExtCtrls, Menus; type TfrmMain = class(TForm) mnuMain: TMainMenu; mnuFile: TMenuItem; mnuExit: TMenuItem; imgTile: TImage; mnuOptions: TMenuItem; mnuBitmap: TMenuItem; mnuGradient: TMenuItem; procedure mnuExitClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure mnuBitmapClick(Sender: TObject); procedure mnuGradientClick(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure FormResize(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } MDIDefProc:pointer;

1176

MDIInstance:TFarProc; procedure MDIWndProc(var prmMsg:TMessage); procedure CreateWnd;override; procedure ShowBitmap(prmDC:hDC); procedure ShowGradient(prmDC:hDC;prmRed,prmGreen,prmBlue:byte); public { Public declarations } end; var frmMain: TfrmMain; glbImgWidth:integer; glbImgHeight:integer; implementation {$R *.DFM} procedure TfrmMain.FormCreate(Sender: TObject); begin glbImgHeight:=imgTile.Picture.Height; glbImgWidth:=imgTile.Picture.Width; end; procedure TfrmMain.FormResize(Sender: TObject); begin FormPaint(Sender); end; procedure TfrmMain.MDIWndProc(var prmMsg:TMessage); begin with prmMsg do begin if Msg=WM_ERASEBKGND then begin if mnuBitmap.Checked then ShowBitmap(wParam) else ShowGradient(wParam,255,0,0); Result:=1; end else Result:=CallWindowProc(MDIDefProc,ClientHandle,Msg,wParam,lParam); end; end; procedure TfrmMain.CreateWnd; begin inherited CreateWnd; MDIInstance:=MakeObjectInstance(MDIWndProc); { create wrapper } MDIDefProc:=pointer(SetWindowLong(ClientHandle,GWL_WNDPROC, longint(MDIInstance)) ); end; procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin { restore default window proc } SetWindowLong(ClientHandle,GWL_WNDPROC,longint(MDIDefProc)); { dispose of instance } FreeObjectInstance(MDIInstance); end; procedure TfrmMain.mnuExitClick(Sender: TObject); begin close;

1177

end; procedure TfrmMain.mnuBitmapClick(Sender: TObject); var wrkDC:hDC; begin wrkDC:=GetDC(ClientHandle); ShowBitmap(wrkDC); ReleaseDC(ClientHandle,wrkDC); mnuBitmap.Checked:=true; mnuGradient.Checked:=false; end; procedure TfrmMain.mnuGradientClick(Sender: TObject); var wrkDC:hDC; begin wrkDC:=GetDC(ClientHandle); ShowGradient(wrkDC,0,0,255); ReleaseDC(ClientHandle,wrkDC); mnuGradient.Checked:=true; mnuBitMap.Checked:=false; end; procedure TfrmMain.ShowBitmap(prmDC:hDC); var wrkSource:TRect; wrkTarget:TRect; wrkX:integer; wrkY:integer; begin {tile bitmap } if FormStyle=fsNormal then begin wrkY:=0; while wrkY < ClientHeight do { go from top to bottom.. } begin wrkX:=0; while wrkX < ClientWidth do { ..and left to right. } begin Canvas.Draw(wrkX,wrkY,imgTile.Picture.Bitmap); Inc(wrkX,glbImgWidth); end; Inc(wrkY,glbImgHeight); end; end else if FormStyle=fsMDIForm then begin Windows.GetClientRect(ClientHandle,wrkTarget); wrkY:=0; while wrkY < wrkTarget.Bottom do begin wrkX:=0; while wrkX < wrkTarget.Right do begin BitBlt(longint(prmDC),wrkX,wrkY,imgTile.Width,imgTile.Height, imgTile.Canvas.Handle,0,0,SRCCOPY); Inc(wrkX,glbImgWidth); end; Inc(wrkY,glbImgHeight); end; end; end; procedure TfrmMain.ShowGradient(prmDC:hDC;prmRed,prmGreen,prmBlue:byte); var

1178

wrkBrushNew:hBrush; wrkBrushOld:hBrush; wrkColor:TColor; wrkCount:integer; wrkDelta:integer; wrkRect:TRect; wrkSize:integer; wrkY:integer; begin { gradient routine } wrkDelta:=255 div (1+ClientHeight); { number of shades desired } if wrkDelta=0 then wrkDelta:=1; { yes, usually 1 } wrkSize:=ClientHeight div 240; { size of blended bars } if wrkSize=0 then wrkSize:=1; for wrkY:=0 to 1+(ClientHeight div wrkSize) do begin wrkColor:=RGB(prmRed,prmGreen,prmBlue); wrkRect:=Rect(0,wrkY*wrkSize,ClientWidth,(wrkY+1)*wrkSize); if FormStyle=fsNormal then begin Canvas.Brush.Color:=wrkColor; Canvas.FillRect(wrkRect); end else if FormStyle=fsMDIForm then begin wrkBrushNew:=CreateSolidBrush(wrkColor); wrkBrushOld:=SelectObject(prmDC,wrkBrushNew); FillRect(prmDC,wrkRect,wrkBrushNew); SelectObject(prmDC,wrkBrushOld); DeleteObject(wrkBrushNew); end; if prmRed >wrkDelta then Dec(prmRed,wrkDelta); if prmGreen > wrkDelta then Dec(prmGreen,wrkDelta); if prmBlue > wrkDelta then Dec(prmBlue,wrkDelta); end; end; procedure TfrmMain.FormPaint(Sender: TObject); begin if FormStyle=fsNormal then if mnuBitMap.Checked then mnuBitMapClick(Sender) else mnuGradientClick(Sender); end; end.

Creating MDI child forms in a DLL and calling them from an MDI parent executable...?

Creating MDI child forms in a DLL and calling them from an MDI parent executable...?

1179

From: [email protected] Basically you have to do a number of things to get DLL forms to appear as MDI child windows. The nice thing is, you can add the WINDOWS main menu to your main exe menu, and all child windows appear under this window when created! Here goes: First, I assume you are loading the DLLs dynamically? With LoadLibrary and GetProcAddress?? If not, you will need to do so, as far as I know. The key is to pass the Application.Handle to the DLLs, and assign that passed variable to the Application.Handle in each DLL. Also, each DLL should export the same procedure or function name. Your main exe that loads the DLLs should keep a TLIST of each DLLs HANDLE. That is to say, when you load a DLL dynamically, you MUST keep it "alive" by not freeing (freelibrary) its handle. Thus, you need some way to keep track of every DLL you load. The easiest way is to use a TLIST. I will show you: PROGRAM MainProgram; INTERFACE uses Windows, etc...; IMPLEMENTATION type SimpleProc = procedure; stdcall; DLLInitProc = procedure( AppHandle : HWND; CallBackProc : SimpleProc ); stdcall; var HandleList : TList; DLLCallProc : SimpleProc; procedure LoadDLL( name : string ); var DLLHandle : THandle; DLLInit : DLLInitProc; begin if FileExists( name ) then begin DLLHandle := LoadLibrary( name ); if DLLHandle <> 0 then begin // loaded, so get the procedure we call to pass info to it @DLLInit := GetProcAddress( DLLHandle, 'ExportedDLLProc' ); if Assigned( DLLInit ) then begin // the DLL exported procedure is found, so lets call it DLLInit( Application.Handle, DLLCallProc ); // now we save this DLLs handle to later FREE it // when the program ends. HandleList.Add( DLLHandle );

end; end; end; end;

procedure LoadAllDLLs; begin // without coding it, somehow you will have to // figure out how to find ALL the dlls path/filenames // possibly in a .CFG file, the Registry, etc.

1180

// loop, getting each path/filename string LoadDLL( DLLName ); // DLLName = path/filename end; procedure TForm1.SomeMenuItemClickToOpenDLLWindow; begin DLLCallProc; // call the passed back DLL proc end; INITIALIZATION HandleList := TList.Create; FINALIZATION HandleList.Free; END. DLL CODE: LIBRARY DLLUnit; INTERFACE USES DLLSource in 'DLLSource.pas'; EXPORTS DLLInit name 'DLLInit'; IMPLEMENTATION END.

UNIT DLLSource; INTERFACE uses Windows, etc..; procedure DLLInit( AppHandle : HWND ); stdcall; export; IMPLEMENTATION USES DLLFormSource; var OldAppHandle : THandle; procedure HandleMenuClick; begin if Form1 = nil then DLLForm := TDLLForm.Create( Application.Handle ) else BringWindowToTop( Form1.Handle ); end; procedure DLLInit; begin // first we assign the passed in Application handle Application.Handle := AppHandle;

1181

// now we assign the passed in CallBackProc to the address // of the procedure we use to handle when the user clicks // on a menu item activating this MDI form. CallBackProc := @HandleMenuClick; end; INITIALIZATION OldAppHandle := Application.Handle; FINALIZATION Application.Handle := OldAppHandle END. DLL Form source: UNIT DLLFormSource; INTERFACE USES Windows, etc..; TDllForm = class( TForm ); procedure OnClose( TObject, Action, etc); procedure OnDestroy(); end; var DLLForm : TDLLForm; IMPLEMENTATION procedure TDLLForm.OnClose; begin action := caFree; end; procedure TDLLForm.OnDestroy; begin DLLForm := nil; end; END. Ok. Ok. There is a "bit" of code here..but really its mostly done for you when you create the 2 projects. The MAIN program, you automatidcally get the main form. This is where you put the MainMenu on the form, and the handler for a menu click that calls an MDI form. Also, you make this form fsMDIForm. the DLL forms are ALL fsMDIChild. One thing I goofed on in the code above, is that I didnt create a TLIST to store each DLLS "CallbackProc" variable. That is to say, in my plug-in core, each DLL calls a REGISTER procedure passed to it just like Application.Handle is passed. Each DLL then calls that procedure (implemented in the MAIN exe program), which in turn keeps track of each DLLs "HANDLE" routine to call when the associated menu item is clicked. So, you will have to implement that if you have more than one DLL loading. And dont forget to keep all DLL handles in memory until you quit the program. Anyways. So, the MAIN program loads each DLL, and calls the DLLInit routine, passing to it the Application.Handle variable, and a variable called CallBackProc. Do NOT forget to use the STDCALL on these types of declarations. They too will generate a GPF if you dont do this. Now, this variable is passed to each DLL. It is assigned in the DLL to a procedure in the DLL. With the DLL(s) loaded in memory, if the user clicks on the menu item associated with one DLL, it then calls this routine. This routine, implemented in the DLL source, first checks to see if the dynamic form, DLLForm is created. If it is, it then brings that window to the top, just as if you selected it via the WINDOW menu. If it isn't, it CREATES it. Since the DLL forms are all MDI Child windows, they automagically appear when you create them. If you were doing a normal app (like

1182

Delphis User Interface) without MDI windows, but normal windows, then you would also need to add something like: DLLForm.Show or DLLForm.ShowModal; to the section that creates the window.

1183

DLL 245. 246. 247.

FTP4W32.DLL & Delphi 2.0 About Thunking D2 to 16bit DLL Alternatives to DLL?

248.

Creating MDI child forms in a DLL and calling them from an MDI parent executable...?dll3

FTP4W32.DLL & Delphi 2.0

From: [email protected] (Brad Stowers) Here's a unit that works for me. Also, I'm working on a component that wraps up the DLL. If anyone is interested in testing it, let me know by email ([email protected]) and I'll send it to you. unit FTP4W; { Updated Feb. 1997 by Brad Stowers ([email protected]) for use with { FTP4W v2.6. Modified to add new functions, fix some errors, make it { "cleaner", and work with Delphi 2. I do not use Delphi 1 at all, so { it is extremely likely that this won't work with Delphi 1, i.e. { 'stdcall' won't compile. If you need to use with Delphi 1, use the { Pascal 'UseFTP4W.pas' sample file, or try deleting all the 'stdcall' { directives. This code based on previous work as credited below:

} } } } } } }

{by Barbara Tikart Polarwolf Hard & Software, D-63906 Erlenbach am Main} {and AStA Uni Konstanz (AStA = Allgemeiner Studierenden Ausschuss)} {eMail to [email protected] or [email protected]} {Declarations for FTP module to use with 'FTP4W' Version 2.2g or higher} {Released into Public Domain} {Get the newest version via http://www.uni-konstanz.de/studis/asta/software/index.html } interface uses Windows, WinSock, SysUtils; const FTP4W_Loaded: boolean = FALSE; loaded. } FTP4W_RightVersion: boolean = FALSE; version of DLL. } const { Transfer modes. } TYPE_A = 'A'; TYPE_I = 'I'; TYPE_L8 = 'L'; TYPE_DEFAULT = #0; { Actions requested by FTP_STORE_ON_SERVER FTP_APPEND_ON_SERVER FTP_GET_FROM_SERVER

{ { { {

{ Check to see if the DLL was { Check to see if we have right

ASCII } Image (Bin) } Local 8 } Whatever server thinks it is. } user.... What are these? } = 65; = 87; = 223;

{ Firewall Types, for when Philippe gets firewall done. } FTP4W_FWSITE = 100; FTP4W_FWPROXY = 103; FTP4W_FWUSERWITHLOGON = 106;

1184

FTP4W_FWUSERNOLOGON

= 109;

{ Return codes of FTP functions } FTPERR_OK = 0; { succesful function } FTPERR_ENTERPASSWORD = 1; { userid need a password } FTPERR_ENTERACCOUNT = 2; { user/pass OK but account required FTPERR_ACCOUNTNEEDED = 2; { user/pass OK but account required FTPERR_RESTARTOK = 3; { Restart command successful FTPERR_ENDOFDATA = 4; { server has closed the data-conn FTPERR_CANCELBYUSER = -1; {Transfer aborted by user FtpAbort}

} } } }

{ User's or programmer's errors } FTPERR_INVALIDPARAMETER = 1000; FTPERR_SESSIONUSED = 1001; FTPERR_NOTINITIALIZED = 1002; FTPERR_NOTCONNECTED = 1003; FTPERR_CANTOPENFILE = 1004; FTPERR_CANTWRITE = 1005; FTPERR_NOACTIVESESSION = 1006; FTPERR_STILLCONNECTED = 1007; FTPERR_SERVERCANTEXECUTE = 1008; FTPERR_LOGINREFUSED = 1009; FTPERR_NOREMOTEFILE = 1010; FTPERR_TRANSFERREFUSED = 1011; FTPERR_WINSOCKNOTUSABLE = 1012; FTPERR_CANTCLOSE = 1013; FTPERR_FILELOCKED = 1014; FTPERR_FWLOGINREFUSED = 1015; FTPERR_ASYNCMODE = 1016;

{ { { { { { { { { { { { { { { { {

Error in parameters } User has already a FTP session } FtpInit has not been call } User is not connected to a server } can not open specified file } can't write into file (disk full?) } FtpRelease without FtpInit } FtpRelease without any Close } file action not taken } Server rejects usrid/passwd } server can not open file } Host refused the transfer } A winsock.DLL ver 1.1 is required } close failed (cmd is in progress) } temporary error during FtpDelete } Firewallrejects usrid/passwd } FtpMGet only in synchronous mode }

{ TCP errors } FTPERR_UNKNOWNHOST FTPERR_NOREPLY FTPERR_CANTCONNECT FTPERR_CONNECTREJECTED FTPERR_SENDREFUSED FTPERR_DATACONNECTION FTPERR_TIMEOUT FTPERR_FWCANTCONNECT FTPERR_FWCONNECTREJECTED

= = = = = = = = =

2001; 2002; 2003; 2004; 2005; 2006; 2007; 2008; 2009;

{ { { { { { { { {

can not resolve host adress } host does not send an answer } Error during connection } host has no FTP server } can't send data (network down) } connection on data-port failed } timeout occurred } Error during connection with FW } Firewall has no FTP server }

{ FTP errors } FTPERR_UNEXPECTEDANSWER FTPERR_CANNOTCHANGETYPE FTPERR_CMDNOTIMPLEMENTED FTPERR_PWDBADFMT FTPERR_PASVCMDNOTIMPL

= = = = =

3001; 3002; 3003; 3004; 3005;

{answer was not expected} { host rejects the TYPE command } { host recognize but can't exec cmd } { PWD cmd OK, but answer has no " } { Server don't support passive mode }

{ Resource errors } FTPERR_CANTCREATEWINDOW FTPERR_INSMEMORY FTPERR_CANTCREATESOCKET FTPERR_CANTBINDSOCKET FTPERR_SYSTUNKNOWN

= = = = =

5002; 5003; 5004; 5005; 5006;

{ { { { {

Insufficent free resources } Insufficient Heap memory } no more socket } bind is not succesful } host system not in the list }

{ FTP4W internal data structures You'll probably never need these. } const FTP_DATABUFFER = 4096; {a good value for X25/Ethernet/Token Ring} type PFtp_FtpData = ^TFtp_FtpData; TFtp_FtpData = packed record ctrl_socket: TSocket; INVALID_SOCKET }

{ control stream

init

1185

data_socket: TSocket; { data stream INVALID_SOCKET } cType: Char; { type (ASCII/binary) } bVerbose: Bool; { verbose mode } bPassif: Bool; { VRAI -> mode passif } nPort: u_short; { connexion Port FTP_DEFPORT } nTimeOut: u_int; { TimeOut in seconds FTP_DEFTIMEOUT } hLogFile: HFile; { Log file } szInBuf: Array [0..2047] of Char; { incoming Buffer } saSockAddr: TSockAddrIn; { not used anymore } saAcceptAddr: TSockAddrIn; { not used anymore } end; { TFtp_FtpData }

init init TYPE_A init FALSE

init init

PFtp_FileTrf = ^TFtp_FileTrf; TFtp_FileTrf = packed record hf: HFile; { handle of the file which is being transfered nCount: uint; { number of writes/reads made on a file nAsyncAlone: uint; { pause each N frame in Async mode (Def 40) nAsyncMulti: uint; { Idem but more than one FTP sssion (Def 10) nDelay: uint; { time of the pause in milliseconds bAborted: Bool; { data transfer has been canceled szBuf : Array [0..FTP_DataBuffer-1] Of Char; { Data buffer bNotify: Bool; { application receives a msg each data packet bAsyncMode: Bool; { synchronous or asynchronous Mode lPos: LongInt; { Bytes transfered lTotal: LongInt; { bytes to be transfered end; { TFtp_FileTrf }

} } } } } } } } } } }

PFtp_Msg = ^TFtp_Msg; TFtp_MSG = packed record hParentWnd: hWnd; { window which the msg is to be passed } nCompletedMessage: uint; { msg to be sent at end of the function } end; { TFtp_Msg } PFtp_Verbose = ^TFtp_Verbose; TFtp_Verbose = packed record hVerboseWnd: hWnd; { window which the message is to be passed } nVerboseMsg: uint; { msg to be sent each time a line is received } end; { TFtp_Verbose } PFtp_ProcData = ^TFtp_ProcData; TFtp_ProcData = packed record { Task data } hTask: HTask; { Task Id hFtpWindow: hWnd; { Handle of the internal window hParentWnd: hWnd; { Handle given to the FtpInit function hInstance: HInst; { Task Instance bRelease: Bool; { FtpRelease has been called { Mesasge information } MSG: TFtp_Msg; VMSG: TFtp_Verbose; { File information } FileTrf: TFtp_FileTrf; {Ftp information} Ftp: TFtp_FtpData; {Linked list} Next,

} } } } }

1186

Prev: PFtp_ProcData; end; { TFtp_ProcData } { FtpMGet callback function type. } TFtpMGetCallback = Function (szRemFile, szLocalFile: PChar; Rc: integer): bool; stdcall; { FTP4W Functions } var { Utilities functions} FtpDataPtr: function: PFtp_ProcData; stdcall; FtpBufferPtr: function: PChar; stdcall; FtpErrorString: function(Rc: integer): PChar; stdcall; Ftp4wVer: function(szVerStr: PChar; nStrSize: integer): Integer; stdcall; { Change default parameters} FtpSetVerboseMode: function(bVerboseMode: bool; hWindow: hWnd; wMsg: UINT): Integer; stdcall; FtpBytesTransferred: function: LongInt; stdcall; FtpBytesToBeTransferred: function: LongInt; stdcall; FtpSetDefaultTimeOut: procedure(nTo_in_sec: Integer); stdcall; FtpSetDefaultPort: procedure(nDefPort: Integer); stdcall; FtpSetAsynchronousMode: procedure; stdcall; FtpSetSynchronousMode: procedure; stdcall; FtpIsAsynchronousMode: function: Bool; stdcall; FtpSetNewDelay: procedure(X: Integer); stdcall; FtpSetNewSlices: procedure(X, Y: Integer); stdcall; FtpSetPassiveMode: procedure(bPassive: Bool); stdcall; FtpLogTo: procedure(hLogFile: HFile); stdcall; { Init functions} FtpRelease: function: Integer; stdcall; FtpInit: function(hWindow: hWnd): Integer; stdcall; FtpFlush: function: Integer; stdcall; { Connection } FtpLogin:

function(Host, User, Password: PChar; hWindow: hWnd; wMSG: UINT): Integer;

stdcall; FtpOpenConnection: function(Host: PChar): Integer; stdcall; FtpCloseConnection: function: Integer; stdcall; FtpLocalClose: function: Integer; stdcall; { Authentification} FtpSendUserName: function(UserName: PChar): Integer; stdcall; FtpSendPasswd: function(Passwd: PChar): Integer; stdcall; FtpSendAccount: function(Acct: PChar): integer; stdcall; { Commands } FtpHelp: function(Arg, Buf: PChar; BufSize: UINT): Integer; stdcall; FtpDeleteFile: function(szRemoteFile: PChar): Integer; stdcall; FtpRenameFile: function(szFrom, szTo: PChar): Integer; stdcall; FtpQuote: function(Cmd, ReplyBuf: PChar; BufSize: UINT): Integer; stdcall; FtpSyst: function(var szSystemStr: PChar): Integer; stdcall; FtpSetType: function(cType: char): Integer; stdcall; FtpCWD: function(Path: PChar): Integer; stdcall; FtpCDUP: function: Integer; stdcall; FtpPWD: function(szBuf: PChar; uBufSize: UINT): Integer; stdcall; FtpMKD: function(szPath, szFullDir: PChar; uBufSize: UINT): Integer; stdcall; FtpRMD: function(szPath: PChar): Integer; stdcall;

1187

{ file transfer } FtpAbort: FtpSendFile: Notify: Bool;

function: Integer; stdcall; function(Local, Remote: PChar; cType: char;

hWindow: hWnd; wMSG: UINT): Integer; stdcall; FtpAppendToRemoteFile: function(Local, Remote: PChar; cType: char; Notify: Bool; hWindow: hWnd; wMSG: UINT): Integer; stdcall; FtpRecvFile: function(Remote, Lcl: PChar; cType: char; Notify: Bool; hWindow: hWnd; wMSG: UINT): Integer; stdcall; FtpAppendToLocalFile: function(Remote, Lcl: PChar; cType: char; Notify: Bool; hWindow: hWnd; wMSG: UINT): Integer; stdcall; FtpGetFileSize: function: DWORD; stdcall; FtpMGet: function(szFilter: PChar; cType: char; bNotify: bool; Callback: TFtpMGetCallback): integer; stdcall; FtpRestart: function(ByteCount: longint): integer; stdcall; FtpRestartSendFile: function(hLocal: HFile; szRemote: PChar; cType: char; bNotify: bool; ByteCount: Longint; hWindow: hWnd; wMsg: UINT): integer; stdcall; FtpRestartRecvFile: function(szRemote: PChar; hLocal: HFile; cType: char; bNotify: bool; ByteCount: Longint; hWindow: hWnd; wMsg: UINT): integer; stdcall; { Directory } FtpDir: function (Def, LocalFile: PChar; LongDir: Bool; hWindow: hWnd; wMSG: UINT): Integer; stdcall; { Advanced } FtpOpenDataConnection:

function(szRemote: pchar; nAction: integer; cType: char): integer; stdcall; FtpRecvThroughDataConnection: function(szBuf: Pchar; var BufSize: UINT): integer; stdcall; FtpSendThroughDataConnection: function(szBuf: PChar; BufSize: UINT): integer; stdcall; FtpCloseDataConnection: function: integer; stdcall; { Firewall } FtpFirewallLogin: function (szFWHost, szFWUser, szFWPass, szRemHost, szRemUser, szRemPass: PChar; nFirewallType: integer; hParentWnd: hWnd; wMsg: UINT): integer; stdcall; { Misc } InitFtpGetAnswerCode: function: integer; stdcall; implementation const ftp4wdll = 'FTP4W32.dll'; { DLL file name }

1188

var hFtp4W: THandle; { DLL handle } { Load the DLL and get all the procedure addresses. } function LoadFtp4WDLL: boolean; var OldMode: UINT; begin if hFtp4W <> 0 then FreeLibrary (hFtp4W); OldMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); { No system messages if can't load. } hFtp4W := LoadLibrary (ftp4wdll); Result := hFtp4W <> 0; SetErrorMode(OldMode); if not Result then exit; { Get all the function addresses } @FtpDataPtr := GetProcAddress(hFtp4W, 'FtpDataPtr'); @FtpBufferPtr := GetProcAddress(hFtp4W, 'FtpBufferPtr'); @FtpErrorString := GetProcAddress(hFtp4W,'FtpErrorString'); @Ftp4wVer := GetProcAddress(hFtp4W, 'Ftp4wVer'); @FtpSetVerboseMode := GetProcAddress(hFtp4W,'FtpSetVerboseMode'); @FtpBytesTransferred := GetProcAddress(hFtp4W,'FtpBytesTransferred'); @FtpBytesToBeTransferred := GetProcAddress(hFtp4W,'FtpBytesToBeTransferred'); @FtpSetDefaultTimeOut := GetProcAddress(hFtp4W,'FtpSetDefaultTimeOut'); @FtpSetDefaultPort := GetProcAddress(hFtp4W,'FtpSetDefaultPort'); @FtpSetAsynchronousMode := GetProcAddress(hFtp4W,'FtpSetAsynchronousMode'); @FtpSetSynchronousMode := GetProcAddress(hFtp4W,'FtpSetSynchronousMode'); @FtpIsAsynchronousMode := GetProcAddress(hFtp4W, 'FtpIsAsynchronousMode'); @FtpSetNewDelay := GetProcAddress(hFtp4W, 'FtpSetNewDelay'); @FtpSetNewSlices := GetProcAddress(hFtp4W, 'FtpSetNewSlices'); @FtpSetPassiveMode := GetProcAddress(hFtp4W, 'FtpSetPassiveMode'); @FtpLogTo := GetProcAddress(hFtp4W, 'FtpLogTo'); @FtpRelease := GetProcAddress(hFtp4W, 'FtpRelease'); @FtpInit := GetProcAddress(hFtp4W, 'FtpInit'); @FtpFlush := GetProcAddress(hFtp4W, 'FtpFlush'); @FtpLogin := GetProcAddress(hFtp4W, 'FtpLogin'); @FtpOpenConnection := GetProcAddress(hFtp4W, 'FtpOpenConnection'); @FtpCloseConnection := GetProcAddress(hFtp4W, 'FtpCloseConnection'); @FtpLocalClose := GetProcAddress(hFtp4W, 'FtpLocalClose'); @FtpSendUserName := GetProcAddress(hFtp4W, 'FtpSendUserName'); @FtpSendPasswd := GetProcAddress(hFtp4W, 'FtpSendPasswd'); @FtpSendAccount := GetProcAddress(hFtp4W, 'FtpSendAccount'); @FtpHelp := GetProcAddress(hFtp4W, 'FtpHelp'); @FtpDeleteFile := GetProcAddress(hFtp4W, 'FtpDeleteFile'); @FtpRenameFile := GetProcAddress(hFtp4W, 'FtpRenameFile'); @FtpQuote := GetProcAddress(hFtp4W, 'FtpQuote'); @FtpSyst := GetProcAddress(hFtp4W, 'FtpSyst'); @FtpSetType := GetProcAddress(hFtp4W, 'FtpSetType'); @FtpCWD := GetProcAddress(hFtp4W, 'FtpCWD'); @FtpCDUP := GetProcAddress(hFtp4W, 'FtpCDUP'); @FtpPWD := GetProcAddress(hFtp4W, 'FtpPWD');

1189

@FtpMKD := @FtpRMD := @FtpAbort := @FtpSendFile := @FtpAppendToRemoteFile := 'FtpAppendToRemoteFile'); @FtpRecvFile := @FtpAppendToLocalFile := 'FtpAppendToLocalFile'); @FtpGetFileSize := 'FtpGetFileSize'); @FtpMGet := @FtpRestart := @FtpRestartSendFile := 'FtpRestartSendFile'); @FtpRestartRecvFile := 'FtpRestartRecvFile'); @FtpDir := @FtpOpenDataConnection := 'FtpOpenDataConnection'); @FtpRecvThroughDataConnection := 'FtpRecvThroughDataConnection'); @FtpSendThroughDataConnection := 'FtpSendThroughDataConnection'); @FtpCloseDataConnection := 'FtpCloseDataConnection'); @FtpFirewallLogin := 'FtpFirewallLogin'); @InitFtpGetAnswerCode := 'InitFtpGetAnswerCode'); end;

GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W,

'FtpMKD'); 'FtpRMD'); 'FtpAbort'); 'FtpSendFile');

GetProcAddress(hFtp4W, 'FtpRecvFile'); GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, 'FtpMGet'); GetProcAddress(hFtp4W, 'FtpRestart'); GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, 'FtpDir'); GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W, GetProcAddress(hFtp4W,

{ Procedure called when unit is finished, i.e. app exiting. } procedure MyExitProc; far; begin if hFtp4W <> 0 then begin { Make sure we shut everything down so we don't cause FTP4W to leak. } FtpAbort; FtpFlush; FtpCloseConnection; FtpLocalClose; FTPRelease; { Unload the DLL. } FreeLibrary(hFtp4W) end; end; var VerInfo: array[0..100] of char; FVer: integer; Begin hFtp4W := 0; AddExitProc(MyExitProc); FTP4W_Loaded := LoadFtp4WDLL; if FTP4W_Loaded then begin { Check to make sure we have a version we can use. } if @Ftp4wVer = NIL then FVer := 0 else FVer := Ftp4wVer(VerInfo, sizeof(VerInfo)); FTP4W_RightVersion := not ((HiByte(FVer) < 2) or ((HiByte(FVer) = 2) and (LoByte(FVer) < 96))); end; end.

1190

About Thunking D2 to 16bit DLL

From: Mike Heacock Please include this URL...as it has an article and sample code within its pages. http://members.aol.com/delphimag/index.htm Alternatives to DLL?

From: "Dmitry" > I was wondering is there any way that I can have a main form compiled > into a EXE and > EACH SECONDARY FORM COMPILED INDIVIDUALLY > and then dynamically load in these other secondary forms in runtime > ( DLL concept) Why not? (* The DLL unit *) library MyLib; type TMyDLLForm = class(TForm) ... end; {$IF dynamically creation} function CreateForm: TForm; {$IFDEF WIN32} stdcall;{ENDIF} export; begin Result := TMyDLLForm.Create(Nil); Result.OnClose := @FreeForm; end; {$ELSE} var MyDllForm: TForm; function CreateForm: TForm; {$IFDEF WIN32} stdcall;{ENDIF} export; begin Result := MyDLLForm; end; {$ENDIF} exports CreateForm; end. (****************) (* The Main Form in exe module. Calling the MyDLLForm *) function CreateForm: TForm; {$IFDEF WIN32} stdcall;{ENDIF} external 'MyLib'; procedure TMyMainExeForm.OnOpenDllFormBtnClick(Sender: TObject); var form: TForm; begin form := CreateForm; form.owner := self; form.parent := self; end;

1191

249. 250. 251. 252.

Resource File String Tables How To Include JPEG's In Your Executable (Delphi 3) resource1 [Q] Resource files (*.res) / scripts (*.rc)<> Loading bitmaps from a resource DLL into a TImage component.resource3

String Tables From: "Joe C. Hecht" Stringtable resources are a very useful tool when your application must store a large number of strings for use at runtime. While you may be tempted to directly embed strings into your executable, using a stringtable resource offers two advantages: 1) The strings contained in the stringtable do not consume memory until they are loaded by your application. 2) Stringtables are easily edited, providing an easy path to internationaly localized versions of your application. Stringtables are compiled into a ".res" file that is attached to your application's exe file at build time. Even after you distribute your appliaction, the stringtable contained in your application's exe file can be edited with a resource editor. My favorite resource editor is Borland's Resource Workshop that ships with the RAD pack. It can produce and edit both 16 and 32 bit resources that are self contained, standalone, or embedded in a .exe or .dll in full WYSIWYG fashion. It's worth noting that all versions of Delphi ship with the Borland Resource Command Line Compiler (BRCC.EXE and BRCC32.EXE), and can be found in Delphi's Bin directory. For our example, we will build an internationalized application that displays two buttons. The buttons will have captions for "Yes" and "No" presented in English, Spanish, and Swedish. It's worth noting that if you want to build international applications using Delphi, you should take a look at Borland's Delphi Translation Suite and Language Pack software. These packages can make porting your application to international markets a snap! Example: We first must create a text file containing our string resources in the applications build directory. You may name the file anything you wish, so long as it has the file extension ".rc" and the filename without the extension is not the same as any unit or project filename. This is very important, as Delphi also will create a number of resource files for your project automatically. Here is the contents of the .rc file for our example. It contains the words "Yes" and "No" in English, Spanish, and Swedish: STRINGTABLE { 1, "&Yes" 2, "&No" 17, "&Si" 18, "&No" 33, "&Ja" 34, "&Nej" } The file starts with the key word stringtable denoting that a string table resource will follow. Enclosed in the curly braces are the strings. Each string is listed by it's index identifier, followed by the actual string data in quotes. Each string may contain up to 255 characters. If you need to use a non-standard character, insert the character as a backslash character followed by the octal number of the character you wish to insert. The only exception is when you want to embed a backslash character, you will need to use two backslashes. Here are two examples: 1, "A two\012line string" 2, "c:\\Borland\\Delphi" The Index numbers that you use are not important to the resource compiler. You should keep in mind that string tables are loaded into memory in 16 string segments. To compile the .rc file to a .res file that can be linked with your application, simply type on the dos command line the full path to the resource compiler, and the full path to the name of the .rc file to compile. Here is an example: c:\Delphi\Bin\brcc32.exe c:\Delphi\strtbl32.rc When the compiler is finished, you should have a new file with the same name as the .rc file you've compiled, only with an extension of ".res". You can link the resource file with your application simply by adding the following statement to your application's code, substituting the name of your resource file: {$R ResFileName.RES} Once the .res file is linked to your program, you can load the resource from any module, even if you specified the $R directive in the implementation section of a different unit. Here is an example of using the Windows API function LoadString(), to load the third string contained in a string resource into a character array: if LoadString(hInstance,

1192

3, @a, sizeof(a)) <> 0 then .... In this example, the LoadString() function accepts the hInstance of the module containing the resource, the string index to load, the address of the character array to load the string to, and the size of the character array. The LoadString function returns the number of characters that where actually loaded not including the null terminator. Be aware that this can differ from the number of bytes loaded when using unicode. Here is a complete example of creating an international application with Borland's Delphi. The application is compatible with both 16 and 32 bit versions of Delphi. To do this, you will need to create two identical .rc files, one for the 16 bit version, and the other for the 32 bit version, since the resources needed for each platform are different. In this example. we will create one file named STRTBL16.rc and another called STRTBL32.rc. Compile the STRTBL16.rc file using the BRCC.exe compiler found in Delphi 1.0's bin directory, and compile STRTBL32.rc using the BRCC32.exe compiler found in Delphi 2.0's bin directory. We have taken into account the language that Windows is currently using at runtime. The method for getting this information differs under 16 and 32 bit Windows. To make the code more consistant, we have borrowed the language constants from the Windows.pas file used in 32 bit versions of Delphi. {$IFDEF WIN32} {$R STRTBL32.RES} {$ELSE} {$R STRTBL16.RES} const LANG_ENGLISH = $09; const LANG_SPANISH = $0a; const LANG_SWEDISH = $1d; {$ENDIF} function GetLanguage : word; {$IFDEF WIN32} {$ELSE} var s : string; i : integer; {$ENDIF} begin {$IFDEF WIN32} GetLanguage := GetUserDefaultLangID and $3ff; {$ELSE} s[0] := Char(GetProfileString('intl', 'sLanguage', 'none', @s[1], sizeof(s)-2)); for i := 1 to length(s) do s[i] := UpCase(s[i]); if s = 'ENU' then GetLanguage := LANG_ENGLISH else if s = 'ESN' then GetLanguage := LANG_SPANISH else if s = 'SVE' then GetLanguage := LANG_SWEDISH else GetLanguage := LANG_ENGLISH; {$ENDIF} end; procedure TForm1.FormCreate(Sender: TObject); var a : array[0..255] of char; StrTblOfs : integer; begin {Get the current language and stringtable offset} case GetLanguage of LANG_ENGLISH : StrTblOfs := 0; LANG_SPANISH : StrTblOfs := 16; LANG_SWEDISH : StrTblOfs := 32;

1193

else StrTblOfs := 0; end; {Load language dependent "Yes" and set the button caption} if LoadString(hInstance, StrTblOfs + 1, @a, sizeof(a)) <> 0 then Button1.Caption := StrPas(a); {Load language dependent "No" and set the button caption} if LoadString(hInstance, StrTblOfs + 2, @a, sizeof(a)) <> 0 then Button2.Caption := StrPas(a); end; How To Include JPEG's In Your Executable (Delphi 3)

From: Marko Peric I'm a Delphi beginner who's exploring this wonderful programming environment, and I just thought I'd like to share some really neat stuff I worked out. Delphi3 comes with the jpeg unit, and that's great, but did you ever wonder how to include jpeg's in your executable and then use them in your application? Well, follow this simple 5 step plan and you can't go wrong! STEP ONE: Create a resource script file (*.RC) with a simple text editor like Notepad and add the following line: 1

RCDATA

"MyPic.jpg"

The first entry is simply the index of the resource. The second entry specifies that we are dealing with a user-defined resource. The third and final entry is the name of the jpeg file. STEP TWO: Use Borland's Resource Compiler, BRCC32.EXE, to compile it into a .RES file. At the MS-DOS command line: BRCC32 MyPic.RC This will create a resource file called MyPic.RES. STEP THREE: Add a compiler directive to the source code of your program. It should immediately follow the form directive, as shown here: {$R *.DFM} {$R MyPic.RES} STEP FOUR: Add the following code to your project (I've created a procedure for it): procedure LoadJPEGfromEXE; var MyJPG : TJPEGImage; // JPEG object ResStream : TResourceStream; // Resource Stream object begin try MyJPG := TJPEGImage.Create; ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA);

1194

MyJPG.LoadFromStream(ResStream); // What!? Yes, that easy! Canvas.Draw(12,12,MyJPG); // draw it to see if it really worked! finally MyJPG.Free; ResStream.Free; end; end; // procedure See the second parameter of the CreateFromID procedure of the TResourceStream component? It's simply the resource index. You can include more than one jpeg in your executable just by adding a line for each jpeg (with a different index) in the resource script (.RC) file. STEP FIVE: Call the procedure, run the program, and voila! Now go eat some nachos. [Q] Resource files (*.res) / scripts (*.rc)<> align="TOP"> From: Ken White The .RC file is simply a text file that lists resources. For most purposes (except defining dialogs for non-VCL apps), you don't need a resource editor. The file is in this format: RESOURCENAME RESOURCETYPE FILENAME For example, to include a bitmap in the resource file: MyBitmap BITMAP MyBitmap.bmp To include a cursor: MyCursor CURSOR MyCursor.cur You use the same technique to include AVI, WAV and ICO files. For other filetypes, you can use the type RC_DATA. To use the resource script (.RC) file, you use Borland's Resource Compiler (BRCC.EXE with Delphi 1, BRCC32.EXE otherwise) which is located in the Delphi Bin directory. The syntax is: BRCC32 MyRes.RC This creates MyRes.RES. You then add the {$R MYRES.RES} to a unit in your application to have Delphi's linker include it, and use one of the Load... API calls (or Delphi's wrappers for some components) to use the resource at runtime. Loading bitmaps from a resource DLL into a TImage component. begin hLib := LoadLibrary('Images.dll'); BMP := TBitmap.Create; with BMP do begin LoadFromResourceName(hLib, 'SPLASH'); Transparent := True; TransParentColor := clFuchsia; TransparentMode := tmFixed; Image1.Canvas.Draw(0, 0, BMP); Free; end; end;

1195

· · · · · · · · · · · · · · · · · · · · · · · · · · · · · · · · · · · ·

Belgeler menüsüne bir dosya ekleme Belgeler menüsünü temizleme Duvar kağıdını değiştirmek Başlat butonunu gizlemek veya kullanılmaz hale getirmek Bir programın çalıştırılması Harddiskin seri numarasının bulunması Windows ve System klasörlerinin bulunması Windows lisans bilgilerinin (isim ve şirket) bulunması Speakerdan Beep sesi çıkartma Bir Denetim Masası uygulamasını çalıştırmak Windows'u kapatmak veya yeniden başlatmak(reboot) Ekran koruyucusunu kapatmak ve açmak Ekran kartım kaç rengi destekliyor Windows Gezginini istediğiniz bir klasörle açma Windows'un Bul (Find File) diyalog penceresini istediğiniz bir klasörle açma Pencerenin kapatma düğmesini etkisiz hale getirme Uygulamam Windows her açıldığında otomatik çalışsın Klasöre Gözat diyalogunu kullanarak bir klasörü seçme Bir web adresini açma Bir DOS programını çalıştırma ve çalışması bitince penceresini kapatma Alt + Tab ve Ctrl + Esc tuşlarının kullanılmaz hale getirilmesi Bir menü öğesine resim ekleme Ağ ortamında makinenin ismini bulma Ağ ortamında login olmuş kullanıcı ismini bulma Ekran çözünürlüğünü nasıl öğrenirim Taskbar'ın (Görev çubuğu) AutoHide özelliği açık mı, kapalı mı? Programım biraz beklesin Caps lock tuşu açık mı, kapalı mı? İmleci (cursor) gizleyip, tekrar gösterme Ekran görüntüsünü alın Map Network Drive diyalogunu açma Bir dosyayı bağlantılı olduğu uygulama ile açma Temp klasörünü bulma Ekran koruyucuyu çalıştırmak - yeni! Güç koruma modunda (Power Safe Mode) çalışan monitörü kapatıp açma - yeni! Windows Tarih/Saat Özellikleri (Date/Time Properties) iletişim kutusunu açma - yeni!

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:\DownLoad\deneme.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); end;

Belgeler menüsünü temizleme uses kısmına ShlOBJ unitini ekleyin; 1196

SHAddToRecentDocs(SHARD_PATH, nil);

Duvar kağıdını değiştirmek var s: string; begin s := 'c:\windows\athena.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ı 1197

WinExec('c:\windows\calc.exe',sw_show); WinExec('C:\WINDOWS\NOTEPAD.EXE C:\WINDOWS\WIN.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('SOFTWARE\MICROSOFT\MS SETUP (ACME)\'); Memo1.Lines.Add(reg.ReadString('USER INFO', 'DefName', 'Mustafa ŞİMŞEK')); Memo1.Lines.Add(reg.ReadString('USER INFO', 'DefCompany', 'Bilgisayar Bilimleri Müh.')); reg.free; end;

1198

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:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal);

Windows'u kapatmak veya yeniden başlatmak(reboot) 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.

1199

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('Software\Microsoft\Windows\CurrentVersion\Run',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 1200

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;

1201

begin Bmp1 := TPicture.Create; Bmp1.LoadFromFile('c:\deneme\turkey.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

1202

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:\test\2.avi','','',SW_NORMAL); Temp klasörünü bulma procedure TForm1.Button1Click(Sender: TObject); var temp_klasor: array[0..MAX_PATH] of char; begin 1203

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);

1204

Delphi İçin Buton Efektleri (Web Türü Buton)

Web türü buton yapmanın amacı bildiğiniz gibi delphinin standart buttonları genellikle klasik programlar için kullanılır . Şimdi yapacağımız button kendi çizdiğimiz 3 resimden oluşuyor. Öncelikle 3 adet aynı boyda aynı textli button çizin. 1. Resim ; buttonun Sabit yani Form üzerindeki duruşudur 2. Resim ; Programımız çalışırken mouse ile aynı buttonun üzerine geldiğimize buttonun alacağı şekil olacaktır. 3.Resim ; Programımız çalışırken yaptığımız button tıklanınca alacağı şekildir. Dikkat ettiyseniz bu taktik HTLM (Web ) için button hazırlanması taktiği ile aynıdır. Şimdi bu taktiği kullanmaya başlayalım . Öncelikle Form üzerine Image kontrolünü ekleyelim ve resim olarak yaptığımız 1. resmi ekleyelim. Şımdi sıra Programımıza değişken tanımlayalım; SetMouse : boolean; Değişken tanımlama işimiz bitince Image Mouse Down olayına aşağıdaki kodları yazınız procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin SetMouse := true; //Mouse Resmin üzerinde Basık olduğunu anlamamız için image1.Picture.LoadFromFile('start-3.bmp'); //Mouse Click Durumunda end; Daha Sonra image Mouse Move Olayına aşağıdaki kodları yazınız procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin image1.Picture.LoadFromFile('start-2.bmp'); //Mouse Buttonun üzerine gelince buttonun alacağı şekil if SetMouse then image1.Picture.LoadFromFile('start-3.bmp'); //Mouse Click Durumunda Buttonun üzerindeki şekil end; Mouse button üzerinde click vaziyetinde olup olmadığını değişkene aktarmak için Image Mouse up olayına aşağıdaki kodu yazınız procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); begin SetMouse := false; //Mouse Click Durumunda Değil end; Button Görüntüleri Tamamlandı şimdi Click Yordamını yapalım. Image Click olayına aşağıdaki kodu yazınız . procedure TForm1.Image1OnClick(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin image1.Picture.LoadFromFile('start-3.jpg'); ShowMessage('Button Tıklandı '); end; Buttonla olan işimiz bitti Mouse buttonumuzun üzerinde olmadığı zaman için mouse şeklini yapalım bunun için Form Mouse Move Olayına Aşağıdaki kodları yazınız.

1205

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin image1.Picture.LoadFromFile('start-1.jpg'); end; Ve işlemimiz bitti. Programınızda birden fazla Bu tür button koymanız için Bütün buttonlar için aynı işlemi yapınız. Form Mouse Move olayına her button için yukarıdaki program satırını yazınız. Örnek: procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin image1.Picture.LoadFromFile('Connect-1.jpg'); image2.Picture.LoadFromFile('DeConnect-1.jpg'); image3.Picture.LoadFromFile('Atack-1.jpg'); image4.Picture.LoadFromFile('Exit-1.jpg'); end; şeklinde yapınız . Bildiğiniz gibi Web' de bu taktiği kullanmamız için Button için yaptığımız resimlerin HTLM de belirtilen Dizinde olması gerekir .Yani Bizim yukarıda yaptığımız olayda resim dosyalarının yerini belirtmememizin amacı resim Button Resim Dosyalarının Program ile aynı dizinde olmasıdır. Bu yüzden sorunun ne olduğunu anladınız galiba yani program bu açıktan dolayı kullanıcı tarıfından değiştirilebilir. Winamp MP3 çalıcıyı bilirsiniz . Winamp SKIN'nin ne olduğunu da biliyorsunuz sanırım , Yani demek istediğim Winamp SKIN'de de bu taktik kullanılmıştır . Aslında bu sorun değil , çünkü bu olayı IMAGE LIST Kontrolü de yapar. IMAGE LIST bir Olay için kullanılan birden fazla resim için kullanılan resim dosyaları olmadan programın bağımsız çalışması için kullanılır. IMAGE LIST Delphinin Win32 sekmesinde bulunur . Gif taktiğine benzer bir taktikle çalışır, biraz incelerseniz kolaylıkla kullanabilirsiniz. Bu arada Delphinin Additional sekmesinde bulunan BitBTN kontrolüyle de buna benzer ama kolay Button kullanabilirsiniz.

1206

Windows API

Windowsda hemen hemen her görsel bileşen bir penceredir ve her pencerenin Windows'un aklında tuttuğu bir tutacağı vardır.Buna programcılık ortamında "Handle" denir. Bu tutacak (Handle) vasıtası ile görsel olan tüm kontrollere erişebilirsiniz ve onları istediğiniz gibi kontrol edebilirsiniz. Esas problem bu penceresel denetimin tutacağını (handle) nasıl bulacağımızdadır. Bunun için Windows API'nin içinde FindWindow ve FindWindowEx adlı fonksiyonlar mevcuttur. Bu fonksiyonlar herhangi bir pencereye başlığı (caption) yada sınıf adı ile erişip geri dönüşte de pencere tutacağını döndürürler.Bu sayede penceresel denetimlere istenilen yaptırılabilir. Bazı penceresel denetimlere sınıf adı ile erişmek gerekir. Çünki bazılarının başlık bilgileri mevcut değildir.Örneğin TaskBar için bir başlık bilgisi yoktur. Öyleyse TaskBar ve onun gibi başlık bilgisi olmayan penceresel denetimlere nasıl erişeceğiz. Bunun için benim sizlere tavsiyem Borland Delphi ile gelen WinSight programını kullanmanızdır. Bu program vasıtası ile Windows altında o anda çalışan programların tutacaklarını, sınıf adlarını, çocuk pencerelerinin ad ve tutacakları gibi gerekli bilgileri elde edebilirsiniz. Windows mesajların gelip gittiği bir işletim sistemidir. Şimdi mesaj kavramını biraz açıklamak gerekir. Mesaj herhangi bir programın, görsel yada görsel olmayan tüm Windows kontrollerinin ne yapması gerektiğini yada ne yaptığını anlamamızı sağlayan bir yapıdır. Windows bir mesajlar hiyerarşisinden oluşmuştur. Windows'ta olup biten herşeyin bir mesajı vardır. Örneğin bir button'un üzerine gelmek, onun üzerinde mouse ile dolaşmak, sağ kliklemek, sol kliklemek, aktif pencereyi değiştirmek, herhangi bir tuşa basmak, herhangi bir tuşu bırakmak bunların hepsi aktif pencereye dolayısıyla İşletim sistemine gönderilen mesajlardır. Örneğin herhangi bir pencere üzerinde bir tuşa basarsanız Windows hemen bir Wm_Keydown, Wm_Char vb. mesajları uygulama penceresine gönderecektir. Yani bir mesaj oluşturacaktır. Bu mesaja bağlı bir kodunuz mevcut ise o olay oluştuktan (yani mesaj gönderildikten) sonra var olan kod çalıştırılacaktır. Windows'un API yardımında "Wm_" kelimesi arattığınızda mesajlar hakkında daha detaılı bilgi bulabilme imkanına sahip olursunuz. Bazı durumlarda Windows'u mesaj konusunda zorlamak gerekir. Gerçekte olmayan bir olayı Windows'a olmuş olarak nasıl gösterebiliriz...? Örneğin yaptığımız bir programın olay yöneticilerinden bir tanesinin tuşa basma olayına yönlendiğini düşünelim. Yani programımızın aktif formunun üzerinde klavye'nin herhangi bir tuşuna basılınca herhangi bir olayın gerçekleşeceğini düşünelim. Bu gibi bir durum sözkonusu iken başka bir uygulama aktif durumdayken acaba bu isteğimizi nasıl gerçekleştireceğiz..? Yine bu iş için Windows'un API fonksiyonlarından iki tanesini anlatmak isterim. Bunlardan birincisi SendMessage, ikincisi PostMessage fonksiyonlarıdır. Bu fonksiyonlar Windows ortamına harici mesajlar gönderebilmenizi sağlar. SendMessage fonksiyonu ile Windows ortamına gönderilen mesajlar "Message queue" adı verilen mesaj kuyruğunun en sonuna atılır ve en üstteki mesajdan en alttakine doğru işletim sistemince sıra ile işlenir. Bu fonksiyon vasıtası ile gönderilen mesajların aktivasyonunu görmek biraz geç olabilir ama daha sağlıklıdır. PostMessage fonksiyonu ise Windows Mesaj kuyruğunun en başına yerleşir. Yani mesaj gönderilir gönderilmez aktif hale geçer ve etkisini kısa bir zaman içinde görebilirsiniz. Şimdi kısa bir örnek verelim.. 253. 254. 255. olarak 256.

Eğer winsight programınız var ise onu açın. Windows'un Calculator (Hesap makinası) programını çalıştırın. Winsight programında Hesap mkinasını bulunca onun sol tarafında sınıf adı "sciCalc" göreceksiniz. Şimdi WinSight programını kapatın. (Zira hafızada çok yer kaplar).

1207

257. Şimdi hesap makinasının pencere tutacağını almamız gerekir. (Sınıf adını bildiğimiz için bu çok kolay..) 258. Bunun için H:=FindWindow(PChar('SciCalc'),Nil); yazmak yeterlidir. (Burada H, HWND tipinde bir değişkendir.) 259. Bunu bulduktan sonra bu pencereye elimizde var olan tutacağı vasıtası ile istenilen mesaj gönderilebilir. Örneğin tuşa basma olayı, şöyleki programımızın OnKeyDown olay yöneticisinde PostMessage(H,WM_Keydown,Key,0); şeklinde bir kod yazarsak Hesap makinasında basılan tuşların aktive olduğunu göreceksiniz.

1208

TCP/IP Protokolünü Kullanarak Pingleme

Delphi 3 ile TCP/IP kontrolünü kullanmak için Internet sekmesinden TCP/IP kontrolünü ve Standart sekmesinden de Button kontrolünü Form'unuza ekleyin. Daha Sonra Button1Click procedürüne şu komut dizisini yazın: procedure TForm1.Button1Click(Sender: TObject); var LocalName, LocalIp, RemoteIp, RemoteHost:string; begin {Değişkenlerimize TCP1 Kontrolünden Datalar Aktarılıyor} LocalName := TCP1.LocalHostName; LocalIp := TCP1.LocalIP ; RemoteIp := TCP1.RemoteHostIP ; RemoteHost:= TCP1.RemoteHost ; {Sıra Geldi Kullanıcıya Aktarmaya} Canvas.TextOut(20,20,'Local Name : '+LocalName); Canvas.TextOut(20,50,'Local Ip : '+LocalIp); Canvas.TextOut(20,80,'Remote Ip : '+RemoteIp); Canvas.TextOut(20,120,'Remote Host :'+RemoteHost); end;

1209

Delphi ile MS Access Database'ine Bağlantı Delphi'den MS Access Databaseine ulaşabilmek için sırasıyla yapılması gerekenler aşağıdaki gibidir: 260. Windows Control Panel'i açın 261. ODBC simgesini çift tıklayın 262. User DSN tabına gelin ve Add butonuna basın 263. Driver olarak "Microsoft Access Driver (*.mdb)" yi seçin ve Finish butonuna basın 264. Data Source Name'i olarak kullanmak istediğiniz bir isim verin. Description kısmına isterseniz database'inizle ilgili bir açıklama yazabilirsiniz. 265. Daha sonra Select butonuna basarak database isminizi verin 266. Advanced butonuna basarak kullanıcı adı ve şifresi tanımlayabilirsiniz (zorunlu değil) 267. OK butonuna basıp ODBC ekranını kapatın 268. Şimdi programınıza bir TDatabase objesi ekleyin 269. AliasName olarak ODBC ayarlarında verdiğiniz (5) Data Source Name'i seçin 270. Database Name olarak istediğiniz bir isim yazın 271. Eğer 7. basamakta bir kullanıcı adı ve şifresi girmediyseniz login ekranın çıkmaması için LoginPrompt seçeneğini false yapın

Eğer database'in bir kullanıcı adı ve şifresi varsa LoginPrompt seçeneğini False yapmanız durumunda database'e ulaşamazsınız. 272. Programınıza bit TTable ekleyin 273. Database Name kısmına TDatabase bileşeninde Database Name kısmına 11. adımda verdiğiniz ismi seçin 274. Programınıza bit TDataSource ekleyin 275. DataSet değeri olarak 13. adımda eklediğiniz TTable adını verin Artık MS Access Database'ine bağlı bir table'a sahipsiniz.

1210

Dolaştır! Herhengi bir nesneyi formun üzerinde sürükleyip dolaştırın. Nesnenizi Nasıl taşırsınız: Örnek: Name property'si "Button1" olan bir butonu form üzerinde sürükleyelim… Procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const sc_DragMove=$F012; begin ReleaseCapture; Button1.Perform(WM_SYSCOMMAND, sc_DragMove, 0); end;

Windows Api' leri İle Dosya Kopyalama Bilindiği üzere eski pascal'cılar hemen bir dosya mantığı kullanarak dosya kopyalama yoluna girerler gayette güzel olur ama biraz daha derine inmek gerekirse yani kullanıcı tarafından açık olan bir dosyayı kopyalamak istenirse eğer aşağıdaki (Klasik Pascal Kopya) kodu bir işe yaramaz bura da Windows' un Api 'lerine ihtiyaç duyarız.

Birinci Yol Kalıp : BOOL CopyFile( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName,

// Kaynak Dosya //Hedef Dosya

BOOL bFailIfExists // Dosyanın Var olup Olmadığı ve ne yapması Gerektiği True/False ); Ör : Result:=CopyFile(PChar(SrcTableName),PChar(DestName),True); Bu Kopyalama işlemi Çok hızlı olup Dosyanın aktif veya pasif olması önemli değil kopyalar.

İkinci Yol Bu işlem Windows'un standart Kopya işlemini yapar. SehellApi Dosyasında Detaylı bir şekilde görebilirsiniz. Kalıp : TSHFileOpStructW = packed record Wnd: HWND;

//Aktif Window Handle

wFunc: UINT;

// Yapılacak İşlem Koya,Silme vs..

pFrom: PWideChar;

// Kaynak Dosya

pTo: PWideChar;

// Hedef Dosya

fFlags: FILEOP_FLAGS;

// Default 0

fAnyOperationsAborted: BOOL; // Olayı İptal Etmek yada Etmemek

1211

hNameMappings: Pointer; lpszProgressTitle: PWideChar;

//Pencere Başlığı

end; Ör : Var

FO

: TSHFileOpStruct;

Aborted

: Boolean;

With Fo Do Begin Wnd:=Handle; WFunc:=FO_COPY; PFrom:=pchar(St1.Cells[0,F]); pTo:=pchar(St1.Cells[1,F]); FFlags:=0; fAnyOperationsAborted:=Aborted; End; try SHFileOperation(FO); finally end;

Klasik Pascal Dosya Kopyalaması AssignFile(FromF, OpenDialog1.FileName); Reset(FromF, 1); { Record size = 1 } if SaveDialog1.Execute then { Display Save dialog box} begin AssignFile(ToF, SaveDialog1.FileName); { Open output file } Rewrite(ToF, 1); { Record size = 1 } Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF)) + ' bytes...'); repeat BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten);

1212

until (NumRead = 0) or (NumWritten NumRead); CloseFile(FromF); CloseFile(ToF); end; end;

Açık Windows Uygulamalarının Gösterilmesi

Burada EnumWindows API fonksiyonuyla bir window handle ve pointer parametreleri çağrılarak gizli ve görünür uygulamalar listelenir. //AnaForm üzerine bir ListBox1 ve Button1 ekleyin //implementation {$R *.DFM} altyna a?a?ydaki fonksiyonu yaz function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean; Export; {$ifdef Win32} StdCall; {$endif} var Buffer : Array[0..99] of char; begin GetWindowText(Wnd,Buffer,100); if StrLen(Buffer) <> 0 then Form1.ListBox1.Items.Add(StrPas(Buffer)); Result := True; end; procedure TForm1.Button1Click(Sender: TObject); begin //Tüm gizli ve görünür uygulamalary listele EnumWindows(@EnumWindowsProc,LongInt(Self)); end;

1213

Kullanıcının Sadece Sizin Programınızı Kullanmasını İsterseniz Bazen kullanıcının sadece sizin yazdığınız programı kullanmasını isteyebilirsiniz. O zaman aşağıdaki prosedürler ihtiyaçlarınızı karşılayacaktır. procedure TForm1.Formcreate(Sender: TObject); var B: LongInt; begin SystemParametersInfo(97,word(True),@B,0); {yukarıdaki satır ctrl-alt-del ve alt-tab tuslarını kapatır} gizle; end; procedure TForm1.FormClose(Sender: TObject); var B: LongInt; begin SystemParametersInfo(97,word(False),@B,0); goster; end; procedure gizle; var wndHandle: Thandle; wndClass: array[0..50] of Char; begin StrPCopy(@wndclass[0],'Shell_TrayWnd'); wndHandle:= FindWindow(@wndclass[0],nil); ShowWindow(wndHandle,SW_HIDE); end; procedure gizle; var wndHandle: Thandle; wndClass: array[0..50] of Char; begin StrPCopy(@wndclass[0],'Shell_TrayWnd'); wndHandle:= FindWindow(@wndclass[0],nil); ShowWindow(wndHandle,SW_RESTORE); end;

1214

Panel vya Buton Üzerinde Screen Saver Formunuzun üzerine bir buton (Button1) birde panel (Panel1) yerleştirin. Daha sonra Button1'in OnClick eventine aşağıdaki kodu yazın. procedure TForm1.Button1Click(Sender: TObject); var FSaverPath : String; StartupInfo : TStartupInfo; ProcessInformation : TProcessInformation; begin FSaverPath:='C:\Winnt\system32\sspipes.scr'; StartupInfo.cb := sizeOf(TStartupInfo); FillChar(StartupInfo, sizeOf(TStartupInfo), #0); FillChar(ProcessInformation, sizeOf(TProcessInformation), #0); CreateProcess(nil, PChar(FSaverPath + ' /p ' + IntToStr(Panel1.Handle)), nil, nil, false, 0, nil, nil, StartupInfo, ProcessInformation); // aşağıdaki kod bloğuda ekran koruyucunun özellikler sayfasını açar... if (CreateProcess(nil, PChar(FSaverPath + ' /c'), nil, nil, false, 0, nil, nil, StartupInfo, ProcessInformation)) then ShowMessage('Evet') Else ShowMessage('Hayır'); end;

1215

Shareware Program Yazanlar İçin Aşağıdaki prosedür yazdığınız programın her windows oturumunda yalnız birkez çalışmasını sağlar. Programı aynı windows oturumunda ikinci kez çalıştırdığınızda program değişkenine gireceğiniz mesajı vererek sonlanacaktır... procedure RunOnceForEveryWindowsSession( MessageStr : String ); var My_Atom : Integer; begin if GlobalFindAtom( 'Buraya_Birseyler_Yazin' ) = 0 then My_Atom := GlobalAddAtom('Buraya_Birseyler_Yazin') else begin ShowMessage( MessageStr ); Application.Terminate; end; end;

Prosedürde GlobalFindAtom ve GlobalAddAtom rutinleri yardımı ile aranacak ve eklenecek ifade aynı olmalıdır. Ben (Buraya_Birseyler_Yazin) dedim siz başka birşey yazabilirsiniz.

Örneğin bu prosedürü aşağıdaki gibi programınızın ana formunun OnShow Eventine eklerseniz programınız o anki windows oturumunda bir kez normal olarak çalışacak fakat ikinci çalıştırma denemesinde girilen mesajı verip sonlanacaktır.. procedure TForm1.FormShow(Sender: TObject); begin RunOnceForEveryWindowsSession( 'Bu program' + ' Her Windows Oturumunda'+ #13#10 + 'Yalnız Bir kez Çalışır...' ); end;

1216

Network Üzerinde Bağlantı Network üzerindeki bir kaynağa bağlanmak veya bağlı olunan bir kaynakla bağı koparmak için aşağıdaki kodları kullanabilirsiniz. WNetConnectionDialog(Handle,RESOURCETYPE_DISK); //Bağlantı kurmak için WNetDisconnectDialog(Handle,RESOURCETYPE_DISK); //Bağlantıyı kesmek için

Final Diyaloğunu Açıp Kapatmak Find diyalog penceresini açıp kapatan bir kod. H:=FindWindow(PChar('#32770'),Nil); // #32770 Find diyalog'un sınıf adıdır. If H = 0 Then // eğer Find diyalog'u açık değilse onu aç... Begin With dd1 Do Begin ConnectMode:=ddeManual; ServiceApplication:='explorer.exe'; SetLink('Folders','AppProperties'); OpenLink; ExecuteMacro('[FindFolder(,C:\Dene)]',False); CloseLink; End; H:=FindWindow(PChar('#32770'),Nil); End; ShowMessage('Find File Dialogunu gizle...!!'); ShowWindow(H,SW_HIDE); ShowMessage('Find File Dialogunu göster...!!'); ShowWindow(H,SW_SHOW);

Register Kullanım Örneği Windows açılırken programınızın otomatik olarak başlatılıp başlatılmamasını nasıl ayarlarsınız. İşte size güzel bir örnek kod. Formunuza CheckBox Ekleyin ve adını Autorun yapın ( veya ne isterseniz.) ve formun Close Olayına Aşağıdaki kodları yazın. procedure Tfilesetup.FormClose(Sender: TObject; var Action: TCloseAction); var AppExe :string; begin if autorun.Checked=true then begin with TRegistry.Create do try RootKey := HKEY_CURRENT_USER; if OpenKey ('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', true) then AppExe:=#34+Application.Exename+#34; WriteString('Proton', AppExe); finally end; end; //DeleteValue('Proton'); İse Programınız Registry den Siler

1217

end;

1218

Başlat Menüsü Programlarının Tespit Edilmesi Başlat menüsünde hangi programların bulunduğunu tespit eden bir kod parçası. Forma bir ListBox, bir Buton, birde DDEClientConv nesnesi ekleyip, Service ve Topic özelligini "Progman" olarak giriniz. var B:Pchar; procedure TForm1.Button1Click(Sender: TObject); begin ListBox1.Items.clear; B := DDEClientConv1.RequestData('Groups'); ListBox1.Items.SetText(B); StrDispose(B); end;

1219

Bir Harddiskin Seri Numarasının Bulunması

Hard diskin seri numarasını bulur. 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;

1220

Windows Kapanış Ekranı Örneği Program ExitWindowsEx() fonksiyonunu kullanıyor. Fonksiyonun genel formatı: BOOL ExitWindowsEx(UINT uFlags, DWORD dwReserved); dwReserved : Bu değer windows tarafında kullanılır. uFlags : Kapanma işleminin tipini belirtiyor. Bu değer aşağıdakilerden biri olabilir.

EWX_SHUTDOWN : Bu seçenek kaydedilmemiş tüm bilgileri kaydederek o anda açık olan tüm uygulamaları sonlandırır ve bilgisyarınızda kapanış ekranı görüntülenir ve bilgisayarı kapanmaya hazır hale getirir. EWX_POWEROFF : Eğer bilgisayarınızda poweroff özelliği varsa bu komut kullanıldığında EWX_SHUTDOWN komutunun yaptığı işe ek olarak bilgisayarı tamamen kapatır. EWX_REBOOT : Bu seçenek kaydedilmemiş tüm bilgileri kaydederek o anda açık olan tüm uygulamaları sonlandırır ve bilgisyarınızı yeniden başaltır. EWX_LOGOFF : Bu seçenek kaydedilmemiş tüm bilgileri kaydederek o anda açık olan tüm uygulamaları sonlandırır ve mevcut kullanıcıyı ağdan kopartır ve yeni bir kullanıcı adıyla bağlanmanız için logon ekranını getirir. Eğer fonksiyon işlevini başarıyla gerçekleştirirse sıfırdan farklı bir değer döndürür. Eğer başarısız olursa sifir döndürür. Oluşan hata GetLastError() fonksiyonu ile bulunabilir. procedure TForm1.BitBtn1Click(Sender: TObject); begin If RadioButton1.Checked=True then ExitWindowsEx(EWX_SHUTDOWN,0); //EWX_SHUTDOWN Bilgisayari Kapatir If RadioButton2.Checked=True then ExitWindowsEx(EWX_REBOOT,0); //EWX_REBOOT Bilgisayari yeniden baslatir If RadioButton3.Checked=True then ExitWindowsEx(EWX_LOGOFF,0); //EWX_LOGOFF Mevcut kullaniciyi logoff yapar end;

Program Windows NT olan makinalarda sadece Log Off yapabiliyor. Çok yakında NT'de kapama ve yeniden başlatma işleminin nasıl yapılabileceği ile ilgili daha detaylı bilgiyi burada bulabilirsiniz.

1221

INCREMENTAL SEARCHING How to add incremental search to your (database) application.

Dateline: 05/04/99 Just a few words Today, developing database applications using Delphi is easy as clicking a mouse button. With the help of the Database Form Wizard, we can create simple (or even complex) database aware forms/programs in seconds. Every Delphi developer can build data processing application, but only those who take care of the user will rise among others. If we want our programs to be "user friendly" we have to provide some additional routines that will speed up data manipulation. This article will be dealing with data searching. Assumptions In order to fully understand the code and techniques described in this article, it will be desirable for you to have some basic knowledge of Delphi's database programming (specifically: indexes and keys) and Object Pascal in general Building a simple data previewing form We will start this tutorial with Database Form Wizard. Of course, everything the wizard does, we can do by hand but the wizard saves a lot of time. Use the Database Form Wizard to build a single-table main form that displays all the fields of customer.db (dbdemos alias) in a grid. To make the grid display data sorted, use Object Inspector to change the TTables component IndexName property to ByCompany. Now, we need to place one TEdit control somewhere on the form, name it edSearch. (Use Object Inspector to change TEdit's name property to 'edSearch'). If you want to, you can remove TDBNavigator control - we don't need it for this simple project. Simple search TTable has a number of functions that will search for values in a database. Some of these are Goto, GoToKey, GoToNearest, Find, FindKey, Find Nearest, etc. For a complete reference see Delphi's help, topic: Searching for records based on indexed fields. In order to provide simple search mechanism, in our application; add this code to handle the edits OnChange event as follows: procedure TForm1.edSearchChange(Sender: TObject); begin with Table1 do begin SetKey; FieldByName('Company').AsString:=edSearch.text; GotoNearest; end; end;

As you can read from Delphi' help, this is just one of the few ways we can use to locate desired records. GotoNearest method of TTable component finds the nearest match to a partial field value. Run your application, and as you type letters in edit control Delphi moves the cursor to the record that most closely matches the text in edSearch. Note: if you don't understand what does SetKey do, don't be lazy: read the help files. This technique is commonly known as incremental search.

1222

Some more spicy solution Let us now extend our search "algorithm" with a few lines of code. The idea is to fill the text property of edSearch control with the value of the selected (found) record - we want our users to be aware (a bit more) of found record and its value. Of course, we have to provide the same functionality as before. I think that this technique and its final result will be much more eye candy - user friendly. Incremental filling search Replace edits OnChange event with the following code: procedure TForm1.edSearchChange(Sender: TObject); var txt, sfind:string; len:integer; begin //don't do anything if user presses //delete or backspace if edFromCode = true then begin edFromCode := false; exit; end; //don't do anything if there is //no text in edSearch txt:=edSearch.Text; if Length(txt)=0 then exit; //goto nearest match with Table1 do begin SetKey; FieldByName('Company').AsString:=edSearch.text; GotoNearest; end; //calculate what part of text should be selected sfind := Table1.FieldByName('Company').AsString; len := Length(sfind) - Length(txt); if len > 0 then begin edFromCode:=true; edSearch.Text:=sfind; edSearch.SelStart:=Length(txt); edSearch.SelLength:=len; end; end;

For this technique, to be fully functional, we have to write some code in edits OnKeyDown event handler: procedure TForm1.edSearchKeyDown (Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key=VK_DELETE) or (Key=VK_BACK) then begin if Lenght(edSearch.Text)>0 then begin; //onchange event should not be executed... edFromCode := true; end; end; end;

This code will assure that our new search algorithm works with delete keys. Note: edFromCode is Boolean type variable defined at the beginning of the unit (above all event handlers, but after the implementation line) - it is global for this unit (we are referencing edFromCode from two different procedures). Check it Try running your program now. While you type letters in edit control, Delphi finds nearest match and fills its value in edit control. 1223

Conclusion I hope you will find some place in your applications for this approach to data searching. If you need some help with code, don't hesitate to mail me, I'll be glad to explain it a bit more... Finally, if you want to provide even more visible approach to data manipulating (using DBGrid) check out Coloring DBGrid article. For non-indexed field searching check Data Searching Part 2

DATA SEARCHING Searching for values/records in non-indexed fields. Incremental Searching Part 2.

Dateline: 12/14/99 Preface In the Incremental searching article, we saw one algorithm that searches for values in a database table. GoToNearest method was used to find the nearest match to a partial field value. In order to use the GoToNearest an application must specify the IndexName property of a table. In other words if we want to search for some Company we have to make sure that Company field is defined as secondary index (ByCompany). Many of you have mailed me with questions like: "How can I search for records in a table on non-indexed field?" In this article we'll extend the Incremental filling search technique to find a value in any (every) field - indexed or non-indexed GotoData First the function. lTable is our Table to search, lField is TField we've added with the Fields Editor and lValue is the string value we want to find in lField. The GotoData returns True if the value (more precisely: nearest match) was found False otherwise. function GotoData (const lTable: TTable; const lField: TField; const lValue: String) : Boolean; var bMark : TBookMark; sPart : string begin Result := False; if not lTable.Active then Exit; if lTable.FieldDefs.IndexOf(lField.FieldName) < 0 then Exit; bMark := lTable.GetBookMark; With lTable do begin DisableControls; try First; While not EOF do begin spart:=Copy(lField.AsString,1,Length(lValue)); if LowerCase(spart) = LowerCase(lValue) then

1224

begin Result := True; Break; end else Next; end; {while} finally EnableControls; end; {try} end; {with} if (Not Result) then lTable.GotoBookMark(bMark); lTable.FreeBookMark(bMark); end;

Project To see how this function works we'll use the project (and the code) from the Incremental searching article. In order to use our GotoData function we have to place one TComboBox component on a form. Change combo's name to cboFields, set its Style property to csDropDownList. We fill this combo with Field Names in the main form's OnCreate event handler.

//fill the combo with Field Names for i:=0 to Table1.FieldCount - 1 do cboFields.Items.Add(Table1.Fields[i].FieldName);

The GotoData function is then used in the edSearch OnChange event handler. Simply replace the code //goto nearest match with Table1 do begin SetKey; FieldByName('Company').AsString:=edSearch.text; GotoNearest; end; sfind := Table1.FieldByName('Company').AsString;

with //GotoData-goto nearest match if GotoData(Table1, Table1.FieldByName(cboFields.Text), edSearch.Text) then sfind := Table1.FieldByName(cboFields.Text).AsString else sfind := '';

1225

Final words Be sure to download this project. As always, if you need some help with code, don't hesitate to mail me, I'll be glad to explain it a bit more...

Distributing your application with the BDE Delphi allows you to generate a nice tight executable file (.EXE), but if you have created a database application you must include the files that make up the Borland Database Engine as well. The table below shows the files that are mandatory when delivering a database application with Delphi. File Name Description ------------------------------IDAPI01.DLL BDE API DLL IDBAT01.DLL BDE Batch Utilities DLL IDQRY01.DLL BDE Query DLL IDASCI01.DLL BDE ASCII Driver DLL IDPDX01.DLL BDE Paradox Driver DLL IDDBAS01.DLL BDE dBASE Driver DLL IDR10009.DLL BDE Resources DLL ILD01.DLL Language Driver DLL IDODBC01.DLL BDE ODBC Socket DLL ODBC.New Microsoft ODBC Driver Manager DLL V2.0 ODBCINST.NEW Microsoft ODBC Driver Installation DLL V2.0 TUTILITY.DLL BDE Table Repair Utility DLL BDECFG.EXE BDE Configuration Utility DLL BDECFG.HLP BDE Configuration Utility Help IDAPI.CFG BDE Configuation File (settings)

To assist the user, Delphi ships with an install program for exporting the appropriate files that you want deliver to your clients.

1226

COLORING DBGRID How to enhance the functionality of a TDBgrid component using colors.

Dateline: 03/16/99 Adding color to your database grids will enhance the appearance and differentiate the importance of certain rows or columns within the database. Since the DBGrid is a great user interface tool for displaying data, this article will focus on questions like "How do I change the color of particular row/column/cell in a DBGrid?" Preparations This article assumes that you know how to connect a database to DBGrid component. The easiest way to accomplish this is to use the Database Form Wizard. Select the employee.db from DBDemos alias. Select all fields except EmpNo. Coloring Columns The first (and the easiest) thing you can do, to visually enhance the user interface, is to color individual column in the data-aware grid. We will accomplish this through TColumns property of the grid. Select the grid component in the form and invoke the Columns editor by double clicking on the grid's Columns property in the Object Inspector. For more information on Columns editor look for "Columns editor: creating persistent columns" in your Delphi help files. Now, everything you have to do is to specify the background color of the cells of the

particular column. For text foreground color, see the font property.

This is what I have done, after few clicks... You have to agree that this is much better that the standard black'n'white grid (of course, use colors if you really need them).

1227

Coloring Rows If you want to color the selected row in a DBGrid but you don't want to use the dgRowSelect option because you want to be able to edit the data you should use the DBGrid.OnDrawColumnCell event. This technique demonstrates how to dynamically change the color of text in a DBGrid: procedure TForm1.DBGrid1DrawColumnCell (Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin if Table1.FieldByName('Salary').AsCurrency>36000 then DBGrid1.Canvas.Font.Color:=clMaroon; DBGrid1.DefaultDrawColumnCell (Rect, DataCol, Column, State); end;

If an employee's salary is greater than 36 thousand, its row is displayed in Maroon colored text. Next technique demonstrates how to dynamically change the color of row in a DBGrid: procedure TForm1.DBGrid1DrawColumnCell (Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin if Table1.FieldByName('Salary').AsCurrency>36000 then DBGrid1.Canvas.Brush.Color:=clWhite; DBGrid1.DefaultDrawColumnCell (Rect, DataCol, Column, State); end;

If an employee's salary is greater than 36 thousand, its row is displayed in White. Coloring Cells And finally: if you want to change the background color of the cells of the particular column (+ text foreground color), this is what you have to do: procedure TForm1.DBGrid1DrawColumnCell (Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin if Table1.FieldByName('Salary').AsCurrency>40000 then begin

1228

DBGrid1.Canvas.Font.Color:=clWhite; DBGrid1.Canvas.Brush.Color:=clBlack; end; if DataCol = 4 then //4 th column is 'Salary' DBGrid1.DefaultDrawColumnCell (Rect, DataCol, Column, State); end;

If an employee's salary is greater than 40 thousand, its Salary cell is displayed in Black and text is displayed in White. Conclusion Techniques described in this article can really distinguish you from others, but be careful: too much coloring is too much... Now, when I look, there are far too much colors in these examples.

1229

Highlighting a Row in a DBGrid How do I highlight a row in a TDBGrid based on the value of field? This question begs for a short bit of a philosophical discourse before I actually answer the question. Really, I'm not just tooting my horn... it's actually valid Cue It Up Providing visual cues for users in your applications is an important part of good interface design. Visual cues allow the user to immediately identify and differentiate special circumstances that may occur within the course of an application’s session. For instance, in a column of numbers, it’s easier to tell the difference between positive and negative values at first glance if the negative numbers are either a different color or enclosed in parentheses. In the table below, the left column contains positive and negative numbers with the negative number merely represented by their negative sign. The right column represents negative numbers in red boldface text. Let's take a look. 10015 10015 15486 15486 -54862 -54862 54846 54846 78948 78948 40594 40594 -45945 -45945 78945 78945 As you can see, it is far easier to discern the negative values in the right column than it is to discern them in the left column. The point to all this is that if you build programs or interfaces which will be viewed by a lot of people, it's a good idea to do the extra bit of work to make the job of interpreting what's in your interface that much easier. Let's Get Down to Business See? I told you it wasn't going to take a long time... In any case, let's get back to the topic... Highlighting a row in a TDBGrid based on the value of a particular field is a perfect example of providing visual cues for your users. But with this particular operation, it's not as intuitive as you might think; not that it's hard, but I had to do a bit of digging to get the answer for this one. At first glance, I thought why not just put some code in the OnCalcFields event. Okay, okay... bad thought. So lo and behold I saw the OnDrawDataCell event. Unfortunately, I found out that OnDrawColumnCell replaced it in the 32-bit versions of Delphi, so I had to turn that way. No problem. I found a bit of code in Neil Rubenking's book, "Delphi Programming Problem Solver," and that got me started. Let's talk concepts first... Behind the Scenes I didn't know much detail information about the TDBGrid component until I studied the VCL source code in DBGrids.PAS. And what I discovered was rather interesting. To draw itself, TDBGrid performs a lot of canvas manipulation. And while it happens rather fast, each cell in the grid is drawn individually. Essentially, the grid gets the 1230

dimensions of each cell and feeds that information into a TRect structure. Then that is passed to various drawing functions to display the text. Yikes! You ought to see the DrawCell method - it's big! Good for us that it's pretty fast at executing... Drawing the Cell As it turns out, the way painting occurs is pretty straight forward. Delphi progresses through the grid row-by-row. In each row, it then iterates through each cell, drawing the background and text within the cell's bounding rectangle. So, to highlight a row, we actually have to highlight each cell of the row, and that's handled through the OnDrawColumnCell event and a little code. Study the code sample below, and we'll discuss it immediately after the listing: procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin with Sender as TDBGrid, DataSource.DataSet do if (FieldByName('AmountPaid').AsFloat > 15000) then DrawField(Column.Field.DisplayText, Rect, Canvas, Column.Font, Column.Alignment, [fsBold], clYellow, clRed); end; {This is the workhorse routine that does the drawing.} procedure TForm1.DrawField(const Value : String; const Rect : TRect; vCanvas : TCanvas; vFont: TFont; vAlignment: TAlignment; FontStyle : TFontStyles; FontColor : TColor; BGColor : TColor); var I : Integer; begin I := 0; //First, fill in the background color of the cell vCanvas.Brush.Color := BGColor; vCanvas.FillRect(Rect); //SetBkMode ensures that the background is transparent SetBkMode(Canvas.Handle, TRANSPARENT); //Set the passed font properties vCanvas.Font := vFont; vCanvas.Font.Color := FontColor; vCanvas.Font.Style := vCanvas.Font.Style + FontStyle; //Set Text Alignment case vAlignment of taRightJustify : begin SetTextAlign(vCanvas.Handle, TA_RIGHT); I := Rect.Right - 2; end; taLeftJustify : begin SetTextAlign(vCanvas.Handle, TA_LEFT); I := Rect.Left + 2; end; taCenter begin

:

1231

SetTextAlign(vCanvas.Handle, TA_CENTER); I := (Rect.Right + Rect.Left) DIV 2; end; end; { case } //Draw the text vCanvas.TextRect(Rect, I, Rect.Top + 2, Value); SetTextAlign(vCanvas.Handle, TA_LEFT); end;

The code above is an excerpt from a form unit that I created. On the form, I've got a TTable, TDataSource, and a TDBGrid dropped onto it. The TTable points to the DBDEMOS alias, and is linked to the ORDERS.DB table. It's really simple. Anyway, what's going in the code? What we're doing in the event handler code is merely adding a little functionality to the default cell drawing methodology by calling the DrawField method of the Form1. Since we're riding on the assumption that the DBGrid iterates row-by-row, while at the same time checking and refreshing its datalinks, we can use that to check the value of a field as DBGrid iterates - in this case, the AmountPaid field - to see if we need to highlight the row. I won't go into specific details about the DataField method. It's pretty straight-forward. However, I will point out the most important thing, and that's the first part of the method: //First, fill in the background color of the cell vCanvas.Brush.Color := BGColor; vCanvas.FillRect(Rect); //SetBkMode ensures that the background is transparent SetBkMode(Canvas.Handle, TRANSPARENT); Here, I'm filling in the background of the cell. If I didn't call SetBkMode immediately after the FillRect method, the row would show up completely solid with no text displayed. In any case, try this out and see how it works for you. Well... we're actually not done yet.... I Just Can't Get No Satisfaction After I wrote this code, I just wasn't satisfied with it. Why? The reason is because I take object-oriented programming seriously, and I realized that the proper way to introduce this type of functionality into a DBGrid would be to actually make a component that had the capability built into it. That way, I wouldn't have to rewrite the code each time I wanted to have this functionality. So that's what I did... NOTE: If you have the InfoPower components by Woll2Woll software, the TwwDBGrid has this functionality PLUS lots of other really neat enhancements. If you don't have them, you should consider buying them. So why would I bother writing an article on this? Well... why not? The code listing below is the complete listing of TEnhDBGrid. I'll talk particulars after I give you the listing. unit EnhDBGrid; interface uses Windows, Classes, Graphics, Grids, DBGrids; type TEnhDBGrid = class(TCustomDBGrid) private

1232

FHighlightBGColor : TColor; FHighlightFont : TFont; FDoRowHighlight : Boolean; procedure DrawField(const Value : String; const Rect : TRect; vCanvas : TCanvas; const vFont: TFont; vAlignment: TAlignment; const FontStyle : TFontStyles; const FontColor : TColor; const BGColor : TColor); protected procedure DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); override; procedure SetHighlightFont(Value : TFont); public constructor Create(AOwner : TComponent); override; property Canvas; property SelectedRows; property DoRowHighLight : Boolean read FDoRowHighLight write FDoRowHighlight default False; published property Align; property BorderStyle; property Color; property Columns stored False; //StoreColumns; property Ctl3D; property DataSource; property DefaultDrawing; property DragCursor; property DragMode; property Enabled; property FixedColor; property Font; property HighlightBGColor: TColor read FHighlightBGColor write FHighlightBGColor; property HighlightFont : TFont read FHighlightFont write SetHighlightFont; property ImeMode; property ImeName; property Options; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ReadOnly; property ShowHint; property TabOrder; property TabStop; property TitleFont; property Visible; property OnCellClick; property OnColEnter; property OnColExit; property OnColumnMoved; property OnDrawDataCell; { obsolete } property OnDrawColumnCell; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEditButtonClick; property OnEndDrag;

1233

property property property property property property property end;

OnEnter; OnExit; OnKeyDown; OnKeyPress; OnKeyUp; OnStartDrag; OnTitleClick;

procedure Register; implementation constructor TEnhDBGrid.Create(AOwner : TComponent); begin inherited Create(AOwner); //Give the highlight font a default value FHighlightFont := TFont.Create; end; procedure TEnhDBGrid.DrawField(const Value : String; const Rect : TRect; vCanvas : TCanvas; const vFont: TFont; vAlignment: TAlignment; const FontStyle : TFontStyles; const FontColor : TColor; const BGColor : TColor); var I : Integer; begin I := 0; //First, fill in the background color of the cell vCanvas.Brush.Color := BGColor; vCanvas.FillRect(Rect); //SetBkMode ensures that the background is transparent SetBkMode(Canvas.Handle, TRANSPARENT); //Now draw out the text in the cell vCanvas.Font := vFont; vCanvas.Font.Color := FontColor; vCanvas.Font.Style := vCanvas.Font.Style + FontStyle; //Now set the text alignment case vAlignment of { } taRightJustify : begin SetTextAlign(vCanvas.Handle, TA_RIGHT); I := Rect.Right - 2; end; taLeftJustify : begin SetTextAlign(vCanvas.Handle, TA_LEFT); I := Rect.Left + 2; end; taCenter : begin SetTextAlign(vCanvas.Handle, TA_CENTER); I := (Rect.Right + Rect.Left) DIV 2; end; end; { case } //Write the text!!! vCanvas.TextRect(Rect, I, Rect.Top + 2, Value);

1234

//Necessary step to align rest of the text in the DBGrid SetTextAlign(vCanvas.Handle, TA_LEFT); end; procedure TEnhDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin //Do the inherited method inherited DrawColumnCell(Rect, DataCol, Column, State); //If user wants row highlighted, then call DrawField if DoRowHighLight then DrawField(Column.Field.DisplayText, Rect, Canvas, FHighlightFont, Column.Alignment, FHighlightFont.Style, FHighlightFont.Color, FHighlightBGColor); end; procedure TEnhDBGrid.SetHighlightFont(Value : TFont); begin //Assign the font FHighlightFont.Assign(Value); end; procedure Register; begin RegisterComponents('BD', [TEnhDBGrid]); end; end.

The component is merely a functionality wrapper for the form code above, so I won't discuss it in any meaningful detail. What I will discuss, however are the properties that I introduced into the component. First off is the public property DoRowHighlight. This is a Boolean property that you set at runtime to activate the functionality of the component. You use it in the OnDrawColumnCell method as follows: procedure TForm1.EnhDBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin //Turns highlighting on or off depending on the row with Sender as TEnhDBGrid, DataSource.DataSet do if FieldByName('AmountPaid').AsFloat > 15000 then DoRowHighlight := True else DoRowHighlight := False; end; This is similar to what I did in the example above, but in this case, depending upon the AmountPaid field's value, I turn the functionality on or off. Admittedly, it's rather crude, but hey! it works! The other two properties are HighlightFont and HighlightBGColor. The first property merely sets the highlighted cells' font properties and the second sets the color of the background you want to paint. With respect to the HighlightFont property, notice in the Create constructor, I actually create an instance of a TFont and assign 1235

it to FHighlightFont. This is necessary, otherwise at runtime, you won't be able to set the font to anything. It's possible to assign the font to the default font of the DBGrid, but you won't be able to change the font. So, creating an instance that can be changed is the way to go. Those of you who are pros at component writing may notice something in the code. The DrawField method is declared as virtual. The reason for this is that just in case someone wanted to add functionality to what I already created, they wouldn't have to rewrite the code - it's adding a bit of an OOP twist to the component. Also, notice that I didn't descend from TDBGrid; rather, I descended directly from TDBGrid. My reasoning behind this was that TDBGrid merely exposes the protected properties of TCustomDBGrid. I felt it was a waste to branch off of a component that didn't really add any new functionality. Also, while I exposed the same properties as TDBGrid does, I could have just as easily limited the exposure. In other words, descending from the ancestor above TDBGrid gives me a lot more control over what I want to expose and not expose. Well, thanks for bearing with me. Have fun with the code!

1236

- 16 Delphi Database Architecture · ·

·

· · · · · ·

· Database Basics · Local Databases Client/Server Databases · Single-Tier, Two-Tier, and Multitier Database Architecture The Borland Database Engine · BDE Drivers · BDE Aliases · Delphi's Built-in Databases · SQL Links Delphi Database Components · The TDataSet Class · The Fields Editor · The Table Component · The Query Component · The StoredProc Component · The UpdateSQL Component · The DataSource Component · The Session Component · The Database Component The BatchMove Component · The TField Component Client/Server Database Components Creating a BDE Alias · Creating an Alias with the BDE Administrator Creating an Alias Through Code Summary Workshop · Q&A · Quiz · Exercises

Today you begin to learn about database programming in Delphi. If you are new to database programming, at first glance it might appear overwhelming. Today I'll try to eliminate any confusion by presenting a clear picture of the labyrinth known as database programming. First, I'll give you an overview of the Delphi database architecture. After that I'll go over some of the data access components. Make no mistake: Database programming is complicated. I'll give you a high-level view of database programming in Delphi, but I won't attempt to cover every detail. NOTE: Not all the concepts and components discussed in this chapter pertain to every version of Delphi. The Professional version of Delphi has more database capabilities than the Standard version. The Client/Server version of Delphi has many more database capabilities than either the Standard or Professional version.

1237

Database Basics Database programming comes with a whole gaggle of buzzwords: BDE, client, server, ODBC, alias, SQL, query, stored procedure, and so on. The good news is that it isn't all that bad after you learn some basics. First, let's take a moment to talk about databases. When you hear the word database, you probably imagine data stored in table format. The table probably contains fields such as FirstName, LastName, and PhoneNumber. These fields are filled with data to create individual records in a database file. If that's what you envision when you think of a database, you're not too far off, but you aren't exactly correct, either. The term database is used to describe an all-encompassing data creation and maintenance system. It is true that a database can be as simple as one table. On the other hand, a real-world database can include dozens or even hundreds of tables with thousands or millions of records. These tables can contain one or more indexes. A complete client/server SQL database solution can also contain numerous queries and stored procedures. (Don't worry; I'll explain some of these terms later in the chapter.) So as you can see, a database is more than just a table with data. Speaking of tables, let's quickly cover some table basics. A table consists of at least two parts: fields and records. Fields are the individual categories of data in a table. For example, a table containing an address book would have a field called FirstName, a field called LastName, one called Address, PhoneNumber, and so on. Fields are also referred to as columns. A record, then, is one person's complete address: first name, last name, address, and so on. Records are also called rows. A database is just a collection of data, of course, but database tables are often displayed in spreadsheet format. The column headers across the top indicate the field names. Each row in the table contains a complete record. Figure 16.1 shows just such a database table displayed in grid (or table) format. FIGURE 16.1. A typical database table. New Term: The pointer to the current record within a database is called the cursor. The cursor points to the record that will be read if data is requested and the record that will be updated if any edits are made. The cursor is moved when a user browses the database, inserts records, deletes records, and so on. NOTE: When I say the cursor is a pointer, I don't mean it's a pointer in the Object Pascal sense. I merely mean it is an indicator of the current record's position. New Term: A collection of data returned by a database is called a dataset. A dataset can be more than just the data contained in a table. A dataset can be the results of a query containing data acquired from many tables. For example, let's say you have a database containing names and addresses of your customers, their orders, and the details of each order. This data might be contained in tables named Clients, Orders, and Order Details. Now let's say you request the details of the last 10 orders placed by Company X. You might receive a dataset containing information from the Clients table, the Orders table, and the Order Details table. Although the data comes from several different sources, it is presented to you as a single dataset.

Local Databases The simplest type of database is the local database. A local database is a database that resides on a single machine. Imagine that you have a program that needs to store a list of names and addresses. You could create a local database to store the data. This database would probably consist of a single table. The table is accessed only by your program; no one else has access to it. Any edits made to the database are written directly to the database. Paradox, dBASE, and Access databases are usually local databases.

1238

Client/Server Databases Another way a database can be implemented is as a client/server database. The database itself is stored and maintained on a file server (the server part of the equation). One or more users (the clients) have access to the database. The users of this type of database are likely to be spread across a network. Because the users are oblivious to one another, more than one might attempt to access the database at the same time. This isn't a problem with client/server databases because the server knows how to handle all the problems of simultaneous database access. The users of a client/server database almost never work with the database directly. Instead, they access the database through applications on their local computer. These applications, called client applications, ensure that the users are following the rules and not doing things to the database that they shouldn't be. It's up to the client application to prevent the user from doing something that would damage the database. DATABASE SERVERS As long as I am talking about client/server databases, let's take a moment to talk about database servers. Database servers come in several flavors. Some of the most popular include offerings from InterBase (a Borland-owned company), Oracle, Sybase, Informix, and Microsoft. When a company purchases one of these database servers, it also purchases a license that enables a maximum number of users to access the database server. These licensed users are often referred to as seats. Let's say a company buys InterBase and purchases licenses for 50 seats. If that company grows to the point that 75 users require access to the database, that company will have to buy an additional 25 seats to be in compliance with the license. Another way that client/server databases are sold is on a per connection basis. A company can buy a license for 50 simultaneous connections. That company can have 1,000 users of the database, but only 50 can be connected to the database at any one time. The database server market is big business, no question about it.

Single-Tier, Two-Tier, and Multitier Database Architecture Local databases are often called single-tier databases. A single-tier database is a database in which any changes--such as editing the data, inserting records, or deleting records--happen immediately. The program has a more direct connection to the database. In a two-tier database, the client application talks to the database server through database drivers. The database server takes the responsibility for managing connections, and the client application is largely responsible for ensuring that the correct information is being written to the database. A fair amount of burden is put on the client application to make sure the database's integrity is maintained. In a multitier client/server architecture, the client application talks to one or more application servers that, in turn, talk to the database server. These middle-level programs are called application servers because they service the needs of the client applications. One application server might act as a data broker, responding to and handling data requests from the client and passing them on to the database. Another application server might only handle security issues. Client applications run on local machines; the application server is typically on a server, and the database itself might be on another server. The idea behind the multitier architecture is that client applications can be very small because the application servers do most of the work. This enables you to write what are called thin-client applications. Another reason to use a multitier architecture is management of programming resources. The client applications can be written by less experienced programmers because the client applications interact with the application server that controls access to the database itself. The application server can be written by more experienced programmers who know 1239

the rules by which the database must operate. Put another way, the application server is written by programmers whose job is to protect the data from possible corruption by errant client applications. Although there are always exceptions, most local databases make use of the single-tier architecture. Client/server databases use either a two-tier or a multitier architecture. So how does this affect you? Most applications you write with Delphi for use with a client/server database will be client applications. Although you might be one of the few programmers given the task of writing server-side or middle-tier applications, it's a good bet that you will write primarily client applications. As an application developer, you can't talk directly to these database servers. Let's look next at how a Delphi application talks to a database.

The Borland Database Engine To enable access to local databases and to client/server databases, Delphi provides the Borland Database Engine (BDE). The BDE is a collection of DLLs and utilities that enables access to a variety of databases.

To talk to client/server databases, you must have the Client/Server version of Delphi. This version ships with SQL Links drivers used by the BDE to talk to client/server databases. Figure 16.2 shows the relationship between your application, the BDE, and the database. FIGURE 16.2. Your application, the BDE, and the database.

BDE Drivers Naturally, database formats and APIs vary widely. For this reason the BDE comes with a set of drivers that enables your application to talk to several different types of databases. These drivers translate high-level database commands (such as open or post) into commands specific to a particular database type. This permits your application to connect to a database without needing to know the specifics of how that database works. The drivers that are on your system depend on the version of Delphi you own. All versions of Delphi come with a driver to enable you to connect to Paradox and dBASE databases. This driver, called STANDARD, provides everything you need to work with these local databases. The Client/Server version of Delphi includes drivers to connect to databases by Sybase, Oracle, Informix, InterBase, and others.

BDE Aliases The BDE uses an alias to access a particular database. This is one of those terms that might confuse you at first. The terms alias and database are often used interchangeably when talking about the BDE. New Term: A BDE alias is a set of parameters that describes a database connection. When it comes right down to it, there isn't much to an alias. In its simplest form, an alias tells the BDE which type of driver to use and the location of the database files on disk. This is the case with aliases you will set up for a local database. In other cases, such as aliases for client/server databases, the alias contains other information as well, such as the maximum size of BLOB data, the maximum number of rows, the open mode, or the user's username. After you create an alias for your database, you can use that alias to select the database in your Delphi programs. Later today, in the section "Creating a BDE Alias," I'll tell you how to go about creating a BDE alias for your own databases.

Delphi's Built-in Databases As long as I am on the subject of aliases, let's take a quick look at the aliases already set up on your system. To view existing aliases, perform these steps: 1. Start Delphi or create a new application if Delphi is already running.

1240

2. Switch to the Data Access tab of the Component palette, select a Table component, and place it on the form. 3. Click on the DatabaseName property in the Object Inspector and then click the drop-down arrow button to display a list of aliases. After performing these steps, you'll see a list of available databases. At least one of these should be the DBDEMOS alias. This database alias is set up when Delphi is installed. Select the DBDEMOS database from the list. NOTE: The list of databases you see depends on several factors. First, it depends on whether you have the Standard, Professional, or Client/Server version of Delphi. It also depends on whether you elected to install Local InterBase. Finally, if you happen to have C++Builder or another Borland product installed (such as Visual dBASE or IntraBuilder), you might see additional databases. As long as you are here, move to the TableName property and take a look at the available tables. The tables you see are those available for this database (this alias). Select another alias for the DatabaseName property. Now look at the table names again. You will see a different list of tables.

SQL Links The Client/Server version of Delphi comes with SQL Links in addition to the BDE. SQL Links is a collection of additional drivers for the BDE. These drivers enable Delphi applications to connect to client/server databases such as those provided by Oracle, InterBase, Informix, Sybase, and Microsoft. Details regarding deployment of SQL Links drivers are also available in DEPLOY.TXT. LOCAL INTERBASE The Standard and Professional versions of Delphi come with a single-user copy of Local InterBase. Local InterBase is just what its name implies: a version of InterBase that operates on local databases. The Client/Server version of InterBase, on the other hand, is a fullfeatured client/server database. The main reason that Delphi ships with Local InterBase is so that you can write an application that operates on local databases and then later change to a client/server database with no programming changes. This gives you an opportunity to hone your client/server programming skills without spending the money for a client/server database. If you attempt to access a Local InterBase table at either design time or runtime, you will be prompted for a username and password. The Local InterBase administrator is set up with a username of SYSDBA and a password of masterkey. You can use these for login, or you can go to the InterBase Server Manager utility and add yourself as a new user to the InterBase system.

Delphi Database Components Okay, so the preceding section isn't exactly the type of reading that keeps you up all night turning pages. Still, it's important to understand how all the database pieces fit together. With that background, you can now turn your attention to the database components provided by VCL and how those components work together to create a database application. First, I'll give you a quick overview of the VCL database components, and then you'll look at individual classes and components in more detail. The VCL database components fall into two categories: nonvisual data access components and visual data-aware components. Simply put, the nonvisual data access components provide the mechanism that enables you to get at the data, and the visual 1241

data-aware components enable you to view and edit the data. The data access components are derived from the TDataSet class and include TTable, TQuery, and TStoredProc. The visual data-aware components include TDBEdit, TDBListBox, TDBGrid, TDBNavigator, and more. These components work much like the standard edit, list box, and grid components except that they are tied to a particular table or field in a table. By editing one of the data-aware components, you are actually editing the underlying database as well. NOTE: All the VCL database components can be termed data components. I use the term data access components for the nonvisual database components on the Data Access tab of the Component palette and the term data-aware components for the visual database components from the Data Controls tab. Interestingly, these two component groups cannot talk directly to each other. Instead, the TDataSource component acts as an intermediary between the TDataSet components and the visual data-aware components. This relationship is illustrated in Figure 16.3. FIGURE 16.3. The architecture of the VCL database components. You'll look at these components in more detail, but first I'll walk you through a quick exercise to illustrate the relationship described in this section. Start Delphi or create a new application if Delphi is already running. Now do the following: 1. Place a Table component on the form. 2. Locate the DatabaseName property in the Object Inspector and choose the DBDEMOS database. 3. Locate the TableName property and choose the ANIMALS.DBF table. 4. Drop a DataSource component on the form and set its DataSet property to Table1 (choose Table1 from the drop-down list). The data source is now linked to the dataset (the Table). 5. Drop a DBGrid component on the form and change its DataSource property to DataSource1. This connects the grid to the data source and, indirectly, to the dataset. 6. Now click the Table component on your form to select it. Change its Active property to True. You now have data in the table. That was easy, but you're not done yet. Notice, by the way, that you can use the scrollbars on the grid even at design time. Okay, just a couple more steps: 1. Place a DBImage component on the form and change its DataSource property to DataSource1 and its DataField property to BMP (BMP is a field name in the ANIMALS.DBF table that contains a picture of the animal). Hey, a fish! Size the DBImage as desired to fit the size of the image that is showing in the component. 2. Place a DBNavigator component on the form and change its DataSource property to DataSource1. Now run the program. Click any of the DBNavigator buttons. When you click on the Next Record button, the record pointer changes in the DBTable and the picture changes in the DBImage component. All that without writing a line of code! The data access components are used to connect to a database and to a particular table in a database. The Table component is used to access a database table. This is the simplest way of accessing the data in a table. The Query component is a way of accessing a database table using Structured Query Language (SQL) statements. SQL is a more powerful way of accessing tables, but it is also more complex. You will use either a Table or Query component to access a 1242

database, but not both. Another component is the StoredProc component that enables you access to a database via stored procedures. A stored procedure is a collection of database statements that performs one or more actions on a database. Stored procedures are usually used for a series of database commands that is repeated often.

The TDataSet Class TDataSet is the ancestor class for TTable, TQuery, and TStoredProc. As such, most properties, methods, and events that these classes use are actually defined by TDataSet. Because so many characteristics of the derived classes come from TDataSet, I'll list the primary properties, methods, and events of TDataSet here, and later I'll list the properties, methods, and events particular to each derived class. Table 16.1 lists the most commonly used properties of the TDataSet class, Table 16.2 lists the primary methods, and Table 16.3 lists the primary events. TABLE 16.1. PRIMARY TDataSet PROPERTIES. Proper ty Active AutoC alcFiel ds Bof Cache dUpda tes CanM odify DataS ource Datab aseNa me Eof FieldC ount Fields

Description Opens the dataset when set to True and closes it when set to False. Determines when calculated fields are calculated. Returns True if the cursor is on the first record in the dataset and False if it isn't. When True, updates are held in a cache on the client machine until an entire transaction is complete. When False, all changes to the database are made on a record-by-record basis. Determines whether the user can edit the data in the dataset. The DataSource component associated with this dataset. The name of the database that is currently being used. Returns True if the cursor is at the end of the file and False if it isn't. The number of fields in the dataset. Because a dataset might be dynamic (the results of a query, for example), the number of fields can vary from one dataset request to the next. An array of TFields objects that contains information about the fields in the dataset. Returns the value of the specified field for the current record. The value is represented as a Variant. An expression that determines which records a dataset contains. When True, the dataset is filtered based on either the Filter property or the OnFilterRecord event. When False, the entire dataset is returned.

FieldV alues Filter Filtere d FilterO Determines how filters are applied. ptions Found Indicates whether a find operation is successful. Handl A BDE cursor handle to the dataset. This is used only when making direct calls e to the BDE. Modifi Indicates whether the current record has been modified. ed RecNo The current record number in the dataset.

1243

Recor dCoun t State Updat eObje ct Updat esPen ding

Returns the number of records in the dataset. Returns the current state of the dataset (dsEdit, dsBrowse, dsInsert, and so on). Specifies the TUpdateObject component to use for cached updates. When True, the cached update buffer contains edits not yet applied to the dataset.

TABLE 16.2. PRIMARY TDataSet METHODS. Method Description Append Creates an empty record and adds it to the end of the dataset. Append Appends a record to the end of the dataset with the given field data and posts Record the edit. ApplyUp Instructs the database to apply any pending cached updates. Updates are not dates actually written until the CommitUpdates method is called. Cancel Cancels any edits to the current record if the edits have not yet been posted. CancelU Cancels any pending cached updates. pdates ClearFiel Clears the contents of all fields in the current record. ds Commit Instructs the database to apply updates and clear the cached updates buffer. Updates Close Closes the dataset. Delete Deletes the current record. Disable Disables input for all data controls associated with the dataset. Controls Edit Enables editing of the current record. EnableC Enables input for all data controls associated with the dataset. ontrols Gets all records from the cursor to the end of the dataset and stores them FetchAll locally. FieldBy Returns the TField pointer for a field name. Name FindFirs Finds the first record that matches the current filter criteria. t

FindNext Finds the next record that matches the current filter criteria. FindLast Finds the last record that matches the current filter criteria. FindPrio Finds the previous record that matches the current filter criteria. r First Moves the cursor to the first record in the dataset. FreeBoo Erases a bookmark set previously with GetBookmark and frees the memory kmark allocated for the bookmark. GetBook Sets a bookmark at the current record. mark GetField Retrieves a list of the field names in the dataset. Names GotoBoo Places the cursor at the record indicated by the specified bookmark. 1244

kmark Insert InsertRe cord Last Locate Lookup

Inserts a record and puts the dataset in edit mode. Inserts a record in the dataset with the given field data and posts the edit. Positions the cursor on the last record in the dataset. Searches the dataset for a particular record. Locates a record by the fastest possible means and returns the data contained in the record. Moves the cursor by the specified number of rows. Moves the cursor to the next record. Opens the dataset. Writes the edited record data to the database or to the cached update buffer. Moves the cursor to the previous record. Updates the data in the dataset from the database. When cached updates are used, this method discards changes previously made to the record but not yet written to the database.

MoveBy Next Open Post Prior Refresh RevertR ecord SetField Sets the values for all fields in a record. s UpdateS Returns the current update status when cached updates are enabled. tatus TABLE 16.3. PRIMARY TDataSet EVENTS.

Event Description AfterCan Generated after edits to a record are canceled. cel AfterClo Generated when a dataset is closed. se AfterDel Generated after a record is deleted from the dataset. ete AfterEdit Generated after a record is edited. AfterIns Generated after a record is inserted. ert AfterOp Generated after the dataset is opened. en AfterPos Generated after the changes to a record are posted. t BeforeC Generated before edits are canceled. ancel BeforeCl Generated before a dataset is closed. ose BeforeD Generated before a record is deleted. elete BeforeE Generated before the dataset goes into edit mode. dit BeforeIn Generated before a record is inserted. sert BeforeO Generated just before a dataset is opened (between the time Active is set to pen True and the time the dataset is actually opened). BeforeP Generated before edits are posted to the database (or the update cache). 1245

ost OnCalcF Generated when calculations are performed on calculated fields. ields OnDelet Generated if an error occurs in deleting a record. eError OnEditE Generated if an error occurs while editing a record. rror OnFilter Generated whenever a new row is accessed and Filter is set to True. Record OnNew Generated when a new record is added to the dataset. Record OnPost Generated when an error occurs while posting the edits to a record. Error OnUpda Generated when an error occurs while cached updates are being written to teError the database. OnUpda teRecor Generated when cached updates are applied to a record. d

The Fields Editor Any TDataSet descendant (TTable, TQuery, or TStoredProc) gives access to the Fields Editor at design time. The Fields Editor enables you to select the fields that you want to include in the dataset. To invoke the Fields Editor, right-click on a Table, Query, or StoredProc component on your form and choose Fields Editor from the context menu. The Fields Editor is displayed. At first the Fields Editor is blank, enabling all fields to be included in the dataset. You can add as many fields as you want to the dataset by selecting Add fields from the Fields Editor context menu. You can also create new fields for the table by choosing New field from the context menu. Figure 16.4 shows the Fields Editor as it appears after adding fields. FIGURE 16.4. The Fields Editor. After you add fields to the dataset, you can click on any field and modify its properties. The properties show up in the Object Inspector, enabling you to change the display format, constraints, display label, or other field characteristics. Cached Updates Cached updates enable you to control when edits are applied to a database, and they are controlled by the CachedUpdates property. When cached updates are allowed, changes to records aren't written directly to the database. Instead, the changes are written to an update cache on the local machine. Records are held in the cache until you call the ApplyUpdates method. To abandon any changes in the update cache, you call the CancelUpdates method. You cancel the edits made to the current record by calling the RevertRecord method.

When cached edits are disabled (CachedUpdates is False), any changes made to a record are written to the database when the cursor leaves the record. This is fine for local databases, but it is not a good solution for client/server databases for a variety of reasons. Most often you hear people talk about network traffic being the primary reason for using cached updates. Although it is certainly true that cached updates help reduce network traffic, the value of cached updates goes far beyond the issue of network traffic. Let me explain further. Many client/server databases return a read-only result set as the result of a query. One advantage of cached updates is that the client can work with a local copy of a dataset, 1246

modify it as needed, and then write the edits to the database all at one time. This is possible because the database server handles updates, insertions, and deletions of records from a read-only dataset. A local database has to lock records when they are being actively edited. When a record is locked, other database users cannot access the record. Using cached updates reduces the time a record is locked to a very short period of time. Another advantage to cached updates is that a user can make several changes to a dataset and then either commit (apply) all changes or rollback (cancel) all changes. This a two-edged sword, however, because if something happens to go wrong on the server when changes are being written to the database, all changes are lost. One drawback of cached updates is that several users might be working with the same record at the same time. It then becomes a race to see who gets the record updated first. In reality, this problem is reduced somewhat by implementing techniques in the client application that check whether multiple edits have taken place on a record. For example, if Joe tries to post an update to a record, the database and/or client application will notify Joe that Mary has changed the record since Joe initially retrieved it from the database. Joe will have to refresh his copy of the dataset to see whether he still needs to modify the record.

The Table Component The Table component, represented by the TTable class, provides the quickest and simplest access to a table. Tables are more than adequate for most single-tier database applications. Usually, you will use the Table component when dealing with local databases and the Query component when dealing with SQL database servers. The TTable class has many properties and methods in addition to those in its ancestor class, TDataSet. Table 16.4 lists the primary properties of the TTable component and Table 16.5 lists the primary methods. Remember, these are properties and methods specific to TTable and do not include those of TTable's ancestor, TDataSet. For the most part, the properties and methods are very intuitive. By that I mean that you can usually figure out what a property or method does by just looking at its name. It doesn't take a lot to figure out that the LockTable method locks a table for an application's specific use and that the UnlockTable method unlocks the table again. Likewise, you don't have to have an IQ of 150 to guess what the CreateTable, DeleteTable, and RenameTable methods do. With that in mind, I'm not going to cover every aspect of every property and method listed here. Instead, let's get on to some of the more interesting aspects of the Table component. TABLE 16.4. PRIMARY TTable PROPERTIES. Property Description Exclusive Locks a local table so that only this application can use it. IndexDefs Contains information about the table's indexes. IndexFieldC The number of fields that make up the current key. ount IndexFieldN Used to set the current key by specifying the names of the fields to use for ames the index. IndexFields Used to retrieve information about a specific field in an index. IndexName Used to specify a secondary index for a table. KeyFieldCou The number of fields to use when searching on partial keys. nt MasterFields The field or fields that should join the master and detail tables. MasterSourc The table to be used as a master table when this table is used as a detail e table. 1247

ReadOnly Specifies whether this table is read-only. TableName The name of the database table. TableType The table's type (Paradox, dBASE, or ASCII). Table 16.5. Primary TTABLE methods. Metho Description d AddIn Creates a new index for the table. dex Apply Applies a range to the dataset. Only records within that the range (determined Range by SetRangeStart and SetRangeEnd) are available for viewing or editing. Batch Moves records from a dataset into the table. Move Cance lRang Removes any ranges currently in effect for the table. e Creat eTabl Re-creates the table using new information. e Delete Deletes a secondary index. Index Delete Deletes a table. Table Empty Deletes all records from the table. Table GetIn dexNa Retrieves a list of all indexes for the table. mes GotoK Moves the cursor to the record indicated by the current key. ey GotoN Moves the cursor to the record that most closely matches the current key. earest LockT Locks a table so that other applications cannot access it. able Rena meTa Renames the table. ble SetKe Enables you to set keys for the dataset. y Sets the start and end range for a dataset and applies the range. This method SetRa performs the same action as calling the SetRangeStart, SetRangeEnd, and nge ApplyRange methods. SetRa ngeEn Sets the end of the range. d SetRa ngeSt Sets the beginning of the range. art Unloc Unlocks a table that was previously locked with LockTable. kTabl 1248

e NOTE: As you have already seen, the DatabaseName property is used to select a BDE alias. For local databases, rather than select an alias from the list, you can enter a directory where database files are located. The TableName property will then contain a list of database tables in that directory. Filters A common need of a filters in detail, databases. Filters query is used to achieve

database application is to filter a table. Before I discuss I want to point out that filters are primarily used on local are rarely used with client/server databases; instead, a SQL the same effect that filters have on local databases.

So why filter? Consider that you might have a table with thousands of records, but you are interested in displaying or working on only a small subset of the table. Let's say you have a database that contains names and addresses of computer users all over the world. Your company sells these names and addresses to other companies that want to do bulk mailings. I call and want to order a mailing list from your company, but I want the list to contain only those computer users who live in Colorado. You could filter your table by postal code and generate a list of names with only Colorado addresses. Or, maybe Borland calls you and wants a list of computer users in Great Britain who are programmers by occupation. In that case, you could filter by occupation and country, thereby giving only the names and addresses the customer is interested in. Using Filters in the Table Component Filters in the Table component are handled in one of two ways: through the Filter property or the OnFilterRecord event. Before I discuss these, let me talk about the Filtered property. This property determines whether the table is filtered. If Filtered is True, the table will apply the filter currently in force (either the contents of the Filter property or the results of the OnFilterRecord event). If Filtered is False, the contents of the Filter property are ignored and the OnFilterRecord event is never generated. For the Filter property, you implement a field name, a logical operator, and a value. A filter might look like this: FirstName = `Bob'

This statement, in effect, says, "Show me all records in which the first name is Bob." Filters can also use the keywords AND, OR, or NOT: CustNo = 1384 AND ShipDate < `1/1/94'

NOTE: The field name and the logical operators (AND, OR, or NOT) are not case sensitive. The following two filter statements are identical: CustName = `TurboPower' and ShipDate < `1/1/94' CUSTNAME = `TurboPower' AND SHIPDATE < `1/1/94'

In the case of searching for text, the FilterOptions property determines whether the search string is interpreted as case sensitive. The following operators can be used in filter statements: Operator Use < Less than > Greater than = Equal to <> Not equal to >= Greater than or equal to 1249

<= Less than or equal to () Used to specify the evaluation order of compound expressions [] Used around field names containing spaces AND, OR, NOT Logical operators Filtering with the Filter Property Earlier I said there are two ways of filtering a table. One way is by using the Filter property. To use this, all you have to do is type the filter statement directly into the Filter property in the Object Inspector at design time or assign a string value to this property at runtime. Naturally, you have to set the Filtered property to True as well. To see what I mean, perform the following exercise. First, set up the core components: 1. Place a Table component, a DataSource component, and a DBGrid component on a form. 2. Click on the Table component and change its Database property to DBDEMOS, its TableName property to ORDERS.DB, and its Active property to True. 3. Click on the DataSource component and change its DataSet property to Table1. 4. Click on the DBGrid component and change its DataSource property to DataSource1. Size the DBGrid as desired. At this point you should have a grid with data in it. Now you can get on with the business of filtering the table. 5. Enter the following in the Value column next to the Filter property: CustNo = 1384

6. Set the Filtered property to True. Now the table should be showing only the orders for customer 1384. Spend some time experimenting with the filter statement and observe the changes to the table each time a different statement is used. Try the following: CustNo = 1510 CustNo = 1384 and ShipDate < `1/1/94' CustNo = 1384 and ShipDate > `1/1/94' OrderNo > 1100 and OrderNo < 1125 Here you are making changes to the filter at design time, but it's more likely that you will change the filter dynamically at runtime. In that case, it's as simple as Table1.Filter := `CustNo = 1510';

NOTE: If Filtered is set to True but the Filter property is blank, the entire dataset is returned just as if the table were not filtered. Filtering with the OnFilterRecord Event The other way you can filter a table is with the OnFilterRecord event. To generate an event handler for this event, double-click in the Value column next to the OnFilterRecord event in the Object Inspector. Delphi will create an event handler. You can then write code to filter the table. Let's take the first filter example from earlier (CustNo = 1384) and filter using the OnFilterRecord event instead of the Filter property: procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolean); var Value : Integer; begin Value := Table1.FieldByName(`CustNo').Value; Accept := (Value = 1384);

1250

end;

I've broken the actual code into two lines to make it more readable. The key element here is the Accept parameter. The OnFilterRecord event is called once for every row in the table. Set the Accept parameter to True for any rows that you want to show. The preceding code sets Accept to True for any rows in which the CustNo field contains a value of 1384. Earlier I gave you four sample filters to try. The first two filters would look like this if you were to use the OnFilterRecord event instead of the Filter property: Accept := Table1.FieldByName(`CustNo').Value = 1510; Accept := (Table1.FieldByName(`CustNo').Value = 1384) and (Table1.FieldByName(`ShipDate').AsDateTime < StrToDate(`1/1/94'));

I'm sure you are thinking, "That's sort of messy." You're right. Using OnFilterRecord means more work, but it's also much more powerful than filtering with just the Filter property. · Using the FilterOptions Property The FilterOptions property determines how the filter will be applied. This property is a set that can contain either or both foCaseInsensitive or foNoPartialCompare. By default this property is an empty set, which means that filters will be case sensitive and will enable partial comparisons. When partial comparisons are enabled, specifying a filter such as LastName := `M*' results in a dataset containing all records in which the LastName field begins with the letter M. Finding Records You can search a table for certain records by several different methods. In fact, this section applies to all TDataSet descendants, not just TTable. NOTE: As with filters, finding records in a client/server database is almost always carried out via SQL queries. Finding records using the TTable methods is primarily a local database operation. To search a filtered dataset, you can use the FindFirst, FindNext, FindPrior, and FindLast methods. These methods are the best way to search a filtered dataset because the filter is reapplied each time one of these methods is called. Therefore, if records that previously did not match the filter have been modified so that they now match the filter, they will be included in the dataset before the search is performed. Another way to search a table is using the FindKey and GotoKey methods. These methods require an index. The FindKey method searches the primary key field or fields for a particular value. If a secondary key is in place, the secondary key field is used to perform the search. The following example sets a secondary key and then searches for a customer number of 1384: Table1.IndexName := `CustNo'; if not Table1.FindKey([1384]) then MessageBox(Handle, `Record Not Found', `Message', MB_OK);

A third way of searching a table includes using the Locate and Lookup methods. One advantage to these methods is that they don't require the table to be indexed. These methods differ in two ways. First, Locate will use the fastest method available to search the table; if a table is indexed, Locate will use the index. The second way these two methods differ is that the Lookup method will also return the values of the fields you have specified in the ResultFields parameter before calling Lookup. Both of these methods enable you to specify a field or fields to search and the search value. The following example illustrates the use of the Locate method: var Options : TLocateOptions; begin Options := [loPartialKey]; if not Table1.Locate(`CustNo', `1384', Options) then MessageBox(Handle, `Record Not Found', `Message', MB_OK);

1251

end;

If the record is found, Locate returns True, and the cursor is updated to reflect the record where the match was found. Master/Detail Tables Setting up a master/detail relationship with the Delphi Table component is easy. Let me explain a master/detail relationship and then I'll show you how to set up one. Let's say you have a table called CUSTOMER that contains information on your customers. That table will likely be indexed on a field called CustNo. Let's further assume that you have a table called ORDERS that contains a list of all orders placed by your customers. Naturally, this table would also have a CustNo field. Now let's say you want to browse the table containing all your customers. Wouldn't it be nice if you could see each customer's orders while you browse? A master/detail table enables you to do that. Perform the following steps to get a good understanding of master/detail tables: 1. Start with a new application. Place a Table component on the form. Set its properties as follows: Name DatabaseName TableName

Master DBDEMOS customer.db

2. Place a DataSource component on the form and set its DataSet property to Master. 3. Now place a second Table component on the form and change its Name property to Details. You'll set the rest of this table's properties in just a minute. 4. Place a second DataSource component on the form. Change its DataSource property to Details. 5. Click on the Details Table component. Change its properties as follows: DatabaseName TableName MasterSource

DBDEMOS orders.db DataSource1

6. Click on the ellipsis button next to the MasterFields property. The Field Link Designer dialog box is displayed. 7. At the top of the Field Link Designer dialog box is a combo box labeled Available Indexes. Select the CustNo index from this combo box. 8. Now both the Detail Fields list box and the Master Fields list box have a CustNo entry. Select CustNo in each of these list boxes and click the Add button to create the relationship. The Joined Fields list box shows that the two tables are joined by their CustNo fields. 9. Click OK to close the Field Link Designer dialog boxes. 10. Drop two DBGrid components on the form and link one to DataSource1 and the other to DataSource2. 11. Change the Active property of both tables to True. The Master table will show all customers, and the Details table will show the orders for each customer. What you just did was create a relationship between the master table and the detail table. This relationship joined these two tables through a common field: CustNo. To fully understand what this means, run the program and move from record to record in the master table. As you select a customer name in the master table, you will see only that customer's orders in the detail table. 1252

The Query Component The Query component is the preferred method of accessing data in client/server databases. The following sections describe the primary properties and methods of the TQuery class. TIP: The Query component doesn't have a TableName property as the Table does. This means that at design time, you can't immediately see a list of tables for the current database. To see a list of tables, you can perform one of two tasks. First, you can temporarily drop a Table component on the form, set the DatabaseName property, and then view the list of tables in the TableName property. You also can select the Query component on the form, right-click on it, and then choose Explore from the context menu. This will take you to either the SQL Explorer (Client/Server version) or the BDE Administrator (Standard and Professional versions). You can use either tool to view the tables in a database. The SQL Property The SQL property is a TStringList that contains the SQL statements to execute. You can set the SQL property's value via the Object Inspector at design time or through code at runtime. To set the value at design time, click the ellipsis button next to the SQL property in the Object Inspector. The String List Editor dialog box is displayed, and you can type in one or more lines of SQL statements. TIP: Remember that the String List Editor dialog box has a feature that enables you to edit string lists in the Delphi Code Editor. When adding lines to the SQL property at runtime, make sure that you clear the previous contents--for example, Query1.SQL.Clear; Query1.SQL.Add(`select * from country');

It's easy to think of the SQL property as a string instead of a string list. If you don't clear the SQL property before adding a string, previous SQL statements will still be in the string list. Errors will almost certainly occur when you try to execute the SQL statement. Executing SQL Statements The statements in the SQL property will be executed when either the Open method or the ExecSQL method is called. If you are using SQL statements that include SELECT, use the Open method to execute the SQL query. If you are using INSERT, UPDATE, or DELETE statements, you need to use the ExecSQL method to execute the query. The following example sets the SQL property and then calls the Open method: Query1.SQL.Clear; Query1.SQL.Add(`select * from country'); Query1.Open;

The SQL SELECT statement retrieves certain columns from a database. The asterisk tells the database server to return all the columns in a table. The preceding example, then, returns the entire table called country from the current database. To return specific columns, use code such as the following: Query1.SQL.Clear; Query1.SQL.Add(`select Name, Capital from country'); Query1.Open;

NOTE: Setting the Active property to True is the same as calling the Open method.

1253

The SQL DELETE statement deletes records from a dataset. To delete a record from a dataset, you can use code like this: Query1.SQL.Clear; Query1.SQL.Add(`delete from country where name = `Royland'); Query1.ExecSQL;

Notice that the ExecSQL method is used instead of the Open method. As I said earlier, you need to use the ExecSQL method to execute a query containing INSERT, UPDATE, or DELETE statements. The INSERT command inserts a record into a dataset: Query1.SQL.Add(ìnsert into country'); Query1.SQL.Add(`(Name, Capital)'); Query1.SQL.Add(`values ("Royland", "Royville")'); Query1.ExecSQL;

NOTE: Notice the use of double quotes in the preceding example. SQL syntax should not be confused with Object Pascal syntax. SQL enables the use of either double quotes or single quotes around value names. You can use either, but if you use single quotes within a string, you need to be sure to double them. Either of the following is valid: Query1.SQL.Add(`values ("Royland", "Royville")'); Query1.SQL.Add(`values (`'Royland'', `'Royville'')');

Updating a dataset using the UPDATE command looks like this: Query1.SQL.Clear; Query1.SQL.Add(ùpdate country'); Query1.SQL.Add(`set Capital = `'Royburg'''); Query1.SQL.Add(`where Name = "Royland"'); Query1.ExecSQL;

Although it isn't my intention to teach SQL, I thought a few examples would help get you started. Using Parameters in SQL Statements SQL statements use parameters to add flexibility. A parameter in a SQL statement is much like an Object Pascal variable. A parameter in a SQL statement is preceded by a colon. Take the following SQL statement, for example: select * from country where name = :Param1

The parameter in the preceding statement is named Param1. When this SQL statement is executed, the value of Param1 in the Params property is substituted for the parameter name: Query1.SQL.Add(`select * from country where Name = :Param1'); Query1.ParamByName(`Param1').AsString := `Brazil'; Query1.Open;

You can set the parameter values of the Params property at design time via the Parameters dialog box, but most of the time you will be changing the parameters at runtime (which is the point of using parameters, of course). Notice in the preceding code that the ParamByName method is used to set the value of Param1. This is probably the easiest way to set a parameter's value. There is another way, however: Query1.Params[0].AsString := `Brazil';

Here the Items property of the TParam class is used to set the value of the parameter. Accessing a parameter by index is more error-prone than accessing the parameter by name because you have to remember the orders of your parameters. Most of the time you will just use ParamByName. NOTE: Not all aspects of a SQL statement can be parameterized. For example, most SQL servers don't allow a parameter for the table name. Take the following SQL statement: select * from :TableName

This statement results in a SQL error because you can't use a parameter for the table name. 1254

The StoredProc Component The StoredProc component represents a stored procedure on a database server. A stored procedure is a set of SQL statements that executes as a single program. Stored procedures are individual programs that run against a database and can encapsulate often- performed database tasks. This makes it easier for programmers to do their work because they don't have to write line after line of code each time they want to perform a certain action. All they have to do is call the stored procedure on the server. This also results in smaller client applications because they don't have to contain unnecessary code. Another purpose of stored procedures is to maintain data integrity. A stored procedure can validate data and either allow or disallow changes to the database based on whether the data validation passes. As with SQL queries, some stored procedures make use of parameters and some do not. For stored procedures that don't take parameters, all you have to do is set the procedure name and execute the procedure: StoredProc1.StoredProcName := `DO_IT'; StoredProc1.Prepare; StoredProc1.ExecProc;

Notice that the Prepare method is called first to prepare the stored procedure. After that, the ExecProc method is called to execute the stored procedure. For stored procedures that take parameters, you have to set the parameters before executing the stored procedure: StoredProc1.StoredProcName := ÀDD_EMP_PROJ'; StoredProc1.ParamByName(ÈMP_NO').Value := 12; StoredProc1.ParamByName(`PROJ_ID').Value := `VBASE'; StoredProc1.Prepare; StoredProc1.ExecProc;

By the way, if you have Delphi Professional or Client/Server, you can test the preceding code yourself by following these steps: 1. Drop a StoredProc component on a form and set its DatabaseName property to IBLOCAL. 2. Place a button on the form and double-click it to create an OnClick event handler. 3. Type the code from the preceding code snippet. 4. Place a Table component on the form and set its DatabaseName to IBLOCAL and its TableName to EMPLOYEE_PROJECT. Place DBGrid and DataSource components on the form and hook them up to the table. Set the table's Active property to True. This enables you to see changes made to the table. 5. Add one line to the end of the code in step 3: Table1.Refresh;

Now run the program. When you click the button, a new record is added to the table with an employee ID number of 12 and a project ID of VBASE. Close the program. Now change the code so that the employee ID number is 10 and rerun the program. This time you will get an error message from the stored procedure stating that the employee number is invalid. You will get the error because the ADD_EMP_PROJ stored procedure validates input, and a value of 10 is invalid for this database. NOTE: You can view a stored procedure using the Explore feature found on the context menu. The stored procedure called ADD_EMP_PROJ looks like this: CREATE PROCEDURE ADD_EMP_PROJ ( EMP_NO SMALLINT, PROJ_ID CHAR(5) ) AS

1255

BEGIN BEGIN INSERT INTO employee_project (emp_no, proj_id) VALUES (:emp_no, :proj_id); WHEN SQLCODE -530 DO EXCEPTION unknown_emp_id; END SUSPEND; END

Naturally, you shouldn't change a stored procedure unless you know what you are doing.

The UpdateSQL Component The UpdateSQL component provides a way of applying edits to a read-only dataset when cached updates are enabled. Ordinarily, a read-only dataset is just that--read only. When cached updates are enabled, however, a read-only database can be modified and the results of those modifications written to the database. Most client/server databases have default actions that they perform when the changes in the update cache are applied. The UpdateSQL component enables you to provide your own SQL statements when a record in a read-only dataset needs to be updated, inserted, or deleted. For example, you can specify default values for certain fields in a dataset by using an UpdateSQL component. The DeleteSQL property enables you to define a SQL query that will be executed when cached updates are applied and the update cache contains deleted records. Likewise, InsertSQL enables you to define a SQL query that will be executed when records have been inserted in a dataset and cached updates are applied. The ModifySQL property is used to define a SQL query that will be called when a record has been modified and cached updates are applied.

The DataSource Component The DataSource component provides a mechanism to hook dataset components (Table, Query, or StoredProc) to the visual components that display the data (DBGrid, DBEdit, DBListBox, and so on). The primary purpose of DataSource is to enable making changes to your applications easier. All the data components on a form are hooked up to the DataSource, which is then hooked up to the dataset.

Because the data components are not hooked directly to the dataset, you can easily change datasets and not have to hook up each and every data component on the form each time you change the dataset. To change your dataset from a Table to a Query, for example, all you have to do is change the DataSet property of the DataSource component. There's no need to change anything in each of the data components. TDataSource has very few properties. As you have already seen, the DataSet property is used to hook the DataSource to an underlying dataset. The Enabled property determines whether the data components hooked up to this data source display data. When Enabled is True, data is displayed. When Enabled is False, the data components are blank. The methods of TDataSource are mostly insignificant, and I won't go over them here. The OnDataChange event is generated when the current record has been edited and the cursor moves to a different record. The OnStateChange event occurs when the state of the dataset changes (when the user moves from edit mode to browse mode, for example).

The Session Component The Session component manages a database session. Each time you start a database application, the BDE sets up a global TSession object called Session. You can use Session to access the current database session. You don't have to create your own TSession objects unless you are writing a multithreaded application. Most of the time this isn't the case, so the default TSession object is usually all you need. 1256

TSession has a couple methods of particular interest. The AddAlias and AddStandardAlias methods can be used to create a BDE alias at runtime. You will probably need to create aliases at runtime when you deploy your applications. Creating a BDE alias is discussed in the section titled "Creating a BDE Alias." The GetAliasNames and GetDatabaseNames methods can be used to get a list of databases. This is handy when you want to enable your users to choose a database from a list. You could put the database names in a combo box, for example: Session.GetDatabaseNames(DBNamesComboBox.Items);

In this case, the Items property of a combo box called DBNamesComboBox is filled with the list of database names. The GetTableNames and GetStoredProcNames methods can be used in the same way.

The Database Component The Database component gives you access to specific database operations. You don't need a Database component for some applications. There are certain operations, though, that require a Database component. These operations are discussed in the following sections. Retaining Database Connections The KeepConnections property is used to control how database connections are handled when a dataset is closed. If KeepConnections is False, the database connection will be dropped when the last dataset is closed. This requires a login the next time a dataset is opened. It's not so much that logins are an annoyance (which they are), but more importantly that logins take time. I don't mean that they take time in the sense that you have to type a username and password in a login dialog box. I mean that they take a lot of processing and network time to open a database connection and log in, even if that login process is automated. If you don't want to worry about logging in every time a dataset is opened, set KeepConnections to True.

Login Control One reason to use a Database component is to control login operations. There are two ways you can control a login. One is by setting the LoginPrompt property to False and explicitly setting the login parameters. You can do this before opening a dataset: Database1.Params.Values[ùser name'] := `SYSDBA'; Database1.Params.Values[`password'] := `masterkey';

The preceding code sets the username and password for a Local InterBase database connection. NOTE: You should be very careful about hard-coding password information in your applications for security reasons. Login prompts are used for a reason. Don't bypass login requirements unless you have a very good reason to do so. Taking this example a little further, let's assume that you have a form with a Database component and a Table component. Let's say you want to create a database connection and open a table without any login prompt. Here's the code: Database1.AliasName := ÌBLOCAL'; Database1.DatabaseName := `MyDatabase'; Database1.Params.Values[ùser name'] := `SYSDBA'; Database1.Params.Values[`password'] := `masterkey'; Table1.DatabaseName := Database1.DatabaseName; Table1.TableName := `CUSTOMER'; Table1.Open; This code first sets the Database component's Alias property to IBLOCAL to connect to Local InterBase. Then the DatabaseName property is set to an

1257

arbitrary name. You can use any name you like for the database name. Next, the database connection parameters (username and password) are set. After that, the Table component's DatabaseName property is set to the value of the Database's DatabaseName property, which hooks the table to the database. Finally, the TableName property is set for the table and the table is opened.

The other way to perform a login is with the OnLogin event. This is generated whenever login information is required. In order to generate this event, you need to make sure that you have the LoginPrompt property set to True. After that, you can provide an event handler for the OnLogin event. It will look like this: procedure TForm1.Database1Login(Database: TDatabase; LoginParams: TStrings); begin LoginParams.Values[ùser name'] := `SYSDBA'; LoginParams.Values[`password'] := `masterkey'; end;

Does this code look familiar? It's essentially the same code used earlier when directly setting the connection parameters of the database. Usually you would not hard-code the username and password (or, at least, not the password) but would probably pull that information from an outside source, such as an edit component, a configuration file, or the Windows Registry. Transaction Control Another reason to use a Database component is for transaction control. Normally, the BDE handles transaction control for you. There might be times, however, when you require complete control over transaction processing. In that case you can use the Database component's transaction control methods. A transaction is a collection of updates to a dataset. Updates can include changes made to records, deleting records, inserting records, and more. You begin a transaction by calling the StartTransaction method. Any changes made to the dataset are held until you call the Commit method. When you call Commit, all updates in the transaction are written to the database. If you want to abandon changes to all updates in the current transaction, you call the Rollback method. The transaction isolation level is controlled by the TransIsolation property's value. (See the TransIsolation topic in the Delphi help for more information on transaction isolation levels.) NOTE: All transaction updates are treated as a single unit, which means that when you call Commit, all updates are committed. When you call Rollback, all updates are canceled. It also means that if something goes wrong during a transaction commit, none of the updates in the current transaction are written to the database.

The BatchMove Component The BatchMove component is used to copy records from one dataset to another. The Source property specifies the source dataset, and the Destination property specifies the destination dataset for the batch move operation. The Mapping property is required if your source and destination datasets don't have identical columns. Mapping is a TStringList property. To specify mappings, edit the string list and add mappings like this: FirstName = FName LastName = LName Notes = Comments

NOTE: The mapping strings use the equal sign and not the Pascal assignment operator (:=). 1258

The column name on the left side of the equal sign is the destination column; the column name on the right side of the equal sign is the source column. Setting the mappings like this tells TBatchMove, "These two datasets don't match, so copy the data from the FName column in the source dataset to the FirstName column in the destination dataset." If your source and destination datasets are not identical and you fail to set column mappings, the batch move will fail. The Execute method performs the batch move. To use TBatchMove, all you have to do is set the Source, Destination, and Mode properties and call the Execute method. You can set the Source and Destination properties at design time or at runtime. The following code creates a copy of a table: DestTable.TableName := `copy.db'; BatchMove1.Destination := DestTable; BatchMove1.Source := SourceTable; BatchMove1.Mode := batCopy; BatchMove1.Execute;

The Mode property specifies how records are applied to the destination dataset. Table 16.6 lists the possible values of the Mode property and their meanings. Table 16.6. MODE property values. Value Description batAppe Appends records from the source dataset to the end of the destination dataset. nd batAppe Combination of batAppend and batUpdate. If a matching record already exists, ndUpdat it is updated. If no matching record exists, a new record is added. e Creates a new table and copies all records from the source table to the new batCopy table. batDelet Deletes records in the destination dataset that match the source dataset. The e destination dataset must have an index. batUpda Replaces records in the destination dataset with records from the source te dataset that have the same key values. CAUTION: Be careful with the batCopy mode. Calling Execute in this mode will overwrite any existing tables and replace the contents with the contents of the source table.

The TField Component The TField class represents a field (column) in a database. Through the TField class, you can set a field's attributes. These attributes include the data type (string, integer, float, and so on), the size of the field, the index, whether the field is a calculated field, whether it is required, and so on. You can also access or set a field's value through properties such as AsString, AsVariant, and AsInteger. TField is a base class for more specific field classes. The descendants of TField include TStringField, TIntegerField, TSmallIntField, TWordField, TFloatField, TCurrencyField, TBCDField, TBooleanField, TDateTimeField, TDateField, TTimeField, TBlobField, TBytesField, TVarBytesField, TMemoField, and TGraphicField. These derived classes extend the base class in small ways to add functionality. For example, numerical field classes have a DisplayFormat property that determines how the number is displayed and an EditFormat property that determines how the value appears while being edited. Each TField descendant corresponds to a specific database field type. The TIntegerField class is used when the field type is an integer, the TTimeField class is

1259

used when the field type is a date or time (or date/time), the TBlobField class is used when the field type is binary large object, and so on. You can access the properties of TField at design time through the Fields Editor. After you add fields, you can click on a field in the Fields Editor and the properties for that field will be displayed in the Object Inspector. Figure 16.5 shows the Fields Editor and Object Inspector while editing fields. FIGURE 16.5. The Fields Editor and Object Inspector. The TField properties and methods are so numerous that I'm not going to list them all here. Instead, I'll walk you through some ways you are most likely to use TField and its descendant classes. Accessing Fields Before you can get or set the field value, you need some way of locating a field. There are at least three ways to do this: · By its pointer name · By the Fields property of TDataSet · By the FieldByName method of TDataSet Accessing a field by its pointer name is probably the least used method. It works only if you have previously added fields to your project using the Fields Editor. When you add fields via the Fields Editor, Delphi creates a pointer for each field by combining the table name with the field name. If you have a table called Table1 and a string field called FirstName, Delphi would create a TStringField pointer called Table1FirstName. You could use this pointer to access a field: Table1FirstName.Value := `Per';

The problem with this approach is that you don't always need to add fields using the Fields Editor. The Fields property offers another way of accessing a field--by position. If you know that the LastName field is the first field in the table, you can use something like this: Edit1.Text := Table1.Fields[0].Value;

The problem with this approach, of course, is that you have to know the exact order of fields. Of the three ways of accessing fields, the most commonly used and reliable is the FieldByName method. Using FieldByName, you have to know only the name of the field to access the field: Table1.FieldByName(`LastName').AsString := Edit1.Text;

FieldByName returns a TField pointer. To make it more understandable, let me break down the preceding line of code: var Field : TField; begin Field := Table1.FieldByName(`LastName'); Field.AsString := Edit1.Text; end; In most cases, FieldByName is the way to go. Oh, you might be wondering which record is modified when you execute the preceding code. All these techniques retrieve the field from the current record.

Retrieving and Setting Field Values After you obtain a pointer to a particular field, you can change its value by using the Value property or any of the As properties (by As properties I mean AsString, AsInteger, AsDateTime, AsBoolean, and so on). These properties perform conversions from one data type to another. Naturally, you can't always be assured that a conversion can be made. For example, if you try to convert a string field containing Smith to an integer, an exception will be thrown. Setting a field's value is simple when you know the secret of FieldByName: Table1.Edit;

1260

Table1.FieldByName(`LastName').AsString := Edit1.Text; Table1.Post;

First, the Edit method is called to put the table in edit mode. If you fail to call Edit, you will get an exception when you try to modify a field's value. After the table is put in edit mode, the field's value is set. In this case I used AsString instead of the Value property. For a string field, it's the same thing in either case. Finally, the Post method is called to post the edit to the database (or the update cache if CachedUpdates is on). That's all there is to it. Retrieving a field's value is just as easy: var AcctNo : Integer; begin AcctNo := Table1.FieldByName(ÀCCT_NBR').Value; { More code here. } end;

TField Events The TField events of note are OnChange and OnValidate. The OnChange event is generated each time a field's value changes. This occurs after the data has been posted. You can use this event if you need to be notified of changes to a field.

The OnValidate event, on the other hand, occurs just before data is posted. If you have a data control on a form associated with a field, that control can usually do validation of data. If, however, you are setting a field's value through code, you might want to do your own validation in the OnValidate event handler. This event is somewhat strange in that it doesn't pass you a parameter that you can use to reject an edit. Instead, you should throw an exception if the validation fails: procedure TForm1.Table1ACCT_NBRValidate(Sender: TField); begin if Sender.AsInteger < 3000 then raise EDBEditError.Create(`Bad Account Number.'); end;

When you throw an exception, the act of posting the data to the database is aborted. To create an event handler at design time, you have to use the Fields Editor to add fields to the dataset. After you have done that, you can select a field in the Fields Editor and then double-click next to the event name in the Object Inspector, as you would for any other event.

Client/Server Database Components The Client/Server version of Delphi comes with three additional data access components that enable the creation of multitiered database systems. (To recap, a multitiered database system is one in which client applications talk to one or more application servers [the middle tier] that in turn talk to the database server.) The multitier database components are TRemoteServer, TProvider, and TClientDataSet. The TRemoteServer component is used in a client application to establish a connection to one or more application servers. The TProvider component, used in a middle-tier application server, acts as a conduit between the database server and the client application. The TClientDataSet component is used in a client application to gain access to the provider on an application server. A detailed account of the use of these components is beyond the scope of this book.

Creating a BDE Alias You can go only so far in database programming without eventually creating a BDE alias. The sample databases are fine, but sooner or later you will need to create an alias for your own databases. When you deploy your Delphi database application, you will also need to create one or more aliases on your users' machines as well. There are many ways to create an alias: · Through the BDE Administrator utility from the Delphi program group 1261

· Through the Database Desktop program · Through the SQL Explorer (Client/Server version only) · Through code at runtime To create an alias, either you must have your users run the BDE Administrator, or you must create any needed aliases through code. Obviously, creating the alias yourself through code is preferable (never underestimate the ability of your users to botch even the most simple tasks). First I'll show you how to use the BDE Administrator to create an alias. Then I'll show you how to create an alias through code.

Creating an Alias with the BDE Administrator While you are developing your applications, you need to create one or more BDE aliases. This is most easily done using one of the BDE utility programs provided with Delphi. The steps for creating an alias using the BDE Administrator and the SQL Explorer are identical, so for simplicity's sake I'll show you how to create an alias with the BDE Administrator. Let's assume for a minute that you are going to create a mailing list application. The first step you need to take is to create an alias for your database. You can create an alias in several ways, but the easiest is probably with the BDE Administrator utility. Perform these steps: 1. Start the BDE Administrator (locate the Delphi group from the Windows Start menu and choose the BDE Administrator icon). The BDE Administrator will start and show a list of database aliases currently installed. 2. Choose Object|New from the BDE Administrator menu (make sure the Databases tab is selected). The New Database Alias dialog box comes up and asks which driver to use for the new alias. 3. You will be creating a database using the Standard driver, and because STANDARD is already selected, you can simply click OK. Now the BDE Administrator looks like Figure 16.6. FIGURE 16.6. The BDE Administrator creating a new database alias. 4. The BDE Administrator is waiting for you to type a name for your alias, so type MyDatabase and press Enter. At this point, you need to provide a few items of information in the Definition window. The Type is already set to STANDARD, so there's nothing to be done there. The DEFAULT DRIVER field is set to PARADOX, which is the type you want, so there's nothing to be done there, either (other choices include dBASE, FOXPRO, and ASCIIDRV). You can also leave the default value for the ENABLE BCD field. The only information you need to supply is the path on disk where the database files will be stored: 1. Click on the PATH field and either type a path or use the ellipsis button to browse to a path. 2. Close the BDE Administrator and say Yes when asked whether you want to save your edits. That's it. You have created a BDE alias. Switch back to Delphi and drop a Table component on a form. Check the DatabaseName property in the Object Inspector to see whether your database alias shows up. If you did everything right, you will see it listed there with the other database names. Your database doesn't have any tables yet, but that's okay. You can take care of that later.

Creating an Alias Through Code To avoid confusion with your users, you will probably want to create any aliases your program needs the first time your program runs. Thankfully, creating an alias at runtime is simple. Here's the code to create a local Paradox alias called WayCool: CreateDirectory(`C:', nil); Session.AddStandardAlias(`WayCool', `C:', `');

1262

That's it? Yes, that's all there is to it. Naturally, you should perform some checks to ensure that the directory and alias were properly created, but that's about all there is to it. NOTE: This example uses the AddStandardAlias method to create a STANDARD type alias. To create aliases for database servers of other types, use the AddAlias method.

Summary That's a lot to absorb. The best way to solidify the material presented in this chapter is to spend a lot of time experimenting. Take some sample databases and perform filters on the tables, try out some SQL statements, and browse the databases with the BDE Administrator or the SQL Explorer. At this point you don't have to worry about writing complete database programs. Just spend some time with the various components and get a feel for how the BDE and the VCL database components work together.

Workshop The Workshop contains quiz questions to help you solidify your understanding of the material covered and exercises to provide you with experience in using what you have learned. You can find answers to the quiz questions in Appendix A, "Answers to the Quiz Questions."

Q&A Q When I ship my Delphi database application, can I simply copy the appropriate BDE files to my users' machines? A No. You must follow the guidelines outlined by Borland in the DEPLOY.TXT file. Generally speaking, this requires using an installation program certified by Borland to install any applications that use the BDE. Q Why is it necessary to use a DataSource component? Why can't the data components and the data access components communicate directly? A Using a DataSource as an intermediary makes your job easier if you have to change datasets later on. Rather than change the DataSet property of numerous data components, you only have to change the DataSet property of the DataSource. For example, let's say you change your dataset from a TTable to a TQuery (a major change). The change would be nearly transparent to your data components because the DataSource does all the work. Q When do I use a TTable and when do I use a TQuery? A Most of the time you will use a TTable when working with a local database (Paradox or dBASE) and a TQuery when working with a client/server database. In the end it is up to you to decide which to use. Q What's the point of Local InterBase? A Local InterBase enables you to develop a local database application that can easily be converted to a client/server application later. Q Do I need to create a TSession for my application? A Not normally. A default TSession is automatically created for every database application. You can use this object, called Session, any time you need access to the properties and methods of the TSession class. The only time you need to create your own TSession objects is when you are writing a multithreaded database application. 1263

Q I am using a local database in my application. Do I need to worry about cached updates? A Generally speaking, no. Cached updates are much more important for client/server databases.

Quiz ·

1. What is a local database?

2. What is the purpose of the BDE? 3. Are a dataset and a table the same thing? If not, explain the difference. 4. Name one advantage of cached updates. 5. What is a stored procedure? 6. What is the purpose of the SQL property of the TQuery component? 7. Name one reason you might want to use your own TDatabase object instead of the default. 8. Why would you want to keep a connection to a remote database open even when you are not currently using the connection? 9. What does the TBatchMove component do? 10. What is a BDE alias?

Exercises 1. Describe how your application, the BDE, and a database work together. 2. Place a DataSource, a Table, and a DBGrid on a form. Hook up the components. Select a database and a table name for the Table component. Set the Table's Active property to True. View the table contents in the grid. 3. Change the Table's TableName property several times to view different tables. (Hint: You must set the Active property to False before changing the TableName property.) 4. Place a second Table component on the form created in exercise 2. Select a database name and a table name. Set the Active property to True. Now change the DataSet property of the DataSource component to Table2 (the second table). What happens to the DBGrid? 5. Create a new BDE alias on your system. 6. Extra Credit: Create a table under the BDE alias created in exercise 5 and populate it with data

- 18 Building Database Applications

·

· Nonvisual Database Programming · Reading from a Database · Creating a Database in Code · Creating the Field Definitions Using Data Modules · Setting Up a Sample Data Module 1264

·

· ·

· Adding to Your Data Module · Running the Data Module Creating Reports · QuickReport Overview · The QuickRep Component · Report Bands · Creating Reports by Hand · Creating Reports the Easy Way Deploying a Delphi Database Application Summary · Q&A · Quiz · Exercises

This chapter is about building database applications. The truth is, I cannot tell you everything there is to know about writing database applications in one short chapter. What I can do is point out some issues you are likely to encounter when writing database applications. Because you already know how to create database forms, you will spend most of this day dealing with lower level aspects of database programming. You'll start with creating and populating a database entirely through code, and then you'll move on to data modules. Toward the end of the day you'll look at creating database reports with the QuickReport components. Finally, the day ends with a discussion on deploying database applications.

Nonvisual Database Programming Up to this point, you have examined almost exclusively the visual aspects of database programming with Delphi. That side of database programming is fun and easy, but sooner or later you have to do some real database programming. The kinds of programs you have written so far have dealt primarily with simple viewing and editing of data. In this section, you learn how to perform certain database operations through code. TIP: I will mention only database operations that pertain to the TTable class. You could also use SQL to perform database operations in code, but I won't present that aspect of databases today.

Reading from a Database This section is short because reading from an existing database isn't difficult. As an example exercise, you will take the CUSTOMER.DB table and create a comma-delimited text file from the data. You won't write every field in the table to the file, but you'll write most of them. The first step is to create a TTable object. Next, attach it to a database and to a particular table within the database. Here's how the code looks: var Table : TTable; begin Table := TTable.Create(Self); Table.DatabaseName := `DBDEMOS'; Table.TableName := `Customer.db'; end;

This code emulates what Delphi does when you set the DatabaseName and TableName properties at design time. The next step is to read each record of the database and write it

1265

to a text file. First, I'll show you the basic structure without the actual code to write the fields to the text file. After that, I'll be more specific. The basic structure looks like this: Table.Active := True; while not Table.Eof do begin { Code here to read some fields from the } { current record and write them to a text file. } Table.Next; end; Table.Free;

This code is straightforward. First, the table is opened by setting the Active property to True (you could also have called the Open method). Next, a while loop reads each record of the table. When a record is written to the text file, the Next method is called to advance the database cursor to the next record. The while loop's condition statement checks the Eof property for the end of the table's data and stops the loop when the end of the table is reached. Finally, the TTable object is freed after the records have been written to the text file. NOTE: You don't specifically have to delete the TTable object. When you create a TTable object in code, you usually pass the form's Self pointer as the owner of the object--for example, Table := TTable.Create(Self);

This sets the form as the table's owner. When the form is deleted, VCL will automatically delete the TTable object. For a main form this happens when the application is closed. Although you are not required to delete the TTable object, it's always a good idea to delete the object when you are done with it. Naturally, you need to extract the information out of each field in order to write it to the text file. To do that, you use the FieldByName method and the AsString property of TField. I addressed this briefly on Day 16, "Delphi Database Architecture," in the section "Accessing Fields." In the CUSTOMER.DB table, the first field you want is the CustNo field. Extracting the value of this field would look like this: var S : string; begin S := Table.FieldByName(`CustNo').AsString + `,';

Notice that a comma is appended to the end of the string obtained so that this field's data is separated from the next. You will repeat this code for any fields for which you want to obtain data. The entire sequence is shown in Listings 18.1 and 18.2. These listings contain a program called MakeText, which can be found with the book's code. This short program takes the CUSTOMER.DB table and creates a comma-delimited text file called CUSOMTER.TXT. Listing 18.1 shows the main form's unit (MakeTxtU.pas). The form contains just a button and a memo. Look over these listings, and then I'll discuss how the program works. LISTING 18.1. MakeTxtU.pas. unit MakeTxtU; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ÂDialogs, StdCtrls, DbTables; type TForm1 = class(TForm) CreateBtn: TButton; Memo: TMemo; procedure CreateBtnClick(Sender: TObject); private { Private declarations } public

1266

{ Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.CreateBtnClick(Sender: TObject); var Table : TTable; S : string; begin { Create the Table and assign a database and Table name. } Table := TTable.Create(Self); Table.DatabaseName := `DBDEMOS'; Table.TableName := `Customer.db'; { Change to the busy cursor. } Screen.Cursor := crHourGlass; { We can use a Memo to show the progress as well as to } { save the file to disk. First clear the memo of any text.} Memo.Lines.Clear; { Open the Table. } Table.Active := True; CreateBtn.Enabled := False; { Loop through the records, writing each one to the memo. } while not Table.Eof do begin { Get the first field and add it to the string S, } { followed by the delimiter. } S := Table.FieldByName(`CustNo').AsString + `,'; { Repeat for all the fields we want. } S := S + Table.FieldByName(`Company').AsString + `,'; S := S + Table.FieldByName(Àddr1').AsString + `,'; S := S + Table.FieldByName(Àddr2').AsString + `,'; S := S + Table.FieldByName(`City').AsString + `,'; S := S + Table.FieldByName(`State').AsString + `,'; S := S + Table.FieldByName(`Zip').AsString + `,'; S := S + Table.FieldByName(`Phone').AsString + `,'; S := S + Table.FieldByName(`FAX').AsString; { Add the string to the Memo. } Memo.Lines.Add(S); { Move to the next record. } Table.Next; end; { Write the file to disk. } Memo.Lines.SaveToFile(`customer.txt'); { Turn the button back on and reset the cursor. } CreateBtn.Enabled := True; Screen.Cursor := crDefault; Table.Free; end; end. All the action takes place in the CreateBtnClick method. When you click the Create File button, the program extracts data from the database table and puts it into the Memo component. First, the value of the CustNo field is read and put into a string, followed by a comma. After that, each subsequent field's value is appended to the end of the string, again followed by a comma. After all the data has been extracted from a record, the string is added to the memo, using the Add method. When the end of the table is reached, the memo contents are saved to disk.

I used a Memo component in this example for two reasons. First, by displaying the results in a memo, you can see what the program produces. Second, the memo component's Lines property (a TStrings) provides an easy way of saving a text file to disk. Figure 18.1 shows the MakeText program after the file has been written. FIGURE 18.1. The MakeText program running. 1267

Creating a Database in Code Most of what you read on database operations in Delphi tells you how to create a database with utilities such as Database Desktop. That's fine if your application has prebuilt tables. But if your application has to dynamically create tables, that approach doesn't work. You must have a way of creating tables through code. For example, if your application enables users to specify the fields of a table, you won't know what the fields are until the user has supplied them. Creating a table in code requires these steps: 1. Create a BDE alias for the database. 2. Create a TTable object. 3. Add field definitions to the FieldDefs property. 4. Add index definitions to the IndexDefs property if your table contains indexes. 5. Create the actual table with the CreateTable method. Let's go over these steps individually so that you know what each step involves. Creating a BDE Alias and a TTable Object You already performed steps 1 and 2 on Day 16 when I talked about creating a BDE alias, and you created a TTable object in the preceding section. Here's a recap of those two steps: var Table : TTable; begin { Create the alias. } CreateDirectory(`c:', nil); Session.AddStandardAlias(`MyDatabase', `c:', `PARADOX'); Session.SaveConfigFile; { Create the table. } Table := TTable.Create(Self); Table.DatabaseName := `MyDatabase'; Table.TableName := `MyTable.db'; end;

This code first creates a BDE alias for a database called MyDatabase in the C: directory. After that, a TTable object is created, and the DatabaseName property is set to the alias created in the first part of the code. Finally, the TableName property is set to the name of the new table you are going to create. At this point the TTable object has been created, but the table itself doesn't exist on disk.

Creating the Field Definitions The next step is to create the field definitions for the table's fields. As you might guess, the field definitions describe each field. A field definition contains the field name, its type, its size (if applicable), and whether the field is a required field. The field's type can be one of the TFieldType values. Table 18.1 lists the TFieldType values. TABLE 18.1. DATABASE TABLE FIELD TYPES. Field type ftUnkown ftString ftSmallint ftInteger ftWord ftBoolean

Description Unknown or undetermined Character or string field 16-bit integer field 32-bit integer field 16-bit unsigned integer field Boolean field 1268

ftFloat Floating-point numeric field ftCurrency Money field ftBCD Binary-Coded Decimal field ftDate Date field ftTime Time field ftDateTime Date and time field ftBytes Fixed number of bytes (binary storage) ftVarBytes Variable number of bytes (binary storage) ftAutoInc Auto-incrementing 32-bit integer counter field ftBlob Binary large object field ftMemo Text memo field ftGraphic Bitmap field ftFmtMemo Formatted text memo field ftParadoxOle Paradox OLE field ftDBaseOle dBASE OLE field ftTypedBinary Typed binary field You create a field definition by using the Add method of the TFieldDefs class. The FieldDefs property of TTable is a TFieldDefs object. Putting all this together, then, adding a new string field to a database would look like this: Table.FieldDefs.Add(`Customer', ftString, 30, False);

This code line adds a string field called Customer with a size of 30 characters. The field is not a required field because the last parameter of the Add method is False. Add as many field definitions as you need, setting the appropriate data type and size for each field. Creating the Index Definitions If your table will be indexed, you also need to add one or more index definitions. Adding index definitions is much the same as adding field definitions. The IndexDefs property of TTable contains the index definitions. To add a new index definition, call the Add method of TIndexDefs: Table.IndexDefs.Add(`', `CustNo', [ixPrimary]);

The first parameter of the Add method is used to specify the index name. If you are creating a primary index (as in this example), you don't need to specify an index name. The second field is used to specify the field or fields on which to index. If you have more than one field in the index, you separate each field with a semicolon--for example, Table.IndexDefs.Add(`', `Room;Time', [ixPrimary]);

The last parameter of the Add method is used to specify the index type. This parameter takes a TIndexOptions set. Different index options can be specified in combination. For example, an index might be a primary index that is sorted in descending order. In that case, the call to Add might look like this: Table.IndexDefs.Add(`', `CustNo', [ixPrimary, ixDescending]);

Creating the Table After you add all the field and index definitions to the table, you create the table. So far you have been setting up the table's layout but haven't actually created the table. Creating the table is the easiest step of all: Table.CreateTable;

The CreateTable method performs the actual creation of the table on disk. CreateTable takes the contents of the FieldDefs and IndexDefs properties and creates the table structure, based on those contents. Now that the table is created, you can fill it with data by using any method required for your application. You can fill the table programmatically or allow your users to add or edit the data from a form. 1269

The book's code contains a program called MakeTabl. This program first creates a table and then fills it with data. The program fills the table with data from the CUSTOMER.TXT file created with the MakeText program earlier in the chapter. Listing 18.2 contains the unit for the main form (MakeTblU.pas). Note that the uses list for this program includes the DBGrids, DBTables, and DB units. LISTING 18.2. MakeTblU.pas. unit MakeTblU; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DbTables, Db; type TForm2 = class(TForm) DBGrid: TDBGrid; CreateBtn: TButton; FillBtn: TButton; procedure CreateBtnClick(Sender: TObject); procedure FillBtnClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form2: TForm2; implementation {$R *.DFM} procedure TForm2.CreateBtnClick(Sender: TObject); const Dir : PChar = `c:'; var Table : TTable; begin { Create a BDE alias, but only if it doesn't already exist. } if not Session.IsAlias(`MyDatabase') then begin CreateDirectory(Dir, nil); try Session.AddStandardAlias(`MyDatabase', Dir, `PARADOX'); Session.SaveConfigFile; except MessageDlg(Èrror Creating Alias', mtError, [mbOk], 0); Exit; end; end; { Now create the Table. } Screen.Cursor := crHourGlass; Table := TTable.Create(Self); try Table.DatabaseName := `MyDatabase'; Table.TableName := `MyTable.db'; { Add the field definitions for each field. } Table.FieldDefs.Add(`CustNo', ftFloat, 0, True); Table.FieldDefs.Add(`Customer', ftString, 30, False); Table.FieldDefs.Add(Àddr1', ftString, 30, False); Table.FieldDefs.Add(Àddr2', ftString, 30, False); Table.FieldDefs.Add(`City', ftString, 15, False); Table.FieldDefs.Add(`State', ftString, 20, False); Table.FieldDefs.Add(`Zip', ftString, 10, False); Table.FieldDefs.Add(`Phone', ftString, 15, False); Table.FieldDefs.Add(`Fax', ftString, 15, False); { Add an index definition for the primary key. } Table.IndexDefs.Add(`', `CustNo', [ixPrimary]); { Everything is set up, so create the Table. }

1270

Table.CreateTable; except MessageDlg(Èrror Creating Table', mtError, [mbOk], 0); Screen.Cursor := crDefault; Table.Free; Exit; end; { All done, so let the user know. } Table.Free; Screen.Cursor := crDefault; CreateBtn.Enabled := False; FillBtn.Enabled := True; MessageDlg( `Table Created Successfully', mtInformation, [mbOk], 0); end; procedure TForm2.FillBtnClick(Sender: TObject); var Table : TTable; Datasource : TDataSource; Lines : TStringList; S, S2 : string; I, P : Integer; begin { Create a TTable. } Table := TTable.Create(Self); Table.DatabaseName := `MyDatabase'; Table.TableName := `MyTable.db'; { Create a data source and hook it up to the Table. } { Then hook the DBGrid to the datasource. } Datasource := TDataSource.Create(Self); Datasource.DataSet := Table; DBGrid.Datasource := Datasource; { Open the Table and the text file. } Table.Active := True; Lines := TStringList.Create; Lines.LoadFromFile(`customer.txt'); { Put the Table in edit mode. } Table.Edit; { Process the Lines. } for I := 0 to Pred(Lines.Count) do begin { Append a record to the end of the file. } Table.Append; { Parse the string and get the first value. } S := Lines[I]; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); { Write the value to the CustNo field. } Table.FieldByName(`CustNo').Value := StrToInt(S2); { Continue for each of the fields. } P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`Customer').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(Àddr1').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(Àddr2').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`City').Value := S2;

1271

P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`State').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`Zip').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`Phone').Value := S2; P := Pos(`,', S); S2 := Copy(S, 1, P - 1); Delete(S, 1, P); Table.FieldByName(`FAX').Value := S2; { We might get a key violation exception if we try to add a { record with a duplicate customer number. If that happens, { we need to inform the user, cancel the edits, put the { put the Table back in edit mode, and continue processing. try Table.Post; except on EDBEngineError do begin MessageBox(Handle, `Duplicate Customer Number', `Key Violation', 0); Table.Cancel; Table.Edit; Continue; end; end; end; { All done with the TStringList so it. } Lines.Free; { We won't the Table so that the Table's data shows } { in the DBGrid. VCL will the Table and Datasource } { for us. } {Table.Free; } {Datasource.Free; } end; end.

} } } }

Using Data Modules As you know by now, setting up database components is easy in Delphi. Still, there is some time involved, even for the simple examples you have been writing. You have to place a Table or Query component on the form and choose the database name. Then you have to set the table name (for a Table) or SQL property (for a Query). You might have to set other properties, depending on how you are using the database. You might also have several events to handle. Next, you have to place a DataSource component on the form and attach it to the table or query. If your application makes use of a Database component, you have to set that component's properties and events as well. None of this is hard, but it would be nice if you could do it all just once for all your programs. Data modules enable you to do exactly that. At the base level, data modules are really just specialized forms. To create a data module, open the Object Repository and double-click the Data Module icon. Delphi creates the data module and a corresponding source unit just as it does when you create a new form. You can set the Name property of the data module and save it to disk, again, just like a form. After you create the data module, you place data access components on it. Then you set all the properties for the data access components as needed. You can even create event handlers for any components on the data module. When you have set everything just the 1272

way you want it, save the data module. Every form in your application can then access the data module.

Setting Up a Sample Data Module A simple exercise will help you understand data modules better. First, you'll set up the data module, and then you'll put it to work: 1. Create a new application. Change the main form's Name property to MainForm. Save the project. Save the main form as DSExMain.pas and the project as DSExampl.dpr. 2. Choose File|New. When the Object Repository appears, double-click the Data Module icon to create a new data module. The Form Designer displays the data module. Change the Name property to DBDemos. 3. Click on the Data Access tab on the Component palette. Place a Table component on the data module. Change the DatabaseName property to DBDEMOS and the TableName to ANIMALS.DBF. Change the Name property to AnimalsTable. 4. Place a second Table component on the data module. Set the DatabaseName property to DBDEMOS and the TableName property to BIOLIFE.DB. Change the Name property to BiolifeTable. 5. Place a DataSource component on the data module. Change its Name property to Animals and its DataSet property to AnimalsTable. 6. Place another DataSource component on the data module. Change this data source's Name to Biolife and its DataSet property to BiolifeTable. Your data module now looks like Figure 18.2. FIGURE 18.2. The finished data module. 7. Double-click on the background of the data module. An OnCreate event handler will be created for the data module. Type this code in the event handler: AnimalsTable.Open; BiolifeTable.Open;

8. Save the project. When prompted, save the data module as DataMod.pas.

Adding to Your Data Module Now let's put the new data module to use. You are going to create two buttons for the application's main form. One button will display a form that shows the Animals table, and the other will display the Biolife table. Here goes: 1. Create a new form. Change the form's Caption property to Animals Form and the Name property to AnimalsForm. 2. Choose File|Use Unit. Choose the DataMod unit from the Use Unit dialog and click OK. The data module is now accessible from the main form. 3. Place a DBGrid component and a DBNavigator component on the form. Select both the DBGrid and DBNavigator components. Locate the DataSource property in the Object Inspector and click the drop-down arrow next to the property. You will see the following displayed in the list of available data sources: DBDemos.Animals DBDemos.Biolife

Choose the DBDemos.Animals data source. 4. Save the unit as DSExU2.pas (or a more meaningful name if you like).

1273

5. Again, create a new form for the project. Repeat steps 1 through 3, but this time choose DBDEMOS.Biolife for the data source and change the Caption to BioLife Form. Change the Name property to BiolifeForm. Save the form as DSExU3.pas. Figure 18.3 shows the Delphi IDE after completing this step.

Running the Data Module These steps demonstrate that after you create a data module, you can use the components on that data module from anywhere in your program. All you have to do is use the unit for the data module, and then all data-aware components will be capable of detecting the data module. Let's finish this application so that you can try it out: 1. Place a button on the main form. Change its Caption property to Show Animals. 2. Double-click the button to generate an OnClick handler for the button. Type this code in the event handler: AnimalsForm.Show;

3. Drop another button on the form. Change its Caption property to Show Biolife. 4. Create an OnClick event handler for this button and type the following code in the event handler: BiolifeForm.Show;

5. Choose File|Use Unit. Choose the DSExU2 unit and click OK. 6. Repeat step 5 to include the DSExU3 unit. Now you can run the program. When you click a button, the appropriate form will appear. Figure 18.4 shows the program running. FIGURE 18.3. The second form completed. FIGURE 18.4. The program running with both forms displayed. Data modules make it easy to set up your database components once and then reuse those components over and over. After you create a data module, you can save it to the Object Repository, where it is always available for your use.

Creating Reports A database program is not complete without some way of viewing and printing data, and that is where reports enter the picture. Up to this point, you have been looking at ways to view individual records or multiple records with the DBGrid component. These methods might be perfect for some applications, but sooner or later you will need more control over the viewing of records. Besides viewing the data onscreen, you will almost certainly need to print the data. A database application that can't print is not very useful. Delphi's QuickReport components enable you to view and print your data with ease.

QuickReport Overview Before you can create a report, you need an overview of how the QuickReport components work.

The QuickRep Component The base QuickReport component is the QuickRep component. This component acts as a canvas on which you place the elements that your report will display (I'll discuss the report elements soon). The QuickRep component has properties that affect the way the report will appear when printed. For example, the Page property is a class containing properties called TopMargin, BottomMargin, LeftMargin, RightMargin, Columns, Orientation, PaperSize, and so on. 1274

The PrinterSettings property is also a class. This property has its own properties, called Copies, Duplex, FirstPage, LastPage, and OutputBin. The ReportTitle property is used to display the print job description in the Windows Print Manager and in the title bar of the QuickReport preview window. The Units property controls whether margins are displayed in millimeters, inches, picas, or other choices. The DataSet property is used to set the dataset from which the report's data will be obtained. NOTE: The DataSet property must be set and the associated dataset must be active before anything will show up in the report. Primary QuickRep methods include Preview and Print. The Print method, as its name implies, prints the report. The Preview method displays a modal preview window. The preview window includes buttons for viewing options, first page, last page, previous page, next page, print, print setup, save report, open report, and close preview. Figure 18.5 shows the QuickReport preview window at runtime. FIGURE 18.5. The QuickReport preview window. QuickRep events of note include OnPreview and OnNeedData. You can use the OnPreview event, instead of the default preview window, to provide a custom preview window. When using a data source other than a VCL database, you use the OnNeedData event. For example, you can create a report from a string list, an array, or a text file.

Report Bands A QuickReport is composed of bands. Bands come in many different types. A basic report has at least three types: a title band, a column header band, and a detail band. The title band contains the report title, which is displayed only on the first page of the report. The column header band is used to display the column headers for the fields in the dataset; the column header appears at the top of every page. Some reports, such as a report used to generate mailing labels, do not have a column headers band. The detail band is the band that does all the work. On the detail band you place any data that you want in the report. You define the contents of the detail band, and QuickReport repeats the detail band for every record in the dataset. In a minute you'll do an exercise that illustrates how the different bands work. Other commonly used band types include page header, page footer, group header, group footer, and summary bands. The QRBand component defines a QuickReport band. The BandType property is used to specify the band type (title, detail, header, footer, and so on). The bands automatically arrange themselves on the QuickRep component, based on the band's type. For example, if you place a QRBand on the report and change its BandType to rbPageFooter, the band will be moved below all other bands. Likewise, a page header band will be placed above all other bands. QuickReport Design Elements QuickReport design elements come in three forms. The first form includes components for text labels, images, shapes, headers, footers, and so on. These components are primarily used to display static design elements. For example, the report title is usually set once and then doesn't change. Another example is a graphic used to display a company's logo on the report. The components in this group are very similar to the standard VCL components. The QRLabel component resembles a standard Label component, a QRImage is similar to the VCL Image component, the QRShape component is similar to the regular Shape component, and so on. Use these components to design the static portions of your reports. The second category of elements contains QuickReport versions of the standard VCL data-aware components. These components are placed on the detail band of a report. 1275

Components in this group include the QRDBText, QRDBRichEdit, and QRDBImage components. Data is pulled from the dataset and placed into these components to fill the body of the report. The third group of QuickReport components includes the QRSysData component and the QRExpr component. The QRSysData component is used to display page numbers, the report date, the report time, the report title, and so on. The QRExpr component is used to display calculated results. The Expression property defines the expression for the calculation. The Expression property has a property editor called the Expression builder that is used to define simple expressions. An expression might be simple, such as multiplying two fields, or complete with formulas such as AVERAGE, COUNT, or SUM.

Creating Reports by Hand Certainly the best way to write truly custom reports is by hand. That might sound difficult, but fortunately the QuickReport components make it easy. The best way for me to explain how to create reports by hand is to take you through an exercise. This exercise creates a simple application that displays and prints a report in list form. I won't tell you to perform every single step in this exercise. For example, I won't tell you to save the project or give you filenames to use--you can figure those out for yourself. Also, you don't have to worry about making the report real pretty at this point. You can go back later and tidy up. The first step is to create the main form of the application. After that's done, you create the basic outline of the report. Here goes: 1. Create a new application. Place two buttons on the main form. Change the caption of the first button to Preview Report and the caption of the second button to Print Report. 2. Choose File|New. Double-click the Report icon in the Object Repository. Delphi creates a new QuickReport form. 3. Place a Table component on the QuickReport form. Change the DatabaseName property to DBDEMOS and the TableName property to EMPLOYEE.DB. Set the Active property to True. 4. Select the QuickReport form. Change the DataSet property to Table1 and change the ReportTitle property to Employee Report. 5. Switch back to the main form. Double-click the button labeled Preview Report. Type this code in the OnClick event handler: QuickReport2.Preview;

6. Double-click the Print Report button and type the following in the OnClick event handler: QuickReport2.Print;

7. Choose File|Use Unit and include the QuickReport form. Now you have a blank report. What you need to do next is add a title band, a column header band, and a detail band. For the next few steps you might want to look ahead to Figure 18.6 to see the final result. Follow these steps: 1. Select a QRBand component from the QReport tab of the Component palette and place it on the report. The band is a title band by default. 2. Select a QRLabel component and place it on the title band. Change the Caption property to Employee Report and change the Font property to your preference (I used Arial, 18 point, bold). Align the component so that it is centered on the band. 3. Place another band on the report. Change the BandType property to rbColumnHeader and change the Font to bold and underlined. 4. Place a QRLabel on the left side of the column header band and change the Caption property to Employee Number. Place a second QRLabel on the band to the right of the first and change 1276

the Caption property to Name. Place a third QRLabel on the band to the right of the last label and change the Caption to Salary. 5. Place another band on the report and change the BandType property to rbDetail. Notice that the band moves below the other bands after you change the band type. 6. Place a QRDBText component on the left edge of the detail band (align it with the Employee Number label on the column header band). Change the DataSet property to Table1 and the DataField property to EmpNo. 7. Place another QRDBText on the detail band and align it with the Name component on the column header band. Change the DataSet property to Table1 and the DataField property to FirstName. Place another QRDBText just to the right of the last one (see Figure 18.6). Attach it to the LastName field of the database table. 8. Add a final QRDBText component on the detail band. Place it below the Salary component on the column header band and attach it to the Salary field in the table. Your form now looks like Figure 18.6.

FIGURE 18.6. Your QuickReport form. You are probably wondering what the report will look like on paper. Guess what? You don't have to wait to find out. Just right-click on the QuickReport form and choose Preview from the context menu. The QuickReport preview window is displayed, and you can preview the report. To print the report, click the Print button. When you are done with the report preview, click the Close button. You can now run the program and try out the Preview Report and Print Report buttons. NOTE: The report you just created is double-spaced. To change the spacing, reduce the height of the detail band. Before leaving this discussion of reports, let me show you one other nice feature of QuickReport. Right-click on the QuickReport form and choose Report settings from the context menu. The Report Settings dialog will be displayed, as shown in Figure 18.7. This dialog enables you to set the primary properties of the QuickRep component visually rather than use the Object Inspector. FIGURE 18.7. The QuickReport Report Settings dialog.

Creating Reports the Easy Way Delphi comes with three built-in QuickReport forms, which can be found on the Forms tab of the Object Repository. The forms are called Quick Report Labels, Quick Report List, and Quick Report Master/Detail. These forms give you a head start on creating reports. You can generate one of the forms from the Object Repository and then modify the form as needed.

Deploying a Delphi Database Application As I said on Day 16, the Borland Database Engine (BDE) is a collection of DLLs and drivers that enable your Delphi application to talk to various types of databases. When you ship an application that uses the BDE, you need to make sure that you ship the proper BDE files and that they are properly registered on your users' machines. The most sensible way to do this is with a Borland-approved installation program. Here at TurboPower Software, we use the Wise Install System from Great Lakes Business Solutions (http://www.glbs.com). Others include InstallShield and its little brother, InstallShield Express. Conveniently, InstallShield Express comes with Delphi Professional and Client/Server, so if you have one of those versions of Delphi, you don't have to rush right out and buy an installation program. 1277

You might be wondering why Borland is involved in dictating how the BDE must be deployed. The reason is simple when you think about it: There are many BDE versions in use. Some folks might be writing and deploying applications that use the BDE from Delphi 1. Others might be using the BDE from C++Builder 1. Still others could be using the BDE that comes with Delphi 4 in their applications. The important point to realize is that the BDE is backward compatible. Newer BDE versions are guaranteed to work with applications written for older BDE versions. This system will only work, however, as long as everyone plays by the rules. Part of the rules say, "Thou shalt not arbitrarily overwrite existing BDE files." Certified installation programs check the version number of any BDE files they find. If the file being installed is older than the existing file, the installation program leaves the existing file in place. This ensures that the user will always have the latest BDE files on his or her system. Another service that these certified installation programs provide is to determine exactly which files you need to deploy for your application. You should read DEPLOY.TXT in the Delphi root directory for more details on deploying applications that use the BDE.

Summary There's no question that creating database applications requires a lot of work. The good news is that Delphi makes the job much easier than other development environments. Today you found out something about the nonvisual aspects of database programming. You also found out about data modules and how to use them. You ended the day with a look at QuickReport. QuickReport makes creating reports for your database applications easy. I also explained what is required to deploy a database application.

Workshop The Workshop contains quiz questions to help you solidify your understanding of the material covered and exercises to provide you with experience in using what you have learned. You can find answers to the quiz questions in Appendix A, "Answers to the Quiz Questions."

Q&A Q I am trying to create a database at runtime. I have created a BDE alias and set all the field definitions, but the table is never created on my hard disk. What have I done wrong? A You have probably failed to call the CreateTable method. You must call this method to physically create the table. Q When designing a report, can I set all my report's properties at one time? A Yes. Just right-click the QuickRep component and choose Report settings from the context menu. The Report Settings dialog is displayed, and you can set most of the report properties visually. Q Can a data module include code as well as components? A Yes. A data module can contain any code necessary to carry out operation of the data module. The data module can contain event handlers or methods that you create. The methods you create can be public or private (for the data module's use only). Q When I preview my report, it is blank. What is wrong? A More than likely you have not set the Active property of the dataset to True. The dataset must be open before the report will function. Q Can I use more than one detail band on a report? 1278

A No. You can place more than one detail band on a report, but only the first one will be used when the report is generated. Q Why do I need a Borland-approved installation program to install my database application? A The BDE is complicated to install, and an approved installation program is guaranteed to do the installation correctly.

Quiz 1. What method do you call to create a database table at runtime? 2. What does the Edit method of TTable do? 3. What method do you call when you want to apply the changes made to a record? 4. How do you create a new data module? 5. Is a data module a regular form? 6. What method do you call to print a QuickReport? 7. What type of QuickReport band displays the dataset's data? 8. What component is used to display the page number on a report? 9. How can you preview a report at design time? 10. What is the QRExpr component used for?

Exercises 1. Create a database (a BDE alias) and a table for the database, either through code or by using the Delphi database tools. 2. Create a data module containing the database table from exercise 1. 3. Generate a report that creates mailing labels. (Hint: Start with a QuickReport Labels object from the Forms page of the Object Repository.) 4. Modify the QuickReport you created in this chapter so that the employee's first and last names are displayed by a QRExpr component. 5. Read the DEPLOY.TXT file in your Delphi directory to understand what is involved in deploying a Delphi database application.

1279

http://delphi.about.com/gi/dynamic/offsite.htm?sit e=http%3A%2F%2Fwww.kaposnet.hu%2Fbooks% 2Ftysdelphi4%2Fch16%2Fch16.htm Delphi - Database application tutorial (final paper) 1. Introduction In prior paper of our database tutorial we looked into the theory. In this final paper we are going to build a simple database application. The application will show the befor discussed techniques. It certainly is not a complete application. It's only ment for showing the various techniques. Download here the source 2. The database tables The main goal of our application is to manage projects and drawings. It is possible to add drawings to a project. The complete application works with three tables : · Project.db - For managing the projects. · Drawing.db - For managing the drawings. · DrawProject.db - For relating drawings to projects and vica versa. Paradox tables are used with the following structure : * = Index of table, A = Alpha numeric (Character) D=Datefield. Drawing.db DrawProject.db Project.db TS TS FieldN y i Ke FieldNa y i Ke Typ Siz FieldName Key ame p z y me p zy e e ee e e Project Drawin 1 A6* A * Drawingnr A 11 * nr gnr 1 Descrip 5 Descri 5 A A Projectnr A 6 * 0 tion 0 ption Client Drawnb 1 A6 A Secondary indexes : Code y 0 OnDrawingnr : Field Drawingnr Date D Date D OnProjectnr : Field Projectnr The tables Project and Drawing are related on a many-to-many relationship. This means that a project can have more then one drawing, and a drawing can belong to more then one project. The relation is maintained in the table DrawProject. 3. The Application The application has one mainform with a pagecontrol on it having three tabsheets. The first tabsheet shows the projects. Here we can : · add, delete and change projects. · add drawings to a project. The second tabsheet shows an overview of all the drawings.Here we can add, delete and change drawings. The third tabsheet offers the possibility of using SQL query's to get specific resultsets from the database. As said, not a complete application, but an application with a lot of databs techniques in it. List of forms of this project : frmMain - the main form dmProject - a datamodule which contains the database components. 1280

frmAddItem - a 'common' form which can be used in combination with a class for adding drawings to a project. (About this later on more) modBrowse - an unit, not a form, which declarates the class for adding 3.1 Setting database components First we need to make a database alias in the BDE-Administrator :

The name of the alias is Project and points to the physical data on disk. Now that this is done we can put the database components in the datamodule and set their properties. What do we need : · a TTable and TDatasource for the projects. · a TTable and TDatasource for the drawings · a TTable and TDatasource for the relation between projects and drawings. (The master - detail relation) · a TTable and TDatasource to show drawing details of the related drawings. · a TQuery and TDataSource component for the query and resultset.

Above you see a screendump of the datamodule dmProject. The properties per component are set as follows : Setting the properties of the data-access components : tbProject Query DataBase Project DataBaseName Project name Name tbProject Name Query TableNa Project.d me b tbProject is used for Query is the component used managing the for SQL queries on the projectdata. database. dsProjec dsQuery t 1281

DataSet tbProject Name dsProject dsProject is the datasource belonging to tbProject. tbDrawin g DataBase Project Name tbDrawin Name g TableNa Drawing. me db tbDrawing is used for managing rhe drawing data. tbPrjDwg DataBase Project Name Name

Dataset Query Name dsQuery dsQuery is the datasource belonging to Query.

dsDrawingToProj ect Dataset Name

dsDrawingToProject is the datasource belonging to tbDrawingToProject. tbDrawingToProj ect DataBaseName

tbPrjDwg Name

TableNa DrawProj me ect.db MasterSo dsProject urce MasterFi Projectnr. elds IndexNa OnProjec me tnr tbPrjDwg shows the drawings which belong to the current project. The mastersource is dsProject, so tbPrjDwg only shows records from the table drawproject which have the current project as project. Notice that the Indexname points to the secondary index OnProjectnr. dsPrjDw g DataSet tbPrjDwg Name dsPrjDwg

tbDrawingT oProject dsDrawing ToProject

Project tbDrawingT oProject

TableName

Drawing.db

MasterSource

dsPrjDwg

MasterFields

Drawingnr

tbDrawingToProject shows the detaildata of the drawings which belong to the current project. The master source is dsPrjDwg. This TTable allways shows one record, based on the current drawing in tbPrjDwg.

1282

dsPrjDwg is the datasource belonging to tbPrjDwg. The dataware components of the application must be set as follows :

The tab Drawings has a DBGrid where drawings can be updated. DBGrid has as source dsDrawing. 3.2 Adding a drawing to a project With the button Add a drawing to this project you can add drawings to the current project. A drawing must be selected from the table Drawing, this drawing will be added, together with the projectnr. in the tablel tbPrjDwg. For selecting a drawing we need a new form. We could build this form similar as the application using it only for drawings. For this demoapplication that would be Ok. But you could also add a project to a drawing, or add a project to 'what ever'. We must make the form as abstract as we can to re-use it for all adding operations in our application. How could this be done : 276. To set the components in the calling code before we show the form. 277. By setting properties at the AddForm so the form can configure itself. 278. By using a class in which we can set easily the properties, and which we can use in the future to add 'add'features in our application. Option 1 and 2 are Ok, but they bring a lot of 'look a like' code for each adding form in our application code. From the OOP perspective option 3 is the best solution, so let give it a try.

1283

The AddForm :

The addform is very simple and consists of a DBGrid and two buttons. In design time we don't need to set database properties.

The following class is used in the adding process : (modBrowse.pas) ///////////////////////////////////////////////////////////////////////////// // modBrowse class // Used for setting the frmAddItem form // // (c) [email protected] http://surf.to/beensoft //////////////////////////////////////////////////////////////////////////// unit modBrowse; interface uses DB, Classes; resourcestring SAddDWG = 'Add a drawing'; type TDBBrowseClass = class private { Private declarations } FDataSource : TDataSource; FFieldCaptionList : TStrings; FFieldList : TStrings; public { Public declarations } Constructor CreateBrowse (aDataSource : TDataSource); Destructor Destroy; Override; function GetCaption : string; virtual; abstract; function GetFieldCaptionList : TStrings; virtual; function GetFieldList : TStrings; virtual; property Datasource : TDataSource read FDataSource write FDatasource; property FieldCaptionList : TStrings read FFieldCaptionList write FFieldCaptionList; property FieldList : TStrings read FFieldList write FFieldList; end; //TDBDWGBrowse : Adding drawings type TDBDWGBrowse = class(TDBBrowseClass)

1284

private { Private declarations } public { Public declarations } function GetCaption : string; override; function GetFieldCaptionList : TStrings; override; function GetFieldList : TStrings; override; end; // Here you could create the TDBPrjBrowse for adding projects implementation { TDBBrowse } constructor TDBBrowseClass.CreateBrowse(aDataSource: TDataSource); begin Inherited Create; FDataSource := aDataSource; // the datasource FFieldCaptionList := TStringList.Create; // the collumncaptions of the grid FFieldList := TStringList.Create; // the fields in the grid end; Destructor TDBBrowseClass.Destroy; begin FFieldCaptionList.Free; // free the caption stringlist FFieldList.Free; // free the field list Inherited Destroy; end; function TDBBrowseClass.GetFieldCaptionList : TStrings; begin FFieldCaptionList.Clear; // clear the list (should be clear) Result := FFieldCaptionList; end; function TDBBrowseClass.GetFieldList : TStrings; begin FFieldList.Clear; // clear the list (should be clear) Result := FFieldList; end; { TDBDWGBrowse } function TDBDWGBrowse.GetCaption: string; begin Result := SAddDWG; //set the caption for DWG adding end; // For the captions of the grid columns function TDBDWGBrowse.GetFieldCaptionList : TStrings; begin FFieldCaptionList.Add('Drawingnr'); FFieldCaptionList.Add('Description'); result := FFieldCaptionList; end; // The FieldName list function TDBDWGBrowse.GeTFieldList : TStrings;

1285

begin FFieldList.Add('DRAWINGNR'); FFieldList.Add('DESCRIPTION'); result := FFieldList; end; end.

The main class is used for initializing the class (datasource) and to create the stringlists. (And destroying them after use) The virtual declared methods can be overriden in the subclasses to set the specific properties like the used fields and captions in the grid. Using this class is still a bit static, we could also use parameters for the fields to initialize them automatic. But then it would maybe be easier to make a component of it on which you can set all the properties in designtime. A very good idea indeed! Let's build a TDBBrowse component in the future. The calling code is as follows : (frmMain) procedure TfrmMain.SetGridProps; // method can be used generally var I : Integer; // Browse : TDBBrowse begin frmAddItem.DBGridItems.Columns.Clear; // Clear the 'normal'fieldlist For I := 0 to Browse.GetFieldList.Count - 1 do // Add field and caption to DBGrid with frmAddItem do begin DBGridItems.Columns.Add; DBGridItems.Columns[I].FieldName := Browse.GetFieldList.Strings[I]; DBGridItems.Columns[I].Title.Caption := Browse.GetFieldCaptionList.Strings[I]; end; end; procedure TfrmMain.btnAddDWGClick(Sender: TObject); // Add a drawing button click begin // First create the DWGBrowse object Browse := TDBDWGBrowse.CreateBrowse(dmProject.dsDrawing); Try frmAddItem := TFrmAddItem.Create(self); // Create the form With frmAddItem do begin Caption := DWGBrowse.GetCaption; // Set the caption of the form DBGridItems.DataSource := Browse.DataSource; // Parse the datasource to grid SetGridProps; // Set grid properties method ShowModal; // show the form With dmProject do // Insert the drawing/project in tabel tbPrjDwg begin tbPrjDwg.Insert; tbPrjDwg.FieldByName('DRAWINGNR').AsString := tbDrawing.FieldByName('DRAWINGNR').AsString; tbPrjDwg.FieldByName('PROJECTNR').AsString := tbProject.FieldByName('PROJECTNR').AsString; tbPrjDwg.Post; end; end; Finally frmAddItem.Free; // free the form Browse.Free; // free the object end; end;

1286

3.3 Making a query On the third tabsheet of the control we can edit SQL code in a memo component and execute it with the button Execute query The buttonClick event is as follows : procedure TfrmMain.btnExecuteSQLClick(Sender: TObject); begin with dmProject do begin Query.Close; Query.SQL.Clear; Query.SQL := mmSQL.Lines; // assign memolines to SQL Query.Open; end; end;

The resultset of the querie is shown in the DBGrid below the memo. With this demo application we tried to clear a few database techniques. Th tutorial Tutorial Delphi basic-databasetechniques is now complete.

1287

Delphide SQL Kullan ımı

Database İlişkisi ID AD MAAS } Kolon adı (field) 1 Kazım 10000 } 2 Metin 75000 } Kayıt (rows) … …………….. ……….. } Kolon Kolon Kolon Table : Database'de saklanan kolonların birleşiminden oluşan kümedir. Table'ın data tipi yoktur. Row : Tek kayıt demektir. Column : Table'daki kolon adına ait kayıtlardır. Örneğin, 'AD' kolonu demek 'AD' kolonuna girilen verilerin tümüdür. Field : Kolon başlıkları ile kayıt başlığı olanlardır. Primary Key : Unique + not null (Tek olmalı ve boş geçilemez.) Foreign Key : Primary key gibidir. Fakat null değerler alabilir. Table'lar ilişkisel veri tabanı(compact) olmalıdır. Tablolar arasında bir ilişki kurulmalıdır. Oracle database'i ile kullanıcı arasında SQL_NET ilişki kurar. Protokoller belirlenir, bir isim altında konfigurasyonlar birleştirilir. Böylece database ismi tanımlanmasıyla ona ait tüm konfigurasyonlar oluşturulur. RDBMS : Oracle'ın server tarafındaki protokoludür. Hızlı erişim sağlar. Güvenlik son derece güçlüdür. Client / server desteklidir. TCP/IP : Oracle'ın server tarafındaki protokoludür.IP numaraları sayesinde client / server mimarisi iletişimi kurulur. RDBMS gibi ortak özellikler taşır. Referantional : Tablolar arasındaki referansların belirtilmesidir. Bazen bir kolonun değerlerinin başka bir tablodaki kolonlardan veri laması gerekmektedir. bu durumda referans verilir. Bir projeye başlarken şu aşamalar yapılır; i. İyi bir analiz ii. Analizin tablolara göre dizaynı ve aralarındaki ilişkiler iii. Akış şeması ve döküman hazırlanması iv. Test edilmesi v. Üretime geçilmesi Database'e üzerinde giriş,değişiklik,silme vb. İşlemlersql ile olur. Tablolar fiziksel olarak gözükmezler. Database içinde saklıdırlar. Operatörler kullanılabilir. Data Dictionary: Database'deki kullanıcılar, yaratılan tablolar vb. Nesneler hakkında detaylı bilgiler bulunan tablodur. Belli başlı fonksiyonlarla ulaşılabilir. SQL : Tablolar arasında iletişim kurar, sorgulama yapar. SQL *Plus : Ek olarak bloklar oluşturulabiliyor. Mantıksal döngüler ve komutlar oluşturulabiliyor. IF, FOR vb. PL / SQL : Server'a bağlanıp insert, update, delete vb. Database üzerinde direkt işlemler yapılabilir. Database'e en hızlı ulaşım ve sorgulama biçimidir. · Yazılan komutlar bufferda işlem yapar. O yüzden her yeni komut yazıldığında önceki komutu siler. · Yazılım kontrolu(syntax) her satırın sonunda kontrol edilir. · Çeşitli formatlarla çıktı alınabilir. · Direkt komut sonunda sonuç alınır., · Select ile data okunur. · İnsert, update,delete (DML) ile var olan bir tablo üzerinde değişiklikler yapılabilir. · Create,alter,drop,rename, truncate(DDL) ile yapısal değişiklikler yapılabilir. · Commit,rollback,savepoint (tranaction) ile yapılan işleri onaylar veya geri alır, iptal edilebilir. · Grant,revoke (DCL) ile objelerin kullanılmasına hak vermek veya geri almak içindir. Güvenlik kurulur. · Exit (^D) ile SQL'den çıkış sağlanır. Böylece yapılan işlemler iptal olur. ·NOT: Tnsnames.ora à Database hakkında bilgiler bu dosyada saklıdır. ·Listener.ora à Server tarafında bulunan config dosyasıdır. 1288

·NOT: Komut yazılımdaki köşeli parantezler o alanın zorunlu olmadığını belirtir. {} işaretleri o alan için birden fazla değer alacağını gösterir. Büyük harf yazılanlar oldugu gibi yazılır. Küçük harf yazanlar açıklamadır. ·SELECT komutu ·Select komutu ile database'den istenilen kriterlere göre veri getirlir. ·Yazılımı: ·SELECT [DISTINCT] {*,column [alias] ,….} ·FROM Tablo ·[WHERE koşullar] ·[ORDER BY {column,expr} [ASC|DEXC] ] ; SELECT :Seçilen kolonları alır. DISTINCT :Belirtilen kolondaki aynı değerlere sahip verilerden sadece birini alır. Örneğin personel kodu xxx olanın personel adı gibi. alias :Kolon adlarının daha açık olması için tanımlanır. FROM table :Belirtilen tabloyu açar. WHERE :Belirli kriterler koşullar oluşturulur. Tablolar arasında birleştirmeler yapılabilir. ORDER BY :Seçilen kolona göre sıralı kayıt getirir. ASC :Artan sırada listelenir. Varsayılan budur. DESC : Artan sırada listelenir. Varsayılan budur. * : Tüm kolonlar seçilmiş anlamındadır. Listelemede rakamlar sağa yanaşık, karakterler sola dayalı gözükür. Kolon adları büyük harf görüntülenir.Aritmatik işlemler kullanılabilir (+,-,/,*). Örneğin; Select maas+maas*0.10 From Personel_Table; Bazen bir matematiksel işlemler daha uzun veya daha karmaşık olabilir. Fonksiyon tanımlayarak kolona sorgulatıp bir sonuç üretebiliriz. Matematiksel işlemlerde öncelik sırası; i. Parantezler (,) ii. *,/,+,iii. soldan sağa doğru öncelik sırası, şeklindedir. Column Alias : Kolon başına açıklayıcı isim verilebilir. Tırnak işaretleri (") ile açıklayıcı kelime belirtilir. Tek kelime için " işareti kullanılmasada olur. Örneğin; Select ad AS "Adı" From Personel_Table; Concatenation Operator: Birden fazla stringi veya kolonu yan yana birleştirip listelemek için kullanılır. İfadeler string olmalıdır. Zaten karakter ve tarih formatındaki değerler tırnak( ' ) işaretleri içerisinde belirtilir. Örneğin; Select ad||' ' ||soyad AS "Adı Soyadı" From Personel_Table; Null : Değeri hiç girilmeyen kolonlar NULL değerini alırlar. NULL sıfır veya boşluk karakteri değildir. Yokluk demektir. Bir rakam ile NULL değer üzerinde matematiksel işlemler yapılamaz. NVL Fonksiyonu: Null değeri yerine yeni değer atar. Alan tipi ne turde ise alacağı değer o türde olmalıdır. Yazılımı: NVL (null_değeri_alan,yeni_değer) Örneğin; NVL(Maas,0); à Maas kolonundaki null değerlerin yerine sıfır atar. veya NVL(Ad,' '); à Ad kolonundaki null değerlerin yerine bos karakter atar. En önemli kullanım amacı hesplamalara işlemin yarıda kesilmesini engellemek içindir. Örneğin maasa zam miktarı eklensin. Ama bazı personele zam yapılmadığı varsayılırsa bu kişiler icin zam kolon değeri null'dur. Buna göre; SELECT maas+NVL(zam,0) From Personel_Table; Tab : Tüm tabloların adlarının saklandığı alandır. Örneğin tüm tabloların listesini vermek için aşağıdaki iki yazılımı da kullanabiliriz.; Yazılımı; SELECT * From Tab; SELECT table_name From user_tables; 1289

Desc : Tablonun kolonlarının adlarını, kolonların tipini ve null değer alıp alamayacağı durumlarını gosterir. Yazılımı: DESC tablo_adı; Kolon tiplerinden bazıları; NUMBER(rakam,ondalık) à Sayısal ifadelerdir. Rakam alanı sayının max alabileceği tamsayı kısmını verir. Ondalık alan ise max. decimal değerini verir. VARCHAR2(sayı) à Karakter ifadelerdir. Sayı ile belirtilen alan, max. karakter sayısıdır. DATE à Tarih ve saat ifadeleridir. Ülke kodu desteğiyle çeşitli formatlarda database’de tutulurlar. CHAR(sayı) à Karakter ifadesidir. VARCHAR2’den tek farkı database’de saklanma şeklidir. Max 255 karakter alabilir. Sayı ile belirtilen alan, max. karakter sayısıdır. ORDER BY : Seçilen kolona göre sıralama yapar. DESC artan sırada, ASC azalan sırada listeler. Null değerler sıralamaya alınmazlar. Örneğin azalan sırada ada gore liste alınsın; SELECT ad,soyad FROM Personel_Table ORDER BY ad DESC; Eğer kolonlar birden fazla ise kolon numarası ile de tanım belirtilebilir; SELECT ad,soyad FROM Personel_Table ORDER BY 1 DESC; Eğer birden fazla kolona göre sıralama yapılmak istenirse, önce yazılan kolon baz alınarak diğer kolona göre sıralı listeler. SELECT ad,soyad FROM Personel_Table ORDER BY 1,2 DESC; WHERE : Sorgulamaları sınırlandırmak amacıyla koşullar konulur. Örneğin departmanı 38 kodlu personel listesi; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE Dept_Id=38; <,>, >=, <= gibi karşılaştırma karakterleri kullanılabilir. Bunlar dışında bazı SQL operatörleri ile daha rahat koşullar konulabilmektedir. BETWEEN Min AND Max: Belirtilen Min. ve Max. değerler arasında değer alabilir. Yani belirtilen iki değer arasında değerler alır. Örneğin yaşı 18 ile 30 arasındaki personeller; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE yas BETWEEN 18 AND 30; IN (liste) : Liste olarak tanımlanan değerleri alır. Yani bir şekilde OR ifadesine denktir. Örneğin yaşı 18, 25 ile 30 olan personeller; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE yas=18 OR yas=25 OR yas=30; Veya SELECT ad ||' ' ||soyad FROM Personel_Table WHERE yas IN(18,25,30); LIKE : Benzerlik vermek için kullanılır. '%' karakteri tum karakterler yerine geçer. '_' karakteri ise tek karakter yerine geçer. Sadece _ işaretini çıkarmak için ' \_ ' işareti kullanılır. Küçük büyük harf ayrımı vardır. '%t' à t harfiyle başlayanlar. '%t%' à t harfi geçen tüm kayıtlar. 'B_K%' à B baş harfi ile başlayan ve 3. Harfi K olan tüm kayıtlar. karakterleri arasında değer girilirse kolon içinde Örneğin soyadı 'M' ile başlayan personeller; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE soyad LIKE ' M% ' ; IS NULL : Kayıdın null olup olmadığını kontrol eder. Örneğin maaşı null olan kayıtları listelesin; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE maas IS NULL ; NOT : Belirtilen koşulun tam ters koşulunu verir. Örneğin maaşı null olmayan kayıtları listelesin; SELECT ad ||' ' ||soyad FROM Personel_Table WHERE maas IS NOT NULL ; SQL *Plus Üzerinde Sorgu Hazırlanmasında Kullanılacak Yardımcı Komutlar Sql komutları sadece hafızada tutulurlar. İşletilen her komut hafıza tutulur. O yüzden kullanıcının işini kolaylaştırmak için bazı ek komutlara ihtiyaç duyulmuştur. Sql Plus’a girmek için komut satırında şu şekilde girilir; 1290

SQLPLUS [kullanıcı adı [/şifre [@Database]]] A[PPEND] Text à Satır sonuna kelime ekler. C[HANGE] /eski/yeni à eski text yerine yeni text ekler. Yeni alanı boş bırakılırsa eski alan olarak belirtilen text silinir. CL[EAR] BUFF[ER] à SQL hafızasındaki tüm satırları siler, hafızayı boşaltır. DEL à Aktif olarak bulunduğu satırı siler. Satır no belirtilirse o satırı siler. I[NPUT] Text à Satır arasına Text ifadesiyle belirtilen cumleyi ekler. L[IST] à Hafızadaki tüm satırları listeler. L[IST] m n à Sadece m ile n arasındaki satırları listeler. R[UN] à Hafızadaki SQL satırını çalıştırır. Aynı işlevi "R,r,/, ; " karakterleride yapar. n Text à n satırındaki cümleyi Text ifadesi belirtilen alana yazılan cümle ile değiştirir. 0 Text à Bulunduğu satırdan bir önceki satıra yeni alan açar ve texti oraya ekler. SAVE Dosya à Hafızadaki komutu belirtilen dosya adı altında saklar. GET Dosya à Belirtilen dosyayı hafızaya yukler. START Dosyaà Belirtilen dosyayı direkt çalıştırır. Hafızaya yuklemez. @ işaretide aynıdır. ED[IT] Dosyaà Belirtilen dosyayı bir editör içinde açar. SPOOL à Ekranda yapılan her türlü işi dosyaya atar. SPOOL OFF ile dosyaya kayıt işlemini durdurur. EXIT à SQL’den çıkış sağlar. HELP Komut à Belirtilen komut için açıklayıcı bilgi verir. SQL Plus Fonksiyonları Fonksiyonlar sayesinde; · Datalar üzerinde hesap yapabilir, · Datalar üzerinde değişiklikler yapılabilir, · Grup oluşturularak bu kayıtlar için kullanılabilir. · Tarih datası çeşitli formatlarda görüntülenebilir, · Kolon tipleri değiştirilebilir. · İç içe fonksiyonlar tanımlanabilir. Öncelikle içteki fonksiyon çalışır. Çıkan sonuca göre dıştaki fonksiyon işlem görür. Sys.Dual : Oracle database’inde bulunan tek kolon ve tek satırdan oluşan bir tablodur. Belirli bir tablodan değerler almadan fonksiyonların kullanılması gerektiginde bu tablo kullanılır. Karakter Fonksiyonları LOWER(Text) : Text olarak belirtilen alanı küçük harfe çevirir. UPPER(Text) : Text olarak belirtilen alanı büyük harfe çevirir. INITCAP(Text) : Text olarak belirtilen alanın baş harfini büyük diğerlerini küçük harfe çevirir. CONCAT (Text1,Text2) : Text1 olarak belirtilen alan ile Text2 alanını birleştirir. ‘ || ‘ simgeside aynıdır. SUBSTR(Text,m,n) : Text alanının m. karakterinden itibaren (m. karakter dahil) n kadar karakter alır. LENGTH(Text) : Text alanın karakter uzunluğunu sayısal olarak verir. NVL(KOLON,DEĞER) : Kolonun aldığı değer null ise değer alanında belirtilen değeri verir. Sayısal Fonksiyonları ROUND(Sayı,m): Sayı alanına girilen rakam, m olarak belirtilen ondalık kadar yuvarlar. Örneğin; ROUND(45.923,2) à 45.92 ROUND(45.923,0) à 46 ROUND(45.923,-1) à 50 ROUND(45.951,2) à 45.92 ROUND(45.929,2) à 45.93 TRUNC(Sayı,m): Sayı alanına girilen rakam, m olarak belirtilen ondalık kadar sondan keser. TRUNC(54.923,2) à 45.92 TRUNC(54.923,-1) à 40 TRUNC(54.929,2) à 45.92 MOD(m,n) : m sayısı n sayısına bolundugunde kalan rakamı bulur. Zamansal Fonksiyonları ve İşlemleri Tarih + sayı à Tarihe sayı kadar gun ekler. Tarih - sayı à Tarihe sayı kadar gun çıkarır. 1291

Tarih - Tarih à İki tarih arasındaki gün farkını sayısal olarak verir. Tarih + sayı / 24 à Tarihe sayı kadar saat ekler. SYSDATE à Sistem tarihini verir. Oracle’ın varsayılan tarih formatı ‘DD-MON-YY’ şeklindedir. Üzerinde aritmatiksel işlemler yapılabilir. MONTHS_BETWEEN(tarih1,tarih2)à İki tarih arasını ay olarak bulur. ADD_MONTHS (tarih,n) à Tarihe n kadar ay ekler. NEXT_DAY(tarih,' gün' ) à tarih'den sonraki günün ilk tarihini verir. LAST_DAY(tarih,' gün' ) à tarih'den önceki günün ilk tarihini verir. ROUND(tarih[,' fmt '] ) à tarih'I belirtilen formata göre aya veya yıla göre yuvarlar. TRUNC(tarih[,' fmt '] ) à tarih'I belirtilen formata göre aya veya yıla göre keser. Çevirme Fonksiyonları TO_CHAR(Sayı,[‘fmt’]) : Girilen tarih veya sayıyı karakter tipine çevirir. Tarih parametreleri; YYYY à Yılı rakamsal olarak gosterir. YEAR à Yılı yazısal olarak verir. BC à Millattan once ve sonrası icin zaman verir. MM à Ayı rakamsal olarak gösterir. MONTH à Ayı yazısal olarak verir. Belirtilen ülkenin tarih yazısıyla verir. MON à Ayı yazısal sadece ilk 3 harfini verir. Belirtilen ülkenin tarih yazısıyla verir. RM à Ayı roma rakamıyla gösterir. DD à Günü rakamsal olarak gösterir. DAY à Günü yazısal olarak verir. Sayısal parametreleri; 9. à Rakamdır. 0. à Sıfır rakamı verir. $ à Rakamın başına $ işareti koyar. . à Ondalık haneye ayırır. , à Rakamı 3’er hane ayırarark aralarına virgül koyar. MI à Negatif sayılar için sonuna – itareti koyar. Örneğin " x nolu kişi xxx'dir." Formatında ekrana liste oluşturalım (id number); SELECT TO_CHAR(id) || ' nolu kisi ' ||name||'dir.' Örneğin sistem tarihini DD-MM-YYYY olarak gösterelim; SELECT TO_CHAR(sysdate,' DD-MM-YYYY') Örneğin sistem zamanını HH:MI olarak gösterelim; SELECT TO_CHAR(sysdate,' HH:MI' ) TO_NUMBER (Karakter) : Girilen karakteri sayısal ifadeye çevirir. TO_DATE(char, [‘fmt’]) : Girilen karakteri belirtilen formatta tarih formatına çevirir. Örneğin tarih kolonundaki değerleri, 7 /11/1998 tarihine eşit olanların listesini oluşturalım. Ama kolon değerleri string olarak ayın uzun ad, günü ve yılı sayısal olarak kayıtlıdır. Bu sorunu çözmek için kullanılır; SELECT no, maas FROM Personel WHERE MAAS_TARIH=TO_DATE('KASIM 7, 1998', 'Month dd,YYYY') Tablolar Arasında İlişki Kurulması (JOIN) * Birden fazla tabloyla ilişki kurularak ortak sorgulama yapılmasıdır. Tabloları belli bir ortak kolona göre birleştirmek için join yöntemi kullanılır. Bunun için öncelikle tablolardaki kolonlar aynı tipte ve aynı büyüklükte olmalıdır. Yazılımı: SELECT table1.kolonları,table2.kolonları FROM table1, table2 WHERE table1.kolon1=table2.kolon2 İki tabloyu birleştirmek için iki tabloda ortak bulunan kolonları where kotulu içinde etitleriz. Örneğin personel adı ve bulunduğu departman listesi icin; 1292

SELECT a.*,b.* FROM personel a , departman b WHERE a.dept_id=b.dept_id Böylece personel tablosundan personel adı ve soyadı, departman tablosundan departman adı bilgisi getirilir. * Bazı durumlarda tablo birleştirme koşulu bir aralık şeklinde oluşabilir. Yani tabloları birleştirirken anahtar sahaların belirli bir aralığı seçilebilir. SELECT table1.kolonları, table2.kolonları FROM table1, table2 WHERE table1.kolon1 BETWEEN table2.min2 AND table2. max2 * (OUTER JOIN) Bir diğer durumda tablodaki verilerin değerleri null olabilir. Fakat biz null değerlere sahip olanlarıda birlerştirmek istersek eksik olan tablonun yanına (+) işareti eklenir. SELECT table1.kolonları, table2.kolonları FROM table1, table2 WHERE table1.kolon1 (+) = table2.kolon2 * (SELF JOIN) Bir başka durumda aynı tablodaki kendi içindeki kolonlar arasında ilişki kurulabilir. Bazı durumlarda kolonlardaki değerleri eşit olma durumlarına göre sorgu düzenlenebilir. SELECT table1.kolonları FROM table1 a, table1 b WHERE table1.a = table1. b Grup (GROUP) Fonksiyonları Bazen belli bir koşula uygun belli bir topluluk için sorgu kurulabilir. Bu durumda grup işlemi yapılır. Örneğin departmanlara göre grup oluşturulup o departmandaki personel sayısı hesaplanabilir. Grup fonksiyonları sadece grup ifadeleriyle kullanılabilir. Yazılımı: SELECT kolonlar, grup fonksiyonları FROM table [WHERE kotul] [GROUP BY grup_kolonu] [HAVING group_kotulu] [ORDER BY kolon] GROUP BY satırı ile kolonlar üzerinde küçük gruplar oluşturulur. HAVING satırı ile bu oluşturulan grup için grup koşulları tanımlanabilir. Where koşulundan farkı WHERE kayıt üzerinde koşul koyar, HAVING ise sadece grup kayıtları üzerinde koşul konabilir ve grup fonksiyonları kullanılabilir. AVG(Kolon) : Belirtilen kolonun ortalamasını bulur. COUNT(Kolon) : Belirtilen kolonun kayıt sayısını bulur. Count(*) ile o grupta oluşturulan kayıt sayısı hesaplanır. Null değerler için nvl fonksiyonu kullanılır. Çünkü kolon içindeki null değerler işleme alınmaz. MAX(Kolon) : Belirtilen kolondaki kayıtların değerlerinin maksimum değerini bulur. Sayısal, karakteristik veya tarihsel olarak kendi içinde sıralama yapabilir. MIN(Kolon) : Belirtilen kolondaki kayıtların değerlerinin minimum değerini bulur. Sayısal, karakteristik veya tarihsel olarak kendi içinde sıralama yapabilir. SUM(Kolon) : Belirtilen kolondaki kayıtların değerlerinin sayısal toplamını bulur. VARIANCE(Kolon) : Belirtilen kolondaki kayıtların değerlerinin matematiksel varyansını bulur. Örneğin bir personel listesindeki departmanların ayrı ayrı departman içindeki personelin max ve min maas alan kişilerin maaslarını isteyelim; SELECT Departman_id, MAX(Maas) , MIN(maas) TABLE Personel GROUP BY Departman_id Veya 38 nolu departmandaki personel sayısını bulalım; SELECT COUNT(*) TABLE Personel WHERE Departman_id = 38

1293

Veya tüm departmanlardaki maaşlarının ortalaması 80.000.000 ‘den büyük olanların listesini oluşturalım; SELECT Departman_id, AVG(Maas) TABLE Personel GROUP BY Departman_id HAVING AVG(maas) > 80000000 Bazı durumlarda iç içe grup oluşturulması istenebilir. Bu durumda şu şekilde yazılır. GROUP BY Kolon1, Kolon2 , … Örneğin Departman adına ve personel yasına göre grup oluşturalım. SELECT Departman_id, Yas TABLE Personel GROUP BY Departman_id, Yas Altsorgular(SUBQUERY) Subquery, bir sorgu oluşturulurken, bu sorguya ait kriterleri başka bir sorgu belirleme durumudur. Kısaca sonucu bilinmeyen koşullar olduğunda bu yöntem kullanılır. Yazılımı: SELECT ….. FROM …… WHERE kolon=( SELECT … FROM …. WHERE ….) Select cümlesi parantes içinde tanımlanır. = koşulu kondu ise select cümlesi tek değer döndürmek zorundadır. Eğer birden fazla değer için koşul konulması gerekirse " in, not in " kelimesi kullanılır. Tek kayıt döndüğünde = yerine >,>=, <, <=, <> kontrol ifadeleride kullanabiliriz. Bir önemli nokta da koşula eşitlenecek değer 2. Select cümlesi içindeki kolon değerine eş olmalıdır. Yani tipleri eşit olmalıdır. Subquery sorgulama tekniğinde order by kullanılamaz. Having grup kotulu içinde select cümlesi kullanabiliriz. Örneğin; 9. sorgu : Kazım' ın departman numarası kaçtır? 10. SELECT dept_id,name FROM Personel WHERE name='Kazım' 11. sorgu : Departman numarası 38 olan kişilerin listesinden adı kazım olan var mı incele? 12. SELECT dept_id,name FROM Personel WHERE dept_id=38 13. sorgu : Bu iki sorgunun birleşimi istenirse, yani departmanı 38 olan kazım adlı personel bigisi ? SELECT dept_id,name FROM Personel WHERE dept_id=( SELECT dept_id FROM Personel WHERE name='Kazım') Çalışma Anında Sorguya Dışarıdan Değer Alma Bir sorgu oluşturulurken bazen bazı alanların değerleri değişkendir. Bu yüzden sorguya dışarıdan değer girilmesi ve bu değere göre bir sorgu oluşturulması gerekir. Bunun için anahtar kelimenin başına ‘ & ‘ karakteri getirilir. Örneğin istenilen departmankoduna göre personelin adı ve soyadı listeleyelim; SELECT ad,soyad FROM Personel WHERE Dept_id = &Departman_kodu Ekran: Departman_kodu için değer gir: 38 eski 1: select ad,soyad from Personel where Dept_id = &Departman_kodu yeni 1: select ad,soyad from Personel where Dept_id = 38 1294

Eğer sorgu yazılımı sorunlu ise bu giriş yapıldıktan sonra anlaşılır ve kesinlikle girilen değer kolon tipine eş olmalıdır. Örneğin ‘&anahtar_kelime’ şeklinde tırnak arasında belirtilmişse giriş olarak sadece text değer girilir. Ama &anahtar_kelime tırnak içinde belirtilmemişse giriş yapılırken tırnak içinde giriş yapılmalıdır. Birden fazla &anahtar_kelime tanımlanırsa sırayla sorgu sorulur ve tüm değerler girildikten sonra sorgu oluşturulur. Eğer where koşulunda &anahtar_kelime’si kullanılmışsa giriş yapılırken matematiksel koşul şeklinde giriş yapabiliriz. Eğer anahtar kelimenin başına ‘ && ‘ konulursa sorgu sırasında sadece bir kerelik sorgu sorulur. Bundan sonra anahtar kelimenin değeri ilk girilen değer olarak geçerlidir. DEFINE değişken=değer : Belirtilen değişkene karakter atanır. ACCEPT : Kullanıcıya açıklayıcı mesaj verilerek istenilen tipte veri girişi yapılması sağlanır. & işaretiyle yapılan işlemin daha kontrollu şeklidir. Yazılımı : ACCEPT değişken [datatipi] [ FORMAT ] [PROMPT text] [HIDE] Değişken à Giriş yapılacak verinin değerinin tutulduğu anahtar kelimedir. Datatipi à Girişi yapılacak verinin veri tipidir. FORMAT à Giriş yapılacak verinin giriş düzeni sağlanır. Örneğin rakam için 9999 (4 haneli sayı) , karakter için A10 (10 karakterlik yer) . PROMPT à Kullanıcıya gireceği değer için açıklayıcı mesaj görüntüler. HIDE à Giriş yapılırken verinin görüntülernmeden giriş yapılması sağlanır. Örneğin şifre girişlerinde. Örnekler; ACCEPT adi PROMPT ‘Adınızı giriniz:’ ACCEPT yas NUMBER PROMPT ‘Yaşınızı giriniz:’ ACCEPT yil NUMBER FORMAT 9999 PROMPT ‘Bulunduğunuz yılı giriniz:’ ACCEPT sifre CHAR PROMPT ‘Tifrenizi giriniz:’ HIDE Örnek: Personel adına göre personel bilgilerini gösterelim. Bunun için bir .sql uzantılı dosyada yazalım. Bu programı start ile çalıştıralım. Ornek.sql SET ECHO OFF ACCEPT adi PROMPT ‘ Adınızı Giriniz:’ SELECT * FROM Personel WHERE UPPER(Personel.ad) LIKE UPPER(‘&adi’) / SET ECHO ON “Start Ornek.sql “ yazılarak sql çalıştırılır. Bazen parametre girişlerini daha başlangıçta vermek istenirse; Start Dosya_adı Parametreler,… Örneğin yukarıdaki örnek için Start Ornek Kazım Tabloların Yaratılması Database’de verilerin saklanması amacıyla tablolar yaratılır. Tablo yaratabilmek için o kullanıcının buna yetkisi olmalıdır. Aynı zamanda limitsiz tablespace hakkına sahip olmalıdır. Yazılımı : CREATE TABLE [kullanıcı.]table (kolon datatipi(boyutu) [DEFAULT değer] [CONSTRAINT constraint_name] constraint_type] [table_constraint] [PCTFREE integer] [PCTUSED integer] [TABLESPACE tablespace] [STORAGE storage_clause] [CACHE] [ENABLE enable_clause] [DISABLE disable_clause] [AS subquery] Kullanıcı à Tablonun yaratıcısıdır. Onun sahip olduğu haklara ve mekana sahiptir. Kolon à Tablonun kolon adlarını belirler. Bir tablodaki kolon sayısı 1-254 arasında olmalıdır. Datatipi à Bir kolonun veri tipini belirler. Varchar2(boyut): Boyut ile belirtilen max miktar kadar karakterdir.Max 1295

değeri 2000’dir. Char(boyut) : Boyut ile belirtilen max miktar kadar karakterdir.Max. değeri 255’dir. Number : e38 ‘e kadar olan tüm sayısal değerlerdir. Number(m,n) : m kadar (max e38) sayının n kadar ondalık alan için değer alır. Date : Tarih ve saat değerlerini bir tutar. Boolean : Mantıksal ifadeleri saklar. Yani doğru ise True, yanlış ise false. Long : Max 2GB ‘a kadar büyük olan alanlar için yer tutar. Raw : Grafiksel yapıdaki veriler için tanımlanır. DEFAULT à Herhangi bir kolona değer girilmezse, direkt olarak değer atamaya yarar. Girilen değerin veri tipi ile aynı olması gerekir. CONSTRAINT à O kolon için daha açıklayıcı olması açısından ve yapısı açısından kullanılır. table_constraint à O tablo için daha açıklayıcı olması açısından belirtilen etikettir. PCTFREE à Tablo üzerinde yapılan kayıt güncelleme işlemleri için, kayıt bloklarındaki ayrılacak rezervasyon yüzde değeridir. 1-99 arasında bir tamsayıdır. 0, tüm bloklara yeni kayıt girişine izin verilir. Varsayılan değer 10’dur. Yani güncelleme için her bloğun %10’unu rezerve eder. Geri kalan %90’nını ise yeni kayıt girişlerine ayırır. PCTUSED à Tablonun her veri bloğu için Oracle’nin koruduğu, kullanılmış alanın min yüzdesini verir. 1-99 arasında bir tamsayıdır.Varsayılan değeri 40’dır. Verilen parametre değerinin altına düşek blok için, yeni kayıt girişi seçimliktir. PCTFREE+PCTUSED <100 olmak zorundadır. TABLESPACEà Oracle’ın tabloyu yaratacağı tablo boşluğunu belirler. Eğer tanımlanmazsa çalışılmakta olan kullanıcının tablo boşluğunda yaratılır. STORAGE à Tablonun depolama karakteristiğini belirler. Büyük tablolarda perfonmans düzenleyici olarak kullanılır. CACHE à Tablo üzerinde arama yapılırken, hafıza cache’nin en çok kullanılanlar üzerinde yer almasını sağlar. ENABLE à Bütün sınırlamaları geçerli kılar. DISABLE à Bütün sınırlamaları iptal eder. AS query à Tablo yaratılırken, alt sorgu aracılığı ile geriye döndürülen satırlar tabloya yerlettirilir.(insert) Data Dictionary Database ile ilgili her türlü bilgiyi buraya atar. Buradan verilere ulaşabiliriz. Kullanıcılar, tablolar, indexler, constraintsler vb. birçok açıklayıcı bilgiler tutulur. Bütün tablo ve viewerların adlarını ve açıklamalarını görnek için ; SELECT * FROM Dictionary; Dictionary’nin yapısını görmek için; DESC dictionary İsim Tip -------------------- -------------------------TABLE_NAME VARCHAR2(30) COMMENTS VARCHAR2(2000) Dictionary’de bulunan objelerden bazıları; User_tables à Hangi kullanıcı ile login olundu ise o kullanıcıya ait tabloları listeler. All_tables à Bütün kullanıcıların yarattığı tabloları listeler. Dba_tables à Database ile ilgili her türlü tablolar listelenir. V$_tables à Systemin performansını ölçmek için tutulan bilgilerdir. V$_librarycacheà Cache’in yeterli olup olmadığını anlamak için bakılır. V$_rollstat à Rollback segmentinin yeterli olup olmadığını anlamak için bakılır. Örnek : Login sifresiyle giren kullanıcının yarattığı tabloların listesini alalım; SELECT table_name FROM user_tables Örnek: Tüm obje isimlerinin listesini alalım; SELECT object_name FROM user_objects Database Üzerinde Transaction Kontrol Komutlar ı

1296

Transaction, datanın tutarlı şekilde korunmasını sağlayan yöntemdir. Database üzerinde kayıt yapma , silme, düzeltme vb. işlemlerin yapılabilmesi için aşağıdaki komutlara ihtiyaç vardır; INSERT INTO : Tabloya yeni bir kayıt eklenmesini sağlar. Yazılımı; INSERT INTO table [(kolon1, kolon2, …)] VALUES (değer1, değer2, …) Kolon à Tablonun kayıt yapılacağı kolon adlarını belirler. Bir tablodaki kolon sayısı 1-254 arasında ve o tabloda var olmalıdır. Değer à O kolon için alacağı değer verilir. Kolon tipiyle aynı olmalıdır. Eğer kolon adları belirtilmezse değerler kolon sırasına göre değer almalıdır. Değerlere sysdate, user vb. hazır fonksiyonlar aktarılabilir. Eğer bir alana değer verilmesi istenmiyorsa, yani boş değer verilmesi isteniyorsa NULL değeri verilir. Örnek: Personel tablosuna yeni bir personel giriti yapalım; INSERT INTO personel (ad,soyad,maas,ayrilma_tarihi,kayit_giris_tarihi) VALUES (‘Kazım’,’Sarıkaya’,400000000,NULL,SYSDATE) Aynı örnek için kolon sırasını bildiğimiz düsünülürse şu şekildede yazılabilir; INSERT INTO personel VALUES (‘Kazım’,’Sarıkaya’,400000000,NULL,SYSDATE) Sadece tek kayıt girişi yapılıyorsa, rahat veri girişi yapılması için değerlere değişken tanımlayarak veri girişi sağlayabiliriz. Böylece table her çalıştığında yeni veri girişi yapılır. Örnek: Personel tablosuna her çalıştırdığımızda yeni bir personel girişi yapalım; INSERT INTO personel (ad,soyad,maas,ayrilma_tarihi,kayit_giris_tarihi) VALUES (‘&Adi’,’&Soyadi’,&maas,NULL,SYSDATE) Örnek: Daha güvenli ve rahat giriş yapılacak şekilde kayıt yapılacak script yazalim; SET ECHO OFF ACCEPT ad PROMPT ‘Adını giriniz:’ ACCEPT soyad PROMPT ‘Soyadı giriniz:’ ACCEPT maas PROMPT ‘Maaşını giriniz:’ INSERT INTO personel(ad,soyad,maas,ayrilma_tarihi,kayit_giris_tarihi) VALUES (‘&ad’,’&soyad’,&maas,NULL,SYSDATE) / SET ECHO OFF Kayıt yapılacak kolonların değerleri bilinmiyorsa veya başka bir tablodan değer alınması gerekiyorsa aşağıdaki yapı kullanılır; Yazılımı; INSERT INTO table [(kolon1, kolon2, …)] Altsorgu Örnek: Personel tablosuna departman tablosundan departman kodu 38 olan personellerin değerlerini aktaralım; INSERT INTO personel(ad,soyad,maas,ayrilma_tarihi,kayit_giris_tarihi) SELECT adi,soyadi,maasi,ayrilma,kayit_giris FROM departman WHERE dept_id=38 UPDATE : Tablodaki kolonların değerlerini değiştirmek için kullanılır. Yazılımı; UPDATE table SET kolon1=değer1, kolon2=değer2, … [WHERE kotul] Kolon à Tabloda değişiklik yapılacak kolon adıdır. Bir tablodaki kolon sayısı 1-254 arasında ve o tabloda var olmalıdır. Değer à O kolon için alacağı değer verilir. Kolon tipiyle aynı olmalıdır. Eğer kolon adları belirtilmezse değerler kolon sırasına göre değer almalıdır. Değerlere sysdate, user vb. hazır fonksiyonlar aktarılabilir. Eğer bir alana değer verilmesi istenmiyorsa, yani boş değer verilmesi isteniyorsa NULL değeri verilir. Örnek: 41 nolu departmanın maaşını %13 artıralım; UPDATE Personel SET maas=maas+maas*13/100 WHERE dept_id=41 Örnek: 649 nolu personelin departman kodu 10 olsun; 1297

UPDATE Personel SET dept_id=10 WHERE personel_id=649 Eğer WHERE koşulu konulmazsa tüm tablo için kolon değerini değiştirir. Koşulu SET ile değiştirdiğimiz kolona veremeyiz. DELETE : Tabloda belirtilen kayıdı siler. Yazılımı; DELETE FROM table [WHERE kotul] Örnek : Personelin maaşları 100.000.000 ‘dan küçük olan kayıtları silelim; DELETE FROM Personel WHERE maas<100000000 Bir tablodaki tüm kayıtları silmek istersek koşul konmaz. Tablo silinmez, sadece kayıtları silinir. Örneğin DELETE FROM Personel Foreign key veya primary key silinecek kayıtda varsa silinme hatası verir. Çünkü başka tablo ile ilişki kurulduğundan(join), diğer tablonun kullandığı kayıt vardır. O yüzden bu kaydı silebilmek için, ilişkide bulunduğu tüm kayıtları önce silmek gerekir. Aynı zamanda tablo üzerinde çalışan kullanıcı varsa kayıtlar silinemez. ROLLBACK komutu ile silinen kayıtları kurtarabiliriz(Tabi ki en son COMMIT komutu kullanılana kadar). COMMIT : Bütün yapılan işlemleri kesin olarak kalıcı olmasını sağlar. Böylece yapılan değişiklikleri varsa diğer kullanıcılarda görür. SAVEPOINT x : İşlemi belirli bir yere yönlendirmek için kullanılır. X ile belirtilen alan için işaret konularak istenildiğinde bu işarete kadar işlemler yapılabilir. ROLLBACK x : Bütün yapılan işlemleri kesin olarak iptal eder. SAVEPOINT komutu ile belirlenen x kodlu alana kadar olan tüm itleri iptal eder. Yazılımı; ROLLBACK [TO SAVEPOINT x] Örnek: UPDATE personel ….. SAVEPOINT dön DELETE FROM Personel INSERT INTO ….. ROLLBACK dön teklindeki bir itlemle personel kaydının silinmesi ve yeni kayıt eklenmesi işlemi iptal edildi. Ama ilk yapılan değişiklik kaldı. Read uncommitted à Commit olmadan görünmez. O halde böyle level yoktur. Read committed à Oracle’ın varsayılan değeridir. Committen sonra işlem görür. Serializable à Yapılan insert işlemleri gözükmez. Eski datalar gözükür. Read only à Transaction itleminde sadece okuma var demektir. ALTER TABLE : Yeni bir kolon eklemek, kolonun tipini veya uzunluğunu değiştirmek vb. yapısal değişiklikler yapılması için kullanılır. Eğer kolon üzerinde değişiklikler yapılacaksa dikkat edilmesi gereken koşullar vardır. Örneğin kayıt uzunluğu 15 iken uzunluğunu 10’a indirirsek kayıt içindeki bilgiler kesilir. Kolonlar ekleyebilir ve yapısal değişiklikler yapabiliriz. Constraint yapısını ekler, silebilir, enable ve disable yapabiliriz. Yazılımı; ALTER TABLE table [ADD (kolon datatipi [DEFAULT değer] [NOT NULL]) , …] [ADD [CONSTRAINT açıklama] tipi (kolon)] [MODIFY (kolon datatipi [DEFAULT değer] [NOT NULL]) , …] [DROP [CONSTRAINT açıklama] tipi (kolon)] [ENABLE | DISABLE CONSTRAINT açıklama] ADD à Yeni bir kolon ekler. MODIFY à Kolonun içeriğini, uzunluğunu ve tipini değiştirir. Bunun için kayıtların değeri null olmalıdır. DROP à Kolonu siler. Kolon à Tabloda itlem yapılacak kolon adıdır. 1298

Datatipi à Kolonun alacağı tipi belirler. DEFAULT değerà Kolonun ilk alacağı değerdir. Kolon hiç değer atanmaz ise burada değer ile ifade edilen sabit veri aktarılır. ENABLE à Unique veya primary key indexlerin otomatik yaratılmasını sağlar. Bütün kayıtların tanımlanan unique veya primary key tanımına uyması gerekir. DISABLE à Unique veya primary key tanımını kaldırır. Örnek : Personel tablosuna ek maas isminde 15 uzunluğunda bir kolon yaratalım. İlk değer 0 olsun. ALTER TABLE Personel ADD (ekmaas number(15) DEFAULT 15) Örnek : Personel tablosundaki pers_id ile departman tablosundaki dept_id arasında FOREIGN KEY kuralım. ALTER TABLE Personel ADD CONSTRAINT personel_dept_id_fk FOREIGN KEY (dept_id) REFERENCES personel(pers_id) Örnek : Personel tablosundaki maas kolonundaki alan uzunluğunu 15’e çıkaralım. ALTER TABLE Personel MODIFY (maas number(15)) Örnek : Personel tablosundaki maas kolonu silinsin. ALTER TABLE Personel DROP (maas number(15)) Örnek: Personel tablosundaki personel_id primary key için index yaratılması otomatikleştirelim; ALTER TABLE Personel ENABLE CONSTRAINT Personel_id_pk DROP TABLE : Tabloyu fiziksel olarak siler. Rollback komutu ile silinen tablo geri getirilemez. Tabloyu ancak yetkisi olan kullanıcı silebilir. Yazılımı; DROP TABLE table [CASCADE CONSTRAINTS] Örnek: Personel tablosunu silelim; DROP TABLE Personel RENAME ..TO.. : Objelerin ismini değiştirmek için kullanılır. Otomatik olarak commit olur. Tabloyu ancak yetkisi olan kullanıcı silebilir. Yazılımı; RENAME eski_isim TO yeni_isim Örnek: Personel tablosunun adını pers olarak değiştirelim; RENAME personel TO pers TRUNCATE TABLE : Tablodaki tüm kayıtları siler. Delete komutu gibi olmasına karşın o komuttan çok daha hızlı silme işlemi yapar. Rollback komutu ile silinen kayıtlar geri getirilemez. Otomatik olarak commit olur. Tabloyu ancak yetkisi olan kullanıcı silebilir. Yazılımı; TRUNCATE TABLE table Delete komutu ile Truncate arasındaki en önemli fark; Delete komutu kayıtları silmek için kayıtlarda boşluk bırakır. Truncate ise tamamen kayıtları temizler, yani başa sarar. Örnek: Personel tablosundaki tüm kayıtları silelim; TRUNCATE TABLE Personel COMMENT ON TABLE : Tablo veya kolonların içeriği hakkında açıklayıcı bilgi verilir. 2000 byte açıklama alanı girilebilir. Yazılımı; COMMENT ON TABLE table | COLUMN table.kolon IS ‘açıklama’ Örnek : Personel tablosu açıklaması ‘Başak Sigorta’da çalışan kişiler’ olarak not düşelim; COMMENT ON TABLE personel IS ‘Başak Sigorta’da çalışan kişiler’ Örnek : Personel tablosundaki pers_id kolonun açıklaması ‘Personel numarası’ olarak not düşelim; 1299

COMMENT ON COLUMN personel.pers_id IS ‘Personel numarası’ ALL_COL_COMMENTS à Yetkili olan kullanıcının kolonlarının açıklayıcı notları listelenir. USER_COL_COMMENTS à Tüm kullanıcıların kolonlarının açıklayıcı notları listelenir. ALL_TAB_COMMENTS à Tüm kullanıcıların tablolarının açıklayıcı notları listelenir. USER_TAB_COMMENTS à Yetkili olan kullanıcının tabloları için açıklayıcı notları listelenir. Otomatik Numara Üretimi(Sequence) Yaptığı iş unique sayılar üretmektir. Belli oranlarda arttırmalar yapılmakta kullanılır. Her çağrıldığında yeni bir sayı üretir. Extra bir hesaplama yapılmadan, seri olarak tanımlandığı şekilde rakamlar üretir. Sayıları cacheden okuduğu için çok hızlı sonuç üretir. Yazılımı; CREATE SEQUENCE kolon [INCREMENT BY n] [START WITH n] [MAXVALUE n | NOMAXVALUE] [MINVALUE n | NOMINVALUE] [CYCLE | NOCYCLE] [CACHE n | NOCACHE] INCREMENT BY n à Sayının artış miktarı belirtilir. Varsayılan değer 1’dir. Birer birer sayı arttırılır. START WITH n à Numaranın üretileceği başlangıç numarasıdır. Varsayılan değer 1’dir. MAXVALUE n à Numaranın alabileceği maksimum rakam yazılır. NOMAXVALUE ile bitiş numarası verilmez. Max = 1027 MINVALUE n à Numaranın alabileceği minimum rakam yazılır. NOMINVALUE ile başlangıç numarası verilmez. Min = 1 CYCLE | NOCYCLE à Maxvalue değeri kadar işlem yapıldıktan sonra işlemi tekrardan başlatır.Varsayılan değer NOCYCLE’dır. CACHE à Cache sayısı kadar sayıyı hafızaya gönderir. Varsayılan değer NOCACHE=20’dir. Örnek: Personel departmanının pers_id kolonunu 10’dan 50’ye kadar 2’şer 2’şer arttıralım; CREATE SEQUENCE pers_id INCREMENT BY 2 START WITH 10 MAXVALUE 50 NOCYCLE NOCACHE Örnek: Personel departmanının pers_id kolonunu birer birer arttıralım; CREATE SEQUENCE pers_id INCREMENT BY 1 START WITH 1 NOMAXVALUE NOCYCLE NOCACHE USER_SEQUENCES : Sequences’in en son durumu gösterir. Yazılımı; SELECT sequence_name, min_value, max_value, increment by, last_number FROM user_ sequences Sequence_name à İşlemlerin tanımlandığı isimdir. Min_value à Sayının aldığı min değerdir. Max_value à Sayının aldığı max değerdir. Increment_by à Sayının aldığı artış miktarının gösterir. Cycle_flag à İşlemin tekrar yapılması isteniyorsa Y, istenmiyorsa N değerini alır. Cache_size à Hazıfazadaki cache sayısıdır. Last_number à Numaranın alacağı değerdir NEXTVAL : En son aldığı sayının bir sonra alacağı değeri gösterir. Örnek: Personel tablosuna pers_id kolonuna otomatik değerler tayarak kayıt edelim; INSERT INTO personel 1300

VALUES (pers_id.NEXTVAL,’Kazım’,’Sarıkaya’) CURRVAL : O anki sayısal değeri gösterir. Eğer hiç nextval fonksiyonu kullanılmamışsa değeri boş değer gelir. Örnek: pers_id kolonunun o anki alacağı değeri seçelim; SELECT pers_id.CURRVAL FROM DUAL ALTER_SEQUENCE : Değişiklik bir yerden başlanacaksa önce drop edilir, sequence işlemini değiştirir. Yazılımı; ALTER SEQUENCE kolon [INCREMENT BY n] [MAXVALUE n | NOMAXVALUE] [MINVALUE n | NOMINVALUE] [CYCLE | NOCYCLE] [CACHE n | NOCACHE] DROP_SEQUENCE : Kolon için yaratılan işlemleri siler. Yazılımı; DROP SEQUENCE kolon View Bir tablo üzerinde sorgulama yapılması için kullanılan nesnedir. Fiziksel olarak herhangi bir yerde saklanmaz. Avantajları; · Database erişimini kısıtlar. Böylece sadece sorgulanan verileri gözükür. · Sorgulamaları kolaylaştırabilir. · Datayı bağımsız olarak gösterebiliriz. Yazılımı; CREATE [OR REPLACE] [FORCE | NOFORCE] VIEW view_adi [alias] AS subquery [WITH CHECK OPTION [CONSTRAINT constraint]] [WITH READ ONLY] FORCE à Hata durumu oluşursa gözardı ettirilir. NOFORCE ise gözardı edilmez. View_adi à Yaratılan view sorgu adıdır.. Alias à Yaratılan işlemin adıdır. WITH CHECK OPTION [CONSTRAINT à View objesine hatalı işleme yapılmasını engeller. Örnek: Departman numarası 41 olan peroneller için perview isminde bir view olşturalım; CREATE VIEW persview AS SELECT * FROM personel WHERE dept_id=41 WITH CHECK OPTION CONSTRAINT empview_ck; Departman id’si 16 olan personellerin departman numarasını 38 yapalım; UPDATE persview SET dept_id=38 WHERE id=16; Bu durumda bu değişiklik tabiki yapılamaz. WITH READ ONLY à View objesinin sadece okuma amaçlı olduğu belirtilir. Farklı bir işlem yapıldığında bunu engeller. Aslında kayıtlar üzerinde değişiklik yapılmasını engeller. Örnek: Departman numarası 45 olan peroneller için perview isminde bir view olşturalım; CREATE VIEW persview AS SELECT * FROM personel WHERE dept_id=41 WITH READ ONLY; Departman id’si 10 olan personellerin silinmesini sağlayalım; DELETE FROM persview 1301

WHERE id=10; Bu durumda işlemi keser ve uyarı verir. USER_VIEWS : Data dictionary tablosunda view tanımları bulunur. View adı, text uzunluğu ve text’I saklar. VİEW_NAME à Kullanıcıya ait view adlarının tutar. TEXT_LENGTH à Sql ifadenin uzunluğudur. TEXT à Sql ifadedir. DROP VİEW : Yaratılan view objesini siler. Yazılımı; DROP VIEW view_adı INDEX YARATMA Indexler, bir tablonun istenilen kolonlarına daha hızlı erişim olanağı sağlamak için kullanılır. Tablodaki kayıtlar üzerinde giriş/çıkış işlemleri yapılırken dataya daha hızlı ulaşılması sağlanır. Primary key tanımlanan kolonlar için otomatik olarak index yaratılır. Index en fazla 16 kolondan oluşur. Bir kolon tipi long veya long raw olamaz. Yazılımı; CREATE INDEX index_adi ON tablo_adı(kolonlar) Örnek: Personelin adına ve soyadına göre index oluşturalım; CREATE INDEX personel_inx ON personel(ad,soyad); Böylece ad kolonu öncelikli olmak kaydıyla birlikte soyadına göre sıralama yapar, yani index oluşturur. Önce ada göre sıralar, eğer aynı isimden birden fazla kayıt oluşursa bu sefer soyad kolonundaki değerlere göre sıralama oluşturur. Index yaratabilmek için; · Index yaratılacak tablonun var olması gereklidir, · Index yaratma hakkına sahip olmalıdır, · Limitsiz tablespace hakkına sahip olmalıdır. Index yaratılma ihtiyacı aşağıdaki koşullar oluştuğunda belirir; · Where ifadesi ile sık sık kullanılan kolonlar kullanılıyorsa, · Join ile birleştirme işlemi yapıldığında, · Kolon değerleri geniş aralıkta ise, · Büyük rakamlı kolonların içinde null değerler bulunuyorsa. Index yaratılmama ihtiyacı aşağıdaki koşullar oluştuğunda belirir; · Tablo küçük ise, · Tablodaki bazı kolonlara sık sık ihtiyaç duyulmadığında, · Tabloda sık sık değişiklikler yapılıyorsa. USER_INDEXES à İndex isimlerini ve unique olup olmadığı bilgilerini saklar. Örnek: Personel tablosuna ait index dosyalarını listeleyelim; SELECT ic.index_name,ic.column_name,ic.colum_position,ix.uniqueness FROM user_indexes ix, user_ind_columns ic WHERE ic.index_name=ix.index_name AND table_name=’Personel’; DROP INDEX à Yaratılan indexleri veri tabanından yok etmek için kullanılır. DATABASE GÜVENLİĞİ Database güvenliği için kullanıcılar tanımlanır. Her kullanıcının bir şifresi bulunur. Kullanıcılara belirli yetkiler verilir. Sistem ve data güvenliği olmak üzere iki kısımda incelenir. Sistem güvenliği içinde kullanıcıya yaratma, değiştirme, silme vb. yetkiler tanımlanır. Data güvenliği için ise datalar başka bir ortama yedekleme(backup) yapılarak sağlanır. Database level aşamaları ile güvenlik sınırlanır. Eğer yüksel level yetkisi varsa yeni kullanıcı(veya tablolar) yaratabilir veya silinebilir. Tabloların yedekleri alınabilir. CREATE USER à Database üzerinde işlemler yapılabilmesi için kulanıcı yaratılır. Yazılımı; 1302

CREATE USER user_adı IDENTIFIED BY tifre DROP USER à Databaseden kullanıcıyı siler. Yazılımı; DROP USER user_adı GRANT (Yetki) à Kullanıcıya yetki verilmesi için kullanılır. Yazılımı; GRANT yetkiler_roller TO kullanıcı [PUBLIC] [WITH GRANT OPTION] [PUBLIC] WITH GRANT OPTION à Sistem haklarını veya rollerini diğer kullanıcılara vermeyi sağlar. Bir rolü bu şekilde belirlersek kullanıcı rolleri değiştirebilir veya silebilir. PUBLIC à Sistem haklarını veya rollerini tüm kullanıcılara vermeyi sağlar. Örnek: Personel tablosunun pers_id,ad kolonlarına webserver kullanıcısı için düzeltme yetkisi verelim; GRANT select(pers_id,ad) ON Personel TO webserver Örnek: Personel tablosuna webserver kullanıcısı için seçme yetkisi verelim; GRANT select ON Personel TO webserver Örnek: Kazım kullanıcısı, webserver kullanıcısının personel tablosu için kayıt etme ve sorgulama yetkilerini verelim; GRANT select,insert ON personel TO webserver WITH GRANT OPTION Örnek: Kazım kullanıcısının personel tablosunu tüm kullanıcılara sorugulama yapabilmesini sağlayalım; GRANT select ON kazim.personel TO PUBLIC Grant yetkisi ile kullanıcılara aşağıdaki tablodaki yetkiler verilebilir Objeler Table View Sequences Procedure ALTER ? ? DELETE ? ? EXECUTE ? INDEX ? INSERT ? ? REFERENCE ? S SELECT ? ? ? UPDATE ? ? CREATE ROLE à Kullanıcıya yetki olarak verilen rollerdir. Yazılımı; CREATE ROLE rol; Örnek: CREATE ROLE Manager; GRANT create table, create view TO Manager; GRANT Manager TO webserver; Manager isminde rol tanımlandı. Tablo ve view yaratma yetkisi verildi. Bu yetkiler Webserver isminde kullanıcıya aktarıldı. Kullanıcının şifresini değiştirmek için; 1303

ALTER USER user_adı IDENTIFIED BY şifre REVOKE à Verilen rolleri geri alır. Yazılımı; REVOKE rol ON tablo FROM kullanıcı Örnek: webserver kullanıcısının şifre tablosuna kayıt etme,düzeltme ve sorgulama yetkilerini kaldıralım, REVOKE select,insert,update ON tifre FROM webserver CREATE SYNONYM à Bir objenin aynısının kopyasının alarak kendi userında yaratır. Yazılımı; CREATE [PUBLIC ] SYNONYM obje_adı FOR kullanıcı.obje PUBLIC à Tüm kullanıcıların yetkilerini alır. Örnek: Webserver’ın personel tablosunun aynısını kendi alanımızda yaratalım CREATE SYNONYM personel FOR webserver.personel DROP SYNONYM à Bir objenin aynısının kopyasının alarak yaratılan objeyi siler. Yazılımı; DROP [PUBLIC ] SYNONYM obje_adı ADVANCED SQL IN à Liste içinde belirlenen değerlerdir. NOT IN à Liste içinde olmayan tüm değerlerdir. ANY à Alt sorgulamadan seçilen değerlerden en az biri karşılaştırılır. ALL à Alt sorgulamadan seçilen değerlerden hepsi karşılaştırılır. Kazım SARIKAYA'ya

1304

Example 1: Add a validity check to the specified field. The field must be a longint, and the TTable must be open. This example uses the following input: fDbiDoRestructure(Table4, Table4.Fields[0], @Min, @Max, nil, True); (This input works for the EMPLOYEE.DB table.) procedure fDbiDoRestructure(Tbl: TTable; Field: TField; MinVal, MaxVal, DefVal: pLongint; Required: Boolean); var hDb: hDbiDb; TblDesc: CRTblDesc; VChk: pVChkDesc; Dir: string; NumVChks: Word; OpType: CROpType; begin NumVChks := 0; SetLength(Dir, dbiMaxNameLen + 1); Check(DbiGetDirectory(Tbl.DBHandle, False, PChar(Dir))); SetLength(Dir, StrLen(PChar(Dir))); VChk := AllocMem(sizeof(VChkDesc)); try FillChar(TblDesc, sizeof(CRTblDesc), #0); VChk.iFldNum := Field.Index + 1; Tbl.DisableControls; Tbl.Close; Check(DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil , nil, hDb)); Check(DbiSetDirectory(hDb, PChar(Dir))); with VChk^ do begin bRequired := Required; if (MinVal <> nil) then begin Inc(NumVChks); bHasMinVal := True; move(MinVal^, aMinVal, sizeof(MinVal^)); end else bHasMinVal := False; if (MaxVal <> nil) then begin Inc(NumVChks); bHasMaxVal := True; move(MaxVal^, aMaxVal, sizeof(MaxVal^)); end else bHasMaxVal := False; if (DefVal <> nil) then begin Inc(NumVChks); bHasDefVal := True; 1305

move(DefVal^, aDefVal, sizeof(DefVal^)); end else bHasDefVal := False; end; TblDesc.iValChkCount := NumVChks; TblDesc.pVChkDesc := VChk; OpType := crADD; TblDesc.pecrValChkOp := @OpType; StrPCopy(TblDesc.szTblName, Tbl.TableName); StrCopy(TblDesc.szTblType, szParadox); Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False)); finally Check(DbiCloseDatabase(hDb)); FreeMem(VChk, sizeof(VChkDesc)); Tbl.EnableControls; Tbl.Open; end; end; Example 2: Pack a Paradox (with DbiDoRestructure) or dBASE table. This example will pack a Paradox or dBASE table therefore removing already deleted rows in a table. This function will also regenerate all out-of-date indexes (maintained indexes). This example uses the following input: PackTable(Table1) The function is defined as follows: // Pack a Paradox or dBASE table // The table must be opened execlusively before calling this function... procedure PackTable(Table: TTable); var Props: CURProps; hDb: hDBIDb; TableDesc: CRTblDesc; begin // Make sure the table is open exclusively so we can get the db handle... if not Table.Active then raise EDatabaseError.Create('Table must be opened to pack'); if not Table.Exclusive then raise EDatabaseError.Create('Table must be opened exclusively to pack'); // Get the table properties to determine table type... Check(DbiGetCursorProps(Table.Handle, Props)); // If the table is a Paradox table, you must call DbiDoRestructure... if (Props.szTableType = szPARADOX) then begin // Blank out the structure... FillChar(TableDesc, sizeof(TableDesc), 0); 1306

// Get the database handle from the table's cursor handle... Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb))); // Put the table name in the table descriptor... StrPCopy(TableDesc.szTblName, Table.TableName); // Put the table type in the table descriptor... StrPCopy(TableDesc.szTblType, Props.szTableType); // Set the Pack option in the table descriptor to TRUE... TableDesc.bPack := True; // Close the table so the restructure can complete... Table.Close; // Call DbiDoRestructure... Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False)); end else // If the table is a dBASE table, simply call DbiPackTable... if (Props.szTableType = szDBASE) then Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, szDBASE, True)) else // Pack only works on PAradox or dBASE; nothing else... raise EDatabaseError.Create('Table must be either of Paradox or dBASE ' + 'type to pack'); Table.Open; end;

Example 3: Alter a field in a Paradox or dBASE table. This example will alter an existing field in a Paradox or dBASE table. NOTE: You must fill in all options in the ChangeRec with 0 or '' if the option is not used in the restructure. FillChar can be used to do this: Fillchar(MyChangeRec, sizeof(MyChangeRec), 0); This example uses the following input: ChangeField(Table1, Table1.FieldByName('FOO'), MyChangeRec) ChangeRec is defined as follows: type ChangeRec = packed record szName: DBINAME; iType: Word; iSubType: Word; iLength: Word; iPrecision: Byte; end; 1307

The function is defined as follows: procedure ChangeField(Table: TTable; Field: TField; Rec: ChangeRec); var Props: CURProps; hDb: hDBIDb; TableDesc: CRTblDesc; pFields: pFLDDesc; pOp: pCROpType; B: Byte; begin // Initialize the pointers... pFields := nil; pOp := nil; // Make sure the table is open exclusively so we can get the db handle... if not Table.Active then raise EDatabaseError.Create('Table must be opened to restructure'); if not Table.Exclusive then raise EDatabaseError.Create('Table must be opened exclusively' + 'to restructure'); Check(DbiSetProp(hDBIObj(Table.Handle), curxltMODE, Integer(xltNONE))); // Get the table properties to determine table type... Check(DbiGetCursorProps(Table.Handle, Props)); // Make sure the table is either Paradox or dBASE... if (Props.szTableType <> szPARADOX) and (Props.szTableType <> szDBASE) then raise EDatabaseError.Create('Field altering can only occur on Paradox' + ' or dBASE tables'); // Allocate memory for the field descriptor... pFields := AllocMem(Table.FieldCount * sizeof(FLDDesc)); // Allocate memory for the operation descriptor... pOp := AllocMem(Table.FieldCount * sizeof(CROpType)); try // Set the pointer to the index in the operation descriptor to put // crMODIFY (This means a modification to the record is going to happen)... Inc(pOp, Field.Index); pOp^ := crMODIFY; Dec(pOp, Field.Index); // Fill the field descriptor with the existing field information... Check(DbiGetFieldDescs(Table.Handle, pFields)); // Set the pointer to the index in the field descriptor to make the // midifications to the field Inc(pFields, Field.Index); // If the szName portion of the ChangeRec has something in it, change it... if (Length(Rec.szName) > 0) then pFields^.szName := Rec.szName; // If the iType portion of the ChangeRec has something in it, change it... if (Rec.iType > 0) then pFields^.iFldType := Rec.iType; 1308

// If the iSubType portion of the ChangeRec has something in it, change it... if (Rec.iSubType > 0) then pFields^.iSubType := Rec.iSubType; // If the iLength portion of the ChangeRec has something in it, change it... if (Rec.iLength > 0) then pFields^.iUnits1 := Rec.iLength; // If the iPrecision portion of the ChangeRec has something // in it, change it... if (Rec.iPrecision > 0) then pFields^.iUnits2 := Rec.iPrecision; Dec(pFields, Field.Index); for B := 1 to Table.FieldCount do begin pFields^.iFldNum := B; Inc(pFields, 1); end; Dec(pFields, Table.FieldCount); // Blank out the structure... FillChar(TableDesc, sizeof(TableDesc), #0); // Get the database handle from the table's cursor handle... Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb))); // Put the table name in the table descriptor... StrPCopy(TableDesc.szTblName, Table.TableName); // Put the table type in the table descriptor... StrPCopy(TableDesc.szTblType, Props.szTableType); // The following three lines are necessary when doing any field restructure // operations on a table... // Set the field count for the table TableDesc.iFldCount := Table.FieldCount; // Link the operation descriptor to the table descriptor... TableDesc.pecrFldOp := pOp; // Link the field descriptor to the table descriptor... TableDesc.pFldDesc := pFields; // Close the table so the restructure can complete... Table.Close; // Call DbiDoRestructure... Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False)); finally if (pFields <> nil) then FreeMem(pFields); if (pOp <> nil) then FreeMem(pOp); end; end; Example 4: Add a master password to a Paradox table. This example uses the following input: 1309

AddMasterPassword(Table1, 'MyNewPassword') The procedure is: procedure AddMasterPassword(Table: TTable; pswd: string); const RESTRUCTURE_TRUE = WordBool(1); var TblDesc: CRTblDesc; hDb: hDBIDb; begin { Make sure that the table is opened and is exclusive } if not Table.Active or not Table.Exclusive then raise EDatabaseError.Create('Table must be opened in exclusive ' + 'mode to add passwords'); { Initialize the table descriptor } FillChar(TblDesc, SizeOf(CRTblDesc), #0); with TblDesc do begin { Place the table name in descriptor } StrPCopy(szTblName, Table.TableName); { Place the table type in descriptor } StrCopy(szTblType, szPARADOX); { Master Password, Password } StrPCopy(szPassword, pswd); { Set bProtected to True } bProtected := RESTRUCTURE_TRUE; end; { Get the database handle from the cursor handle } Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb))); { Close the table } Table.Close; { Add the master password to the Paradox table } Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False)); { Add the new password to the session } Session.AddPassword(pswd); { Re-Open the table } Table.Open; end;

Create a table with a different level, block size, and fill factor than specified in the BDE configuration. Most Delphi users should use TTable.CreateTable. This example uses the following input: fDbiCreateTable(Database1.Handle, 'TableChange', 3, @FDesc, 7, 32768, 95); procedure fDbiCreateTable(hTmpDb: hDBIDb; TableName: String; Fields: Word; pFlds: pFLDDesc; Level, BlockSize, FillFactor: Word); 1310

var pOptDesc, pOrigDesc: pFLDDesc; pOptData, pOrigData: pBYTE; TblDesc: CRTblDesc; sLevel, sBlockSize, sFillFactor: String; begin pOptDesc := AllocMem(3 * sizeof(FLDDesc)); pOrigDesc := pOptDesc; pOptData := AllocMem(20); pOrigData := pOptData; try sLevel := IntToStr(Level); sBlockSize := IntToStr(BlockSize); sFillFactor := IntToStr(FIllFactor); // Set up first parameter pOptDesc.iOffset := 0; pOptDesc.iLen := Length(sLevel) + 1; StrPCopy(pOptDesc.szName, 'LEVEL'); StrPCopy(PChar(pOptData), sLevel); Inc(pOptData, Length(sLevel) + 1); Inc(pOptDesc); // Set up second parameter pOptDesc.iOffset := Length(sLevel) + 1; pOptDesc.iLen := Length(sLevel) + 1 + Length(sBlockSize) + 1; StrPCopy(pOptDesc.szName, 'BLOCK SIZE'); StrPCopy(PChar(pOptData), sBlockSize); Inc(pOptData, Length(sBlockSize) + 1); Inc(pOptDesc); // Set up third parameter pOptDesc.iOffset := Length(sLevel) + 1 + Length(sBlockSize) + 1; pOptDesc.iLen := Length(sLevel) + 1 + Length(sBlockSize) + 1 + Length(sFillFactor) + 1; StrPCopy(pOptDesc.szName, 'FILL FACTOR'); StrPCopy(PChar(pOptData), sFillFactor); // Format the table descriptor FillChar(TblDesc, sizeof(TblDesc), #0); StrPCopy(TblDesc.szTblName, TableName); StrCopy(TblDesc.szTblType, szPARADOX); TblDesc.iOptParams := 3; TblDesc.pFldOptParams := pOrigDesc; TblDesc.pOptData := pOrigData; TblDesc.iFldCount := Fields; TblDesc.pFldDesc := pFlds; // Create the table Check(DbiCreateTable(hTmpDb, True, TblDesc)); finally FreeMem(pOrigDesc, 3 * sizeof(FLDDesc)); FreeMem(pOrigData, 20); end; end; 1311

Example 1: Add a STANDARD database alias to the configuration file. This example uses the following input: fDbiAddAlias1('TestAlias', 'PATH:C:\BDE32\EXAMPLES\TABLES'); procedure fDbiAddAlias1(AliasName, AliasPath: string); begin Check(DbiAddAlias(nil, PChar(AliasName), nil, PChar(AliasPath), True)); end; Example 2: Add an InterBase database alias to the configuration file. This example uses the following input: fDbiAddAlias2('RemoteAlias', 'PATH:frobosrv:d:/interbas;' + 'SERVER NAME:frobosrv:d:/interbas/slim.gdb;' + 'USER NAME:test;' + 'SQLQRYMODE:SERVER;' + 'SQLPASSTHRU MODE:SHARED NOAUTOCOMMIT'); Note: The last parameter in the string does not have a semicolon ( ; ) at the end. procedure fDbiAddAlias2(AliasName, AliasPath: string); begin Check(DbiAddAlias(nil, PChar(AliasName), 'INTRBASE', PChar(AliasPath), True)); end;

Example 1: Open a local database: procedure fDbiOpenDatabase1(var hDb: hDbiDb; Alias: String); begin Check(DbiOpenDatabase(PChar(Alias), nil, dbiReadWrite, dbiOpenShared, nil, 0, nil, nil, hdb)); end; Example 2: Open a NULL database (for in-memory or temp tables) Set the directory for the tables (temp tables only). procedure fDbiOpenDatabase2(var hDb: hDbiDb; Directory: string); begin Check(DbiOpenDatabase(nil, nil, dbiREADWRITE, dbiOPENSHARED, 1312

nil, 0, nil, nil, hDb)); Check(DbiSetDirectory(hDb, PChar(Directory))); end; Example 3: Open a remote database with alias and password. procedure fDbiOpenDatabase3(var hDb: hDbiDb; Alias, Password: string); begin Check(DbiOpenDatabase(PChar(Alias), nil, dbiREADWRITE, dbiOPENSHARED, PChar(Password), 0, nil, nil, hDb)); end; Example 4: Open a database with a user name other than the one specified in the BDE configuration. This example uses the following input: fDbiOpenDatabase3(hDb, 'IBLOCAL', 'sysdba', 'speedy'); The procedure is: procedure fDbiOpenDatabase3(var hTmpDb: hDBIDb; Alias, UserName, Password: string); var Options: FLDDesc; begin FillChar(Options, sizeof(Options), #0); Options.iOffset := 0; Options.iLen := Length(UserName) + 1; StrPCopy(Options.szName, 'USER NAME'); Check(DbiOpenDatabase(PChar(Alias), nil, dbiREADWRITE, dbiOPENSHARED, PChar(Password), 1, @Options, PChar(UserName), hTmpDb)); end;

1313

Tips & Tricks by Binh Ly The following is a list of tips and tricks that might be useful to COM developers of all levels. If you have an interesting tip that's not listed here, please submit it to me and I'll add it to the list if I think it's useful. Index 1. Prefer early binding over late binding 2. Use Connection Points judiciously 3. Initialize threads that interact with COM 4. Marshal interface pointers across apartments 5. Don't call AddRef and Release unless necessary 6. Implement error handling correctly 7. Know how to implement multiple interfaces 8. Know which classes do what 9. Know the 3 most important things in COM security 10. Get rid of that nagging DCOM callback problem 11. Understand marshaling concepts 12. Understand COM identity concepts 13. Design simple and efficient interfaces 14. IDispatch, dispinterfaces, vtable interfaces, dual interfaces, etc. 15. Know how to implement objects that support Visual Basic's For Each construct 16. Know how to implement clients that iterate IEnumVARIANT-based collections (ala Visual Basic's For Each construct) 17. Know how to use aggregation and containment 18. Understand the class factory Instancing property (SingleInstance, MultiInstance) 19. Know how to implement servers that support GetActiveObject 20. Know how to implement an object property that supports the automation defaultproperty syntax 1. Prefer early binding over late binding Late binding is a facility that enables script-based client applications to access and manipulate COM objects. Late binding is based on the concept of runtime discovery and execution of an object's methods through the COM IDispatch interface. When you declare and use object variables as variants, you are using late-binding. Unfortunately, each late bound method call incurs quite a bit of overhead and may slow down your client application considerably. To avoid this, use early (vtable) binding instead. Assuming that you have a coclass Foo contained in a FooServer server. The following shows how to early bind to Foo from your client: In Delphi Use the Project | Import Type Library menu and import FooServer from the list of registered servers. Delphi generates a unit named FooServer_TLB.pas. Include that unit into your project and instantiate Foo as follows: uses FooServer_TLB; var Foo : IFoo; begin Foo := CoFoo.Create; Foo.Bar; //call Bar method end; In C++ Builder Use the Project | Import Type Library menu and import FooServer from the list of registered servers. CBuilder generates a module named FooServer_TLB.h (and FooServer_TLB.cpp). Include that module into your project and instantiate Foo as follows: 1314

#include "FooServer_TLB.h" TCOMIFoo Foo = CoFoo::Create (); Foo->Bar (); //call Bar method 2. Use Connection Points judiciously COM Connection Points is not the only way to enable server-to-client callbacks. In fact, a simple interface handed from the client down to the server will do the trick. However, connection points are widely supported by a lot of applications (especially Microsoft applications), which might force you to eventually deal with it one way or another. Know these when implementing connection points: 6. A lot of connection point implementations are used to trigger server-to-client dispinterface callbacks. A dispinterface is simply a specification for IDispatch.Invoke. Because of this, a server will need to know how to make an IDispatch.Invoke call and a client will need to know how to implement IDispatch.Invoke. Implementing IDispatch.Invoke is not for the faint of heart trust me! If you're implementing connection points in your server for nonscripting clients, forget dispinterfaces and simply implement vtable-based connection points. That would make it a lot easier for you to implement both the client and the server. In addition, a vtable-interface eliminates some of the overhead involved in dispinterface-based calls. 7. When using connection points, a client that connects to the server will require at least 3 roundtrip calls: a) Server.QueryInterface (IConnectionPointContainer), b) IConnectionPointContainer.FindConnectionPoint (CP), and c) IConnectionPoint.Advise (IUnknown) Since IConnectionPoint.Advise takes an IUnknown, the server will also make at least 1 extra roundtrip QueryInterface call back to the client (to obtain IDispatch when using dispinterfaces, or ICustomCallback when using a custom vtable interface) Also, unless the client caches the connection point interface, disconnecting from the server will again require at least 3 roundtrip calls: a) Server.QueryInterface (IConnectionPointContainer), b) IConnectionPointContainer.FindConnectionPoint (CP), and c) IConnectionPoint.Unadvise (Cookie) Therefore, a single client negotiating with the server using connection points will normally require at least 7 roundtrip calls between client and server. For inprocess (or maybe local out-of-process) servers, this is normally Ok. However, for remote servers, this is a little bit too much network traffic for a single client what if a lot of clients connect to the remote server? In short, use connection points only where appropriate. For remote callbacks, prefer a hand-coded mechanism of passing a client's callback interface down to the server through a custom server interface. 8. Connection points are designed in such a way that it's difficult to distinguish among the connected clients. It is difficult, if not impossible, to selectively "filter" certain clients that you may want to call back depending on certain circumstances. In other words, if you don't care about filtering or identifying which client is which, then connection points maybe a good choice for you. Otherwise, resort to a hand-coded mechanism. 1315

3. Initialize threads that interact with COM Ever get the "CoInitialize has not been called" (800401F0 hex) error? Each thread in your application that interacts with COM (i.e. creates COM objects, calls COM APIs, etc.) must initialize itself into an apartment. A thread can either join a single threaded apartment (STA) or the multithreaded apartment (MTA). The STA is system-synchronized based on a windows message queue. Use the STA if your object or thread relies on thread-relative resources such as UI elements. The following shows how to initialize a thread into an STA: procedure FooThreadFunc; //or TFooThread.Execute begin CoInitializeEx (NIL, COINIT_APARTMENTTHREADED); ... do your stuff here ... CoUninitialize; end; The MTA is system-guaranteed to be ruthless. Objects in the MTA will receive incoming calls from anywhere anytime. Use the MTA for non-UI related objects, but synchronize carefully! The following shows how to initialize a thread into the MTA: procedure FooThreadFunc; //or TFooThread.Execute begin CoInitializeEx (NIL, COINIT_MULTITHREADED); ... do your stuff here ... CoUninitialize; end; 4. Marshal interface pointers across apartments Ever get the "The application called an interface that was marshaled for a different thread" (8001010E hex) error? When passing an interface pointer from apartment to apartment, it is a violation of COM's threading rules if you don't perform marshaling. This is because you will bypass any necessary requirements that COM might need in order to successfully make cross-apartment calls. Marshaling interface pointers involve using CoMarshalInterface and CoUnmarshalInterface. However for practical purposes, we tend to prefer the easier CoMarshalInterThreadInterfaceInStream and CoGetInterfaceAndReleaseStream API pair. The following shows how to marshal an interface pointer from Foo1Thread to Foo2Thread, both from different apartments: var MarshalStream : pointer; //original thread procedure Foo1ThreadFunc; //or TFoo1.Execute var Foo : IFoo; begin //assuming Foo2Thread is currently suspended CoInitializeEx (...); Foo := CoFoo.Create; //marshal CoMarshalInterThreadInterfaceInStream (IFoo, Foo, IStream (MarshalStream)); //tell Foo2Thread that MarshalStream is ready Foo2Thread.Resume; CoUninitialize; end; //user thread procedure Foo2ThreadFunc; //or TFoo2.Execute 1316

var Foo : IFoo; begin CoInitializeEx (...); //unmarshal CoGetInterfaceAndReleaseStream (IStream (MarshalStream), IFoo, Foo); MarshalStream := NIL; //use Foo Foo.Bar; CoUninitialize; end; The marshaling technique shown above is also described as marshal once-unmarshal once. If you want to marshal once and unmarshal as many times as you wish, use the COM (NT 4 SP3) provided Global Interface Table (GIT). The GIT allows you to marshal in interface pointer into a cookie and the unmarshaling threads can use this cookie to unmarshal how ever many times they want. Using the GIT, the above example can be written: const CLSID_StdGlobalInterfaceTable : TGUID = '{00000323-0000-0000-C000-000000000046}'; type IGlobalInterfaceTable = interface(IUnknown) ['{00000146-0000-0000-C000-000000000046}'] function RegisterInterfaceInGlobal (pUnk : IUnknown; const riid: TIID; out dwCookie : DWORD): HResult; stdcall; function RevokeInterfaceFromGlobal (dwCookie: DWORD): HResult; stdcall; function GetInterfaceFromGlobal (dwCookie: DWORD; const riid: TIID; out ppv): HResult; stdcall; end; function GIT : IGlobalInterfaceTable; const cGIT : IGlobalInterfaceTable = NIL; begin if (cGIT = NIL) then OleCheck (CoCreateInstance (CLSID_StdGlobalInterfaceTable, NIL, CLSCTX_ALL, IGlobalInterfaceTable, cGIT)); Result := cGIT; end; var MarshalCookie : dword; //original thread procedure Foo1ThreadFunc; //or TFoo1.Execute var Foo : IFoo; begin //assuming Foo2Thread is currently suspended CoInitializeEx (...); Foo := CoFoo.Create; //marshal GIT.RegisterInterfaceInGlobal (Foo, IFoo, MarshalCookie) //tell Foo2Thread that MarshalCookie is ready Foo2Thread.Resume; CoUninitialize; 1317

end; //user thread procedure Foo2ThreadFunc; //or TFoo2.Execute var Foo : IFoo; begin CoInitializeEx (...); //unmarshal GIT.GetInterfaceFromGlobal (MarshalCookie, IFoo, Foo) //use Foo Foo.Bar; CoUninitialize; end; And don't forget to remove the interface from the GIT when you not longer wish to use it: GIT.RevokeInterfaceFromGlobal (MarshalCookie); MarshalCookie := 0; If you dislike the low-level GIT gunk, you can use the friendlier TGIP class from my ComLib library. 5. Don't call AddRef and Release unless necessary With the advent of smart compilers and smart pointers, explicitly calling IUnknown.AddRef and IUnknown.Release is a thing of the past. In Delphi var Foo, AnotherFoo : IFoo; Foo := CoFoo.Create; AnotherFoo := Foo; The assignment to AnotherFoo implicitly calls AddRef on the Foo instance, compliments of the Delphi compiler. Furthermore, when Foo and AnotherFoo go out of scope (or if you assign NIL to them), Delphi will also implicitly call Release for you. In C++ Builder TCOMIFoo Foo = CoFoo::Create (); IFooPtr AnotherFoo = Foo; The assignment to AnotherFoo implicitly calls AddRef on the Foo instance, compliments of the TComInterface smart pointer class (note though that a lot of other assignment operators in TComInterface don't AddRef the source). Furthermore, when Foo and AnotherFoo go out of scope, TComInterface will implicitly call Release for you. 6. Implement error handling correctly In COM, every interface method must return an error code to the client. An error code is a standardized 32-bit value called an HRESULT. The 32 bits in an HRESULT are actually divided into parts as follows: a bit that indicates success or failure (severity), a few bits that indicate the classification of the error (facility), and another few bits that indicate the actual error number (code). What we're most interested in is how to get the error number part into the HRESULT. In addition, COM suggests that our error numbers should be in the range of 0200 hex to FFFF hex. Unfortunately, an HRESULT is rather limiting because in addition to the error number, we might also want the server to tell the client what the error is (description), where it happened (source), and where the client can possibly get more help on the error (help file and help context). For this, COM introduces another interface, IErrorInfo, that the client can use to obtain additional information on an error, if any. In simple terms, IErrorInfo can be thought of as a storage for the error description, source, help file, and help context. If the server passes error information to the client thru IErrorInfo, COM also suggests that the server implement ISupportErrorInfo. Although this is not 1318

required, it is a good idea to do so because some clients, like Visual Basic, will ask the server for this interface. In Delphi Delphi has something called the safecall calling convention. What this means is that if you raise an internal exception within your object's implementation, Delphi will automatically "trap" the exception and convert it to a COM HRESULT, and populate an IErrorInfo structure ready for shipping to the client. This is all done in the HandleSafeCallException function in ComObj. In addition, the VCL classes also implement ISupportErrorInfo for you already. Here's the fun part: When you raise an EWhatever exception in the server, it will always be seen by the client as EOleException. EOleException contains all the goodies in HRESULT and IErrorInfo combined, i.e. the error number, description, source, help file, and help context. The thing is, in order to set up the goodies for the client, the server must raise EOleSysError instead of EWhatever. More specifically, when you raise an EOleSysError, you should make sure the error number you give it is a conventionally formatted HRESULT. To see what I mean, let's say we have an object named FooServer.Foo that has a Bar method. In Bar, we want to raise an error whose number=5, description="Error Message", help file="HelpFile.hlp", help context = 1, and the obvious source="FooServer.Foo". This is how we do it: uses ComServ; const CODE_BASE = $200; //recommended codes are from 0x0200 - 0xFFFF procedure TFoo.Bar; begin //can be assigned once (globally) from somewhere ComServer.HelpFileName := 'HelpFile.hlp'; //help file //raise error: message='Error Message', number=5 + CODE_BASE, help context=1 raise EOleSysError.Create ( 'Error Message', //error message ErrorNumberToHResult (5 + CODE_BASE), //HRESULT 1 //help context ); end; function ErrorNumberToHResult (ErrorNumber : integer) : HResult; const SEVERITY_ERROR = 1; FACILITY_ITF = 4; begin Result := (SEVERITY_ERROR shl 31) or (FACILITY_ITF shl 16) or word (ErrorNumber); end; If you look at the highlighted line closely, the ErrorNumberToHResult call simply converts our error number into a standard HRESULT. Also, we add CODE_BASE (200 hex) to our error number so that we follow COM's suggestion that custom error numbers be in the range of 0200 hex to FFFF hex. Note that we didn't specify the source="FooServer.Foo" value. That's because Delphi "knows" in which object the exception was raised and will automatically fill that in for you. On the client side, this is how we trap the error through EOleException: const CODE_BASE = $200; //recommended codes are from 0x0200 - 0xFFFF 1319

procedure CallFooBar; var Foo : IFoo; begin Foo := CoFoo.Create; try Foo.Bar; except on E : EOleException do ShowMessage ('Error message: ' + E.Message + #13 + 'Error number: ' + IntToStr (HResultToErrorNumber (E.ErrorCode) CODE_BASE) + #13 + 'Source: ' + E.Source + #13 + 'HelpFile: ' + E.HelpFile + #13 + 'HelpContext: ' + IntToStr (E.HelpContext) ); end; end; function HResultToErrorNumber (hr : HResult) : integer; begin Result := (hr and $FFFF); end; Again, I've highlighted the only important line. We call HResultToErrorNumber to extract the error number part from HRESULT and then we subtract CODE_BASE (200 hex) to compensate for the conventional error base. In C++ Builder CBuilder uses ATL. On the server, ATL provides the AtlReportError function that an object can call to return the error number plus the IErrorInfo goodies to the client. To see what I mean, let's say we have an object named FooServer.Foo that has a Bar method. In Bar, we want to raise an error whose number=5, description="Error Message", help file="HelpFile.hlp", help context = 1, and the obvious source="FooServer.Foo". This is how we do it: const CODE_BASE = 0x200; //recommended codes are from 0x0200 - 0xFFFF STDMETHODIMP TFooImpl::Bar() { return AtlReportError ( GetObjectCLSID (), //which class generated the error "Error Message", //error description 1, //help context "HelpFile.hlp", //help file IID_IFoo, //which interface generated the error ErrorNumberToHRESULT (5 + CODE_BASE) //HRESULT ); } HRESULT ErrorNumberToHRESULT (int ErrorNumber) { return MAKE_HRESULT (SEVERITY_ERROR, FACILITY_ITF, ErrorNumber); } Look at the highlighted line closely. ErrorNumberToHRESULT converts our error number to a standard HRESULT. Also, we add CODE_BASE (200 hex) to our error 1320

number so that we follow COM's suggestion that custom error numbers be in the range of 0200 hex to FFFF hex. Note that we didn't specify the source="FooServer.Foo" value. That's because ATL will convert the CLSID that you pass in (first parameter: GetObjectCLSID ()) to its corresponding PROGID and will automatically fill that in for you. If you (normally) derive from CComCoClass, you can also simply call the overloaded Error methods in CComCoClass, which eventually call AtlReportError. The second thing we need to do is to implement ISupportErrorInfo. In order to do that, simply add the simple ATL-provided ISupportErrorInfoImpl class to TFooImpl: class ATL_NO_VTABLE TFooImpl : public CComObjectRoot, public CComCoClass, public IDispatchImpl, public ISupportErrorInfoImpl <&IID_IFoo> { ... BEGIN_COM_MAP(TFooImpl) COM_INTERFACE_ENTRY(IFoo) COM_INTERFACE_ENTRY(IDispatch) COM_INTERFACE_ENTRY(ISupportErrorInfo) END_COM_MAP() ... }; On the client side, we can implement a standard mechanism for extracting the error number out of the returned HRESULT value and the extra error information from IErrorInfo. Fortunately, there exists an EOleException exception class in the VCL that can hold all of this error information. To do this, I've created a simple function, CheckResult, that properly extracts all error information, puts them into an EOleException, and then raises the exception. Here's how you'd use this function: #include const CODE_BASE = 0x200; //recommended codes are from 0x0200 - 0xFFFF void CallFooBar () { TCOMIFoo Foo = CoFoo::Create (); try { CheckResult ( Foo->Bar (), //invoke method which returns the HRESULT Foo, //specifies the IUnknown* of the object we're extracting error info from IID_IFoo //specifies the IID of the interface that contains the method invoked above ); } catch (EOleException& e) { ShowMessage ("Error Message: " + e.Message + '\n' + "Error Number: " + (HRESULTToErrorNumber (e.ErrorCode) - CODE_BASE) + '\n' + "Source: " + e.Source + '\n' + "HelpFile: " + e.HelpFile + '\n' + "HelpContext: " + e.HelpContext 1321

); } } int HRESULTToErrorNumber (int hr) { return HRESULT_CODE (hr); } Again, I've highlighted the only important line. We call HRESULTToErrorNumber to extract the error number part from HRESULT and then we subtract CODE_BASE (200 hex) to compensate for the conventional error base. Finally, here's the ugly CheckResult function that you don't need to mess with: #include void CheckResult ( HRESULT hr, //HRESULT returned from method IUnknown* Object = NULL, //Object in which we invoked the method REFIID ErrorIID = GUID_NULL //IID of the interface that contains the method invoked ) { if (FAILED (hr) && (HRESULT_FACILITY (hr) == FACILITY_ITF)) { bool HasErrorInfo = false; if (Object && (!IsEqualGUID (ErrorIID, GUID_NULL))) { //check ISupportErrorInfo ISupportErrorInfo* SupportErrorInfo = NULL; HRESULT hr = Object->QueryInterface (IID_ISupportErrorInfo, (void**)&SupportErrorInfo); if (SUCCEEDED (hr)) { if (SupportErrorInfo->InterfaceSupportsErrorInfo (ErrorIID) == S_OK) HasErrorInfo = true; SupportErrorInfo->Release (); } } else //assume caller don't care about ISupportErrorInfo! HasErrorInfo = true; if (HasErrorInfo) { int ErrorCode = hr; WideString Description, Source, HelpFile; ULONG HelpContext = 0; //get error info IErrorInfo* ErrorInfo = NULL; if (SUCCEEDED (GetErrorInfo (0, &ErrorInfo))) { ErrorInfo->GetDescription (&Description); ErrorInfo->GetSource (&Source); ErrorInfo->GetHelpFile (&HelpFile); 1322

ErrorInfo->GetHelpContext (&HelpContext); ErrorInfo->Release (); } throw EOleException (Description, ErrorCode, Source, HelpFile, HelpContext); } } } For Visual Basic Clients If you're wondering how this all fits into the Err object in a VB client, here's how you'd trap the error raised above: Private Sub CallFooBar() On Error GoTo ErrorHandler Dim Foo As New FooServer.Foo Foo.Bar Exit Sub ErrorHandler: MsgBox "Error Message: " & Err.Description & vbCr & _ "Error Number: " & Err.Number - vbObjectError - &H200 & vbCr & _ "Source: " & Err.Source & vbCr & _ "HelpFile: " & Err.HelpFile & vbCr & _ "HelpContext: " & Err.HelpContext End Sub On the highlighted line, subtracting vbObjectError extracts the error number from the HRESULT, and then subtracting &H200 (200 hex) compensates for the conventional error base. 7. Know how to implement multiple interfaces The ability to implement any interface in any object is one of COM's greatest strengths. Different development environments provide different means of implementing COM interfaces. Let's say you have a coclass named FooBar (that already supports IFooBar) in which you want to implement 2 external interfaces: IFoo and IBar. IFoo and IBar are defined as follows: IFoo = interface procedure Foo; //implicit HRESULT assumed end; IBar = interface procedure Bar; //implicit HRESULT assumed end; In Delphi type TFooBar = class (TAutoObject, IFooBar, IFoo, IBar) protected //IFooBar ... IFooBar methods here ... //IFoo methods procedure Foo; //IBar methods procedure Bar; ... end; procedure TFooBar.Foo; 1323

begin end; procedure TFooBar.Bar; begin end; If IFooBar, IFoo, and IBar were all IDispatch-based, TAutoObject will pick IFooBar (the primary/default interface) to implement IDispatch, i.e. a script-based client will only be able to see IFooBar's methods. In C++ Builder class ATL_NO_VTABLE TFooBarImpl : public CComObjectRoot, public CComCoClass , public IFooBar, public IFoo, public IBar { BEGIN_COM_MAP(TFooBarImpl) COM_INTERFACE_ENTRY(IFooBar) COM_INTERFACE_ENTRY(IFoo) COM_INTERFACE_ENTRY(IBar) END_COM_MAP() protected: //IFoo methods STDMETHOD (Foo) (); //IBar methods STDMETHOD (Bar) (); } STDMETHODIMP TFooBarImpl::Foo () { } STDMETHODIMP TFooBarImpl::Bar () { } If IFooBar, IFoo, and IBar were all IDispatch-based, you'd probably want to implement TFooBarImpl this way: class ATL_NO_VTABLE TFooBarImpl : public CComObjectRoot, public CComCoClass , public IDispatchImpl , public IDispatchImpl , public IDispatchImpl { BEGIN_COM_MAP(TFooBarImpl) COM_INTERFACE_ENTRY(IFooBar) COM_INTERFACE_ENTRY_IID(IID_IDispatch, IFooBar) COM_INTERFACE_ENTRY(IFoo) COM_INTERFACE_ENTRY(IBar) END_COM_MAP() protected: //... implement methods here ... } 1324

Note how I use COM_INTERFACE_ENTRY_IID () for IDispatch. What this does is whenever TFooBarImpl is QI'd for IDispatch, it will return the IFooBar part of it, i.e. a script-based client will only be able to see IFooBar's methods. This also gets rid of a compile time error because the compiler cannot resolve which of the 3 IDispatches (IFooBar, IFoo, or IBar) to use as its IDispatch implementation. 8. Know which classes do what In Delphi Delphi provides quite a number of classes for COM development: TInterfacedObject, TComObject, TTypedComObject, TAutoObject, TAutoIntfObject, TComObjectFactory, TTypedComObjectFactory, TAutoObjectFactory, etc. How do we know which one to use? Here's the scoop. Ready?! TInterfacedObject TInterfacedObject provides you with an implementation of IUnknown. If you want to create an "internal" object that implements "internal" interfaces that (usually) have nothing to do with COM, TInterfacedObject is the best class to derive from. Of course, you can still use TInterfacedObject to create an object that can be passed to a COM client - just remember, the only support you get from it is IUnknown, nothing more, nothing less. TComObject TComObject provides you with implementations of IUnknown, ISupportErrorInfo, standard COM aggregation support, and a matching coclass class factory support. If you want to create a lightweight client-creatable COM object that implements IUnknown-based interfaces, TComObject is the best class to derive from. TComObjectFactory TComObjectFactory works in tandem with TComObject. It exposes its corresponding TComObject to the outside world as a coclass. Among the goodies TComObjectFactory brings are coclass registration (CLSIDs, ThreadingModel, ProgID, etc.), IClassFactory & IClassFactory2 support, and standard COM object licensing support. In short, if you have a TComObject, use TComObjectFactory with it. TTypedComObject TTypedComObject is TComObject + support for IProvideClassInfo. IProvideClassInfo is simply an automation standard to expose an object's type information (available names, methods, supported interfaces, etc.) stored in an associated type library. In addition to TComObject, TTypedComObject is also useful for objects that want to provide clients with the ability to browse their type information at runtime. For instance, Visual Basic's TypeName function expects an object to implement IProvideClassInfo so that it can determine the object's "documented name" based on type information stored in the type library. TTypedComObjectFactory TTypedComObjectFactory works in tandem with TTypedComObject. It is TComObjectFactory + it provides a cached type information (ITypeInfo) reference for TTypedComObject to use. In short, if you have a TTypedComObject, use TTypedComObjectFactory with it. TAutoObject TAutoObject is TTypedComObject + support for IDispatch. TAutoObject's IDispatch support is automatic and is based on type information stored in the type library - ever wonder why you never had to implement any of the 4 IDispatch methods in your automation objects? If you want to create standard client-creatable automation (supports IDispatch) objects, TAutoObject is the best class to derive from. In addition, as of D4, TAutoObject provides a built-in standard connection point mechanism support. TAutoObjectFactory TAutoObjectFactory works in tandem with TAutoObject. It is 1325

TTypedComObjectFactory + it provides cached type information (ITypeInfo) references for your TAutoObject's default/primary (IDispatch-based) interface and it's connection point's event interface (if any). In short, if you have a TAutoObject, use TAutoObjectFactory with it. TAutoIntfObject TAutoIntfObject is TInterfacedObject + support for IDispatch. More specifically TAutoIntfObject's IDispatch support is type library-based similar to how TAutoObject does it. In contrast to TAutoObject, TAutoIntfObject has no corresponding class factory (coclass) support meaning that external clients cannot directly instantiate a TAutoIntfObject-derived class. However, TAutoIntfObject is excellent for (IDispatchbased) sub-level objects or sub-properties (that are themselves objects) that you want to expose to the clients. In C++ Builder C++ Builder uses ATL. Here's a few important things to know about how your objects are constructed using ATL: In ATL, a COM object = Abstract Class + CComObject (or CComObject variants) The abstract class is what we're familiar with, you know... the class with the infamous ATL_NO_VTABLE tag: class ATL_NO_VTABLE TFooImpl ... TFooImpl is an abstract class because we cannot directly instantiate TFooImpl - try it an you'll see. ATL has this interesting concept that your abstract class must first marry CComObject in order to exist as one valid COM object: CComObject *Foo; CComObject ::CreateInstance (&Foo); //Foo is now an instance of our TFooImpl class Let's backtrack a bit and dig deeper into the abstract class. First, we need to support IUnknown. That's what CComObjectRoot/Ex is for: class ATL_NO_VTABLE TFooImpl : public CComObjectRoot/Ex , ... For details on the differences between CComObjectRoot and CComObjectRootEx, consult ATL Internals by Brent Rector and Chris Sells Next, we decide if we need coclass support, i.e. do we want external clients to be able to create our object. That's what CComCoClass is for: class ATL_NO_VTABLE TFooImpl : public CComObjectRoot, public CComCoClass (TFooImpl, &CLSID_Foo), ... CComCoClass takes care of IClassFactory and aggregation support, registration gunk, some standard COM error handling stuff, etc. To complete CComCoClass' coclass support, we also need an entry in the global OBJECT_MAP structure: BEGIN_OBJECT_MAP(ObjectMap) OBJECT_ENTRY(CLSID_Foo, TFooImpl) END_OBJECT_MAP() Also, CComCoClass automatically does the CComObject ::CreateInstance call for us whenever it is asked to create an instance of our TFooImpl class. With IUnknown and coclass support available, we can then implement our custom interfaces. Let's say we want to implement an interface IFoo declared as follows: IFoo = interface ... end; To do this we need to add IFoo to our abstract class, both in the inheritance chain and the interface map: class ATL_NO_VTABLE TFooImpl : 1326

public CComObjectRoot, public CComCoClass , public IFoo { BEGIN_COM_MAP(TFooBarImpl) COM_INTERFACE_ENTRY(IFooBar) COM_INTERFACE_ENTRY(IFoo) END_COM_MAP() } The "public IFoo" part means that we're implementing IFoo in our class. The COM_INTERFACE_ENTRY (IFoo) part means that clients can get to our IFoo implementation, i.e. clients can QI for IFoo. But what if we want IFoo to be IDispatch-based, as it is "normally": IFoo = interface (IDispatch) ... end; Well, we can still use the above class declaration but we'd also have to manually implement the 4 IDispatch methods. But there's an easier way: define IFoo in a type library (usually in your server's type library) and then use ATL's IDispatchImpl class for built-in IDispatch support, i.e. we don't need to bother with manually implementing the 4 IDispatch methods. Thus: class ATL_NO_VTABLE TFooImpl : public CComObjectRoot, public CComCoClass , public IDispatchImpl { BEGIN_COM_MAP(TFooBarImpl) COM_INTERFACE_ENTRY(IFooBar) COM_INTERFACE_ENTRY(IFoo) COM_INTERFACE_ENTRY(IDispatch) END_COM_MAP() } Note that IDispatchImpl requires the &IID_IFoo and &LIBID_FooServer parts because it will implement IDispatch for us based on the IFoo that we have defined in the type library. Also note that we need an extra COM_INTERFACE_ENTRY (IDispatch) entry in the interface map so that a client that QIs for IDispatch will get our default IDispatch implementation - IFoo. There's a lot more to ATL than what I've shown you here. If you're up to it, check out ATL Internals by Brent Rector and Chris Sells or ATL-A Developer's Guide by Tom Armstrong. 9. Know the 3 most important things in COM security Nothing can be more frustrating than not knowing why your (DCOM) server denies access to your clients. In a nutshell, COM security can be described as follows: Authentication From the server's point of view, your first job is to determine whether or not you want to identify your clients, i.e. do you care who your clients are? This is called authentication. In simple terms, when the server authenticates the client, the server asks the client "show me your ID", the client hands the server its ID, and the server verifies if indeed the ID is legitimate or not. In COM, the ID is the client's username and password account. The server's verification process will involve contacting a domain controller (if any) to determine if the client's account information is valid or not. Authentication can be of different levels ranging from no authentication (server doesn't care to ask the client for its ID) to paranoid authentication (server will ensure that the 1327

client is identified and in addition, all communication between the client and server is encrypted to avoid eavesdroppers from finding out what the client and the server are up to). The authentication levels that you're probably most familiar with (assuming you have used DCOMCNFG) are None and Connect. None, as the name implies, means no authentication. Connect, as the name implies, means authenticate only the first time the client connects to the server. There are other levels of authentication but we won't talk about them in detail here. The most important thing to remember about an authentication level is that they are ranked from lowest authentication (None) to highest authentication (Packet Privacy). Using this ranking, if a server specifies an authentication level of X, any clients who try to connect (make calls) to the server at a lower authentication level than X will automatically be rejected by COM. For example: you specify an authentication level of Connect on your server. An unknown client (who has no account on your network) such as Joe Bum from the Internet tries to contact your server. Since your server specified Connect, COM will perform authentication. COM won't be able to identify Joe Bum and so therefore, COM will flag Joe Bum right at the door with an "Access Denied" message. Access Control Being able to identify the client is only part of the story. Once the server identifies the client, it will need to decide whether or not the client can access it. This concept is similar to that big dude at your local bar: you might be able to produce an ID but he'll let you in only if you're of legal drinking age. This is called access control. There's really nothing much to access control. Your server simply specifies that only users X, Y, and Z have access to it. All other users, even though they have valid IDs, are denied access. In DCOMCNFG terms, the "Use custom access permissions" and "Use custom launch permissions" options under the security tab is what I mean by access control. Server Identity Aside from authentication and access control, another important thing is that a server should be running before clients can connect to it. Before the server runs, there's one last thing that it needs to decide: under which account should it run as? This is called server identity. There are 4 main options for a server's identity: · Use the account of the user that's currently logged in to the server machine (Interactive User) · Use the account of the client that connects to the server (Launching User) · Use a predefined account designed for use only by the server (This User) · Use the SYSTEM account (available only for an NT service COM server) Opting for Interactive User has some interesting aspects. First, the server will only have privileges of the user that's currently logged in to the server machine - and these privileges vary depending on who that user is. In addition, if nobody is logged in, your server can't assume as "nobody" so it will refuse to run. On the bright side, this option is the only one where you get to see your server's forms (if any) and any message boxes that your server pops up. Because of this, Interactive User is excellent for debugging purposes. Opting for the Launching User also has some interesting aspects. First, since the server wants to assume the identity of the client, each client will launch its own separate copy of the server. This is logical because a single instance of the server cannot assume the identity of multiple clients all at the same time. Also, this option is rather crippled in that COM will deny the server access to any remote/network resources from the server machine, even including connecting back to the client machine. Opting for This User is recommended for production deployment. Using this option, you can designate a distinct user account only for purposes of your server. This way, 1328

you can easily give or deny permissions to this particular account depending on what kinds of resources your server needs to access. Summary These 3 aspects are the most important in understanding COM security. However, my discussions here are rather incomplete, at best. For more detailed information, consult Don Box's Essential COM and the following excellent sites: · DCOM 95 Frequently Asked Questions · COM Security Frequently Asked Questions · COM Internet Services · Using Distributed COM with Firewalls · Dan Miser's DCOM FAQ 10. Get rid of that nagging DCOM callback problem If you've ever implemented callbacks across machines, you might have discovered seemingly odd and unexplainable errors. I some other cases, the callback call just doesn't seem to work correctly. Here's why: First, read the Authentication part of Tip #9 above. When the server makes a call back into the client, COM will also perform authentication at the authentication level specified by the client (normally the Default Authentication level in DCOMCNFG). If authentication fails, COM will fail the call. Now here's an interesting aspect of the authentication level. When a client connects to the server, COM will always pick the higher authentication level between the client and the server as the negotiated authentication level. This means that calls from the client to the server and vice-versa will be authenticated at the negotiated authentication level. How is this important? Well if you think that lowering the authentication level on the client side to None (meaning that you want calls from the server back to the client to be unauthenticated) fixes our DCOM callback problem, you're only half right. This is because COM will always look at both the client and the server to determine the negotiated authentication level. If the client specifies None but the server specifies something higher than None, say Connect, COM will use Connect as the negotiated authentication level. This means that when the server calls back into the client, COM will authenticate at Connect level, even if the client didn't really need/want it. Because of this, the authentication must succeed in order for the call to succeed. If authentication fails (i.e. the client cannot verify who the server is), the call will fail. Obviously, one way to solve this problem is to 1) set both authentication levels for client and server to None or 2) make sure the server's identity can be authenticated on the client's domain. For debugging purposes, lowering the authentication level to None for both client and server is simply the easiest. The authentication level can be set in DCOMCNFG or by calling the CoInitializeSecurity API. Another way is to somehow lower the authentication level (to None) at runtime, before the server makes its call back into the client. This can be done using the IClientSecurity interface or the CoSetProxyBlanket API. I won't show you the details of how to do this but you can check out Don Box's Essential COM for a complete discussion. 11. Understand marshaling concepts Ever get the "Interface not supported/registered" (80004002 hex) error? Ever wonder why you have to register at least the type library on a client machine for early binding to work? COM's concept of location transparency is made possible through behind-the-scene helper objects known as proxies and stubs. When a client talks to an object on a remote machine (or, technically, in another apartment), the client really talks to the 1329

proxy, which talks to COM, which talks to the stub, which finally talks to the object: Whenever the client makes a method call, the proxy packs the method parameters into a flat array and gives it to COM. COM then transports the array to the stub, which unpacks the array back to individual method parameters, which then invokes the method on the server object. This process is called marshaling. One of the things you probably never thought about is where do the proxy and the stub come from? The simple answer is that proxies and stubs are also COM objects! In fact, the proxy and stub objects are contained in COM DLLs (also called proxy-stub DLLs) that get registered on your system. An interesting thing about this is that COM provides a built-in proxy-stub DLL that's capable of creating proxy and stub objects on-the-fly based on information contained in a type library. This DLL (oleaut32.dll) is called the type library marshaler or the universal marshaler. Although this marshaler is good enough for most purposes, it is only capable of marshaling parameter data that can be represented using the automation VARIANT data type. In your type library, you must annotate your interface definition with the [oleautomation] flag to specify that you want your interface marshaled using the type library marshaler. The [oleautomation] flag can be used on any interface. A lot of COM newbies think that it is used only for IDispatch-based interfaces. On the contrary, it is perfectly Ok to annotate IUnknown-based interfaces with it (of course, as long as your method parameters are all VARIANT compatible). [oleautomation] simply tells COM to use the type library marshaler for the associated interface and has nothing to do with IDispatch or automation. Delphi and CBuilder takes advantage of the type library marshaler and relies heavily on your type library. If you come from a Visual C++ background, understand that Delphi and CBuilder does not have the ability to easily create custom proxy-stub DLLs useful for non-VARIANT parameter data types. Since the type library marshaler relies on information in your type library, it's obvious that your type library has to be registered on both client and server machines for it work. If you forget to do this, you'll most likely get the dreaded "Interface not supported/registered" error! Type library registration is required only if you use early binding. If you use late binding (i.e. variants or dispinterface binding), COM uses the IDispatch interface which is already registered on your system with a well-known proxy-stub DLL. Therefore, late binding does not require registration of your type library file. 12. Understand COM identity concepts The COM specification is very clear about a few important and elementary concepts of what constitutes something called the "COM Identity". Understanding COM identity is very important and is a must for every COM developer. First and foremost, COM mandates that an object's implementation of QueryInterface for IUnknown, and only IUnknown, must always return the same pointer value. Consider an object FooBar that implements IFooBar, IFoo, and IBar: Foo = FooBar.QueryInterface (IFoo); Bar = FooBar.QueryInterface (IBar); 1330

Assert (Foo.QueryInterface (IUnknown) = Bar.QueryInterface (IUnknown)) The above assertion must always hold true! This IUnknown requirement, among other things, enables a client to compare 2 IUnknown values and definitively tell whether or not they point to the same server object. Note that this requirement is only for IUnknown. An object is not required to follow this requirement for any other interface that it supports. Second, COM mandates that QueryInterface must be symmetric, reflexive, and transitive: Symmetric means that if you got a pointer from a QueryInterface call for a given IID, then calling QueryInterface on that pointer using the same IID must succeed: Foo = FooBar.QueryInterface (IFoo); Foo.QueryInterface (IFoo) must succeed Reflexive means that if you got a pointer from a QueryInterface call for a given IID, then calling QueryInterface on that pointer using the IID of the original pointer must succeed: Foo = FooBar.QueryInterface (IFoo); Bar = Foo.QueryInterface (IBar); Bar.QueryInterface (IFoo) must succeed Transitive means that if you get a pointer that's 2 (or more) QueryInterface calls away from the original pointer, you should be able to get to that pointer directly from the original pointer: FooBar = FooBar.QueryInterface (IFooBar); Foo = FooBar.QueryInterface (IFoo); Bar = Foo.QueryInterface (IBar); FooBar.QueryInterface (IBar) or Bar.QueryInterface (IFooBar) must succeed Third, COM mandates that if a QueryInterface call succeeded (or failed) for a given IID, calling QueryInterface for that same IID at a later time must always succeed (or fail): Foo = FooBar.QueryInterface (IFoo); If the above call succeeds (i.e. FooBar supports IFoo), then calling FooBar.QueryInterface (IFoo) on the same FooBar instance must always succeed. Furthermore, if the above call fails (i.e. FooBar doesn't support IFoo), then calling FooBar.QueryInterface (IFoo) on the same FooBar instance must always fail. All these requirements are important for COM to be able to properly implement it's runtime magic and so that identity (or QueryInterface) semantics are predictable and consistent. For example, you should not selectively accept (or deny) a QueryInterface call for an IID based on the client's identity or the time of the day because your object may never be asked to perform that QueryInterface again. To illustrate, let's say you need FooBar to expose IFoo only to Jack but not to Jill. If Jack calls FooBar.QueryInterface (IFoo), your object hands Jack its IFoo. If Jill calls FooBar.QueryInterface (IFoo), your object fails the call with E_NOINTERFACE. What happens if Jack calls FooBar.QueryInterface (IFoo) and then hands the pointer to Jill? If, in this process, a QueryInterface call never happens (most likely), then Jill will get an IFoo, which is not what you wanted! The symmetric, reflexive, and transitive aspects of QueryInterface ensures that a client does not have to know (or is not required to perform) a particular sequence of QueryInterface calls to get to a particular interface. What this means is that if FooBar implements 5 interfaces: FooBar = class (TFooBar, IFooBar, IFoo, IBar, IJack, IJill) Given a FooBar instance, if the client wants IJill, you must not require the client to go through a particular sequence of QueryInterface calls to get to IJill, i.e. FooBar.QueryInterface (IJill) should be all the client needs to call. Imagine if you required the client to do this to get to IJill: Foo = FooBar.QueryInterface (IFoo); 1331

Bar = Foo.QueryInterface (IBar); Jack = Bar.QueryInterface (IJack); Jill = Jack.QueryInterface (IJill); //finally, my IJill Not only would that be a burden on the client, it'd also hard-code "internal knowledge" of the exact sequence into the client application. A note on Delphi Delphi 4 introduced the implements keyword that enables us to implement "tear-off" interfaces that can be used to optimize on resources (in cases where the client never queries for the tear-off interface). For instance, consider a FooBar class that implements IBar as a tear-off: type TFooBar = class (TComObject, IFooBar, IBar) ... public property BarTearOff : IBar read GetBar implements IBar; end; The above construct has the advantage that if the client never queries for IBar, the BarTearOff property will never be invoked and thus, any resources involved in doing that is never wasted. However, beware! If the client does this: FooBar := CoFooBar.Create; Bar := FooBar as IBar; //calls FooBar.QueryInterface (IBar) BackToFooBar := Bar as IFooBar; //must succeed because of QI reflexivity The last line above looks reasonably correct and should succeed. But, it will succeed only if you implement your BarTearOff property/class correctly. In particular, your BarTearOff class may need to AddRef and Release TFooBar correctly, and forward QueryInterface calls to TFooBar appropriately. If you don't do this extra work in BarTearOff, you'll be violating the laws of COM identity. 13. Design simple and efficient interfaces Designing interfaces can be harder than designing object-oriented classes. This is because an interface is a contract of interoperability between the client and your object. Once you deploy your objects and interfaces, it will be extremely difficult, if not impossible, to make changes to your interfaces. It's difficult to quantify what's a simple or what's an efficient interface. However, I'll show you some practices that can result in complex or inefficient interfaces. Based on these, you'll know how to avoid them when designing your own interfaces. 4. An interface should consist of methods that reflect its functionality. If you find yourself in a situation where you need to publish a method in your object and feel that the new method does not belong in an existing interface, then create a new interface, put that method in there, and add that interface to your object. It's very easy to create a smorgasbord of (hundreds of) unrelated methods into 1 single interface but it's extremely hard to maintain it on the object side and extremely hard to use it on the client side. Nobody likes to use (or maintain) an interface with 100+ methods! 5. Minimize interface inheritance. Being from an OO world, you might be led to think that designing layers and layers of inherited interfaces would impress your colleagues. Consider this simple inheritance chain: IFoo = interface procedure Foo; end; IBar = interface (IFoo) procedure Bar; end; 1332

From an OO standpoint, the advantage of making IBar inherit IFoo is so that given an IBar, a client can call IBar.Foo. Here's the problem: Sooner or later, you might need to add additional functionality to IFoo. If you already deployed IFoo to your clients, you know that it is bad to go back in and simply change IFoo (this would easily break existing clients). What you'd normally do instead is to create a newer IFoo, say IFoo2 (stands for IFoo version 2): IFoo2 = interface (IFoo) //inherits all IFoo methods procedure Foo2; end; Since your OO mentality dictates that you want IBar to inherit IFoo's features, you'll also want to create a new IBar2 that corresponds to IFoo2 (remember the old IBar inherits from the old IFoo, which can't be changed): IBar2 = interface (IFoo2) //inherits all IFoo2 methods procedure Bar; end; Note that since IBar2 can't inherit from both IFoo2 and the old IBar (COM interface inheritance is based on a single inheritance chain), we have to retype method Bar (or more specifically, all IBar methods) into IBar2. If we had 10 IBar methods, we'd have to manually copy all 10 methods into IBar2. If we later evolve the interfaces (IFoo3, IFoo4, IBar3, etc.), you can see how messy this can get. But let's go back to the problem at hand. You wanted IBar to inherit from IFoo because all you wanted to do was for the client to be able to call any of IFoo's methods on an IBar pointer: Bar = CoBar.Create; Bar.Foo; But that's not really necessary. For instance, the client can simply make a QueryInterface call to get to the IFoo part of Bar and invoke method Foo achieving the same result (assuming of course that your object supports both IFoo and IBar): Bar = CoBar.Create; Foo = Bar.QueryInterface (IFoo); Foo.Foo; Furthermore, this second approach does not and will not require nested interface inheritance chains. For instance, on the server side, Bar can simply be implemented as follows: IFoo = interface procedure Foo; end; IBar = interface //no IFoo inheritance here! procedure Bar; end; 1333

Bar = class (TComObject, IFoo, IBar); And more importantly, as IFoo and IBar evolve, we simply evolve Bar using a "flat" (instead of hierarchical) implementation style: IFoo2 = interface (IFoo) ... end; IBar2 = interface (IBar) //no need to inherit IFoo2 here! ... end; Bar = class (TComObject, IFoo, IBar, IFoo2, IBar2, ...) 6. Be careful when implementing collection interfaces for remote objects. The classic collection interface looks something like this: IItems = interface property Count : integer; property Item [Index : integer] : IItem; end; Given an IItems pointer, the client can easily iterate the collection using the Count and Item [] properties like this: Items = ServerObject.GetItems; //assume GetItems returns IItems for i = 1 to Items.Count do begin AnItem = Items.Item [i]; DoSomething (AnItem); end; This is simply classic collection iteration and, in fact, is very object-oriented. What you probably don't realize is that if the server object resides on a remote machine, the above iteration will require at least Items.Count roundtrip calls across the network (due to the IItems.Item [] call inside the for-loop). If there are 100 elements in IItems, that would translate to 100 roundtrips across the wire obviously not a very efficient scenario. What you can do instead is to packet groups of IItems elements into an array and ship that array in chunks from the server to the client. This way if 100 items were packed into groups of 50 elements, that would require only 2 roundtrips (2 x 50 = 100) to bring the entire collection down to the client. In COM, arrays of data can be sent using COM arrays, a very common example of which is the automation safearray (or variant array). I won't go into the details of how to do this but you can check out my DCOM tutorial to see an implementation of this concept. 7. In general, when designing interfaces for remote objects, the more information you can transfer in one method call, the more efficient your applications are. Consider a simple interface with 4 properties: IFoo = interface property Foo; 1334

property Bar; property Jack; property Jill; end; Given a Foo instance, a client will retrieve all 4 properties like this: Foo = CoFoo.Create; FooProperty = Foo.Foo; BarProperty = Foo.Bar; JackProperty = Foo.Jack; JillProperty = Foo.Jill; That's 4 roundtrip calls across the wire if Foo is a remote object. Put that in a loop and that could easily magnify as trouble. A more efficient approach would be to add a method that retrieves (or sets) all properties in 1 shot: IFoo = interface property Foo; property Bar; property Jack; property Jill; procedure GetProperties (out Foo; out Bar; out Jack; out Jill); end; The client would now simply make 1 roundtrip call to retrieve all 4 properties: Foo = CoFoo.Create; Foo.GetProperties (FooProperty, BarProperty, JackProperty, JillProperty); Note that we still might want to keep the 4 individual properties in the interface in case we need granular control of which properties to manipulate. However, by adding a GetProperties method, we can sometimes reduce overhead that may not have been apparent at the time we originally designed our interface. 14. IDispatch, dispinterfaces, vtable interfaces, dual interfaces, etc. If you, like me, are troubled by the exact meanings of IDispatch, dispinterfaces, vtable interfaces, dual interfaces, etc. at one time or another, here's the best I can do to finally clarify things for you. IDispatch is a widely used COM interface. When you use the Delphi/CBuilder File | New | Automation Object wizard, the IDE will create an automation object whose interface is IDispatch-based (if you look in the library editor, your new interface will have IDispatch as its parent interface). What this means is you are allowing scriptbased clients to be able to call methods of your object, nothing more, nothing less. IDispatch contains 2 methods that are most useful for script-based clients: GetIDsOfNames and Invoke. Whenever a client calls a method on your object (through IDispatch), it will, under-the-hood, call GetIDsOfNames followed by Invoke, always. For a detailed discussion on this, check out the automation chapter on my site. Half of the IDispatch protocol is invoking a method based on its associated numeric ID (dispid). In fact, this is precisely what IDispatch.Invoke does. Because of this, it is perfectly reasonable to create an interface that defines only the dispid numbers (and method parameter signatures) as the actual methods of the interface. In theory, a definition of this interface looks like this: 1335

DispFoo = interface dispid_1 (param1); dispid_2 (param1, param2); dispid_n (param1, param2, param3, ...); end; Using this interface, the client would make method calls directly using dispids: FooDisp = CoFoo.Create; FooDisp.dispid_1 (param1); //invoke method whose dispid = 1 FooDisp.dispid_2 (param1, param2); //invoke method whose dispid = 2 In reality, each of the dispid_n method calls above really boils down to an IDispatch.Invoke call. Notice though, that using this new interface, we only make IDispatch.Invoke calls. We can forget about IDispatch.GetIDsOfNames simply because we already know the dispids up front. In COM, this interface is what is called a dispinterface. In simple terms, a dispinterface is an interface that specifies how to make IDispatch.Invoke calls. In contrast to the IDispatch protocol, a more common way for non-script-based clients to call an object's methods is through early binding (or vtable binding). Early binding is based on the concept of low-level stack-based method invocations very similar to how you invoke internal methods and procedures within your application. The object's interface in which you are making early bound method calls into is also known as a vtable interface. In simple terms, if a client makes an early bound method call into your object, it is using (one of) your object's vtable interface. It is possible for an interface to be both IDispatch-based and vtable-based. This allows an interface to be usable to both script-based and non-script-based clients. In COM, such an interface is called a dual interface (contains a dispinterface part and a vtable part). In simple terms, given a dual interface, you can call its methods using either IDispatch (GetIDsOfNames and Invoke) or early binding. 15. Know how to implement objects that support Visual Basic's For Each construct If you or your colleagues develop in Visual Basic, there might be a time where somebody has asked how you can enable VB's For Each construct to work with your Delphi or CBuilder COM collection objects. For Each allows a VB client to iterate a collection's elements in a standard manner. For example: Dim Items as Server.IItems //declare variable that holds collection Dim Item as Server.IItem //declare variable that holds element Set Items = ServerObject.GetItems //retrieve IItems collection from server object //iterate Items in a For Each-loop For Each Item in Items Call DoSomething (Item) //do something to each item in the collection Next How do we make this work? The answer lies in a COM interface called IEnumVARIANT: IEnumVARIANT = interface (IUnknown) function Next (celt; var rgvar; pceltFetched): HResult; function Skip (celt): HResult; function Reset: HResult; function Clone(out Enum): HResult; end; For Each is really nothing but a construct that knows how to call the IEnumVARIANT methods (particularly Next) to iterate through all elements in the collection. Although it's really not that difficult to learn the semantics of IEnumVARIANT, it's often easier to create a high-level reusable class that encapsulates it because you might find yourself 1336

implementing IEnumVARIANT a lot of times. A specific mechanism dictates how we expose IEnumVARIANT to the client. For instance, let's say you have a collection interface that looks like this: //single Foo item IFooItem = interface (IDispatch); //collection of Foo items IFooItems = interface (IDispatch) property Count : integer; property Item [Index : integer] : IFoo; end; First, to be able to use IEnumVARIANT, your collection interface must support automation (be IDispatch-based) and your individual collection item data type must be VARIANT compatible (automation compatible). In simple terms, IFooItems must be IDispatch-based and IFooItem must be VARIANT compatible (e.g. byte, BSTR, long, IUnknown, IDispatch, etc.). Second, we go into the type library and add a read-only property named _NewEnum to the collection interface. _NewEnum must return IUnknown and must have a dispid = -4 (DISPID_NEWENUM). Applying this to IFooItems: IFooItems = interface (IDispatch) property Count : integer; property Item [Index : integer] : IFoo; property _NewEnum : IUnknown; dispid -4; end; Third, we implement _NewEnum by returning our IEnumVARIANT pointer from that property. In Delphi I've created a reusable class (TEnumVariantCollection in ComLib.pas) that hides the details of IEnumVARIANT. In order to plug TEnumVariantCollection into your collection object, you'll need to implement an interface with 3 simple methods: IVariantCollection = interface //used by enumerator to lock list owner function GetController : IUnknown; stdcall; //used by enumerator to determine how many items function GetCount : integer; stdcall; //used by enumerator to retrieve items function GetItems (Index : olevariant) : olevariant; stdcall; end; To see this in action, let's try it on our IFooItems interface: type //Foo items collection TFooItems = class (TSomeBaseClass, IFooItems, IVariantCollection) protected { IVariantCollection } function GetController : IUnknown; stdcall; function GetCount : integer; stdcall; function GetItems (Index : olevariant) : olevariant; stdcall; protected FItems : TInterfaceList; //internal list of Foo items; ... end; function TFooItems.GetController: IUnknown; begin 1337

//always return Self/collection owner here Result := Self; end; function TFooItems.GetCount: integer; begin //always return collection count here Result := FItems.Count; end; function TFooItems.GetItems(Index: olevariant): olevariant; begin //always return collection item here //cast as IDispatch because each Foo item is IDispatch-based Result := FItems.Items [Index] as IDispatch; end; Finally, we implement _NewEnum as follows: function TFooItems.Get__NewEnum: IUnknown; begin //use my TEnumVariantCollection helper class :) Result := TEnumVariantCollection.Create (Self); end; That's it! And say goodbye to that nagging For Each problem! In C++ Builder ATL provides a slew of COM enumerator classes for almost any IEnumWhatever that you can think of. In particular, CComEnum (and CComEnumImpl) are good enough to produce an IEnumVARIANT enumerator that makes VB happy. The general idea when using CComEnum together with IEnumVARIANT is to first produce an array of VARIANTs, then populate this array with our collection's items, then pass this array to an instance of CComEnum, and finally hand out CComEnum's IUnknown to the _NewEnum property. To see this in action, let's try it on our IFooItems interface: //implementation of property _NewEnum STDMETHODIMP TFooItemsImpl::get__NewEnum (LPUNKNOWN* Value) { //create VARIANT array VARIANT* varray = new VARIANT [ItemCount - 1]; //populate array with each Foo item for (int i = 0; i < ItemCount; i++) { VariantInit (&varray [i]); VariantCopy (&varray [i], WhereverYouStoreFooItem [i]); } //initialize CComEnum typedef CComEnum > MyEnumT; //create enumerator CComObject *Enum; CComObject ::CreateInstance (&Enum); //initialize our enumerator with our array 1338

Enum->Init ( &varray [0], //collection low bound &varray [ItemCount], //1 + collection high bound GetUnknown (), //collection owner's IUnknown AtlFlagTakeOwnership //means, Enum will be responsible for releasing varray ); //finally return enumerator's IUnknown to _NewEnum return Enum->QueryInterface (&Value); } If you've noticed, it can be a pain in the neck to create a temporary array of VARIANTs everytime we want to hand out IEnumVARIANT. This is because CComEnum expects a contiguous array of the exact data type of each element that we're dealing with (in this case VARIANT). ATL 3.0 alleviates this problem by allowing enumerator's to "sit" directly on top of a container (especially STL containers) eliminating the need for the temporary array. However, BCB 4 doesn't support ATL 3.0 yet, so we'll just have to make do with what we have. That's it! And say goodbye to that nagging For Each problem! 16. Know how to implement clients that iterate IEnumVARIANTbased collections (ala Visual Basic's For Each construct) In Visual Basic, there's something called a For Each construct that allows a client to easily enumerate an IEnumVARIANT-based collection (see tip above). Assuming that you have an object, Foo, that has an IEnumVARIANT-based property, Items, this is how we use VB's For Each syntax to iterate Foo.Items: Dim Foo as FooServer.Foo Dim Item as Variant Set Foo = CreateObject ("FooServer.Foo") For Each Item in Foo.Items call DoSomething (Item) Next In Delphi Is there an equivalent to For Each in Delphi? The answer is there's the hard way and the easy way. The hard way, obviously, is to familiarize yourself with IEnumVARIANT, specifically IEnumVARIANT.Reset and IEnumVARIANT.Next. The easy way is to use a class, TEnumVariant, that I created for such purpose. Since, in general, it is safe to assume that everybody wants the easy way, I'll show you how to use TEnumVariant against Foo.Items: uses ComLib; var Foo : IFoo; Item : olevariant; Enum : TEnumVariant; begin Foo := CreateOleObject ('FooServer.Foo') as IFoo; //or CoFoo.Create Enum := TEnumVariant.Create (Foo.Items); while (Enum.ForEach (Item)) do DoSomething (Item); Enum.Free; end; What could be easier than this?! In C++ Builder 1339

Is there an equivalent to For Each in CBuilder? The answer is there's the hard way and the easy way. The hard way, obviously, is to familiarize yourself with IEnumVARIANT, specifically IEnumVARIANT.Reset and IEnumVARIANT.Next. The easy way is to use a class, TEnumVariant, that I created for such purpose. Since, in general, it is safe to assume that everybody wants the easy way, I'll show you how to use TEnumVariant against Foo.Items: { TCOMIFoo Foo = CoFoo::Create (); TEnumVariant Enum (Foo->Items); Variant Item; while (Enum.ForEach (Item)) DoSomething (Item); } And here's the TEnumVariant class that you don't want to mess with: //supports IEnumVARIANT for IDispatch-based DISPID_NEWENUM properties class TEnumVariant { public: TEnumVariant () : mEnum (0) { } TEnumVariant (IDispatch *Collection) : mEnum (0) { Attach (Collection); } ~TEnumVariant () { Detach (); } void Attach (IDispatch *Collection) { Detach (); bool ValidEnum = false; if (Collection) { VARIANT Result; VariantInit (&Result); DISPPARAMS DispParamsEmpty; memset (&DispParamsEmpty, 0, sizeof (DispParamsEmpty)); //get prop DISPID_NEWENUM HRESULT hr = Collection->Invoke ( DISPID_NEWENUM, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, &DispParamsEmpty, &Result, NULL, NULL); if (SUCCEEDED (hr)) { //get IEnumVARIANT* Result.punkVal->QueryInterface (IID_IEnumVARIANT, (void**)&mEnum); VariantClear (&Result); Reset (); ValidEnum = (mEnum != NULL); } 1340

} //raise exception if collection does not support IEnumVARIANT if (!ValidEnum) throw Exception ("Object does not support enumeration (IEnumVariant)"); } void Detach () { if (mEnum) { mEnum->Release (); mEnum = NULL; } } void Reset () { if (mEnum) mEnum->Reset (); } bool ForEach (Variant &Data) { if (!mEnum) return false; ULONG Fetched = 0; VARIANT Item; VariantInit (&Item); HRESULT hr = mEnum->Next (1, &Item, &Fetched); if (SUCCEEDED (hr)) { if (Fetched > 0) { Data = Item; VariantClear (&Item); } return (Fetched > 0); } else return false; } protected: IEnumVARIANT *mEnum; }; 17. Know how to use aggregation and containment COM aggregation and containment are two techniques of reusing existing COM objects while still preserving the concept of COM identity. To see why you'd want to use aggregation or containment, consider this simple scenario: You bought 2 COM objects from a vendor, Foo (IFoo) and Bar (IBar). You then want to create your own object, FooBar, that exposes the facilities of Foo and Bar combined. In other words, your FooBar class will look something like this: IFoo = interface procedure Foo; end; 1341

IBar = interface procedure Bar; end; type FooBar = class (BaseClass, IFoo, //FooBar exposes IFoo IBar //FooBar exposes IBar ) end; What you want to do is to (re)use Foo when implementing your IFoo methods and to (re)use Bar when implementing your IBar methods. This is where aggregation and containment can help. Containment Let's start with containment first because that's easier. Containment is simply the process of instantiating an inner object (object to reuse) and then delegating method calls into that inner object. This is how we do containment for IFoo in FooBar: In Delphi type TFooBar = class (TComObject, IFoo) protected //IFoo methods procedure Foo; protected FInnerFoo : IFoo; function GetInnerFoo : IFoo; end; procedure TFooBar.Foo; var Foo : IFoo; begin //obtain internal Foo object Foo := GetInnerFoo; //delegate call to internal Foo object Foo.Foo; end; function TFooBar.GetInnerFoo : IFoo; begin //create internal Foo object if not yet initialized if (FInnerFoo = NIL) then FInnerFoo := CreateComObject (Class_Foo) as IFoo; //return internal Foo object Result := FInnerFoo; end; Doing something like this is not delegation and, thus, is not considered containment: type TFooBar = class (TComObject, IFoo) protected function GetInnerFoo : IFoo; property InnerFoo : IFoo read GetInnerFoo implements IFoo; end; The difference between this and the prior class is that in the prior class, TFooBar is the 1342

one exposing IFoo (and internally delegates implementation method-by-method to InnerFoo). In this class, it is InnerFoo's IFoo that the client actually sees, so no delegation is happening. In C++ Builder class ATL_NO_VTABLE TFooBar : public CComObjectRoot, public CComCoClass, public IFoo { protected: BEGIN_COM_MAP(TFooBar) COM_INTERFACE_ENTRY(IFoo) END_COM_MAP() //IFoo methods STDMETHOD (Foo) (); protected: IFoo *mInnerFoo; IFoo* GetInnerFoo (); public: void FinalRelease (); end; STDMETHODIMP TFooBar::Foo () { //obtain internal Foo object IFoo * Foo = GetInnerFoo (); //delegate call to internal Foo object Foo->Foo (); } IFoo* TFooBar::GetInnerFoo () { //create internal Foo object if not yet initialized if (mInnerFoo == NULL) { HResult hr = CoCreateInstance ( CLSID_Foo, NULL, CLSCTX_INPROC, IID_IFoo, (void**)&mInnerFoo); ErrorCheck (hr); } //return internal Foo object return mInnerFoo; } void FinalRelease () { //release inner Foo if (mFoo) { mFoo->Release (); mFoo = NULL; } } Note that the concept of containment is delegation! You simply forward/delegate all calls from the outer object into the inner object. 1343

Aggregation Implementing containment can be tedious because if the inner object's interface has a lot of methods, you'll have to do a lot of typing when delegating from the outer object ("owner" object) to the inner object. In other words, if IFoo has 20 methods, then you'll have to type all 20 methods into TFooBar and delegate each one of them to InnerFoo. Another thing about containment is that you have to explicitly know the inner's interface up-front so that you can delegate properly. This means that if the inner's interface evolves, you might need to revisit the outer and rebuild it in case you want to expose new functionality from the inner. These are some of the reasons why you might want to look at aggregation. Simply put, aggregation is the mechanism of directly exposing the inner to the client, while correctly preserving COM identity. The first rule about aggregation is that you can aggregate an inner object *only* if it supports aggregation. This means that the inner must know how to implement the delegating and the non-delegating QIs. To learn more about the details on the delegating and non-delegating QIs, consult Inside COM by Dale Rogerson. The second rule of aggregation is that when the outer constructs the inner, it should 10. Pass in it's (outer) IUnknown into the inner as part of the CoCreateInstance call, and 11. Ask for the inner's IUnknown, and only IUnknown In addition, it is recommended that the outer forwards a QI call to the inner only if the client asks for the inner's interface (some texts refer to this as planned aggregation). Assuming that Foo is aggregatable, this is how we aggregate Foo into TFooBar: In Delphi The QI forwarding for IFoo is easily implemented using Delphi's implements keyword. type TFooBar = class (TComObject, IFoo) protected function GetControllingUnknown : IUnknown; function GetInnerFoo : IFoo; property InnerFoo : IFoo read GetInnerFoo implements IFoo; //exposes IFoo directly from InnerFoo protected FInnerFoo : IUnknown; end; function TFoo.GetControllingUnknown : IUnknown; begin //returns the correct outer unknown for aggregation if (Controller <> NIL) then Result := Controller else Result := Self as IUnknown; end; function TFooBar.GetInnerFoo : IFoo; begin //create internal Foo object if not yet initialized if (FInnerFoo = NIL) then CoCreateInstance ( CLASS_Foo, //Foo's CLSID GetControllingUnknown, //outer passes it's controlling IUnknown into inner CLSCTX_INPROC, //assume Foo is inproc IUnknown, //ask for Foo's IUnknown, and only IUnknown 1344

FInnerFoo //output inner Foo ); //return internal Foo object Result := FInnerFoo as IFoo; end; When implementing the inner (aggregatable) object itself, Delphi's TComObject (root of all COM objects) has the aggregation feature built-in already. In simple terms, any COM object that ultimately derives from TComObject is aggregatable (supports aggregation). In C++ Builder You can simply use ATL's COM_INTERFACE_ENTRY_AGGREGATE macro to aggregate an inner into the outer's interface map. class ATL_NO_VTABLE TFooBar : public CComObjectRoot, public CComCoClass { protected: BEGIN_COM_MAP(TFooBar) COM_INTERFACE_ENTRY(IFoo) COM_INTERFACE_ENTRY_AGGREGATE(IID_IFoo, mInnerFoo) END_COM_MAP() //this is used for GetControllingUnknown!!! DECLARE_GET_CONTROLLING_UNKNOWN() protected: IUnknown *mInnerFoo; public: HRESULT FinalConstruct (); void FinalRelease (); end; HRESULT FinalConstruct () { //create inner Foo HRESULT hr = CoCreateInstance ( CLSID_Foo, //Foo's CLSID GetControllingUnknown (), //outer passes it's controlling IUnknown into inner CLSCTX_INPROC, //assume Foo is inproc IID_IUnknown, //ask for Foo's IUnknown, and only IUnknown (void**)&mInnerFoo //output inner Foo ); return hr; } void FinalRelease () { //release inner Foo if (mFoo) { mFoo->Release (); mFoo = NULL; } } When implementing the inner (aggregatable) object itself, ATL's CComCoClass has the aggregation feature built-in already. This is made possible because of the 1345

DECLARE_AGGREGATABLE () macro in CComCoClass. For a detailed discussion on ATL aggregation support, consult ATL Internals by Brent Rector and Chris Sells. In simple terms, it is safe to assume that any COM object that ultimately derives from CComCoClass is aggregatable (supports aggregation) by default. That's it for aggregation. And don't forget, aggregation only works if the inner is written to support aggregation. If it's not, then aggregation is the wrong choice, whereas containment would be a right choice. 18. Understand the class factory Instancing property (SingleInstance, MultiInstance) A lot of folks get confused with the class factory Instancing property. This is probably because of reading incorrect documentation and/or listening to incorrect advise. In fact, the COM documentation (on MSDN, for instance) is very clear about the instancing property - and that's where everyone should be reading about instancing from. Let's translate COM instancing into lay terms. 1. The class factory Instancing property applies *only* to EXE servers. For DLL servers, Instancing is undefined and inapplicable! 2. The class factory Instancing property is not a property of the EXE server nor the COM object. It does not dictate, per se, how EXE servers are launched depending on client requests. So forget about those confusing "one object per server or multiple objects per server" rules. This is what Instancing really means: Each object in your server that a client can create has an associated object called a factory object (or class factory). If your server consists of 2 objects, Foo and Bar, there will be a class factory for Foo and another class factory for Bar. Whenever the client requests to create an object in your server, COM will actually ask the associated class factory to create the object. In effect, the class factory is a gatekeeper for object creation through COM. Class factories are registered with the COM runtime when an EXE server runs (and they are revoked when the server terminates). Registration allows, among others, COM to locate and request any given registered class factory to create the object that the client requests. COM allows each class factory to register using 3 instancing modes: SingleUse, MultiUse, and MultiSeparateUse. We'll only talk about SingleUse and MultiUse because these are the 2 common ones. SingleUse means that COM will request the class factory to create *at most 1 instance* of the it's associated object. After a SingleUse class factory has created its one instance, COM will revoke it from runtime. Thus, when the next client comes along and requests to create an object from this class factory, COM sees that it's no longer registered and will launch another instance of the EXE server to be able to obtain the class factory again. Relaunching repeats the process: factories get registered again, COM finds the factory, requests it to create the object and then, if it's SingleUse, immediately revokes the factory from runtime. This cycle just keeps on going and going. MultiUse, on the other hand, means that COM will request the class factory to create *however many instances* of it's associated object. This means that, unlike SingeUse, COM will not revoke the factory from runtime at all. Thus, when the next client comes along and requests to create an object from this class factory, COM will always see that it's still registered and will happily create the object using the class factory from within the currently running EXE instance. In Delphi In Delphi terms: ciSingleInstance = SingleUse ciMultiInstance = MultiUse And ciInternal has nothing to do with COM. ciInternal simply means that your Delphi COM object doesn't get registered into the registry nor does the class factory get 1346

registered with the COM runtime. In effect, clients won't be able to see (and create) COM objects marked with the ciInternal factory instancing flag. I've always used this definition of class factory Instancing and I've never been confused! Ever! 19. Know how to implement servers that support GetActiveObject If you've been working with MS Office automation, you're probably familiar with the global "Application" object per server. For instance, MS Word allows you to connect to it's running Application (_Application interface) instance as follows: var Word : variant; begin //connect to running instance of Word if available //GetActiveOleObject will raise an exception if there is no active instance of Word Word := GetActiveOleObject ('Word.Application'); end; This facility can sometimes be useful when developing your own COM servers. Here's how we can do this type of thing. First, in your server, you'll need to register an instance of your global Application object with something called the COM Running Object Table (ROT). The ROT is nothing but a location where you register named object instances to be accessible by client applications. We can easily get our Application object into the ROT using the RegisterActiveObject API: function RegisterActiveObject ( unk: IUnknown; //object to register const clsid: TCLSID; //CLSID of object to register dwFlags: Longint; //registration option flags, generally use ACTIVEOBJECT_STRONG out dwRegister: Longint //handle returned by COM on successful registration ): HResult; stdcall; And, as you might have already expected, you can later revoke a registered object from the ROT to make it unavailable to clients. Revoking is done using the RevokeActiveObject API: function RevokeActiveObject ( dwRegister: Longint; //registration handle obtained from calling RegisterActiveObject pvReserved: Pointer //set to NIL/NULL ): HResult; stdcall; Practically speaking, registering an object into the ROT means that your server should not terminate at least until after you revoke it from the ROT. But the question is, who should (or when should you) revoke the object from the ROT? The practical convention seems to be that the object should revoke itself in response to a Quit (or Exit) command call from the client. This practice is apparent in the MS Office applications. In other words, in your global Application object, you'll probably want to expose a Quit method and in that method, call RevokeActiveObject to remove your global object from the ROT. The actual conventions on when to call RegisterActiveObject and RevokeActiveObject are documented by Microsoft. For more details on this, check out the Automation Programmer's Reference. On a different note, all this stuff about registration into the ROT is only practical for EXE servers. For a DLL server, it might be a bit more tricky to determine when to register/revoke an object from the ROT because the lifetime of a DLL server is dependent on the client host. Assuming that we want a global Foo object to be accessible from the ROT, here's how we implement it: In Delphi In your DPR file: 1347

begin Application.Initialize; RegisterGlobalFoo; Application.CreateForm(TForm1, Form1); Application.Run; end. var GlobalFooHandle : longint = 0; procedure RegisterGlobalFoo; var GlobalFoo : IFoo; begin //create Foo instance GlobalFoo := CoFoo.Create; //register into ROT OleCheck (RegisterActiveObject ( GlobalFoo, //Foo instance Class_Foo, //Foo's CLSID ACTIVEOBJECT_STRONG, //strong registration flag GlobalFooHandle //registration handle result )); end; Then we add a Quit method to Foo (IFoo) and revoke the GlobalFoo instance from there: procedure TFoo.Quit; begin RevokeGlobalFoo; end; procedure RevokeGlobalFoo; begin if (GlobalFooHandle <> 0) then begin //revoke OleCheck (RevokeActiveObject ( GlobalFooHandle, //registration handle NIL //reserved, use NIL )); //make sure we mark as revoked GlobalFooHandle := 0; end; end; Here's how a Delphi client locates our GlobalFoo from the ROT using the GetActiveObject API: var FooUnk : IUnknown; Foo : IFoo; begin //check if Foo is active //can also use Delphi's GetActiveOleObject function here if Foo is an automation object if (Succeeded (GetActiveObject ( 1348

Class_Foo, //Foo's CLSID NIL, //reserved, use NIL FooUnk //returned Foo from ROT ))) then begin //QI for IFoo Foo := FooUnk as IFoo; //...do something with Foo here... //terminate global Foo, will revoke from the ROT Foo.Quit; end; end; Delphi also has a GetActiveOleObject function that accepts a PROGID instead of the object's CLSID. GetActiveOleObject internally calls GetActiveObject, and only works for automation (IDispatch-based) objects. In C++ Builder In your server's main CPP file: WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) { try { Application->Initialize(); RegisterGlobalFoo (); Application->CreateForm(__classid(TForm1), &Form1); Application->Run(); } catch (Exception &exception) { Application->ShowException(&exception); } return 0; } static DWORD GlobalFooHandle = 0; void RegisterGlobalFoo () { //create Foo instance TCOMIFoo GlobalFoo = CoFoo::Create (); //register into ROT HRESULT hr = RegisterActiveObject ( GlobalFoo, //Foo instance CLSID_Foo, //Foo's CLSID ACTIVEOBJECT_STRONG, //strong registration flag &GlobalFooHandle //registration handle result ); ErrorCheck (hr); } Then we add a Quit method to Foo (IFoo) and revoke the GlobalFoo instance from there: STDMETHODIMP TFooImpl::Quit() { RevokeGlobalFoo () 1349

RevokeGlobalFoo (); return S_OK; } void RevokeGlobalFoo () { if (GlobalFooHandle != 0) { //revoke HRESULT hr = RevokeActiveObject ( GlobalFooHandle, //registration handle NULL //reserved, use NULL ); ErrorCheck (hr); //make sure we mark as revoked GlobalFooHandle = 0; } } Here's how a CBuilder client locates our GlobalFoo from the ROT using the GetActiveObject API: { IUnknown *FooUnk = NULL; IFoo *Foo = NULL; //check if Foo is active HRESULT hr = GetActiveObject ( CLSID_Foo, //Foo's CLSID NULL, //reserved, use NULL &FooUnk //returned Foo from ROT ); if (SUCCEEDED (hr)) { //QI for IFoo FooUnk->QueryInterface (IID_IFoo, (void**)&Foo); FooUnk->Release (); //...do something with Foo here... //terminate global Foo, will revoke from the ROT Foo->Quit (); Foo->Release (); } } 20. Know how to implement an object property that supports the automation default-property syntax Assuming you created an automation interface like this: ICollection = interface (IDispatch) property Item [Index : variant] : variant; end; For a client, given an ICollection pointer, you can get to any item using this syntax: Collection.Item [Index] You might have come across other automation-based collections where they let you be lazy and do something like this instead: 1350

Collection [Index] Allowing clients (particularly VB clients) this syntax can be very convenient specially if you have deep levels of hierarchies of collections. To understand what I mean, compare this: Collection.Item [Index].SubCollection.Item [Index].SubsubCollection.Item [Index] to this simpler syntax: Collection [Index].SubCollection [Index].SubsubCollection [Index] Fortunately for us, automation allows us to easily do this kind of thing. In the type library, simply mark your Item [] property with a dispid value of 0 (DISPID_VALUE). This means that COM will automatically "hint at" the Item [] property as the default property of your collection. Since this default property facility is based on dispids, this only works for automation (IDispatch-based) interfaces. For pure vtable interfaces, there is no such thing as default properties - so you can forget about this :).

1351

Building ActiveX Controls with Delphi 3 by Conrad Herrmann

Contents Introduction What is ActiveX™? Types of ActiveX Controls Why Should I Build an ActiveX control? The Structure of an ActiveX Server Library The first steps are the easiest: Generating an ActiveX Library Using the ActiveX Control Wizards A First Example: Making TButton into an ActiveX control. What the Wizard Generates The ActiveX Project File The DAX Architecture The ActiveX Control Implementation File The Type Library Advanced Features Per-property Browsing Custom Object Streaming Adding verbs to a control Adding Property Pages to an ActiveX Control Accessing Ambient Properties Adding Custom Registry Entries Web Deployment and Code Signing Data-aware controls Conclusion Further Reading

Introduction This course is about how to build an ActiveX control using Delphi 3. In addition to presenting a tutorial on how to use Delphi 3's wizards to convert an existing VCL control into an ActiveX control, the course introduces areas where the control designer may want to extend the basic code, and provides in-depth explanation of Delphi's DAX class hierarchy.

Who should take this class? This class is for Delphi developers who are interesting in taking their Delphi programs or business objects across the Internet or into an Intranet. It is also for programmers who want to take their Delphi-written components to an audience that uses VB, PowerBuilder or some other development environment. The course is a programming tutorial. Students are expected to be familiar with the Delphi component model, and have an introductory knowledge of Microsoft COM. While they are not expected to be familiar with Delphi's interface syntax and class hierarchies, the course will not cover these in detail even though they are foundation material. Students are not required to be familiar with the ActiveX Control specifications and interfaces, and will be insulated from most of these details. Instead, the course will focus on Delphi's ActiveX Control class hierarchy and the wizards used to generate new ActiveX control components.

1352

What is ActiveX™? ActiveX is the brand name for Microsoft's component object model. Components are objects (in the conventional sense) with some special capabilities that allow them to be easily combined into an application. Regardless of the model used to implement them, components have properties, methods, events, and can load and save their properties to/from a definition file. Traditional objects exist only at compile time (where they are really just symbol table entries in the mind of the compiler) and at runtime (where they're fully active and interacting with the user), but components also support design-time operation. A control in design mode usually is like one at runtime except it has restricted behavior and its primary methods and events aren't active. Some design-time controls have augmented capabilities not available at runtime, such as showing property-editor dialogs. Controls that are invisible at runtime are visible at design-time, so the user can interact with the control. Components make programming easier than traditional OO languages because they allow the programmer to replace code statements with specifications. Instead of entering code to create an object and choosing the right constructor to initialize the object, you simply drag and drop the object onto its container (a form or other logical container, like a data module) and set its creation properties using a property editor. This not only makes the programming easier, it also makes learning how to use a new object much easier. The ActiveX component object model provides all these basic facilities and varies only slightly from the Delphi object model's capabilities. For example, Delphi has no property pages but does have property editors. The primary technical difference stems from how the components are written. Delphi's component model assumes language support from the Object Pascal compiler (or C++Builder) as well as using helper code from the Delphi runtime library. As a result, while programming is easy the binary details are less formalized. This is an intentional choice on the part of Delphi's designers-it's the compilers responsibility to create the appropriate connecting code and runtime type information (RTTI) for objects. The ActiveX component model is designed to be language-independent and highly version-resilient in object form. The developer (perhaps with the help of wizards; perhaps a wizard himself) was expected to write all the code to satisfy the component model's requirements. As a result, the COM specification provides much less meat, but is more highly formalized-Microsoft has published three or four big volumes documenting the specification and updated the spec several times.

Types of ActiveX Controls ActiveX defines several component patterns, each of which has characteristics that make it appealing for specific situations. Which type you're interested in building depends on the capabilities the control will be expected to have, and how you intend to use the component. ActiveX Control An ActiveX Control most closely resembles the TWinControl descendants found in Delphi. The control is intended to be inserted into a form-like container, it has a window, can be automated via properties and methods, it can fire events to its container, save its state to storage provided by its container and restore a saved stated. ActiveX Controls often provide a set of property pages that allow the user to edit the saved state, and supports property inspectors via a property-browsing interface. Non-visual ActiveX Control A non-visual control is not visible to the user at runtime. This component is most closely related to Delphi's TComponent, which is the base class of all the non-visual controls like TQuery. The control does not create a window at runtime, but it usually does at designtime so the user can manipulate it with a mouse. Data-bound ActiveX Control. 1353

This control is also like a standard ActiveX control, except that it receives some data from a data source. The data source is usually a field in a database, but it really could be from any source. Usually, a specific property (often named "Text" or "Value") is bound to the current value of the data source. Design-time controls A new feature of ActiveX Controls, this pattern allows the design-time behavior of a control to be separated from the runtime code. The two are built into separate libraries, and the runtime code is usually much smaller than the design-time code. This shrinks the size of the runtime module, which can be very beneficial when the code needs to be downloaded over the Internet. For commercial vendors, it also guarantees that the end-user can't use the control's design environment without purchasing it. Internet data controls These controls, which are in other ways normal ActiveX Controls, are designed to download data from a remote Internet site. An example of this might be a picture control with a property called Source that is an URL string. Internet data controls can download data asynchronously and update their display as the data arrives. The picture viewer control starts up empty and displays the picture in blocks as data blocks arrive over the Net. Downloadable controls These controls can be downloaded from an Internet site and installed locally. They contain a signature that identifies the control's author. They also implement behavior that determines whether the control can be trusted to not do something undesirable if it receives untrusted data or is scripted inside a Web page that contains untrusted scripts. ActiveForms An Active Form is really just an ActiveX-ified representation of a Delphi TForm. It's primarily intended as a delivery vehicle for an entire application function within an Intranet, and can be used to integrate Delphi applications seamlessly with a corporate Web. ActiveForms can make use of the Delphi VCL to bring up dialogs, and can connect to remote data or business object servers. ActiveDocument An Active Document is really a pair of objects based on the document-view design pattern, and is the most direct descendant of the original OLE specification. ActiveDocs contain code to read a document out of a file and to display and/or edit the data in a window. Non-windowed controls These are extremely lightweight ActiveX controls that don't create a window handle even though they do have a visual representation. These correspond to the VCL's TGraphicControl class in Delphi.

Why Should I Build an ActiveX control? Delphi directly supports building ActiveX Controls, ActiveForms, and downloadable controls using wizards, the DAX class framework and its documentation. But since Delphi already comes with its own complete object model, why would you want to create ActiveX components? If you pay heed to Microsoft's messaging, there really are two reasons why you should be interested in building ActiveX components: Visual Basic and Internet Explorer. I you prefer to focus on technical reasons to build an ActiveX component, the language independence is the main thing. Components built for ActiveX can be used in a wide variety of programming environments on Windows, not just Delphi or C++Builder. This means you can build business objects that can be reused across your organization by people using PowerBuilder, VB or other tools.

1354

ActiveX Limitations Although the ActiveX model offers significant advantages, there are still ways in which it can be better to stick with Delphi's native VCL model:

No containership hierarchy An ActiveX component has no standardized means of locating one of its peers. Components speak only to their container, and there exists no standard allowing an object to inquire about another object. This doesn't mean that controls cannot communicate with other objects, only that the object's container must a specialized broker for this process. For example, ActiveX data-bound controls are given their data by their containers, unlike in Delphi where the control asks its container to locate a component with the same name as the DataSource property.

No property inspectors ActiveX relies heavily on property pages for editing properties, rather than Delphi's notion of property inspectors. The main difference is that property pages can edit multiple properties, whereas property editors don't usually edit multiple properties.

No smart linking of components into the executable ActiveX controls are independent OLE libraries (usually, DLLs), which means they can't be linked into your program and must be registered separately. This can make them inconvenient to install and makes yet another thing the end user must think about when uninstalling. It also leaves a possible installation conflict, if two programs install two different versions of the same library, and the two libraries are inadvertently incompatible with each other. Perhaps more importantly, once the ActiveX libraries are linked you carry all the code around in the DLL even if your program doesn't use it all. When you use Delphi's native VCL controls, the smart linker will remove unused code, slimming the resulting executable significantly.

The Structure of an ActiveX Server Library For the purposes of this class, an ActiveX server library is really just a Windows DLL, with some specific requirements: 1. It must export the following functions: DllRegisterServer, DllUnregisterServer, DllGetClassObject and DllCanUnloadNow. Any other functions are allowed, too. 2. The server contains class factories, one per component class. An application asks for the appropriate factory by calling the DllGetClassObject function. 3. It provides the object implementations. Each factory has a CreateObject method that creates and returns an instance of a component. The code to implement the component is contained in the DLL. 4. It contains some special resources in the same DLL. These are: · a small bitmap that is used to represent the control on a tool palette. · A type library. · Version information. 5. The DLL optionally is stamped with a code signature identifying the control's author.

Libraries, Controls, and Multi-control libraries Delphi gives you three options when creating an ActiveX control. You can create a blank library with no controls, add a control to an existing library, or combine both steps and create an ActiveX library with an initial control. The reason for this is that while it is convenient to produce the library and the control in the same step, you may want to insert

1355

multiple controls into the same library. Also, an ActiveX server library can contain other kinds of OLE objects besides controls, including property pages, automation objects, etc.

The first steps are the easiest: Generating an ActiveX Library Using the ActiveX Control Wizards Since the Delphi Components and ActiveX components share many semantics and differ only in implementation, making an ActiveX Control out of a VCL is really just a matter of making a translation layer on top of the VCL implementation. This layer makes Delphi properties and methods look like OLE automation methods, makes Delphi events look like OLE Object events, and makes a VCL control look like an ActiveX server. The conversion process involves specifying the automation and event interfaces and the object's ClassID, and then wrapping the whole thing up in an ActiveX server library. It also involves writing short adapter routines for each of the properties, methods and events to convert OLE-style calls to Delphi and vice versa. This part is not intellectually challenging but can become time consuming if your control has a 50-100 properties, methods and events as many do. Fortunately, Borland provides an wizard to automate the entire production of an ActiveX Control from the Delphi VCL. The wizard uses CodeInsight™ technology to parse out the properties, methods and events from a VCL control, then generates appropriate code for their ActiveX versions. Thanks to a few new wizards, generating an ActiveX control is very simple. The basic steps are: 9. Build a normal Delphi component, based on TWinControl. Make sure the control is installed in your control palette. 10. Go to the ActiveX wizards page in the Object Repository (see Figure 1) and choose "ActiveX Control." Delphi presents you with a wizard page (see Figure 2) where you choose the VCL control to derive from and fill in other information. For the VCL class name, choose the class you just installed. The dialog also presents a number of checkbox options. 11. When you press OK, the wizard generates the code needed to implement the ActiveX control and adds the code to a project. If the current project is already an ActiveX library, then the wizard adds the control to the current project. If the current project is not an ActiveX project, then the wizard offers to create a new project to contain the ActiveX control. 12. Build the project. You now have an ActiveX control. 13. Register the control in the system, using the Run|Register ActiveX Server command. Registering is something you only need to do when you first create the control, or when you change the control's information that would be stored in the registry,

1356

Figure 1. The ActiveX page of the Object Repository

Figure 2. The ActiveX Control Wizard dialog box

A First Example: Making TButton into an ActiveX control. In order to explain the code generated by the ActiveX wizard, we first have to have an example control to examine. In the following sections, I'll use TButton as a simple example. Applying the above steps for creating an ActiveX control to the TButton control yields the following steps: 8. Make sure TButton is installed on the palette. This is easy since it's the way Delphi comes installed. 9. Choose File|New, select the ActiveX page and choose ActiveX Control. Press OK. In the wizard dialog, choose TButton as the VCL class name. The wizard automatically fills in the ActiveX name as ButtonX, the implementation unit as ButtonImpl1.pas, and the project name as ButtonXControl.dpr. The control options are all unchecked. Accept these defaults and press the OK button. 10. The wizard informs you that since the current project is not an ActiveX project, it needs to create a new project. Answer OK. Now the wizard generates all the code for your project and control. 11. Build the project. There is now a file called "ButtonXControl.ocx" on your machine. 12. Register the control in the system, using the Run|Register ActiveX Server command. If successful, Delphi pops up a message saying "Successfully registered ActiveX server, 'c:\delphi3\ButtonXControl.ocx.'"

What the Wizard Generates To understand what the ActiveX control hierarchy and the wizard actually do, I'll walk through the code generated by the wizard when you make a new control out of a TButton component. The wizard generates: 12. A project file (ButtonXControl.dpr). 13. An ActiveX server implementation file that contains: · Automation interfaces and method implementations for the ActiveX control. The interfaces and methods map to those properties and methods of the VCL control that can be mapped to OLE. · Event interfaces and proxy implementations that map from the VCL events to the ActiveX protocols. 1357

·

Class registry information and a factory object that allows the object to be registered and created by COM. 14. A type library (.tlb) file that is imported into the project. 15. A Pascal version of the type library.

The ActiveX Project File The wizard generates the project file, ButtonXControl.dpr, shown here. I've inserted commentary into the code, so the best way to proceed is to read through the code from top to bottom. library ButtonXControl;

The library clause defines that the project produces a DLL file called 'ButtonXControl'. uses ComServ, ButtonImpl1 in 'ButtonImpl1.pas' {ButtonX: CoClass};

Since the library implements an ActiveX component called 'ButtonX', the line tells Delphi to include the control's implementation in the project DLL. The {ButtonX: CoClass} comment tells Delphi that ButtonImpl1 contains a class implementation that implements the CoClass 'ButtonX' from the type library. This comment helps the Delphi IDE keep the type library and the object's implementation in sync when you edit the type library. exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer;

This clause specifies that the library exports the standard ActiveX server functions. These functions are implemented in ComServ, listed above in the uses clause, so you don't have to worry about implementing them. {$R *.TLB}

The {$ *.TLB} directive tells the linker to include the type library file as a resource into the DLL. {$R *.RES}

This tells the linker to include the project's resources. This includes at least one toolbar bitmap and optionally a version information resource. {$E ocx}

The {$E ocx} directive tells the linker that the output filename's extension should be ".OCX". begin end.

The DAX Architecture Before diving into the actual ActiveX control implementation, it would be worthwhile to describe the general architectural model used to implement an ActiveX control. In the DAX model, an ActiveX control is really built with three cooperating objects: the factory, an ActiveX controller object, and the VCL control. These objects in turn interact with objects they find in their environment: · the factory interacts with CoCreateInstance and other OLE runtime functions, and creates a controller object. · the controller object interacts with an ActiveX container and site, can be automated by an ActiveX script engine, manipulates the VCL control, and forwards events that the VCL control fires to its container site; · the VCL object interacts with and is embedded into its parent window, and fires events back to the controller object. Figure 3 shows a diagram of the three objects and their relationship to each other and their environments.

1358

Figure 3. The DAX object architecture Delphi's VCL class frameworks provide classes that implement these relationships: TActiveXFactory, TActiveXControl, and TWinControl. To implement a class derived fromTWinControl, you will need to create a new controller class derived from TActiveXControl. This class is the subject of the next section.

The ActiveX Control Implementation File This file contains the main implementation code of our ActiveX control's ActiveX controller object. This is the object that defines an automation interface and implements the OLE automation-style properties, methods and events. Let's walk through the file and examine the interesting lines of code: unit ButtonImpl1; interface uses Windows, ActiveX, Classes, Controls, Graphics, Menus, Forms, StdCtrls, ComServ, StdVCL, AXCtrls, ButtonXControlLib;

The ActiveX unit is the unit that defines all the system interfaces and data types. It's like the OLE2 unit in Delphi 2, except that it's implemented using the new language features. The OLE2 unit is still around for compatibility with older code, but any new ActiveX code you write should be written using ActiveX. AXCtrls defines the Delphi ActiveX class hierarchy, also called DAX. The ButtonXControlLib unit is the Pascal-language version of the server's type library. It defines all the interfaces that are available to any object in the server. Normally you would never edit this file, since it is regenerated from the type library every time you edit and save the type library. Instead, you should edit the type library directly using Delphi's Type Library Editor. type TButtonX = class(TActiveXControl, IButtonX)

This clause defines an object type, TButtonX, that will be used to implement the controller object. TActiveXControl is the base class of all ActiveX controls and is implemented in the AXCtrls unit. The statement also says that the class implements IButtonX, which is the control's automation interface defined in the type library. private { Private declarations } FDelphiControl: TButton;

This private member points to the VCL control. It gets initialized in the InitializeControl method, below. In code that appears below, this member is used to get and set properties, call methods, and do other operations on the VCL object. FEvents: IButtonXEvents;

This is a pointer to the container's event sink. IButtonXEvents is a dispinterface, not a dual interface, so what is stored is really an IDispatch pointer. This value gets set when the EventSinkChanged method is called, when the control is inserted or removed from a container. FEventSink can be nil at various points in your program's execution, so always be aware of this. In fact, your control could be inserted into a container that cares nothing about events, so FEventSink could be nil all the time. Note that while the DAX class library supports multicast events, it is far easier to write your control to fire unicast events. This works fine for ActiveX controls, where the control is likely to fire events only to its container. procedure ClickEvent(Sender: TObject); procedure KeyPressEvent(Sender: TObject; var Key: Char);

These are declarations for the event handler proxies. I'll discuss these below, where they are implemented. protected { Protected declarations } procedure InitializeControl; override; procedure EventSinkChanged(const EventSink: IUnknown); override; procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;

1359

The preceding three methods declare implementations of three overridable virtual methods. These are discussed below. function function function function function function function function function function

Get_Cancel: WordBool; safecall; Get_Caption: WideString; safecall; Get_Cursor: Smallint; safecall; Get_Default: WordBool; safecall; Get_DragCursor: Smallint; safecall; Get_DragMode: TxDragMode; safecall; Get_Enabled: WordBool; safecall; Get_Font: Font; safecall; Get_ModalResult: Integer; safecall; Get_Visible: WordBool; safecall;

These methods are property getter methods for the control. These methods come from the IButtonX interface. Note that all these automation methods are declared using the safecall calling convention. Safecall is the ObjectPascal convention used for declaring dual interface compatible automation methods. Safecall guarantees that if an exception is thrown it will be caught and returned as an OLE error, following OLE calling conventions. It also copies the return value into a return parameter slot, which is declared as an out parameter in the type library. procedure Click; safecall;

This method is the only public method a TButton exposes that can be published via OLE automation. Most of TButton's public methods are internal to VCL's implementation or don't make sense for the object to provide for automation. For example, the SendToBack method, which is public in TButton's ancestor class TWinControl, is a method that should be provided by the container. This method is first declared in the IButtonX interface. procedure procedure procedure procedure procedure procedure procedure procedure procedure procedure

Set_Cancel(Value: WordBool); safecall; Set_Caption(const Value: WideString); safecall; Set_Cursor(Value: Smallint); safecall; Set_Default(Value: WordBool); safecall; Set_DragCursor(Value: Smallint); safecall; Set_DragMode(Value: TxDragMode); safecall; Set_Enabled(Value: WordBool); safecall; Set_Font(const Value: Font); safecall; Set_ModalResult(Value: Integer); safecall; Set_Visible(Value: WordBool); safecall;

These methods are the property setter methods for the control, and are also defined in the IButtonX interface. They each take a single parameter, which is the new value for the property. end; implementation { TButtonX } procedure TButtonX.InitializeControl;

This method is called after the control is created, but before the control is shown or inserted into its container. The main purpose of this method is to establish the connection between the COM controller object and the VCL object. In the implementation of this virtual method, the controller gets a pointer to the VCL object, and then hooks its event proxies into the VCL object. begin FDelphiControl := Control as TButton;

Control is a property (of type TWinControl) declared in TActiveXControl, that is initialized before InitializeControl is called. Of course, it really points to a TButton control, since that's what we want this ActiveX control to implement. This line of code coerces the TWinControl pointer back into a TButton, and stores that pointer in this object. FDelphiControl.OnClick := ClickEvent; FDelphiControl.OnKeyPress := KeyPressEvent;

These lines bind the VCL events in the control to this object's event handler proxy methods. This ensures that when the VCL control fires events, this object will receive 1360

them. I'll describe the detail in the ClickEvent and KeyPressEvent implementations, but obviously the control will forward the event to its container, using the ActiveX event protocol. Bug: The wizard should have generated code for the standard events, and should have bound OnKeyPress to TActiveXControl.StdKeyPressEvent, and OnClick to StdClickEvent. By the time you read this, a fix may be available for the wizard. end; procedure TButtonX.EventSinkChanged(const EventSink: IUnknown); begin FEvents := EventSink as IButtonXEvents;

This code receives the event sink that the container provided, and remembers it in the FEvents member. FEvents will be used later to fire events to the object's container. IButtonXEvents is the control's event dispinterface, which is declared as the default source interface in the type library. end; procedure TButtonX.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); begin { Define property pages here. Property pages are defined by calling DefinePropertyPage with the class id of the page. For example, DefinePropertyPage(Class_ButtonXPage); }

This protected method starts with no actual implementation code. It provides you with a means of enumerating the property pages that you want shown for your control. Since your project initially has no property pages, this method is left blank, with instructions on how to fill it in. I'll come back to this topic later, when we discuss property pages. end;

Implementing Property Get and Set Methods The following are typical property getter and setter methods. All of these follow the same basic pattern: they're safecall OLE automation method implementations for property get and set calls. Since the only thing you have to do to set a property in Delphi is to assign the value, most of these methods look like the following two methods: function TButtonX.Get_Cancel: WordBool; begin Result := FDelphiControl.Cancel; end; procedure TButtonX.Set_Cancel(Value: WordBool); begin FDelphiControl.Cancel := Value; end;

There are a number of cases where the property accessor code may be more complicated. When the data type of the property is an integer-derived type, the value parameter in a setter function is passed in as a SmallInt. Your code needs to typecast this number into the appropriate Pascal type type before assigning it to a Pascal property. For example, the Cursor property is of type TCursor, which is declared: type TCursor = -32768..32767;

The implementation of Cursor's getters and setters look like this: function TButtonX.Get_Cursor: Smallint; begin Result := Smallint(FDelphiControl.Cursor); end; procedure TButtonX.Set_Cursor(Value: Smallint); begin FDelphiControl.Cursor := TCursor(Value); end;

1361

ActiveX string properties (BSTRs) are compatible with Delphi's WideString type, and must be used even if the VCL component exposes a property as an AnsiString. You can do this by converting the AnsiString value to a WideString in the getter function, and vice versa in the setter function. (in this example, remember the TCaption type is a synonym for String). function TButtonX.Get_Caption: WideString; begin Result := WideString(FDelphiControl.Caption); end; procedure TButtonX.Set_Caption(const Value: WideString); begin FDelphiControl.Caption := TCaption(Value); end;

Another interesting case concerns properties that have complex OLE types, such as fonts, pictures, and string lists. Since a font is a separate object that has a dispatch interface, it can be modified independently of the control, and the control needs to refresh appropriately when this happens. For example, you could say in VB: myFont = control.Font myFont.Facename = 'Arial'

In this case, the control needs to change its font to Arial and refresh the display. This necessitates that the Get_Font method should create and return an OLE object that can expose the properties of the font as OLE properties. Conversely, setting the VCL's property in the TFont variable should update the OLE font. Fortunately, the DAX library provides builtin functions for handling these common types. The font property's getter and setter method implementations demonstrate the use of the GetOleFont and SetOleFont functions. function TButtonX.Get_Font: Font; begin GetOleFont(FDelphiControl.Font, Result); end; procedure TButtonX.Set_Font(const Value: Font); begin SetOleFont(FDelphiControl.Font, Value); end;

You'll notice that the ActiveX Control wizard does not generate a complete list of all the properties that TButton publishes to the Delphi form designer. The wizard has decided that the Height, HelpContext, Hint, Left, Name, ParentFont, ParentShowHint, PopupMenu, ShowHint, TabOrder, Tag, Top and Width properties should not be exposed to OLE automation, because they don't make sense for an ActiveX control. This can be because the container implements the behavior itself using extended properties (in the case of position and tabbing properties), because ActiveX containers do not implement the behavior (ParentFont, HelpContext and hints), or because the property type is not standard OLE property type (PopupMenu). The TActiveXControl class also contributes a number of property accessors for the properties available to any TWinControl. These include the following properties: BackColor, Caption, Enabled, Font, ForeColor, HWnd, TabStop, and Text.

Implementing Methods Passing on automation methods to the VCL control is fairly straightforward. Simply call the appropriate method in the VCL control that is kept in FDelphiControl. Methods that have parameters may need to be modified, but this control doesn't have any. procedure TButtonX.Click; begin FDelphiControl.Click; end;

1362

Event Handling The following two methods demonstrate how a Delphi-style event handler forwards an event to the object's container. The event handlers are connected to the VCL control in the InitializeObject method, above. procedure TButtonX.ClickEvent(Sender: TObject); begin if FEvents <> nil then FEvents.OnClick;

This implementation simply passes on the event to the container's event sink, if it has been installed. FEvents was set in the EventSinkChanged method described above. FEvents is a dispinterface, which means it is really just an IDispatch pointer. Historical note: When I first implemented this, FEvents was a Variant from Delphi 2 until the compiler folks had dispinterfaces working properly. Calling a method on a dispinterface works just like calling a method on a Variant that contains an IDispatch pointer, but there are two key differences. The first is performance: calling through a dispinterface binds the method's dispid at compile-time, eliminating the sometimes costly GetDispIDsOfNames call. The second difference is that while ActiveX control containers expose their event sinks using an IDispatch pointer, in this case the IDispatch implementation is not required to implement GetDispIDsOfNames at all! It turns out that some containers do implement this code, but most do not. If you want your event firing to work in all containers, you must use dispinterfaces to fire the events. end; procedure TButtonX.KeyPressEvent(Sender: TObject; var Key: Char); var TempKey: Smallint; begin

In a this case, the parameters expected for OLE events are not the same as for the Delphi events. In these cases the event handler proxy may need to massage the event's parameters before firing the event to the container. In this case, the OnKeyPress event passes a pointer to a SmallInt to the container, but the Delphi control passes a pointer to a Char to the event handler. OLE events don't have a Sender parameter, so that parameter is dropped before passing on the event to the parent. TempKey := Smallint(Key); if FEvents <> nil then FEvents.OnKeyPress(TempKey); Key := Char(TempKey); end;

TActiveXControl contributes handlers for common events like Click, DblClick, KeyDown, KeyPress, KeyUp, MouseDown, MouseMove, and MouseUp. initialization TActiveXControlFactory.Create( ComServer, TButtonX, TButton, Class_ButtonX, 1, '', 0);

This line of code, which gets executed when the library is loaded, creates the class factory (based on the class, TActiveXControlFactory) for the control. ComServer is a global variable that represents the library itself. Among other things, the ComServer contains a list of all the factories that have been created in the library. The other parameters to the factory are: TButtonX - the ActiveX implementation class defined above TButton - the VCL control class Class_ButtonX - the ClassID of the object. This GUID is imported from the ButtonXControlLib unit, generated from the type library. ToolbarBitmapID - this is a resource identifier of a bitmap resource. The wizard generates a bitmap resource for each control, based on the control's registered icon. ActiveX containers extract this bitmap to show on their control palettes. 1363

LicenseString - This is blank because we didn't select MiscControl flags - these are a combination of OLEMISC_* values that you can use to request special container behavior. DAX always adds the following flags to any VCLderived control: OLEMISC_RECOMPOSEONRESIZE, OLEMISC_CANTLINKINSIDE, OLEMISC_INSIDEOUT, OLEMISC_ACTIVATEWHENVISIBLE, OLEMISC_SETCLIENTSITEFIRST end.

The Type Library The ActiveX type library is a binary file containing the meta-data for each of the controls listed in an ActiveX library. It describes the objects in the library, the properties, methods and events and other interfaces available to each control, and the user-defined data types used for these. In addition to containing symbol names and type information, a type library contains a variety of other information, including human- readable descriptive text, a reference to a help file and GUIDs for each of these items. When you compile an ActiveX library, the type library gets copied into the DLL as a resource, where it can be loaded by any interested client program. The ActiveX wizards generate a type library for you when you first create the ActiveX Control from a Delphi VCL, and stores the type library in a .TLB file. This library defines all the properties and methods for your ActiveX control. For any properties or parameters that convert to OLE compatible types, the wizard generates properties and parameters using those OLE types. When your control contains enumeration properties or parameters, the wizard generates a type declaration for that enumeration in the type library. In the case where the data type is a TFont, TPicture, or TStrings, the wizard assigns the property or parameter an IFont, IPicture or IStrings type and generates adapter code to convert between the data types. If your VCL control contains properties or parameters that aren't standard or adaptable, generally records or non-COM object types, the wizard will skip that data item. This doesn't mean that the property doesn't exist, only that you won't be able to access it through a COM interface.

The Pascal Version of the Type Library unit ButtonXControlLib; { This file represents the pascal declarations of a type library and will be written during each import or refresh of the type library editor. Changes to this file will be discarded during the refresh process. } { ButtonXControlLib Library } { Version 1.0 } interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; const LIBID_ButtonXControlLib: TGUID = '{B12863C0-A9EA-11D0-A6DF-444553540000}'; const { TxDragMode } dmManual = 0; dmAutomatic = 1; { TxMouseButton } mbLeft = 0; mbRight = 1; mbMiddle = 2; const { Component class GUIDs } Class_ButtonX: TGUID = '{B12863C3-A9EA-11D0-A6DF-444553540000}';

1364

type { Forward declarations } IButtonX = interface; DButtonX_ = dispinterface; IButtonXEvents = dispinterface; ButtonX = IButtonX; TxDragMode = TOleEnum; TxMouseButton = TOleEnum; { Dispatch interface for ButtonX Control } IButtonX = interface(IDispatch) ['{B12863C1-A9EA-11D0-A6DF-444553540000}']

This is the control's main (dual) automation interface. The controller object's class will implement all these methods. procedure Click; safecall; function Get_Cancel: WordBool; safecall; procedure Set_Cancel(Value:WordBool); safecall; function Get_Caption: WideString; safecall; procedure Set_Caption(constValue: WideString); safecall; function Get_Default: WordBool; safecall; procedure Set_Default(Value: WordBool); safecall; function Get_DragCursor: Smallint; safecall; procedure Set_DragCursor(Value: Smallint); safecall; function Get_DragMode: TxDragMode; safecall; procedure Set_DragMode(Value: TxDragMode); safecall; function Get_Enabled: WordBool; safecall; procedure Set_Enabled(Value: WordBool); safecall; function Get_Font: Font; safecall; procedure Set_Font(const Value: Font); safecall; function Get_ModalResult: Integer; safecall; procedure Set_ModalResult(Value: Integer); safecall; function Get_Visible: WordBool; safecall; procedure Set_Visible(Value: WordBool); safecall; function Get_Cursor: Smallint; safecall; procedure Set_Cursor(Value: Smallint); safecall; property Cancel: WordBool read Get_Cancel write Set_Cancel; property Caption: WideString read Get_Caption write Set_Caption; property Default: WordBool read Get_Default write Set_Default; property DragCursor: Smallint read Get_DragCursor write Set_DragCursor; property DragMode: TxDragMode read Get_DragMode write Set_DragMode; property Enabled: WordBool read Get_Enabled write Set_Enabled; property Font: Font read Get_Font write Set_Font; property ModalResult: Integer read Get_ModalResult write Set_ModalResult; property Visible: WordBool read Get_Visible write Set_Visible; property Cursor: Smallint read Get_Cursor write Set_Cursor; end; { DispInterface declaration for Dual Interface IButtonX } DButtonX_ = dispinterface ['{B12863C1-A9EA-11D0-A6DF-444553540000}']

This is the dispinterface version of the dual interface above. procedure Click; dispid 1; property Cancel: WordBool dispid 2; property Caption: WideString dispid 3; property Default: WordBool dispid 4; property DragCursor: Smallint dispid 5; property DragMode: TxDragMode dispid 6; property Enabled: WordBool dispid 7; property Font: Font dispid 8; property ModalResult: Integer dispid 9; property Visible: WordBool dispid 10; property Cursor: Smallint dispid 11; end; { Events interface for ButtonX Control }

1365

IButtonXEvents = dispinterface ['{B12863C2-A9EA-11D0-A6DF-444553540000}']

This is the events dispinterface for the control. The control can fire these events to its container if the container installs an event sink. procedure OnClick; dispid 1; procedure OnKeyPress(var Key: Smallint); dispid 2; end;

[Note: This file also includes declarations for TButtonX, which is the VCL class generated when you import the ButtonX control back into Delphi. For brevity's sake, I've deleted this from this listing.] implementation end.

Advanced Features The DAX class hierarchy provides mechanisms for you to implement or customize certain features of ActiveX controls. These features include per-property browsing, persistence streaming, verbs, property pages, ambient properties, and registration. TActiveXControl defines an immense number of protected methods, most of which are simply implementations of its interface methods. Because they're just interface method implementations, you probably won't need to override any of them. Nevertheless, they are protected to allow for extending the hierarchy over time, especially as Microsoft defines new behaviors and changes existing ones. This still leaves a few protected methods you might want to override in specific circumstances. The following sections describe these situations.

Per Property Browsing Property browsing support allows a property inspector to display a property that doesn't normally have a text representation, such as a font. It also allows the inspector to show a dropdown list of values that the property can have. You only need to implement per property browsing where normal variant conversions can't convert your data to a string or won't do it in the way you want. Per-property browsing is implemented using three methods that work together: GetPropertyString, GetProperty Strings, and GetPropertyValue. function GetPropertyString(DispID: Integer; var S: string): Boolean;

When the property inspector displays a property, it calls this method to see if the property has a display string. If you want your property to have a display string, add a case statement for the property, calculate the string you want to show for the property's current value, and return True. Otherwise, return False; Example: The following code demonstrates how you can show the Cursor property as a string surrounded by square brackets. function TButtonX.GetPropertyString( id: Integer; var S: String): Boolean; begin case id of 10: {Caption} begin S := '[' + IntToStr( Get_Cursor ) +']'; Result := True; end; else Result := False; end; end;

Bug: There was a bug in the shipping version of Delphi 3.0, which may be fixed by the time you read this. The implementation of TActiveXControl.GetDisplayString was left blank, when it should actually pass control to the GetPropertyString method mentioned 1366

above. Fortunately, this is easy to work around, since it simply requires supplying an implementation for IPerPropertyBrowsing.GetDisplayString. The following code shows the two places to modify the code to reimplement GetDisplayString correctly, in the class definition and in the class implementation. TButtonX = class(TActiveXControl, IButtonX, IPerPropertyBrowsing) ... function GetDisplayString(dispid: TDispID; out bstr: WideString):HResult; stdcall; ... end; ... function TButtonX.GetDisplayString(dispid: TDispID; out bstr: WideString): HResult;var S: String; begin if GetPropertyString( dispid, S ) then begin bstr := S; Result := S_OK; end else Result := E_NOTIMPL; end; function GetPropertyStrings(DispID: Integer; Strings: TStrings): Boolean;

GetPropertyStrings and GetPropertyValue work in tandem. GetPropertyStrings is called to populate a string list with a list of values that will be shown in a dropdown listbox. Once the user selects one of these, GetPropertyValues is called to retrieve the variant value for the selected property. procedure GetPropertyStrings(DispID: Integer; Strings: Tstrings): Boolean; begin if DispID = DISPID_FOO then begin Strings.Add('Ten'); Strings.Add('Twenty'); Strings.Add('Thirty'); Result := True; end else Result := False; end; procedure GetPropertyValue(DispID, Cookie: Integer; var Value: OleVariant); begin if dispid = DISPID_FOO then Value := Cookie *10; end;

Custom Object Streaming The default streaming behavior for DAX objects is to read or write all the property values from the VCL control using the VCL format. You can add extra information to the persistence stream by overriding the LoadFromStream or SaveToStream methods. Be sure to call the inherited method in order to load or save the control's properties properly. These methods are defined as: procedure

LoadFromStream(const Stream: IStream); procedure SaveToStream(const Stream: IStream); They read data from or insert data into a persistence stream. This happens when a control is being restored from a form file or saved into one. 1367

Working with OLE Streams In Delphi, the standard streaming class is called TStream, which has Read, Write and Seek methods. Most Delphi objects are derived from TPersistent, which is a class that can save its contents to a TStream. In the OLE world, stream objects provide an interface called IStream that also has Read, Write and Seek methods. Delphi 3 provides a class called TOleStream that exposes an IStream as a TStream. When a TActiveXControl is told to save its state to a stream via the SaveToStream method, it is given the IStream as a parameter. If you want to save extra data for your control to the stream, and the data being saved is a TPersistent-derived object, you can use the stream adaptor to allow the TPersistent object to save itself to the IStream. Here is an example of code that uses TOleStream to save and load a string list in addition to the control's properties. var ExtraInfo: TStringList; procedure TButtonX.SaveToStream( const Stream: IStream); var dStream: TStream; begin inherited; dStream := TOleStream.Create( Stream ); try ExtraInfo.SaveToStream(dStream); finally dStream.free; end; end; procedure TButtonX.LoadFromStream( const Stream: IStream ); begin inherited; dStream := TOleStream.Create(Stream ); try ExtraInfo.LoadFromStream(dStream); finally dStream.Free; end; end;

Adding verbs to a control A verb is a user-initiated action, generally from a menu item, that causes the object to do something interesting. Examples include 'cut', 'execute' or 'run'. You can add verb capabilities to your control by adding two pieces of code-one to register the verb and another to execute the verb. Registering a verb with the object's factory lets the verb information be copied into the system registry when the library is installed. This is a requirement of ActiveX because it allows the object's verbs to be displayed without having the object loaded in memory first. To register verbs, call the AddVerb method on the factory object, as in the following code. Note the ampersand ('&') in the verb description strings-it is common practice for the container to display this string in a menu item for the user, and the ampersand is used to indicate the keyboard selection character for the menu item. In the following example code, a verb called 'Click' is added to the TButtonX control, which will allow the user to click the button from the container's 'Click' menu item. When the user selects 'Click', the button's click method is called, which simulates a button click. const VERB_CLICK = 100; initialization with TActiveXControlFactory.Create( ComServer, TButtonX, TButton, Class_ButtonX, 1, '', 0) do begin

1368

AddVerb( VERB_CLICK, '&Click'); end; end.

The container is responsible for popping up a menu that contains the object's verbs, and it then calls the ActiveX control when the user selects one of the menu items. The DAX class hierarchy calls the object's PerformVerb method to actually execute the verb. The PerformVerb method for the Click example would be as follows: procedure TButtonXControl.PerformVerb(Verb: Integer); begin case Verb of VERB_CLICK: FDelphiControl.Click; else inherited PerformVerb(Verb); end; end;

Adding Property Pages to an ActiveX Control A property page is a form embedded in a notebook control called a property dialog. Like the Delphi Object Inspector, the property dialog's purpose is to provide the user with a way to edit the control's properties. Rather than presenting the user with a long list of property names and values, the property dialog presents related properties together on a page. You're not required to provide property pages for an ActiveX control, but they can be useful if your intended end-user is a non-technical user. The property pages that appear inside a property dialog are just normal windows, but they are also OLE contained objects, just like ActiveX Controls. Because a property page is an OLE object, it has to be packaged in an ActiveX library and registered in the system registry. The property page doesn't have to actually exist in the same library as the control that uses it. This is because some property pages can represent common data types and be reused across multiple libraries. Delphi provides four basic property pages for font, color, picture and string properties. The ClassIDs of these are Class_DColorPropPage Class_DFontPropPage Class_DPicturePropPage Class_DStringPropPage

Every property page 'edits' an OLE object. When the property page becomes active, it needs to copy properties from the object into the controls on the page. When the user clicks the Apply button, the page needs to copy the properties back to the OLE object. To add a property page to your project, you need to start the ActiveX Property Page wizard from the Object Repository. This wizard will generate a new unit and a form. For the purposes of this example, I'll also put an edit control on the form, so I can use it to edit the Caption property of my control. The unit for the resulting property page looks like the following code segment. There are four places to focus on in this code, which are discussed in the text. unit Unit1; interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms, ComServ, ComObj, StdVcl, AxCtrls; type TPropertyPage1 = class(TPropertyPage)

The page is derived from TPropertyPage, which in turn is derived from TCustomForm. This means you can design the form as you would design any other form. TPropertyPage adds an OleObject property, which references the object your property page is editing. TPropertyPage also declares the UpdatePropertyPage and UpdateObject methods, which you override below. 1369

Edit1: TEdit; private { Private declarations} protected procedure UpdatePropertyPage; override; procedure UpdateObject; override; public { Public declarations } end; const Class_PropertyPage1: TGUID = '{75ACC806-A9A5-11D0-A6DF-444553540000}'; implementation {$R *.DFM} procedure TPropertyPage1.UpdatePropertyPage; begin { Update your controls from OleObject }

This method is called by the DAX hierarchy in order to copy data from the OleObject to the page's controls. UpdatePropertyPage is called when the property dialog first comes up, but can be called again if the user presses the Undo button (if present). Here is an example of code to copy the Caption property from OleObject to a control on the page. (This code assumes you've placed an edit control on your form, and it's called Edit1). Edit1.Text := OleObject.Caption;

If you want your property page to show radio buttons or other complex interacting controls, the code may be more complicated than this simple example but the principle is the same: get the value of a property from OleObject and set the value of one or more controls on the form. end; procedure TPropertyPage1.UpdateObject; begin { Update OleObject from your controls }

This method does the reverse of the UpdatePropertyPage method-it copies the data from the controls to OleObject's properties. This normally happens when the user presses the OK or Apply keys. Here is an example of code to copy data back from the edit control to OleObject's Caption property: OleObject.Caption := Edit1.Text; end; initialization TActiveXPropertyPageFactory.Create( ComServer, TPropertyPage1, Class_PropertyPage1);

This code registers the property page as a COM object in the ActiveX library. TActiveXPropertyPageFactory is the class to use when creating the factory for property pages. As with ActiveX Controls, ComServer is the global variable that represents the ActiveX library. TPropertyPage1 is the form class declared above, and Class_PropertyPage1 is the object's ClassID. end.

Connecting the Property Page to an ActiveX Control Once you've designed a property page, you need to add the page to the control's list of pages. DAX asks an ActiveX Control to provide the ClassIDs of all its property pages by calling the protected DefinePropertyPages method. The method's parameter is a callback that you can call to add the ClassID of one of your property pages to the list. When DefinePropertyPages returns, the property dialog creates the page objects and selects the first one to the front. procedure TButtonX.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); begin

1370

DefinePropertyPage(Class_PropertyPage1); end;

Because this code is executed when the user brings up the property dialog, you have complete control about which pages to present to the user. Depending on the user's license or access rights, you may choose not to show certain pages for an object.

Accessing Ambient Properties An ambient property is a property provided by the control's container. Once the control is inserted in a container, it can query for the values of the container's ambient properties. The container can define whatever ambient properties it wants to expose. ActiveX defines a standard set of ambient properties, which includes: BackColor, DisplayName, and others. A container is not required to provide any or all of these properties, but if it does, Microsoft defines which dispids to use for each. ActiveX allows you to access ambient properties through the site's IDispatch interface. Delphi provides a dispinterface, IAmbientDispatch, which can be used to access the standard interfaces. Since it's a dispinterface, it's really just an IDispatch pointer and can be cast to any other dispinterface. If you're interested in querying the container for a nonstandard ambient property you'll need to define a new dispinterface that defines the property and its dispid, then cast FAmbientDispatch to the new dispinterface. Here's the declaration of IAmbientDispatch: IAmbientDispatch = dispinterface ['{00020400-0000-0000-C000-000000000046}'] property BackColor: Integer dispid DISPID_AMBIENT_BACKCOLOR; property DisplayName: WideString dispid DISPID_AMBIENT_DISPLAYNAME; property Font: IFontDisp dispid DISPID_AMBIENT_FONT; property ForeColor: Integer dispid DISPID_AMBIENT_FORECOLOR; property LocaleID: Integer dispid DISPID_AMBIENT_LOCALEID; property MessageReflect: WordBool dispid DISPID_AMBIENT_MESSAGEREFLECT; property ScaleUnits: WideString dispid DISPID_AMBIENT_SCALEUNITS; property TextAlign: Smallint dispid DISPID_AMBIENT_TEXTALIGN; property UserMode: WordBool dispid DISPID_AMBIENT_USERMODE; property UIDead: WordBool dispid DISPID_AMBIENT_UIDEAD; property ShowGrabHandles: WordBool dispid DISPID_AMBIENT_SHOWGRABHANDLES; property ShowHatching: WordBool dispid DISPID_AMBIENT_SHOWHATCHING; property DisplayAsDefault: WordBool dispid DISPID_AMBIENT_DISPLAYASDEFAULT; property SupportsMnemonics: WordBool dispid DISPID_AMBIENT_SUPPORTSMNEMONICS; property AutoClip: WordBool dispid DISPID_AMBIENT_AUTOCLIP; end;

Example: The following code responds to the button click, and sets the button's caption to the DisplayName ambient property. The DisplayName property is usually the control's name in its container. procedure TButtonX.Click; var Site: IOleClientSite; Ambients: IDispatch; begin GetClientSite( Site ); if Site <> nil then Site.QueryInterface(IDispatch, Ambients); if Ambients <> nil then begin Caption := IAmbientDispatch(Ambients).DisplayName; end; end;

Tracking Changes to Ambient Properties When the container changes the value of one of its ambient properties, it informs the control by calling the object's OnAmbientPropertyChange method. In Delphi, you can implement your own handler for this method by overriding the method and reimplementing the IOleControl interface in your class. Bug: Ambient Confusion 1371

As if the ActiveX specification wasn't confusing enough, Microsoft has been confused about how to implement ambient properties. Certain MS containers, such as Access 97, incorrectly assume the IDispatch interface it provides for ambient properties can be the same as the event sink. To make matters worse, some versions of MFC assume they must be the same IDispatch pointers. The lesson here is that over the years ActiveX has become enough of an architectural mess that nobody can ensure-or for that matter definecomplete compliance. What this means for you as an ActiveX control developer is that you need to be diligent about testing your control in a variety of containers, and be prepared to encounter some strange and unexpected behaviors. Even Microsoft has published controls that work in Internet Explorer but not in other containers, and each container has different reactions to the control's incompatibility.

Adding Custom Registry Entries You may want to add new registry entries for your control. For example, Microsoft recently published a specification, called component categories, that involves adding registry entries under the Component Categories key. DAX provides a means of adding registry entries in the factory class. Every Delphi COM factory provides a virtual UpdateRegistry method that gets called when the library is registered or unregistered. If you want to add new items to the registry when the library is registered, derive a new factory class from TActiveXControlFactory and override its UpdateRegistry method. Then replace the factory Create call at the bottom of the control's implementation unit with a call that creates an instance of your new factory class. Example: The following code defines a special factory class called TSpecialFactory that adds a subkey of the class key called "SpecialKey". This key has a numeric value, which you set in the constructor. type TSpecialFactory = class(TActiveXControlFactory) public constructor Create(ComServer: TComServerObject; ActiveXControlClass: TActiveXControlClass; WinControlClass: TWinControlClass; const ClassID: TGUID; ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer; SpecialKeyValue: Integer); override; procedure UpdateRegistry(Register: Boolean); override; protected FSpecialKeyValue: Integer; end; constructor TSpecialFactory.Create(ComServer: TComServerObject; ActiveXControlClass: TActiveXControlClass; WinControlClass: TWinControlClass; const ClassID: TGUID; ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer; SpecialKeyValue: Integer); var TypeAttr: PTypeAttr; begin FSpecialKeyValue := SpecialKeyValue; inherited Create(ComServer, ActiveXControlClass, WinControlClass, ClassID, ToolboxBitmapID, LicStr, MiscStatus); end; procedure TSpecialFactory.UpdateRegistry(Register: Boolean); var ClassKey: string; begin ClassKey := 'CLSID\' + GUIDToString(ClassID); if Register then begin

1372

inherited UpdateRegistry(Register); CreateRegKey(ClassKey + '\SpecialKey', '', IntToStr(FSpecialKeyValue)); end else begin DeleteRegKey(ClassKey + '\SpecialKey'); inherited UpdateRegistry(Register); end; end;

To use this class factory, simply replace the existing class factory creation code in the initialization section of your ActiveX library: The last line in the example below sets the value of "SpecialKey" to 1234. initialization TSpecialFactory.Create(ComServer, TButtonX, TButton, Class_ButtonX, 1, '', 0, 1234); end.

Web Deployment and Code Signing Web Deployment ActiveX controls built with Delphi can be deployed to a web site for downloading into Internet Explorer. Before you can deploy your control, there are several things you need to figure out: · Where the binary codebase will reside on your server. This could be an URL like "http://www.mycorp.com/code/DAXSamp.ocx". · A directory where Delphi can copy the HTML file. If the HTTP server is running on your machine, this could be a local filename like "c:\https\codebase\". · A directory where Delphi can copy the codebase file. If the HTTP server is running on your machine, this could be a local filename like "c:\https\pages\". Once you've specified these basic options, you can copy the code to the server by invoking the Project|Web Deploy command. When you invoke the Web Deploy command, Delphi generates a web page that refers to your control and copies it to the HTML destination directory. Delphi then copies the codebase to the web server's codebase destination directory. The generated HTML code looks like the following code. Using the above example directories, Delphi copies it to a file called c:\https\pages\DAXSamp.HTM.
Delphi ActiveX Test Page
You should see your Delphi forms or controls embedded in the form below.

It the server is a remote Web server that you don't have file-system access to, you will need to tell Delphi to put the files in a local directory. Then, you can use your usual webpage deployment method (for example, FTP or FrontPage) to deploy the code to your server.

1373

Code Signing Signing your ActiveX control accomplishes two things. First, it identifies you or your organization as the author of the code. Second, it gives the recipient of the code the ability to verify that what they received is what you made and it hasn't been tampered with. The key element in code signing is your certificate, which is a code key assigned to you by a company called a certificate authority. The certificate file appears in the form of a .SPC (Software Publisher's Certificate) file, delivered to you by the certificate authority. You also need a private key file (.PVK), which you created as part of your application to the CA for the SPC file. Microsoft also provides you with a means of creating untrusted keys for testing purposes. See Microsoft's web site, http://www.microsoft.com/workshop/prog/security/authcode/codesign.htm for the paper, "Signing Code with Microsoft's Authenticode". The process is also described in the Microsoft INET SDK, which is where you will find the tools required for manufacturing the untrusted test keys. Delphi 3 provides a project options page where you can specify your code signature information, including the file that contains the credientials and the file that contains the private key. In the Project|Web Deployment Options dialog, in the Project page, check the Code Sign Project checkbox. Then, turn to the Code Signing page and fill in the credentials file and private key file fields. The application name and optional company URL fields will appear in the certificate dialog when the app is downloaded and verified. You should enter your company's information here.

Web Security Security is an extremely important when you're building an ActiveX for web deployment. While ActiveX controls can be very powerful and convenient, they can also become your worst nightmare. As a builder of ActiveX controls, here are some things you should consider: · Be ethical. Don't build ActiveX controls that are harmful. · Build your control to be tamper-resistant. · Keep close watch on your software certificate. Establish notary procedures for its use. Keep records about what controls you've signed and who signed it, and who had access to the signature key. · Don't give your control privileges over your network. Don't include default passwords, etc. · Set up your server so it knows who downloads the controls and when and where. When deploying ActiveX controls in an Intranet, here's some advice: · Code signatures do not necessarily mean full security. Even signed, legitimate ActiveX controls have security flaws that can be taken advantage of. · Don't accept HTML pages containing an ActiveX control from anyone you don't trust as well as your least trustworthy staff. If you have a business partner that only publishes its data through an ActiveX, allow only that ActiveX to run, and only in the context of the page they published. · Caveat surfer

Data-aware controls VB4 provides an open specification for "simple data bound controls." Such controls are typically controls that show a single value, like an edit field or a check box. Unlike the VB complex data binding spec, this standard has been adopted by a number of vendor, with

1374

the notable exception of Delphi itself. Despite the fact that Delphi doesn't host data-bound ActiveX controls, it can be used to produce them without too much trouble. It doesn't take much to make a control data-aware, once you have a working ActiveX control. A simple data-aware ActiveX control has a special property that represents its "value". The property might be called Value, Text, Temperature, or whatever. This property is marked in the type library with several flags that indicate that it can be bound to. You can use the type library editor to set the flags in the control that indicate how the property is to be bound. Figure 3 shows how this can be done, by checking the Bindable, Request Edit, Display Bindable and Default Bindable flags of the property's Attributes pane.

The options tell the container that it can bind a data source value to this property. If the container chooses to bind a data source to the bindable property, the two always keep their values synchronized: when the data source changes value, the value property, and when the value property changes the data source changes value. Figure 4. Type library editor, showing the Caption property defined as the default bound property. The value property must also ask its container for permission to change the value property, before the property is actually changed. The container can refuse the modification if desired. You can implement this relationship easily by taking advantage of the OnChanging and OnChanged events of your VCL control. class TButtonXControl = ...; ... private FPropNotifySink: IPropNotifySink; end; procedure TButtonXControl.InitializeControl; begin FConnectionPoints.CreateConnectionPoint(IPropNotifySink, PropNotifySinkConnect); FDelphiControl.OnChanged := OnChangedEvent; FDelphiControl.OnChanging := OnChangingEvent; end; procedure TButtonXControl.PropNotifySinkConnect(const Sink: IUnknown);

1375

begin if Sink <> nil then OleCheck(Sink.QueryInterface(IPropNotifySink, FPropNotifySink)) else FPropNotifySink := nil; end; procedure TButtonXControl.Set_Caption(const Value: WideString); begin FDelphiControl.Caption := TCaption(Value); end; procedure TButtonXControl.OnChangingEvent( Sender: TObject ); begin if FPropNotifySink <> nil then if FPropertyNotifySink.RequestEdit( DISPID_CAPTION ) = S_FALSE then OleError( CTL_E_SETNOTPERMITTED ); end; procedure TButtonX.OnChangedEvent( Sender:TObject ); begin if FPropNotifySink <> nil then FPropNotifySink.OnChanged( DISPID_CAPTION ); end;

Conclusion Delphi 3 provides you with an easy way to get started building ActiveX controls, bu combining a basic class framework called DAX with the VCL and a set of code-generation wizards. In this class, I've explained how to convert a VCL control into an ActiveX control, and then how to add some of the more important ActiveX features to the control. I've also explained how the Delphi ActiveX framework is built, and shown how you can extend it. This is an important skill, because ActiveX is an extremely fluid specification.

Further Reading Microsoft's OLE web site is at http://www.microsoft.com/oledev. There's lots of really good stuff there.

Books Designing and Using OLE Custom Controls, Tom Armstrong, M&T Press. Tom maintains a web site at http://www.widgetware.com, including a comprehensive FAQ. OLE Controls Inside Out, Adam Denning, Microsoft Press Inside OLE, Kraig Brockschmidt, Microsoft Press More book listings can be found at http://www.microsoft.com/oledev/books.htm

White papers The Java Beans Specification, at http://splash.javasoft.com/beans/spec.html This paper is a better explanation of component models than Microsoft's. What OLE is Really About, by Kraig Brockschmidt, at http://www.microsoft.com/oledev/olecom/aboutole.htm. Best quote: "OLE is very much like the Coke bottle…" Vijay Mukhi's site: http://www.neca.com/~vmis/ Vijay writes irreverently about various technologies, including ActiveX. Best quote: "Microsoft has won the battle for the Internet".

Documentation OLE Controls specification, versions 1.0, 1.1 and 2.0, from Microsoft. OC96 - additions to the OLE controls specification, from Microsoft.

1376

ActiveX SDK Docs on ActiveX Controls: http://www.microsoft.com/msdn/sdk/platforms/doc/activex/src/olectrl.htm Authenticode: see Microsoft's web site at http://www.microsoft.com/security/tech/misf8_2.htm ActiveDesigner: see http://www.microsoft.com/intdev/sdk/dtctrl

Class hierarchies Class hierarchies can be useful reference material when you can't find why something doesn't work. Look for cryptic comments like 'some containers do this, so we have to bend over backwards here' to discover where a Microsoft developer has been there before you. MFC - with Borland C++ 5.01 or Microsoft Visual C++ 4.2a. ActiveX SDK - the BaseCtl framework. See http://www.microsoft.com/intdev/sdk/sdk.htm ATL 2.x - with Microsoft Visual C++ 5.0 OLE Control Developer's Kit - from Microsoft, in the ActiveX SDK. (C) Copyright 1997 by Conrad Herrmann. You may copy, modify, distribute or use for any purpose all ObjectPascal source code published in this article. All other rights reserved.

1377

COM Objects in Delphi, Part 1 What it takes to overcome Delphi's lack of multiple inheritance Neil J. Rubenking The PC software development community is segregated by platform and programming language. I program with Delphi for Windows, you program in assembly language for DOS, and she programs in C++ for OS/2. Expertise developed on one platform doesn't necessarily apply to another, and skill in one programming language may actually hinder learning another. And interprocess communication, which has the potential to break down these barriers, is made difficult by differing internal representations of data. But there is one way to bridge the gap--with a language-independent, cross-platform standard for communication between objects: Microsoft's Component Object Model (COM). And COM is here now; it's the essential technology underlying OLE and ActiveX. Unfortunately, the current literature's COM programming examples don't demonstrate much language-independence. All but a very few use C++. Some examples are straight C++ code and take advantage of the language's multiple inheritance. Others are built on MFC and rely so heavily on COM-specific macros that the result isn't even recognizable as C code. The bottom line: If C++ isn't your development language, you're at a disadvantage when it comes to learning COM programming. In this column and a follow-up, we'll discuss the implementation of COM objects using Borland's Delphi development environment. This first part explains the problems involved in a Delphi COM implementation and demonstrates some solutions. The next article will show five specific COM objects--implementations of five standard Windows 95 shell extension types. Under some circumstances, COM objects can reside in .EXE files. But for the sake of simplicity, this article will deal with only the more commonly used COM objects that reside in DLLs.

COM object essentials What's inside a COM object? That's none of your business! A COM object shares information with the world only through defined interfaces. Each interface provides one or more functions that another object or a program can call. Every COM object must support the IUnknown interface and its three functions, AddRef, Release, and QueryInterface. AddRef and Release handle the mundane task of managing the object's life span. Each call to AddRef increments the object's reference count, and each call to Release decrements the reference count. The object is destroyed when the reference count goes to 0. The utterly essential function of the IUnknown interface is QueryInterface. Once a program or another object gets access to the always present IUnknown interface, it can call QueryInterface to access all other interfaces supported by the object. IUnknown is the root of all COM interfaces. Every other COM interface is effectively a descendant of IUnknown and thus must also provide implementations of the three IUnknown functions. The concept of object in COM terminology isn't quite the same thing as the concept as it relates to Delphi or C++. A COM interface, however, is similar to a Delphi or C++ object that has no public data members and only virtual methods. The interface's list of functions corresponds directly to an Object Pascal or C++ object's virtual method table. In fact, you can create a COM interface in either language simply by declaring an object with the correct list of virtual methods. The method declarations must match the function definitions for the desired interface, naturally, but they must also appear in the correct position in the virtual method table. That means the methods must be declared in the defined order and no other virtual methods can precede them.

1378

The OLE2.PAS file that comes with Delphi 2.0 defines an IUnknown interface object type and dozens of IUnknown descendants, such as IClassFactory, IMarshal, and IMalloc. Each of the supplied objects' interface function methods is declared as virtual, stdcall, or abstract. The virtual keyword is required, as noted above. The stdcall keyword instructs the compiler to use the standard calling convention for the method. The abstract keyword indicates that the method is not implemented in the object itself but must be implemented in any descendant for which an instance is created. More than 50 direct descendants of IUnknown are defined in OLE2.PAS, and each one supports both the interface for which it is named and IUnknown. A problem arises when a COM object needs to support two or more interfaces other than IUnknown. The C++ implementation simply defines the COM object as multiply inheriting from the objects representing the interfaces it needs to support. An object in Delphi doesn't support multiple inheritance, so a different approach is required. (C++ programmers may be interested to note that an MFC-based COM object uses the same approach as described below for Delphi, a fact obscured by the complex set of macros used to define a COM object with MFC.)

Satellites and Containers The key to creating COM objects with multiple interfaces with Delphi involves treating the COM object as a container for its interfaces. A COM object does not have to be every interface object that it supports. It simply must supply the interface on demand, when the QueryInterface function of its IUnknown interface is called. The Delphi-based COM object handles the three IUnknown functions directly and returns a pointer to itself when the IUnknown interface is requested via QueryInterface. It acts as a container and manager of other objects that implement other interfaces. The satellite interface objects "reflect" the three IUnknown functions to their container. When a request arrives for one of the satellite interfaces (as usual, via QueryInterface) the container returns a pointer to the satellite object. Figure 1 shows the Delphi implementation of the satellite and container types of interface objects, along with a corresponding IClassFactory interface.

Satellite objects The ISatelliteUnknown object type descends directly from the supplied IUnknown type and necessarily overrides the abstract methods corresponding to the three IUnknown functions. ISatelliteUnknown has a single protected data field called FContainer, of type IContainerUnknown (defined below), which is initialized in its Create constructor. The implementations for the three IUnknown functions simply return the result of calling the corresponding method in the container object. Depending on which interface it has requested, the calling program may gain access to the QueryInterface, AddRef, and Release functions directly through the container object or through any of its satellite objects. If you've read much OLE literature, you'll realize that the names used in Figure 1 for the parameters to QueryInterface in the DelphCOM unit shown here are nonstandard. Usually the parameter representing the ID of the desired interface is named riid, and the parameter representing the returned object is called ppv. Since the names of the parameters have no significance outside of the object, I have replaced the cryptic standard names with the more intelligible WantIID and ReturnedObject.

Container objects The IContainerUnknown object type is another direct descendant of IUnknown. It maintains its own reference count as a protected data field named FRefCount; the AddRef function increments FRefCount and the Release function decrements it. Both AddRef and Release return the new reference count; in addition, if the count has reached 0, the Release function frees the object.

1379

The DelphCOM unit also defines a global reference count for the entire DLL that contains descendants of the generic COM objects. The constructor and destructor of the container object increment and decrement, respectively, the global reference count. Every DLL that contains COM objects is required to supply two specific functions, DLLCanUnloadNow and DLLGetClassObject. DLLCanUnloadNow, implemented in the DelphCOM unit, returns False unless the global DLL reference count is 0. DLLGetClassObject will be specific to each DLL that relies on DelphCOM and can't be written until the COM objects (descendants of ISatelliteUnknown and IContainerUnknown) have been defined. The IContainerUnknown object responds to a QueryInterface request for the IUnknown interface by returning a pointer to itself. If any other interface is requested, it returns the error code E_NOINTERFACE. In a descendant of IContainerUnknown, the QueryInterface function will first call this inherited function. If the inherited method returns E_NOINTERFACE, the descendant will check the requested interface ID against the additional interfaces it supports, and return the satellite object that matches the request.

The Class Factory COM objects can be created on command from the system or a program. The actual creation is handled by a COM object type called a class factory, another direct descendant of IUnknown. The IMyClassFactory object in the DelphCOM unit implements AddRef and Release, just as the IContainerUnknown object did. It responds to QueryInterface requests for IUnknown or IClassFactory by returning a pointer to itself. Besides those three functions, the IClassFactory interface adds two new ones, CreateInstance and LockServer. Since LockServer is not generally required, IMyClassFactory returns the special value E_NOTIMPL, indicating the function is not implemented. The most essential function of a class factory, the one that makes it a factory, is CreateInstance. The calling program uses CreateInstance to produce an instance of the desired object. The DelphCOM unit, however, doesn't contain any "finished" objects; it holds only the generic satellite and container objects. When we define a COM object descendant of IContainerUnknown, we also need to define an IMyClassFactory descendant whose CreateInstance function returns an instance of that COM object. With the introduction of IMyClassFactory, the set of generic COM objects for Delphi is complete. The system of container and satellite objects can be used in any object-oriented language, and, in fact, COM objects designed under MFC use a similar system. Part 2 of this article will move from theory to practice. It will extend the generic objects defined in Part 1 to create examples of five Windows 95 shell extension types: a context-menu handler, a property-sheet handler, a right-drag handler, an icon handler, and a copy-hook handler. Once you use and understand the examples, you'll be completely prepared to build your own practical extensions to the Windows 95 shell. Neil J. Rubenking is the contributing technical editor ofPC Magazine.

GUIDs, CLSIDs, and IIDs Creating and managing COM objects relies heavily on Globally Unique Identifiers, or GUIDs (pronounced "GOO-ids"). A GUID is a 128-bit number generated by the Windows API function CoCreateGUID. GUIDs should be globally unique: CoCreateGUID should never return the same GUID twice. As OLE maven Kraig Brockschmidt (of Microsoft's OLE design team) puts it, the likelihood of two calls to CoCreateGUID returning the same value is "about the same as two random atoms in the universe colliding to form a small California avocado mated to a New York City sewer rat." Every interface needs an Interface ID (IID), which is a GUID. Delphi's OLE2.PAS file defines dozens of IIDs. The example code for this article refers to IID_IUnknown and IID_IClassFactory; the Delphi-supplied OLE2.PAS file contains dozens more IIDs. In addition, every object class registered with the system needs a Class ID (CLSID). If you've 1380

ever looked at the Registry key HKEY_CLASSES_ROOT\CLSID with RegEdit, you've seen dozens or even hundreds of these unintelligible strings of numbers. These are the class IDs of all the COM objects registered on your system. No question about it; to do COM programming you'll have to work with existing GUIDs as well as create new GUIDs specific to your program. Free utilities, such as UUIDGEN.EXE, will generate GUIDs for you, but you'll then be faced with the tedious task of rewriting them in the correct form for a Delphi constant. Instead of UUIDGEN.EXE, use the text-mode "console" program available from PC Magazine Online. You can either load it into the Delphi IDE and compile it, or you can compile it with the command line Delphi compiler by entering DCC32 GUIDS.DPR. Run the resulting program, and you'll get a brand-new, never-before-seen GUID, expressed first as a string and then as a Delphi typed constant. When you start a new project, mentally count up the number of distinct GUIDs you'll need, add a few for good luck, then pass that number to GUIDS.EXE, redirecting the output of GUIDS.EXE to a file. The resulting file will contain as many GUIDs as you requested, and, normally, they will form a continuous block of numbers. Having all the GUIDs used by your project differ in just one digit makes them easier to recognize as related. Now you can cut GUIDs from this text file and paste them into your project as needed. FIGURE 1: These generic COM interface objects aid in creating Delphi-based COM objects that support multiple interfaces. unit DelphCom; // "generic" objects for creating COM objects in Delphi. // ISatelliteUnknown is an interface object that's meant // to be contained by IContainerUnknown. Each actual COM // object that needs to support more than one interface // will descend from IContainerUnknown, and will implement // QueryInterface. interface USES Windows, Ole2, Classes, SysUtils, ShellApi, ShlObj; VAR DllRefCount : Integer; type IContainerUnknown = class; ISatelliteUnknown = class(IUnknown) // Meant to be contained by an IContainerUnknown // Reflects the three IUnknown functions to its // container. protected fContainer : IContainerUnknown; public constructor Create(vContainer: IContainerUnknown); function QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; override; function AddRef: Longint; override; function Release: Longint; override; end; IContainerUnknown = class(IUnknown) protected FRefCount : Integer; public Constructor Create; destructor Destroy; override; {IUnknown functions} function QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; override; function AddRef: LongInt; override; function Release: LongInt; override; end; IMyClassFactory = Class(IClassFactory) private FRefCount : Integer; public constructor Create;

1381

destructor Destroy; override; function QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; override; function AddRef: LongInt; override; function Release: LongInt; override; // descendant MUST implement CreateInstance function LockServer(fLock: BOOL): HResult; override; end; function DLLCanUnloadNow : HResult; StdCall; Export; implementation (****** ISatelliteUnknown ******) constructor ISatelliteUnknown.Create(vContainer: IContainerUnknown); begin fContainer := vContainer; end; function ISatelliteUnknown.QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; begin Result := fContainer.QueryInterface(WantIid, ReturnedObject); end; function ISatelliteUnknown.AddRef: LongInt; begin Result := fContainer.AddRef; end; function ISatelliteUnknown.Release: LongInt; begin Result := fContainer.Release; end; (****** IContainerUnknown ******) constructor IContainerUnknown.Create; begin Inherited Create; FRefCount := 0; Inc(DllRefCount); end; destructor IContainerUnknown.Destroy; begin Dec(DllRefCount); Inherited Destroy; end; function IContainerUnknown.QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; VAR P : IUnknown; begin IF IsEqualIID(WantIID, IID_IUnknown) THEN P := Self ELSE P := nil; Pointer(ReturnedObject) := P; IF P = NIL THEN Result := E_NOINTERFACE ELSE begin P.AddRef; Result := S_OK; end; end; function IContainerUnknown.AddRef: LongInt; begin Inc(FRefCount); Result := FRefCount; end; function IContainerUnknown.Release: LongInt; begin Dec(FRefCount); Result := FRefCount; IF FRefCount = 0 THEN Free; end;

1382

(****** IMyClassFactory ******) constructor IMyClassFactory.Create; begin Inherited Create; Inc(DllRefCount); FRefCount := 0; end; destructor IMyClassFactory.Destroy; begin Dec(DllRefCount); Inherited Destroy; end; function IMyClassFactory.QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; begin IF IsEqualIID(WantIid, IID_IUnknown) OR IsEqualIID(WantIid, IID_IClassFactory) THEN begin Pointer(ReturnedObject) := Self; AddRef; Result := S_OK; end ELSE begin Pointer(ReturnedObject) := NIL; Result := E_NOINTERFACE; end; end; function IMyClassFactory.AddRef: LongInt; begin Inc(FRefCount); Result := FRefCount; end; function IMyClassFactory.Release: LongInt; begin Dec(FRefCount); Result := FRefCount; IF FRefCount = 0 THEN Free; end; function IMyClassFactory.LockServer(fLock: Bool): HResult; begin Result := E_NOTIMPL; end; (****** exported function ******) function DLLCanUnloadNow: hResult; StdCall; Export; begin IF DllRefCount=0 THEN Result := S_OK ELSE Result := S_FALSE; end; initialization DllRefCount := 0; end. (continues)

COM Objects in Delphi, Part 2 Creating four Windows 95 shell-extension COM objects Neil J. Rubenking Creating COM objects in Delphi is quite different from creating COM objects in C++, although similarities do exist: COM objects support one or more COM interfaces, and a single COM interface can be represented by a Delphi object or a C++ object. When a 1383

COM object needs to support multiple interfaces, a C++ implementation uses multiple inheritance to derive an object that inherits from all of the necessary interfaces. Multiple inheritance is not a feature of Delphi, so the Delphi implementation needs to take a different approach. A Delphi-based, multi-interface COM object must be built from several separate objects. Each required COM interface is represented by a satellite object, descended from the Delphi-supplied IUnknown object type. The satellite object implements the IUnknown interface. The COM object as a whole is represented by a container object, also descended from IUnknown. The container object, which contains instances of the satellite objects as data fields, returns a pointer to the requested interface when its QueryInterface function is called. The first part of this article presented these concepts, along with their implementation, in the ISatelliteUnknown and IContainerUnknown objects. Now we'll use these objects to create shell-extension COM objects for Windows 95. We'll demonstrate the creation of four Windows 95 shell extensions in Delphi: a contextmenu handler, a property-sheet handler, a drag-and-drop handler, and an icon handler. The example shell extensions act on an imaginary file type, DelShellFile, associated with the extension .DEL. A DelShellFile's single line of text represents a whole number; in a real program this would be replaced by some more complex attribute of the file. The four shell extensions will interact with this "magic number." You'll also find a copy-hook-handler shell extension in the source code for this article. But because its implementation didn't require use of the container/satellite system, that extension won't be discussed in the article itself. All code mentioned in this article is available for download from PC Magazine Online. (See the sidebar "Getting the Files" in the Utilities column for details.)

Preparing Helper Interfaces Figure 1 represents the hierarchy of supporting objects that we'll create. The solid lines define a standard object hierarchy, with the Delphi-defined IUnknown object at the top. Beneath each object's name is a list of the interfaces it supports, omitting the ubiquitous IUnknown interface. The dotted lines represent the container/satellite relationship on which this entire system is based. The context menu, property sheet, and drag-and-drop-handler shell extensions rely on the IShellExtInit interface for initialization. The icon handler relies on the IPersistFile interface for the same purpose. Figure 2 shows the declarations for satellite objects that implement these two helper interfaces and for container objects that are pre-initialized to handle these satellite objects. type IMyShellExtInit = class(ISatelliteUnknown) public function Initialize(pidlFolder:PItemIDList; lpdobj: IDataObject; hKeyProgID:HKEY):HResult; virtual; stdcall; end; IMyPersistFile = class(ISatelliteUnknown) public function GetClassID(var classID: TCLSID): HResult; virtual; stdcall; function IsDirty: HResult; virtual; stdcall; function Load(pszFileName: POleStr; dwMode: Longint): HResult; virtual; stdcall; function Save(pszFileName: POleStr; fRemember: BOOL): HResult; virtual; stdcall; function SaveCompleted(pszFileName: POleStr): HResult; virtual; stdcall; function GetCurFile(var pszFileName: POleStr): HResult; virtual; stdcall; end; ISEIContainer = class(IContainerUnknown) protected FShellExtInit : IMyShellExtInit; // Satellite interface

1384

public FNumFiles : Integer; FInitFiles : TStringList; FIDPath : String; Constructor Create; destructor Destroy; override; function QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; override; end; IPFContainer = class(IContainerUnknown) protected FPersistFile : IMyPersistFile; // Satellite interface public FPFFilename : String; Constructor Create; destructor Destroy; override; function QueryInterface(const WantIID: TIID; var ReturnedObject): HResult; override; end;

The IMyShellExtInit object adds the method Initialize, which implements the IShellExtInit interface's Initialize function. It inherits ISatelliteUnknown's handling of the QueryInterface, AddRef, and Release methods. Thus IMyShellExtInit's virtual method table matches perfectly with the set of functions that defines an IShellExtInit interface. The Initialize method extracts a list of files from data supplied by the calling program and stores it in a data field of its container object, which must be of the type ISEIContainer. ISEIContainer inherits the AddRef and Release methods of IContainerUnknown. In its implementation of QueryInterface, ISEIContainer first calls the QueryInterface method inherited from IContainerUnknown. If that method doesn't return S_OK, the overriding QueryInterface method checks to see if IShellExtInit is being requested; if so, QueryInterface passes back a pointer to its protected data field FShellExtInit, which is an object of type IMyShellExtInit. ISEIContainer also defines data fields to hold a list of files, the number of files, and a path. Its Create constructor initializes the file list and FShellExtInit objects, and its Destroy destructor frees the memory used by those two objects. The IMyPersistFile object looks a lot more complicated than IMyShellExtInit, but five of the six methods that implement functions of the IPersistFile interface simply return the result code E_FAIL. IMyPersistFile's Load method receives a filename in Unicode form; it converts this filename to an ANSI string and stores it in a data field of its container object, which must be of type IPFContainer. Like ISEIContainer, IPFContainer overrides QueryInterface. If the inherited QueryInterface method fails, it checks to see if IPersistFile is being requested. If so, it passes back a pointer, of type IMyPersistFile, to its protected data field FPersistFile. The container object's constructor and destructor methods create and destroy the FPersistFile object as well. Now we're ready to build the shell extensions themselves.

The Context-Menu Handler When you right-click on a file in Windows 95 Explorer, the system checks to see whether a context-menu handler is defined for that file's type. If one is, the system creates an instance of the context-menu handler COM object and passes a list of selected files to the Initialize function of the object's IShellExtInit interface. Then it calls the QueryContextMenu function of the IContextMenu interface. The function uses standard Windows API functions such as InsertMenu to insert menu items or separators; the function's return value is the number of items added, not including separators. The IContextMenu interface's InvokeCommand function is called when the user selects one of the added menu items, and the GetCommandString function is called to supply an explanation of the menu item in Explorer's status bar.

1385

The Delphi objects used to define and initialize a context-menu handler are IMyContextMenu, IDSContextMenu, and ICMClassFactory. IMyContextMenu is an ISatelliteUnknown descendant that implements the three IContextMenu functions. IDSContextMenu is a descendant of ISEIContainer, so it already supports IShellExtInit. IDSContextMenu adds a protected data field, FContextMenu, of type IMyContextMenu. As before, IDSContextMenu's constructor and destructor create and destroy the satellite object, and its QueryInterface method passes back a pointer to the FContextMenu object when IContextMenu is requested. This unit also defines ICMClassFactory, a descendant of IMyClassFactory that specifically returns an instance of IDSContextMenu. The CreateInstance method creates and returns the requested instance, but only if the interface being requested is one that IDSContextMenu supports. Each of the shell extensions will have a nearly identical IMyClassFactory descendant. The QueryContextMenu method checks whether or not multiple files are selected. For a single file, it adds a menu item titled Magic Number; for multiple files, it adds an item titled Average Magic Number. The InvokeCommand method displays the requested number in a simple message box after validating its arguments. And the GetCommandString method returns a single-word name for the menu item or a descriptive string, depending on which was requested.

The Drag-and-drop Handler A drag-and-drop handler is quite similar to a context-menu handler--in fact, it even supports the same IContextMenu interface. The drag-and-drop extension, however, is invoked when a file is dragged with the right mouse button onto a folder, and it is registered to the folder file type, not to the file type of the dragged file. The IMyDragDrop satellite object implements the methods QueryContextMenu, InvokeCommand, and GetCommandString. The QueryContextMenu method first flips through the list of files supplied by the system and checks whether the files are all of type DelShellFile. If they are, the method adds a menu item named Count Files, along with a separator, and returns 1; if not, it does nothing and returns 0. When the menu item is chosen, the InvokeCommand method counts the files in the dropped-on folder and adds the number of files to the magic number of each selected DelShellFile. Because a DelShellFile's icon depends on its magic number, a call to the API function SHChangeNotify tells the system to redisplay each of the files. The IDSDragDrop container object is functionally identical to the IDSContextMenu object. It simply maintains a satellite object of type IMyDragDrop rather than IMyContextMenu.

The Property-Sheet Handler When the user selects Properties from the context menu for one or more selected files of the same file type, the system checks to see if a property-sheet handler is defined for that file type. If so, the system creates an instance of the shell extension and initializes it with a list of files via the IShellExtInit interface's Initialize function. The system also calls the AddPages function of the IShellPropSheetExt interface to allow the property-sheet handler to add one or more property pages. The other IShellPropSheetExt interface function, ReplacePages, is normally not implemented. Delphi programmers will suddenly find themselves in terra incognita when implementing AddPages. In order to create the property-sheet page, you must supply a dialog-box template resource and a dialog-box function. Only old-time Windows programmers will remember those hoary precursors to today's visual development style. You can use a resource-creation tool like Borland's Resource Workshop to create the dialog template, or create the resource script as text and compile it with the BRCC.EXE resource compiler that comes with Delphi. The resource script that defines the DelShellFile property sheet is included with the downloadable source code.

1386

This resource script defines two statics (labels), a list box, and a button. The constants IDC_Static, IDC_ListBox, and IDC_Button, used as control ID numbers, are defined in the shared include file, SHEET.INC. The AddPages method initializes various fields of a TPropSheetPage structure, including the dialog-box template, the dialog-box procedure, and the program-defined lParam. Here, lParam holds the list of files passed by the shell. The callback function serves to ensure that this list gets deallocated. A call to CreatePropertySheetPage creates a page based on the TPropSheetPage structure, and a call to the shell-supplied lpfnAddPage function adds the page to the Properties dialog. The dialog-box procedure handles two specific messages. On a WM_INITDIALOG message, it adds to the list box the list of files pointed to by the lParam field of the property sheet page, preceding each with its magic number. The procedure sets the static control to reflect the number of files selected. It then disposes of the file list, and sets the field that held the file list to 0. When the user clicks the Zero Out button, the dialog-box procedure receives a WM_COMMAND message with the low word of the wParam set to the button's ID. The dialog-box procedure steps through the list of files, sets each file's magic number to 0, and calls the SHChangeNotify API function to signal a need to redisplay the file's icon. Virtually every property-sheet dialog-box procedure will need to respond to WM_INITDIALOG in order to initialize its controls. If it does more than just display information, it will need to respond to WM_COMMAND messages from particular controls as well.

The Icon Handler In most cases, the Windows 95 shell gets the icon for a file by checking the DefaultIcon key below the Registry key for the file's type. But if DefaultIcon is set to %1, the shell will call the file's icon-handler shell extension instead. The system calls the Load function of the icon handler's IPersistFile interface, passing the name of the file. The icon handler can supply a file-specific icon through the IExtractIcon interface's GetIconLocation and Extract functions, either by giving the filename and index for an icon resource or by creating an icon on demand. The example IMyExtractIcon satellite object implements both possibilities. If the conditional compilation directive UseResource is defined, the GetIconLocation method copies the name of the DLL containing the IMyExtractIcon object into the szIconFile argument, then calculates the value of the piIndex argument from the file's magic number. The method sets the pwFlags argument to include GIL_PERINSTANCE, meaning each file may have a different icon, and GIL_DONTCACHE, meaning the system should not cache the icon. The Extract method is not used; it simply returns S_FALSE. When the UseResource conditional compilation directive is not defined, the IMyExtractIcon satellite object creates an icon for each file. The GetIconLocation method stores the file's magic number in the piIndex argument and uses the same flags, plus the GIL_NOTFILENAME flag. The shell calls the Extract method, which creates both a large and a small icon for the file. The height of the red bar within the icon's rectangle is determined by the file's magic number. The source code demonstrates on-the-fly icon creation, but since this is tangential to the article's topic, we won't discuss its details here.

Packaging the Product To put your shell extensions to work, you must compile them into a DLL that implements the standard functions DLLGetClassObject and DLLCanUnloadNow. The code that defines this DLL is included with the article's source code. DLLGetClassObject determines which object is being requested, creates a class factory to match, and returns the object created by the class factory. The code that defines this DLL is included with the article's source code, a simple console application that handles registering and unregistering all of the example shell extensions.

1387

Before building your own shell extensions based on the examples, be sure to generate new Globally Unique Identifiers (GUIDs) to replace all of the GUIDs in the code. You can do this with the GUIDS program presented in the previous installment of this column. Neil J. Rubenking is contributing technical editor ofPC Magazine.

COM Object Debugging Most modern development environments include an integrated debugging feature that lets you step through or trace code, set breakpoints, and watch variables. But when your code resides in a DLL rather than in an executable program, integrated debuggers can't help you. Even if you use a 32-bit standalone debugger, COM objects won't be easily accessible, because they operate in the memory context of the object or program that calls them. For example, if the COM objects in question are Windows 95 shell extensions, they run in Windows Explorer's memory space. In many cases, the questions you'd want a debugger to answer about your COM objects are quite simple: Was the DLL activated at all? Did the system try to create an instance of the COM object? Which interface was requested? Such questions can be handled by a simple message-logging technique in which the COM object broadcasts a status message that is received by a separate logging program. The unit DllDebug, available from PC Magazine Online, implements the broadcast side of this process. The unit's initialization section sets the WM_LOGGIT variable to the unique message identifier that's obtained by passing the string Debugging Status Message to the RegisterWindowMessage function. The first call to RegisterWindowMessage using a given string will return a unique message number; subsequent calls using the same string will return the same message number. Because 32-bit programs use separate memory contexts, the Loggit function can't simply pass a pointer to the status message string itself. The pointer would be invalid in the receiving program's memory context. Instead, the Loggit function adds the status message to the global atom table. It calls SendMessage, passing -1 as the window handle, WM_LOGGIT as the message number, and the atom as the wParam. SendMessage doesn't return until all top-level windows have had a chance to process the message. At that point, the atom can safely be deleted. The NameOfIID function, also included in the DLLDebug unit, will come in handy when composing status messages. As written, it reports the name of IIDs related to shell extensions, but you can add any system IID values that are relevant to your project. So, for example, within a QueryInterface method you might insert the line: Loggit(Format('QueryInterface: %s requested', [NameOfIID(WantIID)]));

Broadcasting the WM_LOGGIT message is half the job; now we need a program to receive and log the status message. The Logger program, also available online, demonstrates one way to handle that task. Since the value of the WM_LOGGIT message isn't known until run time, it's not possible to set up a standard message-handling method. Instead, the program overrides the form's DefaultHandler method. When a WM_LOGGIT message comes through, this method extracts the status message from the passed atom and adds it to a list box. Besides this core functionality, the program includes three buttons that allow you to insert a comment, clear the list box, and save the logged status messages to a file. Figure A shows the Logger program in action. In this dialog box, the QueryInterface methods of several Delphi-based COM objects have been "instrumented" with a line that logs the name of the requested interface. This list of requests occurred when Explorer initially extracted a particular file's icon, after which the user right-clicked the file and viewed its properties; everything worked correctly. If the logger shows unexpected results, you'll add more calls to the Loggit function around the problem area and try again until you've identified the source of the problem. 1388

FIGURE 1: This is the object hierarchy for the Delphi shell extension objects we'll create. Supported interfaces (other than IUnknown) are listed in italics beneath each object name, and dotted lines represent container/satellite relationships. FIGURE 2:Two satellite objects implement the helper interfaces required by context-menu, property-sheet, drag-and-drop, and icon-handler Windows 95 shell extensions. FIGURE A: This simple debug message logger adds received status messages to a list box.

1389

Attaining True One-Step ActiveX As you can see from the previous example, it is not always easy to convert your Delphi components into ActiveX controls. This is because we converted an existing Delphi component—in particular, a component that used some advanced features of the Visual Component Library. In this respect, the ActiveX Control Framework is not as flexible as the VCL. However, you must weigh this against the benefit of being able to use ActiveX controls in products other than Delphi and C++ Builder. If your goal is to create an ActiveX control, there are some guidelines that you should follow. First, make sure your component descends from TWinControl or one of its descendants. Graphic controls cannot be embedded within a TActiveXControl wrapper. If you need to provide custom painting in your component, descend from TCustomControl instead. Second, use only automation-compatible types for properties and method parameters. This will enable the ActiveX Control Wizard to convert your component’s properties, but it may also force you to redesign the interface to your components. Third, the Delphi component should be considered the source code for the ActiveX control. Therefore, it is better to modify the Delphi component and reconvert it into an ActiveX control rather than modifying the ActiveX control’s implementation unit. Of course, this is unavoidable if you don’t have the source for the Delphi component. In summary, one-step ActiveX is indeed attainable if you follow these guidelines.

On the Drawing Board Next time, we will continue discussing the process of converting Delphi components into ActiveX controls. In particular, we will cover advanced features such as per-property browsing, property pages, streaming, and deployment. v Copyright © 1998 The Coriolis Group, Inc. All rights reserved.

Listing 1 - ListBoxImpl.src unit ListBoxImpl; interface uses Windows, ActiveX, Classes, Controls, Graphics, Menus, Forms, StdCtrls, ComServ, StdVCL, AXCtrls, DelphiByDesignXLib_TLB; type TListBoxX = class(TActiveXControl, IListBoxX) private { Private declarations } FDelphiControl: TListBox; FEvents: IListBoxXEvents; procedure ClickEvent(Sender: TObject); procedure DblClickEvent(Sender: TObject); procedure KeyPressEvent(Sender: TObject; var Key: Char); // Add a custom event handler for the OnDrawItem event procedure DrawItemEvent( Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState ); protected { Protected declarations } procedure InitializeControl; override; procedure EventSinkChanged(const EventSink: IUnknown); override; procedure DefinePropertyPages( DefinePropertyPage: TDefinePropertyPage); override; function Get_BorderStyle: TxBorderStyle; safecall; function Get_Color: TColor; safecall; function Get_Columns: Integer; safecall;

1390

function Get_Ctl3D: WordBool; safecall; function Get_Cursor: Smallint; safecall; function Get_DragCursor: Smallint; safecall; function Get_DragMode: TxDragMode; safecall; function Get_Enabled: WordBool; safecall; function Get_ExtendedSelect: WordBool; safecall; function Get_Font: Font; safecall; function Get_ImeMode: TxImeMode; safecall; function Get_ImeName: WideString; safecall; function Get_IntegralHeight: WordBool; safecall; function Get_ItemHeight: Integer; safecall; function Get_ItemIndex: Integer; safecall; function Get_Items: IStrings; safecall; function Get_MultiSelect: WordBool; safecall; function Get_ParentColor: WordBool; safecall; function Get_ParentCtl3D: WordBool; safecall; function Get_SelCount: Integer; safecall; function Get_Sorted: WordBool; safecall; function Get_Style: TxListBoxStyle; safecall; function Get_TabWidth: Integer; safecall; function Get_TopIndex: Integer; safecall; function Get_Visible: WordBool; safecall; procedure AboutBox; safecall; procedure Clear; safecall; procedure Set_BorderStyle(Value: TxBorderStyle); safecall; procedure Set_Color(Value: TColor); safecall; procedure Set_Columns(Value: Integer); safecall; procedure Set_Ctl3D(Value: WordBool); safecall; procedure Set_Cursor(Value: Smallint); safecall; procedure Set_DragCursor(Value: Smallint); safecall; procedure Set_DragMode(Value: TxDragMode); safecall; procedure Set_Enabled(Value: WordBool); safecall; procedure Set_ExtendedSelect(Value: WordBool); safecall; procedure Set_Font(const Value: Font); safecall; procedure Set_ImeMode(Value: TxImeMode); safecall; procedure Set_ImeName(const Value: WideString); safecall; procedure Set_IntegralHeight(Value: WordBool); safecall; procedure Set_ItemHeight(Value: Integer); safecall; procedure Set_ItemIndex(Value: Integer); safecall; procedure Set_Items(const Value: IStrings); safecall; procedure Set_MultiSelect(Value: WordBool); safecall; procedure Set_ParentColor(Value: WordBool); safecall; procedure Set_ParentCtl3D(Value: WordBool); safecall; procedure Set_Sorted(Value: WordBool); safecall; procedure Set_Style(Value: TxListBoxStyle); safecall; procedure Set_TabWidth(Value: Integer); safecall; procedure Set_TopIndex(Value: Integer); safecall; procedure Set_Visible(Value: WordBool); safecall; end; implementation uses AboutListBox; { TListBoxX } procedure TListBoxX.InitializeControl; begin FDelphiControl := Control as TListBox; FDelphiControl.OnClick := ClickEvent; FDelphiControl.OnDblClick := DblClickEvent; FDelphiControl.OnKeyPress := KeyPressEvent; // Add a custom event handler for the OnDrawItem event FDelphiControl.OnDrawItem := DrawItemEvent; end;

1391

procedure TListBoxX.EventSinkChanged(const EventSink: IUnknown); begin FEvents := EventSink as IListBoxXEvents; end; function TListBoxX.Get_Enabled: WordBool; begin Result := FDelphiControl.Enabled; end; // Other Get_ Methods procedure TListBoxX.Set_Enabled(Value: WordBool); begin FDelphiControl.Enabled := Value; end; // Other Set_ Methods procedure TListBoxX.DrawItemEvent( Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState ); var ItemColor: TColor; begin ItemColor := FDelphiControl.Font.Color; // Generate the OnColorItem ActiveX event if FEvents <> nil then FEvents.OnColorItem( Index, ItemColor ); // Draw the item using the ItemColor with FDelphiControl do begin if not ( odSelected in State ) then Canvas.Font.Color := ItemColor; Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[Index]); Canvas.Font.Color := FDelphiControl.Font.Color; end; end; initialization TActiveXControlFactory.Create( ComServer, TListBoxX, TListBox, Class_ListBoxX, 1, '{B19A64E4-644D-11D1-AE4B-444553540000}', 0); end.

Distributing ActiveX Controls There are a couple of issues involved in distributing ActiveX controls. First and foremost, you must distribute the *.ocx file that contains your ActiveX controls. If you choose to build your ActiveX library project using runtime packages, you will also need to distribute all of the runtime packages required by your component. 1392

If you instruct the ActiveX control wizard to generate a design-time license for your ActiveX control, you will also need to distribute the corresponding *.lic file. If you deploy an ActiveX control library that uses the IStrings interface or the predefined font, color, strings, or picture property pages, then you must also deploy the standard VCL type library, which comes in two forms: the StdVcl32.dll library, and a standalone type library called StdVcl32.tlb. Both files are located in the Windows System directory (for example, C:\WinNT\System32) after Delphi 3 is installed. Control libraries that use the predefined property pages must deploy StdVcl32.dll. However, if the ActiveX controls only use the IStrings interface, the StdVcl32.tlb type library may be deployed instead. Regardless of which file is deployed, the file must be registered in the system registry, just like the ActiveX control library.

The Turbo Register Server Utility The system registry can be updated with the information needed to support your ActiveX control by using the Turbo Register Server (TRegSvr) utility provided as a demo application in Delphi. The project is located in the Demos\ActiveX\TRegSvr directory beneath the main Delphi 3 installation directory. Of course, before you’ll be able to use the program, you’ll need to compile it. TRegSvr has a simple command-line interface. After the program name, you specify a set of options followed by the file to register. The file can be an ActiveX server DLL or a type library. The default action is to register the specified file. The -u option is used to unregister the specified file. The -t option is used to indicate that the type library contained in the specified file should be registered. This option is not needed if the specified file ends in “.tlb”. The -q option instructs the TRegSvr program to operate in Quiet Mode by not displaying any output. This option makes TRegSvr ideal to execute during installation programs. For the examples presented earlier, the following calls to TRegSvr handle registering the TListBoxX ActiveX control with the system: TRegSvr -q DelphiByDesignXLib.ocx TRegSvr -q StdVcl32.dll

On the Drawing Board Next time, Visual Developer Magazine celebrates its 50th issue. Ever since my “Blazing Pascal” column (the precursor to “Delphi by Design”) first appeared in PC Techniques years ago, I have received quite a bit of feedback. Some of the messages were simply comments. Others asked where the source code from the column could be found. But by far the most common questions asked were about Delphi programming techniques. That is, “how to” questions. For example, the following is a typical message: “Hi, Ray. I read your column every issue. Your article on was excellent. However, I’ve run into a programming problem that I’m hoping you’ll be able to help me with. How do I in Delphi?” Okay, so maybe I exaggerated the tone of the first two sentences. The point is that I receive a lot of good questions, and because many of the same questions keep coming up, I have often wanted to incorporate a topic or two in my articles. Unfortunately, I never have any extra room in my column. Therefore, the next installment of “Delphi by Design” will not have a single topic. Instead, I’m putting together a collection of topics based on questions that I have received. v Copyright © 1998 The Coriolis Group, Inc. All rights reserved.

Listing 1 - ListBoxImpl.src unit ListBoxImpl; interface

1393

uses Windows, ActiveX, Classes, Controls, Graphics, Menus, Forms, StdCtrls, ComServ, StdVCL, AXCtrls, DelphiByDesignXLib_TLB; type TListBoxX = class( TActiveXControl, IListBoxX ) private { Private declarations } FDelphiControl: TListBox; . . . protected { Protected declarations } procedure InitializeControl; override; procedure EventSinkChanged(const EventSink: IUnknown); override; procedure DefinePropertyPages( DefinePropertyPage: TDefinePropertyPage); override; function GetPropertyString( DispID: Integer; var S: string ): Boolean; override; function GetPropertyStrings( DispID: Integer; Strings: TStrings ): Boolean; override; procedure GetPropertyValue( DispID, Cookie: Integer; var Value: OleVariant ); override; { Methods that support properties } . . . end; implementation uses TabWidthPpg, AboutListBox, SysUtils; { TListBoxX } procedure TListBoxX.DefinePropertyPages( DefinePropertyPage: TDefinePropertyPage ); begin { Associate Predefined Property Pages with this control } DefinePropertyPage( Class_DStringPropPage ); DefinePropertyPage( Class_DFontPropPage ); { Associate a Custom Property Page with this control } DefinePropertyPage( Class_PpgTabWidth ); end; function TListBoxX.GetPropertyString( DispID: Integer; var S: string ): Boolean; begin case DispID of 5: // 5 = DispID for DragCursor property in IListBoxXDisp begin S := CursorToString( Get_DragCursor ); Result := True; end; 26: // 26 = DispID for Cursor property in IListBoxXDisp begin S := CursorToString( Get_Cursor ); Result := True; end;

1394

else Result := False; end; end; function TListBoxX.GetPropertyStrings( DispID: Integer; Strings: TStrings ): Boolean; var I: Integer; Cookie: Integer; TempList: TStringList; begin case DispID of 5, // 5 = DispID for DragCursor property in IListBoxXDisp 26: // 26 = DispID for Cursor property in IListBoxXDisp begin TempList := TStringList.Create; try GetCursorValues( TempList.Append ); for I := 0 to TempList.Count - 1 do begin Cookie := StringToCursor( TempList[ I ] ); Strings.AddObject( TempList[ I ], TObject( Cookie ) ); end; finally TempList.Free; end; Result := True; end; else Result := False; end; end; procedure TListBoxX.GetPropertyValue( DispID, Cookie: Integer; var Value: OleVariant ); begin case DispID of 5, // 5 = DispID for DragCursor property in IListBoxXDisp 26: // 26 = DispID for Cursor property in IListBoxXDisp begin { Cookie represents the item that was selected } Value := Cookie; end; end; end; {= All other support methods deleted for space =} initialization TActiveXControlFactory.Create( ComServer, TListBoxX, TListBox, Class_ListBoxX, 1, '{B19A64E4-644D-11D1-AE4B-444553540000}', 0); end.

Listing 2 - DelphiByDesignXLib_TLB.src unit DelphiByDesignXLib_TLB; { This file contains pascal declarations imported from a type library. This file will be written during each import or refresh of the type library editor. Changes to this file will be discarded during the

1395

refresh process. } { DelphiByDesignXLib Library } { Version 1.0 } interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; const LIBID_DelphiByDesignXLib: TGUID = '{B19A64DB-644D-11D1-AE4B-444553540000}'; const { Component class GUIDs } Class_ListBoxX: TGUID = '{B19A64DE-644D-11D1-AE4B-444553540000}'; type { Forward declarations: Interfaces } IListBoxX = interface; IListBoxXDisp = dispinterface; IListBoxXEvents = dispinterface; { Forward declarations: CoClasses } ListBoxX = IListBoxX; { Forward declarations: Enums } TxBorderStyle = TOleEnum; TxDragMode = TOleEnum; TxImeMode = TOleEnum; TxListBoxStyle = TOleEnum; TxMouseButton = TOleEnum; { Dispatch interface for ListBoxX Control } IListBoxX = interface(IDispatch) ['{B19A64DC-644D-11D1-AE4B-444553540000}'] function Get_DragCursor: Smallint; safecall; procedure Set_DragCursor(Value: Smallint); safecall; . . . function Get_Cursor: Smallint; safecall; procedure Set_Cursor(Value: Smallint); safecall; . . . procedure AboutBox; safecall; . . . property DragCursor: Smallint read Get_DragCursor write Set_DragCursor; . . . property Cursor: Smallint read Get_Cursor write Set_Cursor; end; { DispInterface declaration for Dual Interface IListBoxX } IListBoxXDisp = dispinterface ['{B19A64DC-644D-11D1-AE4B-444553540000}'] property BorderStyle: TxBorderStyle dispid 1; property Color: TColor dispid 2; property Columns: Integer dispid 3; property Ctl3D: WordBool dispid 4; property DragCursor: Smallint dispid 5; property DragMode: TxDragMode dispid 6; property Enabled: WordBool dispid 7; property ExtendedSelect: WordBool dispid 8; property Font: Font dispid 9; property ImeMode: TxImeMode dispid 10; property ImeName: WideString dispid 11;

1396

property IntegralHeight: WordBool dispid 12; property ItemHeight: Integer dispid 13; property Items: IStrings dispid 14; property MultiSelect: WordBool dispid 15; property ParentColor: WordBool dispid 16; property ParentCtl3D: WordBool dispid 17; property Sorted: WordBool dispid 18; property Style: TxListBoxStyle dispid 19; property TabWidth: Integer dispid 20; property Visible: WordBool dispid 21; procedure Clear; dispid 22; property ItemIndex: Integer dispid 23; property SelCount: Integer readonly dispid 24; property TopIndex: Integer dispid 25; property Cursor: Smallint dispid 26; procedure AboutBox; dispid -552; end; { Events interface for ListBoxX Control } IListBoxXEvents = dispinterface ['{B19A64DD-644D-11D1-AE4B-444553540000}'] procedure OnClick; dispid 1; procedure OnDblClick; dispid 2; procedure OnKeyPress(var Key: Smallint); dispid 3; procedure OnColorItem(Index: Integer; var Color: TColor); dispid 4; end; implementation end.

Listing 3 - TabWidthPpg.pas unit TabWidthPpg; interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms, ComServ, ComObj, StdVcl, AxCtrls, ComCtrls; type TPpgTabWidth = class( TPropertyPage ) GrpPreview: TGroupBox; GrpTabWidth: TGroupBox; LstPreview: TListBox; ChkUseTabs: TCheckBox; TrkTabWidth: TTrackBar; procedure ChkUseTabsClick(Sender: TObject); procedure TrkTabWidthChange(Sender: TObject); private { Private declarations } protected procedure UpdatePropertyPage; override; procedure UpdateObject; override; public { Public declarations } end; const Class_PpgTabWidth: TGUID = '{8BE91420-9070-11D1-AE4B-44455354616F}';

1397

implementation {$R *.DFM} procedure TPpgTabWidth.UpdatePropertyPage; var I: Integer; begin { Update your controls from OleObject } { Copy strings from control into preview list box } for I := 0 to OleObject.Items.Count - 1 do LstPreview.Items.Add( OleObject.Items[ I ] ); ChkUseTabs.Checked := OleObject.TabWidth > 0; TrkTabWidth.Position := OleObject.TabWidth div 4; LstPreview.TabWidth := OleObject.TabWidth; end; procedure TPpgTabWidth.UpdateObject; begin { Update OleObject from your controls } OleObject.TabWidth := LstPreview.TabWidth; end; procedure TPpgTabWidth.ChkUseTabsClick(Sender: TObject); begin TrkTabWidth.Enabled := ChkUseTabs.Checked; if ChkUseTabs.Checked then LstPreview.TabWidth := TrkTabWidth.Position * 4 else LstPreview.TabWidth := 0; end; procedure TPpgTabWidth.TrkTabWidthChange(Sender: TObject); begin Modified; LstPreview.TabWidth := TrkTabWidth.Position * 4; end; initialization TActiveXPropertyPageFactory.Create( ComServer, TPpgTabWidth, Class_PpgTabWidth ); end.

1398

COM and ActiveX · · · · · · · · · · · · · · · ·

· Understanding COM COM Terminology Reference Counting The IUnknown Interface Creating a COM Object Adding Code Understanding ActiveX Using Third-Party ActiveX Controls Creating New ActiveX Controls Changing the ActiveX Palette Bitmap Web Deploying ActiveX Controls and ActiveForms Web Deployment Options Web Deploy Summary Q&A Quiz Exercises

OLE, ActiveX, COM, DCOM, VCL, CORBA, MTS. . . the industry certainly doesn't lack for acronyms when it comes to the subject of component architecture! In this chapter, I explain some of these acronyms and at least mention the others in passing. I'll explain what these terms mean and try to shed some light on the often-confusing world of COM and ActiveX. Specifically, I cover · What COM is · Creating COM objects · The Delphi Type Library Editor · Creating ActiveX controls · Creating ActiveForms · Deploying ActiveX controls I'd be lying if I said that COM, ActiveX, and OLE are easy to understand. They are not. It can be very confusing at first. I can't do justice to this subject in one chapter. My goal for this chapter is to give you enough of a background on these architectures so that you can better understand the acronyms you see bandied about these days. You will also get some good hands-on training in creating COM and ActiveX controls. Fortunately, Delphi takes a great deal of the pain out of dealing with these APIs.

Understanding COM You can't talk about OLE and ActiveX without talking about COM, which stands for Component Object Model. New Term: COM (Component Object Model) is a Microsoft specification for creating and implementing reusable components. "Components? I thought Delphi used VCL components." Certainly VCL components are the most effective use of components in Delphi. They aren't the only possibility, though. As you work through this hour, you will get a clearer picture of how COM and ActiveX work with Delphi. COM is the basis for both OLE and ActiveX. An analogy might be the TObject class in VCL. All classes in VCL are ultimately inherited from TObject. Derived classes automatically get the properties and methods of TObject. They then add their own properties and methods to provide additional functionality. Similarly, OLE and ActiveX are built on top of COM. COM is the foundation for all OLE and ActiveX objects. 1399

As a component architecture, COM has two primary benefits: · COM object creation is language independent. (COM objects can be written in many different programming languages.) · A COM object can be used in virtually any Windows programming environment including Delphi, C++Builder, Visual C++, Visual Basic, PowerBuilder, Visual dBASE, and many more. NOTE: One major drawback to COM is that it is heavily tied to the WinTel (Windows/Intel) platform. So although you can use a COM object in many different Windows programming environments, you can't necessarily use that COM object in a UNIX programming environment. Recently Microsoft has tried to move COM to nonWindows platforms, but it remains to be seen whether this attempt will ultimately succeed. This chapter deals only with COM and ActiveX as they exist in the Win32 programming environment. You can use a number of different languages and environments to write COM objects. You can create COM objects with Delphi, C++Builder, Visual C++, Visual Basic, and probably a few other development environments. When created, a COM object can be used in an even wider variety of development environments. A COM object created in Delphi can be used by a VB programmer, a C++Builder programmer, or even a Visual dBASE or PowerBuilder programmer. A COM object is typically contained in a DLL. The DLL might have an extension of .DLL or it might have an extension of .OCX. A single library file (DLL or OCX) can contain an individual COM object or can contain several COM objects.

COM Terminology COM is full of confusing terminology. The following sections explain some of the terms used in COM and how the many pieces of COM fit together. All of these pieces are interrelated, so you'll have to read the entire section to get the big picture. COM Objects New Term: A COM object is a piece of binary code that performs a particular function. A COM object exposes certain methods to enable applications to access the functionality of the COM object. These methods are made available via COM interfaces. A COM object might contain just one interface, or it might contain several interfaces. To a programmer, COM objects work a lot like Object Pascal classes. COM Interfaces Access to a COM object is through the COM object's interface. New Term: A COM interface is the means by which the user of a COM object accesses that object's functionality. A COM interface is used to access a COM object; to use the object, if you will. The interface in effect advertises what the COM object has to offer. A COM object might have just one interface, or it might have several. In addition, one COM interface might implement one or more additional COM interfaces. COM interfaces typically start with the letter I. The Windows shell, for example, implements interfaces called IShellLink, IShellFolder, and IShellExtInit. Although you can use any naming convention you like, the leading I universally and immediately identifies the class as a COM interface to other programmers. COM interfaces are managed internally by Windows according to their interface identifiers (IIDs). An IID is a numerical value contained in a data structure (a record). The IID uniquely identifies an interface.

1400

COM Classes New Term: A COM class (also known as a coclass) is a class that contains one or more COM interfaces. You can't use a COM interface directly. Instead, you access the interface through a coclass. A coclass includes a class factory that creates the requested interface and returns a pointer to the interface. COM classes are identified by class identifiers (CLSIDs). A CLSID, like an IID, is a numerical value that uniquely identifies a COM class. GUIDs COM objects must be registered with Windows. This is where CLSIDs and IIDs come into play. CLSIDs and IIDs are really just different names for the same base data structure: the Globally Unique Identifier (GUID). New Term: A GUID is a unique 128-bit (16-byte) value. GUIDs are created by a special COM library function called CoCreateGUID. This function generates a GUID that is virtually guaranteed to be unique. CoCreateGUID uses a combination of your machine information, random number generation, and a time stamp to create GUIDs. Although it is possible that CoCreateGUID might generate two GUIDs that are identical, it is highly unlikely (more like a statistical impossibility). Thankfully, Delphi programmers don't have to worry about creating GUIDs. Delphi automatically generates a GUID when you create a new automation object, COM object, ActiveX control, or ActiveForm control. GUIDs in Delphi are defined by the TGUID record. TGUID is declared in System.pas as follows: TGUID = record D1: Integer; D2: Word; D3: Word; D4: array[0..7] of Byte; end; When you create a new COM object, Delphi automatically creates the GUID for you. For example, here's the GUID for a test COM object I created: Class_Test: TGUID = `{F34107A1-ECCF-11D1-B47A-0040052A81F8}';

Because GUIDs are handled for you by Delphi, you won't typically have to worry very much about GUIDs. You will, however, see GUIDs a lot as you create and use COM objects (including ActiveX controls). TIP: If you need to generate a GUID manually, you can type Ctrl+Shift+G in the Code Editor. Delphi will generate a GUID for you and insert it at the cursor point. Type Libraries COM objects often use a type library. New Term: A type library is a special file that contains information about a COM object. This information includes a list of the properties, methods, interfaces, structures, and other elements that the control contains. The type library also provides information about the data types of each property and the return type and parameters of the object's methods. This information includes the data types in the object, the methods and properties of the object, the version information, interfaces in the object, and so on. Type libraries can be contained in the COM object as resources or as a standalone file. Type library files have a .TLB extension. A type library is necessary if other developers are going to use your COM objects as development tools. A COM object's type library contains more information about the object than is available by simply querying the object for its interfaces. The Delphi IDE, for example, uses the information found in type libraries to display an ActiveX control on the Component palette. Users of a COM object can examine the type library to see exactly what methods and interfaces the object contains. 1401

DCOM Distributed COM (DCOM) is a subset of COM that provides the capability to use COM objects across networks or across the Internet. DCOM extends COM to provide the mechanism for using COM in a networking environment. A detailed discussion of DCOM is beyond the scope of this book, but note that DCOM is definitely prevalent in certain types of network programming. NOTE: CORBA (Common Object Request Broker Architecture) is a competing technology to DCOM. CORBA is platform-independent, which makes it more desirable than DCOM in many ways. In addition, CORBA is an open architecture supported by a consortium of software companies (unlike DCOM, which is a Microsoft-specific solution). Fortunately, Delphi gives you the option of creating both DCOM and CORBA objects.

Reference Counting Every COM object has a reference count. The reference count, naturally, contains the number of processes that are currently using the COM object. A process is any application or DLL that uses a COM object. Because a COM object can be used by any number of processes at one time, reference counting is used to determine when the COM object is no longer needed in memory. When a COM object is created, its reference count is initialized to 1. The reference count is incremented by one each time a process attaches to the COM object. When a process detaches from the COM object, the reference count is decremented by one. When the reference count gets to 0, the COM object is freed from memory.

The IUnknown Interface All COM interfaces descend from a base interface called IUnknown. Table 15.1 lists the methods of IUnknown. TABLE 15.1. IUnknown METHODS. Method Description QueryInte Queries the interface to obtain a list of supported interfaces. rface AddRef Increments the interface's reference count. Decrements the interface's reference count. When the reference count Release reaches 0, the object is freed from memory. I mention IUnknown primarily for historical reasons. Delphi programmers don't really have to worry much about IUnknown as other programmers do. Delphi takes care of handling reference counting and freeing the memory for the COM object. Delphi also elevates dealing with COM objects to a level that makes an intimate knowledge of IUnknown all but obsolete.

Creating a COM Object To help bring this into perspective, let's create a COM object. This COM object will be ridiculously simple but should illustrate how to use and build COM objects in Delphi. The COM object you create will have these characteristics: Na Type Description me property X The first number to multiply. property Y The second number to multiply. method DoIt A method that multiplies the two numbers and returns the result. The following sections explain the process of creating the COM object. 1402

Creating an ActiveX Library The first step in creating a COM object is to create a DLL project that will contain the COM object's code. Delphi uses the term "ActiveX Library" to refer to all COM library projects. This description isn't entirely accurate, but it's close enough. Perform these steps to create an ActiveX Library: 1. Close all projects. Choose File|New from the main menu to display the Object Repository. 2. Click on the ActiveX tab to show the ActiveX page (see Figure 15.1). Double-click the ActiveX Library icon. Figure 15.1. The Object Repository's ActiveX page. 3. Choose File|Save and save the project as ComTest. That's all there is to this particular step. Delphi creates a DLL project for you and is waiting for your next move. Creating the Actual Object The next step is to create the COM object itself. This step is also relatively simple. Perform these steps to do so: 1. Choose File|New from the Delphi main menu. The Object Repository is displayed. Click on the ActiveX page. 2. Double-click on the COM Object icon. Delphi displays the COM Object Wizard, as shown in Figure 15.2. FIGURE 15.2. The COM Object Wizard.

THE COM OBJECT WIZARD Let me take a moment to talk about the COM Object Wizard. The Class Name field is used to specify the class name for your COM object. Type the class name here, but don't prepend the class name with either a T as you would for a Delphi class, nor an I as is customary for interfaces. Delphi will take care of creating the class and interface names automatically. The Instancing field is used to control how multiple instances of the COM object are handled. Choices include Internal, Single Instance, or Multiple Instance. See the "COM object wizard" topic in the Delphi help for descriptions of these instancing options (you can click the Help button on the COM Object Wizard to display the correct help topic). The Threading Model field is used to specify how client applications can call your COM object. Choices include Single, Apartment, Free, or Both. Again, see the Delphi help for descriptions of the threading models. The Implemented Interfaces field is where you add the names of any interfaces that your COM object will implement. If you have an interface called IMyFileIO and you want to use that interface in your new COM object, you would type IMyFileIO in this field. The Description field is used to supply a description for the COM object. The description is optional, but it's a good idea to provide one. When the Include Type Library check box is checked, Delphi will create a type library for the COM object. Creating a type library enables your COM object to be used by client applications. Okay, let's get back to work: 1403

3. Enter Multiply in the Class Name field. 4. Enter Test COM Object in the Description field. 5. Check the Include Type Library check box. The other fields on the dialog box can be left at their default values. 6. Click OK to close the dialog box. When you click the OK button, Delphi creates a unit for the COM object's class and displays the Type Library Editor, as shown in Figure 15.3. Before continuing, I need to take a moment to talk about the Type Library Editor. Using the Type Library Editor The Type Library Editor is used to manipulate a type library. The Type Library Editor enables you to add or remove interfaces, add properties and methods to interfaces, remove elements from interfaces, and create host of other COM elements such as enumerations, records, or coclasses. The Type Library Editor makes it easy to add elements to a type library. You'll learn about adding elements in the next section when you add properties and a method to the COM object. On the left side of the Type Library Editor is the Object pane. The Object pane contains a tree view control. At the top of the tree view hierarchy is the type library itself. Below the type library are elements contained in the type library. In Figure 15.3, you see two elements: the IMultiply interface and the Multiply coclass. On the right side of the Type Library Editor is the Information pane. This pane provides information about the object currently selected in the Object pane. The information presented in the information pane varies with the type of object selected. The Attributes page shows the type library name, its GUID, version, help string, help file, and so on. NOTE: Remember earlier when I said that Delphi programmers don't need to worry much about GUIDs? The COM object you just created already has a GUID, as does the type library itself. Delphi creates these GUIDs for you automatically. As I said before, you'll see GUIDs a lot as you work with COM objects, but you don't have to worry about creating them. When the type library node is selected, the Information pane shows a tab labeled Uses. When you click on this tab you will see a list of type libraries that this type library relies on. In almost all cases, this list will include the OLE Automation library, but it can contain others as well. The exact libraries a particular type library relies on depends on the type and complexity of the COM object the type library describes. The Text page shows the type library definitions in IDL syntax. IDL is sort of a scripting language used to create binary type library files. You shouldn't change any of the text on this tab unless you know exactly what you are doing. You might, however, refer to the Text page for reference. This is probably of more value to experienced programmers than to beginners. Other pages might be displayed in the Information pane depending on the type of object selected. For complete details, be sure to read the "Type Library Editor" help topic in the Delphi help. You will learn more about the Type Library Editor as you work through the rest of the chapter. Now let's get back to creating the COM object. Adding Properties and Methods to the COM Object Before going further, you should save the project again. You didn't realize it, but Delphi created a new unit when you created the COM object in the previous step. Choose File|Save All from the main menu and save the unit as MultiplyU. 1404

Now you are ready to make the COM object do something. Remember, this COM object is incredibly simplistic, so it won't do much, but it will at least do something. ADDING PROPERTIES First you will add properties to the COM object. Here are the steps: 1. Click on the IMultiply node in the Type Library Editor's Object pane. Notice that the Information pane shows the interface's name, GUID, and version. Notice also that the Parent Interface field shows the ancestor of IMultiply as IUnknown. If you recall, I said earlier that IUnknown is the base (or parent) interface from which all other interfaces are derived. Delphi automatically assumes a base interface of IUnknown. You can change the base interface to some other interface if you want by choosing an interface from the list of available interfaces. Other interfaces in the list are themselves derived from IUnknown or one of its descendants. 2. Right-click and choose New|Property from the context menu. The Type Library Editor adds two new nodes to the Objects pane under the IMulitply interface. The cursor is in editing mode so that you can type the name of the new property. 3. Type X for the property name and then press the Enter key. Both of the new nodes change to X. There are two nodes to each property because, by default, a property is assumed to be a read/write property. COM requires a Get method to read a property and a Put method to write to a property, hence the two entries. Click on either of the two nodes labeled X. Notice the Invoke Kind field in the Information pane as you select first one X node and then the other. Notice that the field changes from Property Set to Property Get. 4. Notice in the Information pane that the Type field says Integer. That's the data type you want for this property, so you don't need to change the type. 5. Create another new property but this time use a different approach. Locate the New Property button on the Type Library Editor toolbar. Click the drop-down arrow next to the New Property button. Choose Read|Write from the list of property types. The Type Library Editor creates the new property. Name this property Y. You can accept the default data type of Integer for this property as well. Behind the scenes Delphi is adding code to the project's units as you add elements. Adding a Method Next, you add a method. Perform these steps: 1. Select the IMultiply object in the Object pane and click the New Method button on the Type Library Editor toolbar. 2. Name the method DoIt. Notice that the Invoke Kind field says Function (as opposed to Property Get and Property Set). Next you must set the method's parameters. The method will have this syntax: function DoIt : Integer;

3. Click on the Parameters tab in the Information pane. Change the Return Type field to Integer (choose Integer from the combo box). This method doesn't have any parameters, so you can leave the Parameters list empty. After you have set the return type, click the Attributes tab to display the Attributes page. This step isn't strictly necessary, but does serve the purpose of taking you back to where you started. 4. Click the Refresh Implementation button on the Type Library Editor toolbar.

1405

Now that you have added the two properties and methods, it's time to see what Delphi has been doing behind the scenes. Listing 15.1 shows the class's unit as it appears after performing the steps up to this point. (Don't worry if your unit doesn't look exactly like Listing 15.1. My version of Delphi might have added code in a slightly different order than yours.) LISTING 15.1. MultiplyU AFTER ADDING PROPERTIES AND A METHOD. unit MultiplyU; interface uses Windows, ActiveX, ComObj, ComTest_TLB; type TMultiply = class(TTypedComObject, IMultiply) protected function DoIt: Integer; stdcall; function Get_X: Integer; stdcall; function Get_Y: Integer; stdcall; procedure Set_X(Value: Integer); stdcall; procedure Set_Y(Value: Integer); stdcall; {Declare IMultiply methods here} end; implementation uses ComServ; function TMultiply.DoIt: Integer; begin end; function TMultiply.Get_X: Integer; begin end; function TMultiply.Get_Y: Integer; begin end; procedure TMultiply.Set_X(Value: Integer); begin end; procedure TMultiply.Set_Y(Value: Integer); begin end; initialization TTypedComObjectFactory.Create(ComServer, TMultiply, Class_Multiply, ciMultiInstance, tmSingle); end.

This is the shell of the COM object. Notice that the TMultiply class is derived from both TTypedComObject and IMultiply. (To C++ programmers, this might look like multiple inheritance. It's not exactly multiple inheritance, but it is similar in some ways.) You haven't seen the IMultiply class yet, but you will a bit later. You must fill out this shell in order to make the COM object do something. You will do that next.

Adding Code You will now add code to the TMultiply class to make the COM object functional. Perform these steps (refer to Listing 15.2 if necessary): 1. Display the MuliplyU.pas unit in the Code Editor. Add these lines to the TMultiply class declaration, just above the protected keyword: private FX : Integer; FY : Integer;

These are the declarations for the data fields that will hold the X and Y property values. 2. Scroll down into the implementation section and locate the Get_X method (use the Code Explorer if you like). Type this line of code in the method: 1406

Result := FX;

3. Locate the Get_Y method and add this line: Result := FY;

4. Locate the DoIt method and add this line of code: Result := FX * FY;

This line of code multiplies the value of FX and FY and returns the result. 5. Scroll down further until you see the Set_X method. Type this line of code in the Set_X method: FX := Value;

6. Locate the Set_Y method and add this line: FY := Value;

That's all you need to do. Your code should now look like Listing 15.2. LISTING 15.2. THE COMPLETED MultiplyU UNIT. unit MultiplyU; interface uses Windows, ActiveX, ComObj, ComTest_TLB; type TMultiply = class(TTypedComObject, IMultiply) private FX : Integer; FY : Integer; protected function DoIt: Integer; stdcall; function Get_X: Integer; stdcall; function Get_Y: Integer; stdcall; procedure Set_X(Value: Integer); stdcall; procedure Set_Y(Value: Integer); stdcall; {Declare IMultiply methods here} end; implementation uses ComServ; function TMultiply.DoIt: Integer; begin Result := FX * FY; end; function TMultiply.Get_X: Integer; begin Result := FX; end; function TMultiply.Get_Y: Integer; begin Result := FY; end; procedure TMultiply.Set_X(Value: Integer); begin FX := Value; end; procedure TMultiply.Set_Y(Value: Integer); begin FY := Value; end; initialization TTypedComObjectFactory.Create(ComServer, TMultiply, Class_Multiply, ciMultiInstance, tmSingle); end.

Although you were working on the MulitplyU unit, Delphi was busy building the type library and a unit to contain the type library code. The unit has the same name as the project with 1407

a trailing _TLB. This project is named ComTest. The full unit name for the type library unit, then, is ComTest_TLB.pas. Listing 15.3 shows this unit as it exists at this point. Remember, your unit might not look exactly like Listing 15.3. LISTING 15.3. THE ComTest_TLB.pas UNIT. unit ComTest_TLB; // ******************************************************************** // // WARNING // // ------// // The types declared in this file were generated from data read from a // // Type Library. If this type library is explicitly or indirectly (via // // another type library referring to this type library) reimported, or // // the `Refresh' command of the Type Library Editor activated while // // editing the Type Library, the contents of this file will be // // regenerated and all manual modifications will be lost. // // ******************************************************************** // // PASTLWTR : $Revision: 1.11.1.55 $ // File generated on 6/8/98 7:16:51 PM from Type Library described below. // ******************************************************************** // // Type Lib: D:\Borland\D4\Bin\ComTest.tlb // IID\LCID: {7CDAFB76-FF36-11D1-81F1-0040052A83C4}\0 // Helpfile: // HelpString: ComTest Library // Version: 1.0 // ******************************************************************** // interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; // *********************************************************************// // GUIDS declared in the TypeLibrary. Following prefixes are used: // // Type Libraries : LIBID_xxxx // // CoClasses : CLASS_xxxx // // DISPInterfaces : DIID_xxxx // // Non-DISP interfaces: IID_xxxx // // *********************************************************************// const LIBID_ComTest: TGUID = `{7CDAFB76-FF36-11D1-81F1-0040052A83C4}'; IID_IMultiply: TGUID = `{7CDAFB77-FF36-11D1-81F1-0040052A83C4}'; CLASS_Multiply: TGUID = `{7CDAFB79-FF36-11D1-81F1-0040052A83C4}'; type // *********************************************************************// // Forward declaration of interfaces defined in Type Library // // *********************************************************************// IMultiply = interface; // *********************************************************************// // Declaration of CoClasses defined in Type Library // // (NOTE: Here we map each CoClass to its Default Interface) // // *********************************************************************// Multiply = IMultiply; // *********************************************************************// // Interface: IMultiply // Flags: (0) // GUID: {7CDAFB77-FF36-11D1-81F1-0040052A83C4} // *********************************************************************// IMultiply = interface(IUnknown) [`{7CDAFB77-FF36-11D1-81F1-0040052A83C4}'] function Get_X: Integer; stdcall; procedure Set_X(Value: Integer); stdcall; function Get_Y: Integer; stdcall; procedure Set_Y(Value: Integer); stdcall; function DoIt: Integer; stdcall; end; CoMultiply = class class function Create: IMultiply; class function CreateRemote(const MachineName: string): IMultiply; end;

1408

implementation uses ComObj; class function CoMultiply.Create: IMultiply; begin Result := CreateComObject(CLASS_Multiply) as IMultiply; end; class function CoMultiply.CreateRemote(const MachineName: string): ÂIMultiply; begin Result := CreateRemoteComObject(MachineName, CLASS_Multiply) as ÂIMultiply; end; end.

Notice that this unit contains the declaration for the IMultiply interface. As you can see, IMultiply is derived from IUnknown. Notice also that this unit contains the coclass Multiply. It is important to understand that this unit is regenerated each time you compile an ActiveX library project. It is generated from the type library file. Note the warning at the top of the unit. The comments are telling you that any changes you make to this file will be lost the next time the COM object is rebuilt. It really doesn't do any good to modify the type library source file, because it will be regenerated automatically. Building and Registering the COM Object Now you are ready to compile the ActiveX library project. This step compiles the COM object and builds the DLL in which the COM object resides. After building the COM object, you can register it. Here are the steps: 1. Choose Project|Build ComTest from the main menu. Delphi will build the DLL containing the COM object. 2. Choose Run|Register ActiveX Server from the main menu. This step registers the COM object with Windows. If you fail to perform this step, you will get an exception that says, "Class not registered" when you attempt to access the COM object. Delphi registers the COM object DLL with Windows. After the DLL has been registered, Delphi displays a message box, as shown in Figure 15.4. FIGURE 15.4. Delphi reporting the COM object successfully registered. When Windows registers the COM object, it adds information about the object to the Registry. Figure 15.5 shows the Registry entry created when the COM object was registered with Windows. FIGURE 15.5. The Registry key created when the COM object was registered. NOTE: Delphi ships with a utility called TREGSVR.EXE that can be used to register an ActiveX control from the command line. To register a control called MYSTUFF.OCX, you would run TREGSVR from a command prompt like this: tregsvr mystuff.ocx

To unregister an ActiveX, use the -u switch as follows: tregsvr -u mystuff.ocx

Sometimes this is more convenient than loading an ActiveX project in Delphi and registering or unregistering the control from the IDE.

NOTE: In this exercise I had you create a COM object. You could also have used an automation object. An automation object derives from IDispatch rather than IUnknown. IDispatch provides the additional functionality required for a COM object to act as an automation server (an object that can control one application from another). Your COM object is now ready to use. 1409

Building an Application That Uses the COM Object A COM object doesn't do you much good if you can't use it. In this step, you create an application that uses the COM object you just created. Follow these steps: 1. Create a new application. Place a Button component and a Label component on the form. Save the project as ComApp and the main form's unit as ComAppU. 2. Switch to the Code Editor and locate the uses list for the main unit. Add these units to the uses list: ComObj ComTest_TLB

This ensures that the code that references the COM object will compile. 3. Double-click the form's button to create an OnClick event handler. Modify the OnClick handler so that it looks like this: procedure TForm1.Button1Click(Sender: TObject); var Mult : IMultiply; Res : Integer; begin Mult := CreateComObject(CLASS_Multiply) as IMultiply; if Assigned(Mult) then begin Mult.Set_X (20); Mult.Set_Y (60); Res := Mult.DoIt; Label1.Caption := IntToStr(Res); end; end;

This code first declares a pointer to the IMultiply interface called Mult and an Integer variable to hold the result. Next, the CreateComObject function is called with a parameter of CLASS_Multiply. CLASS_Multiply is a constant that contains the GUID for the COM object class (refer to Listing 15.3). The return value from CreateComObject is assigned to the Mult pointer. Notice that I use the as operator to cast the return value to an IMultiply pointer. CreateComObject returns an IUnknown pointer, so the as operator is used to cast the IUnknown pointer to an IMultiply pointer. After the COM object is created, I assign values to the X and Y properties. After that I call the DoIt method of the COM object and display the result in the Label component. NOTE: In the real world, I would have written the preceding procedure differently. For example: procedure TForm1.Button1Click(Sender: TObject); begin with CreateComObject(CLASS_Multiply) as IMultiply do begin Set_X(20); Set_Y(60); Label1.Caption := IntToStr(DoIt); end; end;

I wrote the procedure the way I did to illustrate each step. Run the program. When you click the form's button, the label should change to say "1200" (the product of 20 * 60). That's it! Your COM object works. This COM object can be used from Visual Basic, Visual C++, C++Builder, or any other development environment that supports COM.

1410

Understanding ActiveX ActiveX is a relatively new term for a technology that has been around for awhile. Originally ActiveX controls were called OCX controls. The term OCX is still widely used in some circles. An ActiveX control typically has a filename extension of either DLL or OCX. An ActiveX control is essentially a COM object in disguise. The primary difference between an ActiveX control and a COM object is that an ActiveX control has a design-time interface. An ActiveX control also has code that enables it to be deployed on a Web page or over a network. ActiveX is a subset of COM, so everything you learned about COM objects in the first part of the chapter applies to ActiveX controls as well.

Using Third-Party ActiveX Controls There isn't a lot to know about installing and using third-party ActiveX controls. All you have to do is import the ActiveX into the IDE and begin using the control. To see how this works, let's do a quick exercise. This exercise requires that you have Microsoft Internet Explorer installed on your system. If you don't have Internet Explorer installed, skip this exercise. (You won't be missing anything because I show you how to install an ActiveX control you have built in the section "Build, Register, and Install the Control.") Perform these steps: 1. Choose Component|Import ActiveX Control from the main menu. The Import ActiveX dialog box is displayed. 2. Scroll down through the list of installed components until you find Microsoft Internet Controls (the exact text of the item will depend on the version of Internet Explorer you have installed on your system). Select the item. Figure 15.6 shows the Import ActiveX dialog box after this step. FIGURE 15.6. The Import ActiveX dialog box. Notice the Class names list box in the middle of the page. This list box contains a list of ActiveX controls in the selected file (SHDOCVW.DLL in this case). 3. The Palette page field shows ActiveX. This is a the palette page where the new controls will be installed. Click on this field and type ActiveXTest. 4. Leave the Unit dir name and Search path fields on their default settings and click the Install button. The Install dialog box comes up and asks what package you want the controls installed into. (All controls, whether they are VCL or ActiveX, must be in a package.) 5. Click on the Into new package tab. Enter MSIE in the File name field and Internet Explorer Package in the Description field. 6. Click the OK button. Delphi creates a new package called MSIE.dpk and prompts you to build and install the package. Click Yes to install the package. After the package is built, Delphi displays a message box telling you which controls were added to the Component palette. Click Yes to dismiss the message box. 7. Scroll the Component palette to find the ActiveXText tab. You should see two or three controls on that page of the Component palette (again, depending on the version of Internet Explorer you have installed). The components are ready for use. Experiment with the new controls and see how they work. You probably won't get very far without documentation, but at least you get a sense for how installing an ActiveX works. (For a more complete explanation of using Internet Explorer as an ActiveX, see the section, "Using Internet Explorer as an ActiveX Control" on the Bonus Day, "Building Internet Applications.")

1411

NOTE: You must have a design-time license in order to use an installed ActiveX control. A design-time license is a file with an .LIC extension. In some cases you can import ActiveX controls to the Delphi Component palette without a design-time license, but you will get an error message when you attempt to place the control on your form. To remove the Internet Explorer controls from the Component palette, choose Component|Install Packages from the main menu. Locate the Internet Explorer Package in the Design packages list box and click the Remove button. The ActiveXTest tab is removed from the Component palette. NOTE: Deploying an application that uses ActiveX controls requires special attention. Deploying applications using ActiveX controls is covered in detail on the Bonus Day in the section "Deploying Internet Applications."

Creating New ActiveX Controls There are two ways to create an ActiveX control in Delphi: · From an existing VCL component · From scratch using an ActiveForm In this section, you create an ActiveX control using both of these methods. Creating an ActiveX Control from an Existing VCL Component Creating an ActiveX control from an existing VCL component is downright simple. After you create a component, you can turn it into an ActiveX control in no time at all. I haven't talked about creating components yet, so I don't want to go into a lot of detail on creating components now (covered on Day 20, "Creating Components"). What you will do, then, is create an ActiveX control from one of the VCL components provided by Borland. Generate the ActiveX Project with the ActiveX Control Wizard The first step is to generate the ActiveX project. As always, Delphi does most of the work for you. All you have to do is supply a few fields in the ActiveX Control Wizard. Here are the steps: 1. Choose File|Close All to close all projects and then choose File|New from the main menu. The Object Repository is displayed. 2. Click the ActiveX page and then double-click the ActiveX Control icon. The ActiveX Control Wizard is displayed (see Figure 15.7). FIGURE 15.7. The ActiveX Control Wizard. 3. Select TButton from the list of classes in the VCL Class Name combo box. The next four fields are automatically filled in with default values. Because this is just a test, you can leave those fields on their default values. The fields are self-explanatory, so I don't need to go over each one. 4. The Threading Model is set to Apartment. Leave this setting as it is. Other threading models include Single, Free, and Both. See the Delphi help for more information on threading models. 5. Check the Include Design-Time License check box. When this option is checked, Delphi will create a design-time license for the control. The design-time license will prevent other programmers from using the control unless they have the license. 6. Check the Include Version Information check box. This will enable you to add version info to the control via the Project Options dialog box.

1412

7. Check the Include About Box check box as well. When this box is checked, Delphi will automatically create an About dialog box for the control. Click OK to close the ActiveX Control Wizard. Delphi will create a project file (ButtonXControl1.bpr) and three units for the project. The first unit is the TButtonX class unit (ButtonXImp1.pas). The second unit is the type library file for the control, named ButtonXControl1_TLB.pas. This file contains the information Delphi needs to create the type library for the control. The third file, About1.pas, is the unit for the About box. If you want to customize the About box, you can do that at this time. The About box is just another Delphi form, so feel free to customize it in any way you like. NOTE: Version info is required in order for your ActiveX controls to work in Visual Basic. Build, Register, and Install the Control Because you aren't making any modifications to the control itself, you can jump right to building the control and registering it. This is the same process you went through when you registered the COM object you created earlier. An extra step is required when implementing ActiveX controls, though, because ActiveX controls have a design-time interface. Try this: 1. Choose Project|Build ButtonXControl1 from the main menu. Delphi builds the ActiveX project. 2. Choose Run|Register ActiveX Server from the main menu. The ActiveX control is registered and Delphi displays a message box telling you that the OCX is registered (ActiveX projects have a default extension of .OCX). Click OK to dismiss the message box. 3. Choose Component|Import ActiveX Control from the main menu. Choose ButtonXControl1 Library (Version 1.0) from the list of installed controls (had you not performed step 2, this entry would not have been present in the list of installed controls). The class name of the button, TButtonX, shows in the Class names list box. 4. Set the Palette page field to ActiveX. Click Install to continue. 5. The Install dialog box is displayed. You are going to install the control into the default Delphi user package DCLUSR40.BPL. The File name field should already contain this package. If it doesn't, choose it from the combo box. The Description field now says Delphi User's Components. Click the OK button to install the control. 6. Click Yes to the message box regarding building and installing DCLUSR40.BPL. Click OK when the message box confirming the installation is displayed. The control is now installed. Test the ActiveX Control Now you can test your new ActiveX control. First, create a new project. NOTE: When you create a new project, Delphi will prompt you to save the package file (DCLUSR40.DPK) and the ActiveX control project. Whether you save these files is up to you. My intention was to have you create a quick ActiveX. There's really no need to save the files. If, however, you think you might want to save the files to examine them later, save the files. Now follow these steps: 1. Locate the ActiveX tab on the Component palette. 2. The last control in the list is the ButtonX control. Select it. 1413

3. Place a ButtonX control on your form. Notice that the button doesn't have a default caption as a regular VCL button does. 4. Change the Caption property to Test. The button's caption changes just as a VCL button's caption would change. Notice the list of properties in the Object Inspector. They are mostly the same properties you would see on a VCL button (the ActiveX was created from a VCL TButton after all), but you might have noticed that the Value column looks slightly different. Remember, this is an ActiveX control and is intended to be used in any environment that hosts ActiveX controls. For that reason, some of the property values are expressed in a more generic way. 5. Double-click the button and you will find that nothing happens. An ActiveX control doesn't have the capability to automatically create an event handler when you double-click the button like a VCL component does. Instead, switch to the Events page and double-click the Value column next to the OnClick event. An event handler is generated. Type this line of code: MessageDlg(`Hey, it works!', mtInformation, [mbOK], 0);

6. Run the program and test the button to ensure that it works. When you have verified that the button works, close the program. 7. Bring up the form and right-click on the button. Choose About from the context menu. The control's About box is displayed. The About box is not customized in any way, but you can go back and do that later if you want (provided you saved the file earlier). NOTE: The idea behind one-step ActiveX is to take a working VCL component and create an ActiveX control from that component. Most of the time, you won't have to modify the ActiveX code in any way. However, you certainly can modify the ActiveX code after it has been generated by Delphi if you so desire. Be aware, though, that if you regenerate the ActiveX code from your original VCL component, all changes made to the ActiveX source will be lost. NOTE: You can create ActiveX controls only from windowed VCL controls (controls derived from TWinControl or one of its descendents). The list of VCL controls from which you can build an ActiveX control contains all installed components that specifically meet this criteria. Unregister the ActiveX Control After experimenting with your new ActiveX control, you should unregister it so that it doesn't occupy space in the Registry. To unregister the ActiveX control, do this: 1. Choose Component|Import ActiveX Control from the main menu. 2. Select the ActiveX in the list of installed ActiveX controls and click the Remove button. 3. Click Yes on the confirmation dialog box to have Delphi unregister the ActiveX. Alternatively, you can load the ActiveX project (if you previously saved it) and choose Run|Unregister ActiveX Server from the main menu. NOTE: If all else fails, you can always locate the ActiveX control in the Registry and delete the key for that control. Use the Registry Editor's find function to find the key (search for the control's name or its GUID). Naturally, you want to be careful when editing the Registry manually.

1414

Creating ActiveForms Creating an ActiveForm is almost as easy as creating an ActiveX from an existing VCL component. Naturally, you can create a complex ActiveX containing many components on a single form. Contrary to what its name implies, however, an ActiveForm can be used to create a simple ActiveX control from scratch (a colored button, for example). In other words, ActiveForms are not only for creating fancy forms with dozens of gadgets. They are for creating single-use ActiveX controls as well. In this section, you will create an ActiveForm. The ActiveForm will have two edit controls, a label and a button. The button will take the contents of the two edit controls, multiply them together, and display the result in the label. Yes, I know it doesn't require a lot of imagination to stick with the "multiply two numbers" idea, but my goal is to show you how to create an ActiveForm with the minimum amount of code. Keeping the code to a minimum allows you to focus on the ActiveForm creation process without getting bogged down in code. Create the ActiveForm Creating an ActiveForm is so easy it's amazing. Follow these steps: 1. Close all projects and then choose File|New from the main menu. The Object Repository is displayed. 2. Double-click the ActiveForm icon. The ActiveForm Wizard is displayed. This dialog box is identical to the ActiveX Control Wizard except for the fact that the VCL Class Name field is grayed (it doesn't apply here). 3. Enter MyFormX in the New ActiveX Name field. 4. Change the Implementation Unit field to read MyFormImpl.pas. 5. Change the Project Name field to MyFormProj.dpr. 6. Leave the Thread Model set to Apartment. Check the Include Version Information check box. 7. Click the OK button to continue. Delphi creates the required units and displays a form. Create the Form An ActiveForm form is just a regular form at this stage. You can add controls to the form, add code, and respond to events just like you do for a form that belongs to an application. The one difference is that the title bar on an ActiveForm does not appear on the control itself. It's just there at design time. In this step, you will add components and code to make the ActiveForm functional. As you work through the steps, it might help to refer to Figure 15.8 later in the chapter, which shows the completed form. I'm going to give you the primary components in the following steps and let you finish the rest on your own. Perform these steps: 1. Size the form to approximately 175 (width) by 275 (height). 2. Add an Edit component near the top-center of the form (see Figure 15.8). Change its Name property to Num1Edit, its Text property to 0, and its Width to 50 or so (the exact width is not important). Change the AxBorderStyle property to afbRaised. 3. Click on the Edit component and copy it to the Clipboard; paste a new component from the Clipboard. Place the new component below the first. Change its Name property to Num2Edit. 4. Place a Label component below the two edit controls. This label will display the results. Change the label's Name property to ResultLbl and its Caption property to 0. 1415

5. Place a Button component on the form to the right of the Edit components. Change its Name to GoButton and its Caption to Go!. 6. Double-click the button and make the OnClick event handler look like this: procedure TMyFormX.GoButtonClick(Sender: TObject); begin try ResultLbl.Caption := IntToStr( StrToInt(Num1Edit.Text) * StrToInt(Num2Edit.Text)); except on EConvertError do MessageDlg(Òops! You entered an invalid value.', mtError, [mbOK], 0); end; end;

This code simply extracts the values of the two edit controls, multiplies them together, and displays the result in the ResultLbl label. The exception handling code displays a message box if the user enters invalid values. An EConverError exception will be raised if the conversion from text to integer fails (if one of the edit controls contains text, for example). 7. Add additional labels to match Figure 15.8. 8. Choose View|Type Library from the main menu. In the Information page, change the Help String field to My Test ActiveForm Library. This is the text that will be displayed in the Import ActiveX dialog box when you install the ActiveForm. 9. Save the project. Accept the default filenames. (You specified them in the ActiveForm Wizard.) Figure 15.8 shows the completed form. FIGURE 15.8. The finished ActiveForm. Build, Register, and Import the ActiveForm Now you can build, register, and import the ActiveForm. When built, the ActiveForm is like any other ActiveX control. Because you've done this several times now, I'm not going to go over every step. Follow these steps: 1. Choose Project|Build MyFormProj from the main menu. 2. When the project is built, choose Run|Register ActiveX Server from the main menu. 3. Choose Component|Import ActiveX Control from the main menu. Install My Test ActiveForm Library (Version 1) into the DCLUSR40 package. Install to the ActiveX page or any other page you choose. The ActiveForm is now installed as an ActiveX control. Try the ActiveForm Now it's time to take the ActiveForm for a test drive. This will be fairly simple: 1. Create a new application. 2. Click the ActiveX tab on the Component palette and choose MyFormX button (the one with the default Delphi icon). 3. Place a MyFormX control on your form. 4. Run the program and test out the ActiveX. That's all there is to it. With Delphi, great-looking ActiveX controls are a breeze to create! There simply is no better development environment for creating ActiveX controls than Delphi, bar none.

1416

Changing the ActiveX Palette Bitmap Ultimately you will want to change the bitmap of the ActiveX from the default that Delphi provides to one of your own design. Changing the bitmap requires following these steps: 1. Create a binary resource file (.RES) with Image Editor. 2. Create a 24¥24 bitmap. Give the bitmap a numeric name (2 for example). 3. Link the resource file to the ActiveX project with the $R compiler directive. (Linking resources was discussed on Day 8, "Creating Applications in Delphi" and is discussed further on Day 20, "Creating Components.") 4. Modify the ActiveX class factory creation routine in the implementation unit (the ActiveForm's .PAS file). A typical class factory creation routine looks like this (it's in the initialization section at the bottom of the unit): TActiveFormFactory.Create( ComServer, TActiveFormControl, TMyFormX, Class_MyFormX, 1, { Change this number. } `', OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL, tmApartment);

Notice the line I have marked with a comment. This parameter of TActiveFormFactory.Create is the resource number of the bitmap you want displayed on the Component palette. If you saved the new bitmap with a name of 2, you would replace the 1 in this code snippet with a 2. 5. Rebuild, reregister, import, and install the ActiveForm again. The new bitmap should now show up in the Component palette. Alternatively, you can modify the ActiveForm project's .RES file and change the bitmap named 1 to look like you want.

Web Deploying ActiveX Controls and ActiveForms One of the great features of ActiveForms is that you can use them on a Web page. In order to use an ActiveForm on a Web page, you must use the Web Deploy option. Using Web Deploy requires a Web server, so I can't effectively walk you through the Web deployment process. I can, however, give you a little insight into the process. When you choose Web Deploy, Delphi performs two tasks: · Builds the ActiveX control and copies the file to the Web Deploy target directory · Creates an HTML file that contains the code needed to load the ActiveX control The locations of these files is determined by the Web deployment options. Let's look at that next.

Web Deployment Options Before you can use Web Deploy, you must set the Web deployment options. To set the Web deployment options, choose Project|Web Deployment Options from the main menu. The Web Deployment Options dialog box is displayed, as shown in Figure 15.9. Figure 15.9. The Web Deployment Options dialog box. At the bottom of the Web Deployment Options dialog box is a check box labeled Default. Check this box if you want the settings you have specified to be the new defaults for future projects. Most of the time, you will deploy to the same Web site, so you will probably want to set the defaults after you have everything set up just the way you want it.

1417

Project Page: Directories and URLs Section The Directories and URLs section is where you specify the target location for your ActiveX. The Target dir field is used to specify the directory where Delphi will copy the ActiveX after it is built. This field must be a directory--it cannot be an URL location. If you are like me, you might not have direct access to the directory where your Web site is located. (TurboPower's Webster Royland keeps access pretty tightly controlled.) If that is the case, you will have to specify a local directory in this field and then later use your Web publishing software to publish the files to your Web site. The Target URL field is used to specify the page where the ActiveX will reside on the server. This page is used by Delphi when it creates the HTML page that shows the control. For example, the HTML file that Delphi created for me is shown in Listing 15.4. (I had to break a couple of lines because they were too long for the page.) LISTING 15.4. THE HTML CODE GENERATED BY DELPHI FOR THE ACTIVEX FILE.
Delphi 4 ActiveX Test Page
You should see your Delphi 4 forms or controls embedded in the form below.

Notice the URL in the codebase statement. This is the path I typed in the Target URL field of the Web Deployment Options dialog box. By the way, you can copy the entire OBJECT tag from the Delphi-generated HTML code directly to your Web page's HTML source when you get ready to officially deploy your ActiveX code. NOTE: The name of the HTML file created by Delphi is the project name with an extension of .htm. The HTML dir field of the Web Deployment Options dialog box is used to specify the location where Delphi will place the HTML code it generates (refer to Listing 15.4). As with the Target dir field, if you don't have direct access to your Web site's directories, you will have to specify a local directory and then publish the HTML file to your Web site. Project Page: General Options Section This section is where you specify the global Web deployment options. The Use CAB file compression field determines whether the ActiveX is compressed. Compressing the ActiveX reduces the size of your ActiveX, making downloading the control that much faster. I used CAB compression on the ActiveForm created earlier in the project and the ActiveX size went from 312KB in OCX form to 204KB in CAB form. Windows takes care of automatically decompressing and registering the ActiveX, so there's no real disadvantage to using CAB compression. The Include file version number indicates whether Delphi should include the version number in the codebase statement (again refer to Listing 15.4). The version tag is optional, so you don't specifically need it. Note, however, that some browsers won't load

1418

the ActiveX if the version tag is present (Netscape Navigator with an ActiveX plug-in, for example). The Auto increment release number will automatically increment the version number in the ActiveX's version info each time the ActiveX is deployed. The Code sign project option plays an important role in ActiveX deployment. When this option is on, Delphi will code sign the ActiveX. Code signing is the process of attaching a binary signature to a file. This binary signature identifies the company that created the ActiveX, among other information. Code signing is important because Internet Explorer expects ActiveX controls to be code signed. If Internet Explorer's security level is set to High or Medium, any ActiveX controls that are not code signed will not load. Simply put, if you are going to deploy your ActiveX controls so that the public can use them, they must be code signed. The Code Signing page of the Web Deployment Options dialog box contains the information needed to code sign the ActiveX. Delphi does not provide the credentials file or the private key needed to code sign files. To obtain a credentials file and private key, you will need to contact Microsoft. For more information, search the Microsoft Web site for the terms "Digital Signing" and "Certificate Authority." The Deploy required packages and Deploy additional files options are used if you have built your ActiveX with runtime packages or if there are additional files that must ship with your control. If you choose either of these options, you must specify the packages or additional files on the Packages and Additional Files pages of the Web Deployment Options dialog box. NOTE: When in doubt, click the Help button in the Web Deployment Options dialog box. Delphi help explains each of the pages of this dialog box.

Web Deploy After you set the deployment options, you are ready to deploy your ActiveX. To deploy the ActiveX, simply load the ActiveX project and choose Project|Web Deploy from the Delphi main menu. Delphi will build the ActiveX and deploy it based on the settings in the Web Deployment Options dialog box. If you elected to use CAB compression, Delphi will compress the ActiveX into a CAB file as well. Remember, if you don't have direct access to your Web site's directories, you will have to publish the ActiveX and HTML file to your Web site before you can test the ActiveX. The act of deploying the ActiveX is trivial--setting the Web deployment options is the hard part. Figure 15.10 shows the example ActiveForm created earlier running on a Web page. FIGURE 15.10. The test ActiveForm running on a Web page. NOTE: ActiveX controls have virtually no security restrictions. Be careful when downloading ActiveX controls from unknown (or unverified) sources. When downloaded, an ActiveX control has access to your entire system. Be equally careful when writing your own ActiveX controls. Make absolutely sure that your ActiveX control won't do anything to negatively impact other users' machines.

Summary I won't lie to you--there's a lot more to COM and ActiveX than what is presented here. For example, I didn't talk about OLE. OLE, like ActiveX, is a subset of COM. OLE adds a layer to COM to enable applications to link and embed OLE automation servers in a container application. Still, you learned a great deal about COM and ActiveX today. Most importantly, you found out how to create COM objects, ActiveX controls, and ActiveForms. 1419

You also learned a bit about Web Deploy and how to use it to deploy your ActiveX controls on a Web page.

Workshop The Workshop contains quiz questions to help you solidify your understanding of the material covered and exercises to provide you with experience in using what you have learned. You can find the answers to the quiz questions in Appendix A, "Answers to the Quiz Questions."

Q&A Q Do I have to understand the inner workings of COM to write ActiveX controls in Delphi? A Although some understanding of COM is certainly helpful, it is not vital to creating ActiveX controls with Delphi. Delphi makes it easy to create ActiveX controls without an in-depth understanding of COM. Q What is a type library? A A type library is a binary file that describes the interfaces, data types, methods, and classes in a COM library (including ActiveX). Q Are OLE and COM the same thing? A No. COM is the base upon which OLE is built. OLE is much more complex and convoluted than COM. Certainly OLE has more functionality, but OLE is a bloated beast that is best avoided if possible. Q I noticed some nifty-looking ActiveX controls registered on my system, so I installed them on the Delphi Component palette. They show up on the Component palette but when I try to use one of the controls, I get an error message about a design-time license. Why is that? A In short, you are not authorized to use those controls in a design environment (Delphi, for example). ActiveX users must deploy and register their ActiveX controls on every system that uses those controls. To prevent anyone from freely using those controls, the control vendors require a design-time license before the control can be used at design time. When you purchase an ActiveX control from a vendor, you get the design-time license. Q I created an ActiveX control and placed it on my form. The program used to work fine, but now when I try to run the program I get an exception that says, Class not registered. Why is that? A Every ActiveX control must be registered on the system on which it is being used. You might have inadvertently unregistered the ActiveX control on your system some time after you originally installed the control. To reregister the control, load the ActiveX project in Delphi and choose Run|Register ActiveX Server. Alternatively, you can register the OCX file with the TREGSVR.EXE utility. Q I created and installed an ActiveForm and everything went fine. Later I wanted to change the ActiveForm. I couldn't compile the ActiveForm project, though, because I kept getting an error, Could not create output file MyProj.OCX. What's wrong? A You need to remove the ActiveForm control from the Delphi Component palette before you can rebuild the control. When the control is installed in Delphi, its OCX file is loaded by the Delphi IDE and cannot be overwritten. 1420

Q Web Deploy confuses me. There are so many options. Am I the only one who doesn't understand this stuff? A Certainly not. After you have worked through the Web Deploy process a few times, it's not nearly so daunting as it might appear the first time you try it. Q I'm having problems getting my ActiveX to work on a Web page. I keep getting an error from Internet Explorer when I try to load the page. The error says, Your current settings prohibit ActiveX controls. What's wrong? A Your ActiveX control is not code signed. An ActiveX control must be code signed before Internet Explorer will download the control when the user's security settings are set to either medium or high.

Quiz 1. What is the base (or parent) interface for all COM interfaces? 2. What is a GUID? 3. What happens when a COM object's reference count reaches 0? 4. What is the name of the Delphi utility used when working with type libraries? 5. How do you create GUIDs when writing COM objects in Delphi? 6. What do you choose from the Object Repository when creating an ActiveX from a VCL component? 7. Can you use Delphi-created ActiveX controls in Visual Basic? 8. After your ActiveX control is built and registered, how do you install it to the Delphi Component palette? 9. How do you unregister an ActiveX that you have created? 10. Can you use the ActiveX controls created in Delphi on a Web page?

Exercises 1. Create a simple COM object from scratch. It isn't important what the COM object does, just that you go through the steps of creating it. 2. Write a Delphi application that uses the COM object created in exercise 1 (don't forget to register the COM object). 3. Create an ActiveX control from a VCL TEdit component. Install the control to the Delphi Component palette and use it on a form. 4. If you have access to Visual Basic, take the ActiveX created in exercise 3 and use it in a VB application. 5. Create an ActiveForm control of your own design. 6. If you have a Web site, deploy the ActiveForm created in step 5 and display it on a Web site page. 7. Extra Credit: Modify the ActiveForm control created in step 5 so that it uses a custom bitmap on the Delphi Component palette rather than the default bitmap. 1421

INTERBASE ile İSTEMCİ / SUNUCU VERİ TABANI TASARIMI

0

11 Şub 2002 22:56 Eklendi

InterBase 1. Bölüm Neden Interbase Paradox, Dbase, Access,..vb veri tabanları client/server mimariyi desteklemezler ve sadece küçük veri tabanlarını yönetmek için tasarlanmışlardır. Paradox ve Dbase aslında bir DBMS ‘değildir (DataBase Management System - Veri Tabanı Yönetim Sistemi) Paradox ve Dbase tablolarında veri tabanının yönetimini BDE (Borland Database Engine) üstlenmektedir. Interbase kullanırken BDE’nin yüklenmesine gerek yoktur. Paradox tabloları onbinlerce kaydı işleyebilirler eğer projelerinizde Client/Server (İstemci/Sunucu) mimarisine dayalı projeler geliştirmiyorsanız pek tabi Paradox’ta kullanabilirsiniz. Ama profesyonel bir veri tabanı programcısı olacaksanız mutlaka bir DBMS ‘de deneyim sahibi olmanız gerekir. Interbase; Oracle, MS-SQL gibi büyük veri tabanlarının bir çok olanağına sahiptir. Interbase sunucularda saklanan çok büyük sayıdaki kayıtları yönetmek için geliştirilmiştir. Interbase yazılımcılara asgari özelliklere sahip bir arabirim sunar ve Delphi, C++ Builder, Visual Basic vb gibi (client-side) istemci yakası bir aracı kullanarak programlar yaratmanızı bekler. Ben bu yazıda LIBS’e (Local Interbase Server) referansta bulunacağım. Zaten bir LIBS veritabanını ağ üzerinde gerçek bir istemci/sunucu uygulamasına dönüştürmek için tek yapılması gereken veritabanını sunucu bilgisayara kopyalamak ve varsa alias’ı yeni konuma yönlendirmektir. (ör: copy benimDB.gdb f:\database gibi) Database Yaratmak Interbase Paradox veya Dbase gibi tabloları bir klasörde bulunan ayrı dosyalar halinde saklanmaz. Bunun yerine veritabanı denilen tek bir büyük dosyada tutulur. Bunun için önce bir veri tabanı yaratmamız gerekir daha sonra bir dizi tablo yaratabiliriz. Biz burada database ve tablo yaratmak için WISQL (Windows Interactive Standart Query Language) kullanacağız. WISQL databaselerin ana dili olan SQL komutlarıyla çalışır ve bu da tanımladığınız veritabanının yapısını anlamanızı kolaylaştırır. File->Create Database seçilir ve gelen iletişim kutusundan “Location Info” kısmını Local Engine olarak ayarlayalım. Ve sırasıyla Database : c:\data\dersane.gdb , UserName = SYSDBA , Passwor = masterkey seçelim. Hemen burada belirtmeliyim ki GDB uzantısını kullanmak bir zorunluluk değildir, ama standart’ı seven biriyseniz böyle yapabilirsiniz. Ben interbase için veritabanı yaratırken hep GDB uzantısını kullanırım. Evet şimdi dersane isimli içi boş bir veri tabanımız var.Aslında içi boş bir veritabanı demek yanlış olur 1422

çünkü Interbase kendi system tablolarını da biz veritabanını yarattığımızda yaratmış olacaktır. Şimdi bu database içerisinde bir tablo yaratalım. Tablomuzun ismi sicil olsun. Ama daha önce yarattığımız veritabanına bağlanmamız gerek. Yani File->Connect to Database seçtikten sonra database = c:\data\dershane.gdb yazıp username ve şifreyi de yazdıktan sonra veritabanına bağlanmış olacağız. Şimdi SQL ifadelerini kullanarak sicil adında bir tablo yaratacağız. CREATE TABLE SICIL (OGRNO DOUBLE PRECISION NOT NULL, ADI VARCHAR(20), SOYADI VARCHAR(20), DOGTAR DATE, CINSIYETI SMALLINT, ADRESI BLOB SUB_TYPE TEXT SEGMENT SIZE 80, ILCE VARCHAR(20), IL VARCHAR(20), POSTAKODU VARCHAR(6), PRIMARY KEY (OGRNO)); Yazıp Ctrl + Enter tuşlarına birlikte basarak bu sorguyu çalıştıralım. Eğer bir hata mesajı yoksa her şey yolunda demektir. Daha sonra File->Commit Work seçip gelen iletişim kutusuna tamam dedikten sonra Sicil isimli tablomuz kalıcı olarak yaratılmış olacak. Şimdi menüden Metadata->Extract Databse veya Metadata->Extract Table ‘ı seçerek tablomuzun ve veritabanımızın yapısını alabiliriz. Böylece dökümanlarımızı daha çabuk oluşturabiliriz. Yukarıda bir çok veri tipine sahip alanlar ve birde Primary anahtar yarattık. Bu aşamadan sonra size tavsiyem DBD (DataBase Desktop) yeri geldiğinde kullanmak için veritabanınızı gösteren bir Alias yaratın. Ben şu an Dersanedb isimli bir alias yarattığınızı varsayıyorum. Bunu şunun için söylüyorum Eğer daha önceki verileriniz Paradox, Dbase vb. tablolarda ise DBD kullanarak otomatik olarak Interbase tabloların çevirebilirsiniz. Böylece Interbase geçiş sürenizde kısalacaktır. Varsayalım Sicil.db adındaki Paradox tablomuzu dersaneDb aliasında bulunan ve dersane isimli interbase veritabanına aynı isimde kopyalamak istiyoruz. DBD’yi çalıştıralım Tools->Utility->Copy seçelim gelen iletişim kutusundan kopyalamak istediğimiz paradox tablosunu bulalım ve Ok butonuna basalım. Şimdi hedef database’i seçmek için dersanedb alias’ını seçelim username ve password girdikten sonra yeni tablo adını yazıp Copy butonuna basalım işte oldu Paradox tablosu artık Interbase tablosuna çevrildi. Şimdi Resim isimli bir tablo yaratacağız ve bu tablodada öğrencilerin resimlerini bulunduracağız. CREATE TABLE RESIM (OGRNO DOUBLE PRECISION NOT NULL, RESIM BLOB SUB_TYPE 0 SEGMENT SIZE 80, ACIKLAMA BLOB SUB_TYPE 0 SEGMENT SIZE 80, PRIMARY KEY (OGRNO)); Ctrl + ENTER ve File->Comit Work seçelim ve bu tabloda kalıcı olarak yaratılmış olsun. Şimdi 3. tablomuzda öğrencinin velisi ile ilgili kayıtları tutacak 1423

CREATE TABLE VELI ( OGRNO DOUBLE PRECISION NOT NULL, VADI VARCHAR(20), VSOYADI VARCHAR(20), VISTEL VARCHAR(15), VGSM VARCHAR(15), PRIMARY KEY (OGRNO) ); Ctrl + ENTER ve File->Comit Work seçelim ve bu tabloda kalıcı olarak yaratılmış olsun. * Primary key olarak yarattığınız alanları mutlaka NOT NULL olarak belirleyin.

INTERBASE ile İSTEMCİ / SUNUCU VERİ TABANI TASARIMI (2)

0


Yabancı Anahtarlar (FOREIGN KEY) Şimdi bu tablolarda veri bütünlüğünü sağlamak amacı ile yabancı anahtarlar ekleyelim. Aşağıdaki satırdaki yabancı anahtar örneği Resim tablosuna double tipinde OGRNO isimli bir alanı eklemektedir. Böylece Sicil tablomuz master tablo Resim ve Veli tablomuzda detail tablo olarak tanımlanmıştır. Eğer Master tablomuza bağlı detail kayıtlar varsa master tablomuzdaki kaydın silinmesine izin verilmeyecek ve bir aykırı durum bildirilecektir. Veya Detail tabloya Master tabloda olmayan bir öğrenci numarasını girmek istediğimizde yine bir aykırı durum yaratılacaktır ve izin verilmeyecektir. ALTER TABLE RESIM ADD FOREIGN KEY (OGRNO) REFERENCES SICIL(OGRNO); Ctrl + ENTER ve File->Comit Work seçelim böylece bu tabloya kalıcı olarak yabancı anahtar eklenmiş oldu. ALTER TABLE VELI ADD FOREIGN KEY (OGRNO) REFERENCES SICIL(OGRNO); Ctrl + ENTER ve File->Comit Work seçelim böylece bu tabloya kalıcı olarak yabancı anahtar eklenmiş oldu. Şimdi Yabancı anahtarların etkisini görmek üzere birkaç kayıt ekleyelim. INSERT INTO SICIL (OGRNO,ADI,SOYADI) VALUES (1, "Cüneyt","ERDEM"); INSERT INTO SICIL (OGRNO,ADI,SOYADI) VALUES (2, "Lütfiye","ERDEM”); Ctrl + ENTER ve File->Comit Work seçelim böylece bu tabloya kalıcı olarak 2 adet Kayıt eklemiş olduk. Şimdi OGRNO=1 olan master kayda detail kayıtlar ekleyelim. 1424

INSERT INTO RESIM (OGRNO) VALUES (1); //Sadece öğrenci No kaydettik Ve INSERT INTO VELI (OGRNO,VADI,VSOYADI,VISTEL) VALUES (1,"Celal","ERDEM","0.322.XXX 55 55"); Ctrl + ENTER ve File->Comit Work seçelim böylece bu tabloya kalıcı olarak Kayıt eklemiş olduk. Şimdi Ogrno “1” olan master kayda bağlı detail kayıtlar var ve biz bu master kaydı silmek isteyelim. DELETE FROM SICIL WHERE OGRNO = 1; yazıp çalıştırmak için Ctrl+Enter’a baslım. Cevap “Statement failed, SQLCODE = -530“ hiç de açıklayıcı olmayan bir hata mesajı olarak bize rapor edildi. Eğer delphi bileşenleri ile bu kaydı silmeye çalışsaydık Delphi bize bir aykırı durum yaratacak ve master kayda beğlı detail kayıtların olduğunu söyleyen bir hata mesajı rapor edecekti. Oysa Ogrno “2” olan kaydı silmek istediğimizde isteğimiz derhal yerine getirilecektir. Bunun nedeni 2 nolu master kayda bağlı detail kaydın olmayışıdır. “RDBMS ‘lere yeni başlayan arkadaşlar bu kontrolün Delphi içinden de kolayca yapilabileceğini düşünebilirler ama bu onlarca satır kontrol demektir; Ayrıca kodunuzun okunurluğunu ve bakımını da zorlaştıracaktır. Ama böyle bir kontrolü DataBase’in üzerine tanımlarsanız hem bu işlem otomatik yapılacak hem de başka uygulamalar tarafından da tanınacaktır.Zaten diğer yöntem istemci/sunucu uygulama mantığına da tamamen ters düşmektedir.”


1

12 Şub 2002 01:24 serwetim

2. Bölüm Interbase’de Güvenlik Geçen bölümde Database, Table, Foreign Key’ ler yaratmayı ve anlamlarını öğrendik. Bu bölümde iyi bir Veri Tabanı Yönetim Sisteminde bulunması gereken güvenlik konusunu inceleyeceğiz. Eğer verileriniz sizin için değerli ve bir kontrol düşkünüyseniz Interbase sizi hayal kırıklığına uğratmayacaktır. Eğer Interbase veri tabanımızı güvenli bir hale getirmek istiyorsak kuşkusuz ilk yapılması gereken SYSDBA kullanıcısının şifresini değiştirmektir. Şifreyi değiştirmek için Interbase Server Manager’a SYSDBA ve masterkey şifresini kullanarak girin. Menüden Tasks->User Security seçimini yapın. SYSDBA kullanıcı adını seçip Modify User ‘ı işaretleyin. Şimdi yeni bir şifre yazın. İşte oldu bu işlemden sonra database tamamen sizin kontrolünüzde olacaktır. Ayrıca bu programı kullanarak Backup/Restore, Maintenance (Bakım) vb işlemleri de yapabilirsiniz. Eğer isterseniz yeni kullanıcılar da tanımlayabilirsiniz. Yaratılan yeni kullanıcıların sistemde hiçbir hakkı olmadığı varsayılır. Kullanıcılara haklar vermek için grant adlı SQL komutunu kullanacağız. Ama önce bir user tanımlayalım. Interbase Server Manager ‘a girelim Tasks->User Security / Add User ‘ı işaretleyelim ve username ‘i USER1 ve PASSWORD’ü de USER1 olarak tanımlayalım. Şimdi bu kullanıcının hemen hemen hiçbir hakkı yok ve biz buna bazı haklar vereceğiz. Öncelikle sicil tablosunu select etme hakkını 1425

verelim. Interbase Windows ISQL ‘i çalıştıralım ve SYSDBA kullanıcısı ile girip database’e bağlanalım ve aşağıdaki SQL cümleciğini yazalım. Grant select on SICIL to USER1 Bu işlemden sonra USER1 kullanıcısı ile database’e bağlanırsanız SICIL tablosunu select edebilecek ama başkada bir şey yapamayacaksınız. Bir kullanıcıya altı farklı hak verebilirsiniz. 1. all : Select, delete, insert, update, execute haklarını içerir. 2. select : Bir tablonun tümünü veya bir kısmını görüntüleyebilme. 3. delete : Bir tablodan veya görüntüsünden (view) kayıt silebilme. 4. insert : Bir tabloya veya görüntüsüne kayıt ekleyebilme. 5. update : Bir tablodaki veya gürüntüsündeki kayıtları güncelleyebilme. 6. execute : Bir Depolanmış yordamı (Stored Procedure) çalıştırabilme. Eğer bir kullanıcıya hem select yetkisi vermek hemde kendisine verilen yetkileri başkasına da verebilme yetkisi verebilmek istersek grant select on sicil to USER1 with grant option satırı ile verebiliriz. Ama bu kullanıcı başka bir kullanıcıya sadece sahip olduğu hakları verebilir. Yani USER1 kullanıcısı başka bir kullanıcıya sadece sicil tablosu üzerinde select hakkı verebilir. Örnekler: Grant insert on sicil to USER1 Grant select on sicil to USER1, USER2, USER3 Grant select, insert, delete, update on sicil to USER1 Grant delete on sicil to USER1 with grant option Yukardaki satırlar ilgili kullanıcılara ilgili tablolar için ilgili hakları verir. Bu hakları kaldırmak; geçersiz kılmak için ise revoke komutu kullanılır. Revoke için örnek Revoke insert on sicil from USER1 Role : Interbase’de kullanıcı tanımlı roller tanımlanarak; bu roller kolayca bir veya birkaç kullanıcıya verilerek onun belli yetkilere sahip olması sağlanır Örnek: create role administrator; CTRL+ENTER grant update on sicil to administrator; CTRL+ENTER grant administrator to user1,user2,user3; CTRL+ENTER Yukarıda administrator isimli bir rol yaratılmış ve bu role sicil tablosu üzerinde güncelleme yetkisi verilmiş daha sonrada bu tanımlı rol USER1,USER2,USER3 kullanıcılarına verilmiştir. INTERBASE ile İSTEMCİ / SUNUCU VERİ TABANI TASARIMI (4)

0


3. Bölüm Interbase’de Strored Procedure ,View,Trigger ve Generators hakkında Strored Procedure Nedir?, Ne amaçla kullanılır Depolanmış Yordamlar(Stored Procedure) : Interbase veritabanı üzerine yazılan 1426

rutinlerdir. Kullandığınız dille veya SQL ile bir ilgisi olmayıp; İnterbase veritabanına özgü bir kod yapısıdır. Stored Procedur’ların kodu platformdan bağımsızdır. Eğer verilerinizi hem UNIX’te hem de Windows’ta kullanacaksanız veritabanı işlemlerinizin çoğunu Stored Procedur’lar aracılığla yapmanızı öneririm. Böylece Stored Procedure’ların gerekli işleri yapmasını sağlayan çok küçük istemci uygulamalar yaratabilirsiniz. En önemlisi istemci/sunucu uygulamalarda Stored Procedure’lar sunucu(server) yakasında çalışacağından (yani veritabanı’nın olduğu yerde) ilgili işlemler çok hızlı gerçekleşecek ve network trafiğini rahtlatacaktır. Evet Stored Procedure (Depolanmış yordamlar) genel anlamda anladığımıza göre şimdi basit bir Procedure yaratalım ama önce genel yapısını inceleyelim CREATE PROCEDURE ProcedureName RETURNS AS BEGIN END SQL Explorer ‘i açıp Procedure’un üzerinde CTRL + N ‘e basalım Aşağıda yazacağımız yordam bize veri kümesi değil sadece bir değer dönderecektir. CREATE PROCEDURE SICIL_COUNT RETURNS (SICILCOUNT INTEGER ) AS BEGIN SELECT COUNT(*) FROM SICIL INTO :SICILCOUNT; SUSPEND; END Bu yordam hiç parametre almaz fakat bir değer döndürür. CTRL + A (Apply yapalım). Evet basit bir Depolanmış Yordam yazdık. Şimdi bunu çalıştıralım. Şimdi ISQL’i açalım ve veritabanına bağlandıktan sonra; select * from SICIL_COUNT (CTRL + ENTER’a basıp run edelim. Şimdi bunu delphi ile bir TStoredProc bileşenini kullanarak bu yordamdan dönen veriyi alabiliriz. Burada hemen söylemeliyim ki ben bir Delphi programcısı değil C,C++ proramcısıyım ama bu basit kodu sanırım Delphi’de sizin için yazabilirim. Şimdi Delphi’yi açalım ve bileşen paletinden TDatabase veya TIBDatabase’i alıp formumuzun üzerine sürükleyelim ve Databasename özelliğine uygun yolu yazdıktan sonra ör:”c:\data\dersane.gdb” gibi, daha sonra TStoreProc veya TIBStoredProc bileşenini formumuzun üzerine sürükleyelim DatabaseName özelliğine Database nesnesini atadıktan sonra StoredProcName özelliğine de yazmış olduğumuz yordamın ismini eşitleyelim (“SICIL_COUNT”) Function TForm1.GetRecordCount: Integer; Begin StoredProc1.Prepare; StoredProc1.ExecProc; 1427

Result := StoredProc1.ParamByName(‘SICILCOUNT’).AsInteger; End Şimdi bir Exception yaratalım ve bu exception’ı çağıran bir procedure yazalım. Exception bir hata durumunda ekranda göstereceğimiz mesajı tanımlar ve genel yapısı aşağıdaki gibidir. CREATE EXCEPTION name 'mesajınız'; ISQL’i açalım ve veritabanına bağlandıktan sonra CREATE EXCEPTION DETAILHATA "Master kayıt kayıp veya yok"; CTRL + ENTER bu exception’u master tabloda olmayan bir öğrenci numarasını detail kayıt olan VELI tablosuna ekleyeceğimiz kayıtta çıkacak hatada çağıracağız. Bu hatanın çıkma sebebi önceki bölümlerde tanımladığımız Referans Integrity (Referans Bütünlüğü)’den kaynaklanmaktadır. Şimdi Veli tablosuna kayıt ekleyecek Stored Procedure’ımızı yazalım. SQL Explorer’ı açalım, veritabanımıza bağlanalım ve procedure’ın üzerinde CTRL + N’e basalım CREATE PROCEDURE ADD_VELI ( OGRNO DOUBLE PRECISION, VADI VARCHAR(20), VSOYADI VARCHAR(20) ) AS BEGIN BEGIN INSERT INTO VELI (OGRNO,VADI,VSOYADI) VALUES (:OGRNO, :VADI, :VSOYADI); WHEN SQLCODE -530 DO EXCEPTION DETAILHATA; END SUSPEND; END Evet sanırım anlaşılıyor şimdi bu yordamı ISQL’den çalıştıralım; tabii isterseniz delphi veya başka bir programlama dilinden de çağırabilirsiniz. execute procedure add_veli(11,"Cüneyt","ERDEM"); CTRL + ENTER 11 numaralı öğrenci master tabloda tanımlı olmadığı için tanımladığımız hata mesajı ekrana gelecektir. Fakat bu yordamı Ana tabloda var olan bir kayıt numarası ile çalıştırırsanız bu hata çıkmayacak istediğiniz veriler VELİ tablosuna yazılacaktır. Şimdilik Depolanmış Yordamlar konusuna burada ara verip Trigger ve Generators’ ler hakkında bir şeyler öğrenelim.


0


(Generators and Triggers) Üreticiler ve Tetikleyiciler: Interbase de Paradox’ta ki (+) Autoincrement veri tipi yoktur. Aslında bu hemen 1428

hiçbir DBMS’de yoktur (MS-SQL vb) ama bu bir eksiklik değildir. Otomatik sayı üretmek için Üreticiler (Generators) ve Tetikleyicilerden (Trigger) yararlanacağız. Önce bir Üretici tanımlayalım; CREATE GENERATOR OGRNO_GEN; CTRL + ENTER’a basalım. Şimdi OGRNO_GEN isimli bir üretici tanımladık. Ve şimdi bu üreticinin hangi numaradan başlayacağını belirtelim. SET GENERATOR OGRNO_GEN TO 100 İlk öğrenci numaramız 100’den başlayacak. Ama burada hemen belirtmeliyim; Eğer bu üreticiyi silmek isterseniz DROP kullanamazsınız. Bunun için Delete komutunu kullanmamız gerekir; üreticiler Interbase’in sistem tablolarına yaratılır ve bunu silmek için: DELETE FROM RDB$GENERATOR WHERE RDB$GENERATOR_NAME = 'OGRNO_GEN'; CTRL + ENTER Kullanarak silebiliriz. Evet şimdi bu üreticiyi kullanacak bir trigger yazlım. Trigger Begin Bloğuyla başlar ve END cümlesi ile sona erer. Bir Triger içerisinden Depolanmış yordamlar çağrılabilir. Triggerlar tabloya yazılır. Bir trigger bir olaya bağlı olarak otomatik çalışır. Şimdi Trigger’ımızı yazalım. SQL Explorer’ı açalım; Sicil Tablosunu seçip, Trigger üzerine gelip CTRL + ENTER’a basalım CREATE TRIGGER SICILTRIGGER FOR SICIL BEFORE INSERT POSITION 0 AS BEGIN NEW.OGRNO = GEN_ID(OGRNO_GEN,1); /* buradaki 1 in anlamı 1 er artır demektir*/ END Ve şimdi ISQL i açarak SQL cümlesini çalıştıralım. INSERT INTO SICIL (ADI,SOYADI) VALUES ( "M.C.","UYAN"); Select * from sicil Yeni kaydımızın OGRNO = 101 olduğunu görürüz. Eğer yeni bir kayıt daha eklersek 102,103 vs olacaktır. Şimdi başka bir trigger yazalım ve bu trigger Master tablosundaki Öğrenci numarasını değiştirdiğimizde master tabloya bağlı detay tabloların tümünü değiştirsin. Yine triggerımızı Sicil tablosu üzerine yazıyoruz; CREATE TRIGGER OGRNOUPDATE FOR SICIL AFTER UPDATE POSITION 0 AS BEGIN IF(OLD.OGRNO<>NEW.OGRNO) THEN BEGIN UPDATE RESIM SET RESIM.OGRNO = NEW.OGRNO WHERE RESIM.OGRNO = OLD.OGRNO; UPDATE VELI SET VELI.OGRNO = NEW.OGRNO WHERE VELI.OGRNO = OLD.OGRNO; END END 1429

Şimdi tetikleyiciyi denemek için ISQL’i açalım ve aşağıdaki SQL cümleciğini yazalım. UPDATE SICIL SET OGRNO = 15 WHERE OGRNO = 1; Ana tablodaki 1 nolu öğrencinin numarasını 15 olarak değiştiriyoruz. Ve şimdi bakalım tüm tablolarda değiştimi ? Select * from sicil Select * from resim Select * from veli Evet tüm tablolarda 1 nolu öğrencinin artık 15 nolu öğrenci olarak görünüyor olması lazım. Şimdi de Veri kümesi döndüren bir Depolanmış Yordam yazalım. CREATE PROCEDURE OGRLISTE ( OGRNO1 INTEGER, OGRNO2 INTEGER /* Uygulamadan gönderilecek parametreler*/ ) RETURNS ( ADI VARCHAR(30), SOYADI VARCHAR(30), /* Yordam dan döndürülecek değerler.*/ OGRNO INTEGER, VADI VARCHAR(30), VSOYADI VARCHAR(30) ) AS BEGIN FOR /* sorgu başlatılıyor..*/ SELECT SICIL.ADI,SICIL.SOYADI,SICIL.OGRNO,VELI.VADI,VELI.VSOYADI FROM SICIL,VELI WHERE SICIL.OGRNO = VELI.OGRNO AND SICIL.OGRNO BETWEEN :OGRNO1 AND :OGRNO2 ORDER BY OGRNO ASC INTO :ADI,:SOYADI,:OGRNO,:VADI,:VSOYADI DO SUSPEND; END Yukarıda tanımlı yordam görmek istedğiniz aralıkta size öğrencileri veli isimleri ile beraber listelemektedir. Örnek : ISQL’i açalım DB’ye bağlandıktan sonra; SELECT * FROM OGRLISTE(47, 59); CTRL + ENTER Evet sonuç karşımızda 47 ile 59 no arasındaki tüm öğrenciler listelenecektir. Tabii biz kullanıcıların ISQL’e girmesini bekleyemeyiz bunun için aşağıda yazacağınız istemci programdan bu depolanmış yordamı nasıl çağıracağınız açıklanmıştır. Artık bu Depolanmış Yordamı istemci programınızdan çalıştırabilirsiniz. Bunun için yapmanız gereken Form üzerine TDatabase veya TIBDatabase, TIBStoredProcedure, TIBQuery alalım. Daha sonra TDatabase’in DatabaseName = C:\data\dersane.gdb yazalım. TStoredProc.StoredProcName = “OGRLISTE” ‘ye eşitleyelim ve Query1’e aşağıdaki sorguyu yazalım. TDataSource ve TDBGrid ‘i de Query1’e bağlayalım. SELECT * FROM OGRLISTE(:OGRNO1, :OGRNO2) ve gerekli parametreleride Query1.ParamByName ile vererek Query1.Active = true; yapalım. İşte sonuç karşımızda. 1430

Daha önce de belirttiğim gibi akla şu soru gelebilir, Biz Depolanmış Yordam yerine bu sorguyu doğrudan TQuery nesnesine yerleştirebilirmiyiz. Cevap tabii ki evet ama bu durum da sorgunun işletilmesi daha uzun sürecektir. Üstelik bu işi istemci taafında çözmeniz gerekir. En doğrusu sorguyu yukarıda ki gibi sunucuya yerleştirmektir. “Yukarıda referans bütünlüğüne sahip güçlü veritabanları yaratmak için kullanılan teknikleri öğrendik. Üreticiler, tetikleyiciler ve depolanmış yordamları kullanmayı ve ilişkisel verilerde filtreleme yapmayı da öğrendik. Kısacası genel hatlarıyla profesyonel bir veritabanı oluşturmak için gerekli temel bilgileri artık biliyoruz. Bu bilgiler iyi bir veritabanı oluşturmamız için bize gereken tüm bilgileri elbette vermemiştir ama sırası geldikçe bunları da öğreneceğiz.”

View : View’i güvenlik için kullanabileceğiniz gibi karmaşık sorgular kurup bunu view ile sunucu tarafında hızlı bir şekilde çalıştırılmasını da sağlayabilirsiniz. View aslında bir tablonun veya tabloların görüntüsüdür. Eğer view için basit bir güvenlik örneği vermek gerekirse Yukarıda haklardan bahsetmştik biz bir kullanıcıya select hakkı verdiğimizde bu kullanıcı ilgili tablonun tüm alanlarını select edebilecektir. Bazen bunu istemediğimiz durumlar olabilir. Örneğin personel tablosunda ki ücret alanının görülememesi gibi. İşte bu gibi durumlarda view kullanabilirsiniz. Örnek CREATE TABLE PERSONEL ( PERNO DOUBLE PRECISION NOT NULL, ADI VARCHAR(20), SOYADI VARCHAR(20), UCRET VARCHAR(15), PRIMARY KEY (PERNO) ); şimdi bu tabloya select yetkisi olan herkes UCRET alanını da select edebilecektir ama biz bunu istemiyoruz. Bunun için hemen bir VIEW yaratacağız CREATE VIEW PERSONEL_LIST AS SELECT PERNO, ADI, SOYADI FROM PERSONEL Ve kullanıcıya select hakkı verirken PERSONEL tablosuna değilde onun görüntüsü üzerine select hakkı vereceğiz. Grant select on PERSONEL_LIST to USER1 Evet artık USER1 Personel ücretlerini göremeyecektir. View’lerin başka kullanım alanlarıda karmaşık sorguların view içine yerleştirilip istemci program tarafından kolay ve hızlı sorgular gerçekleştirebilmesidir. Sonuç Olarak : istemci / sunucu veri tabanı tasarlamanın yararı tartışılmazdır. 1431

1. Network trafiğini rahatlatır. 2. Veritabanın’daki bir uygulama değişikliği tüm client uygulamalara otomatik olarak yansıtılacaktır. 3. Veritabanını geliştirme ve Veritabanı bakım işlerinde geçen zamanı kısaltır. 4. Uygulamanın performansını arttırır 5. vs.vs..... eh uzun bir yazı oldu. Ben uğraştım yazdım umarım sizde gayret gösterir okursunuz. Tüm soru ve önerilerinizi bu makaleye bırakırsanız bende bu makalede cevaplayacağım. NOT: KUSURA BAKMAYIN MAKALEYİ TERSTEN VERDİM. EN ALTTAKİ SAYFA İLK SAYFA OLUYOR.TESTEN OKUYUN. VERITABANIN HEYACAN VEREN NOKTALARI INTERBASE 7 VE DELPHI

11 Şub 2002 14:39 Kemal

Öncelikle ikinci Makalemi biraz aceleye getirmiş bulunuyorum umarım faydalı bilgileri yeterince Kapsar. Birinci interbase makalemde bazı eksiklikleri bu makalemde tamamlamak istiyorum öncelikle Interbase için söz etmiş oldugum WorkBenchTools a ek olarak piyasada bazı yardımcı toollar vardır.Bunlardan en çok bilinen ve kullanılarnları IBExpert ve WorkBench dir.Delphi 6 içerisinde gelen Interbase 6 Interbase 5.x göre bir çok bug dah temizlenmiştir.lakin Date formatı interbase 6 da en büyük degişikliklerden birisidir.Bu makalemde özellikle Delphi ile interbase kullanımdan ve genel Query mantıgından bahsedecegim Delphi5,6 ile gelen IBComponents paketi Direct Apilerle interbase baglanmanın en önemli yollarından biridir Standart TTable ve TQuery nesnelerin kullanılmasını hiç bir sekilde tavsiye etmem Neden diye Soracak olanlara ise şu cevabı kısacık olarak açıklayım bilindigi üzere bir çok yeni başlayan arkadaş Database yapılarına BDE kullanarak baglanırlar genellikle en büyük sorunları install aşamasında olur ama gerçekte en büyük sorun hızdır nasıl mı? normalde delphi ile işlenen Veri Kodu ilk BDE tarafından algılanır ve BDE den Database de işlem yapılır sonuç yine BDE aktarılır ordanda Delphi Koduna Sonuç olarak bu uzambaçlı yol hız performansını önemli açıdan etkiler artı BDe de çıkan buglar yine programınızı etkileyecektir.Buna ek olarak programların hızını etkileyen en büyük etkenlerde Formların Autocreate olarak kullanılmaması Table yada Queryde While not Table or Query.EOF do begin end; veya For i:=1 to 99999999 gibi büyük döngüsel işlemler veya repeat until gibi kodlar programın akışını yavaşlatır.Gerçekte yapılması gereken StoredProcedure 1432

kullanılarak bu tip rutin ve döngüsel ifadeleri Databasede halletmektir.Delphide Commit işlemleri şu sekilde yapılır.Öncelikle Program içinde olan bütün Queryler close durumda olmalıdır nezaman kullanılırsa açılıp işlem bitip Ana forma geçildiginde kapatılmalıdır.Delphi 6 içinde interbase ulkaşmak öncelikle Bir DataModule Oluşturalım bunu Delphide New DataModule seçerek yapabiliriz Adını Dm1 koyalım Sonra içerisine IBDataBase ve IBTransection yerleştirelim IBDatabase nesnesini secelim ve mousen sag tuşuna basalım çıkan menude Username ve Password Alanlarını girelim Default SYSDBA,masterkey dir.Login checkboxı tıklayalım ve IBTransectioni mousle sag tıklayarak Read Commited seçenegini seçelim. Not:Ufak bir ekleme Aklıma gelmişken Veritabanı dizaynı çok önemlidir.Her projeye başlarken veritabanını oluşturmak uzmanlık ve üst bilgi isteyen bir işlemdir.Delphide yazılan kodun açıkçası pek önemli degildir hatasız bir veri mantıgı programınızı güçlu kılar mesala Arama islemlerinde Stringsel arama programınızı ve sorgunuzu yavaşlatır bunun için dahima Numeric arama kullanınız Mesal Kod,Adı olan iki fieldda 5 milyok kayıt olsun Aynı Queryde Ada göre arama Stringsel oldugundan daha uzun sürerken Kod'a göre olan numeric arama daha kısa zamanda tamamlanır.Buna ek olarak Alt Sorgulamadan(SubQuery) birazda bahsetmek istiyorum Mesala 3 tane Tablomuz olsun Musteri,Siparis ve Ürün Mesala söyle birsey olsun Ürün tablosundan Siparis Eden Müsterileri Görmek istiyorum Bunun için SubQuery kullanılmadan 2 Query yazılması gerekirken SubQuery yazılarak işlem 1 Adıma indirilir Örnek Select UrunKod,Ucret from URUN Where Ucret=(Select UrunKod from Urun Where UrunKod='10') gibi veya Select Urun,Adet, Toplam=(Select Sum(Adet) from Siparis),Oran=(Adet/Select Sum(Adet) from siparis) from Siparis Query ile Kayıt Ekleme INSERT TabloAdı Select FieldListesi From Tablo Where AramaField Örnek INSERT Yeni_Musteri Select Adi,SoyAdi From Musteri Query Kullanılarak UPDATE işlemi Yapılması UPDATE TabloAdi SET Field=ifade Where ArananFiledlar Örnek UPDATE Siparis SET Fiyati=Fiyati* 1.6 Where Fiyat='1000' Yani Fiyatı 1000 olanların Fiyatını 1600 yap demiş olduk. Ouery Kullanılarak Kayitlarin Silinmesi DELETE Tablo Where ArananFieldlar Örnek Delete Musteri Where Kod='80' gördügünüz üzere bu Queryler hep Numerik işleme göre Arama yapıyor Sonuç 1433

olarak hızlı ve hatasız çalışırlar. Mesala Query ile Tarih Nasıl Alınır ? Bunun için GETDATE Kullanırız Örnek Select GETDATE() GO QUERY ile Matematiksel Fonksiyonların Kullanılması ABS Mutlak Deger Yani Herzaman Pozitif olacak Örnek Select ABS(-2) Sonuc 2 dir. FLOOR Verilen Degeri Tamsayiya Döndürür Select FLOOR(72.55) Sonuç 72 Olacaktır. SQRT KareKök Örnek 6 ile 25 Arasındaki Sayıların Karekök Alınır. DECLARE @Deger FLOAT SET @Deger=6 While @Deger<25 Begin Select SQRT(@Deger) Select @Deger=@Deger+1; end GO Query ile Case Kullanılması Örnek Select Adi,SoyAdi,musterigrubu= Case grubu When 'A' then 'Cirosu 1000000 TL Üzerinde' When 'B' then 'Cirosu 100000 TL Üzerinde' When 'C' then 'Cirosu 10000 TL Üzerinde' ELSE 'Diger bir Sınıfta' END From Musteri Order By Adi GO Delphide Query nin Afterposuna IBTransaction1.CommitRetaining Yazarsanız Veriler Anında Veritabanına işler. Şimdilik Bukadar Bir Sonraki Makalemde görüşmek Dilegiyle Saygılarımla Kemal GÜLOL

1434

TTABLE/TQUERY ÜZERİNDE ARTTIRARAK ARAMA DBMEMO İÇERİSİNDE BİR METNİN ARANMASI BİR TABLONUN ALAN BİLGİLERİNİN ELDE EDİLMESİ TDBGRİD BİLEŞENİ ÜZERİNDE, KAYIT SIRALAMA MEVCUT TABLODAKİ KOLONLARIN ELENMESİ BİR TABLODAKİ TMEMOFİELD TİPLİ BİR ALAN İÇERİĞİNİN TMEMO BİLEŞENİNE AKTARILMASI BİR PARADOX TABLOSUNA İKİNCİ İNDEKS EKLENMESİ DETAYI OLAN BİR TABLODAN KAYIT SİLME DBGRİD VE MEMO ALANLAR TABLO İÇERİĞİNİN TSTRİNGRİD BİLEŞENİNE DOLDURULMASI TTABLE VEYA TQUERY ÜZERİNDEN KAYIT NUMARASININ BULUNMASI DBASE TABLOLARINDAN SİLİNMİŞ KAYITLARIN ATILMASI UYGULAMA İÇERİSİNDEN BDE KOD ADI (ALİAS) YARATILMASI BDE KOD ADI (ALİAS) PARAMETRELERİNİN ELDE EDİLMESİ BİR DBASE (.DBF) TABLOSUNDAKİ SİLİNMİŞ KAYITLARIN GÖRÜNTÜLENMESİ BİR TABLODAKİ ALAN SAYISININ BULUNMASI BİR TABLODAKİ VERİNİN, BAŞKA BİR TABLOYA EKLENMESİ SORGUDAN TABLO YARATILMASI SORGUDAN TABLOYA VERİ AKTARIMI TABLODAKİ BİR ALANA AİT VERİLERİN, BAŞKA BİR ALANA KOPYALANMASI TABLO KOPYALAMA TABLO SİLME ALAN ADININ BULUNMASI ORTAK ALAN İSİMLERİ TABLODAKİ ALAN İSİMLERİ ALAN NUMARASI ALAN UZUNLUĞU ALAN TİPLERİ TABLONUN ANAHTAR ALANLARI LOOKUP YÖNTEMİYLE DEĞER SEÇME DİYALOĞU BİR PARADOX TABLOSUNUN YENİDEN ANAHTARLANMASI TABLO ADININ DEĞİŞTİRİLMESİ TABLO YAPILARI AYNI MI? BİR TABLO ALANINDAKİ DEĞERLERİN SAĞ TARAFINDAKİ BOŞLUKLARIN TEMİZLENMESİ ARANAN ALAN, TABLODA VAR MI? ALAN ANAHTAR MI? TABLO MEVCUT MU? TABLO MEVCUT VE ESAS ANAHTARI VAR MI MEVCUT BİR TABLO İLE AYNI YAPIDA BAŞKA BİR TABLO YARATMAK TABLO FİLTRELEME ŞİFRELİ PARADOX TABLOSUNA OTOMATİK BAĞLANTI SUBSTRİNG FONKSİYONUNUN SQL CÜMLESİNDE KULLANILMASI DBCONTROLGRİD KAYDIRMA ÇUBUKLARI TABLODAN DOSYAYA AKTARMA SORGUDAN DOSYAYA AKTARMA ÖZEL BİR DBGRİD AĞ İŞLEMLERİ AĞ DA TANIMLI KULLANICILAR KİMLER? SES VE GRAFİK İŞLEMLERİ StringGrid içerisinde BMP EKRAN YAKALAMA BİR RESMİ, BMP FORMATINDAN JPEG FORMATINA ÇEVİRME DUVAR KAĞIDI DEĞİŞTİRME SİSTEMİN KULLANABİLECEĞİ RENK SAYISININ BULUNMASI DBGRİD ALANLARININ RENKLENDİRİLMESİ LİSTBOX BİLEŞENLERİNDE RENKLİ SATIRLAR

1435

RENK PALETLERİNİN YARATILMASI VE KULLANIMI MÜZİK CD Sİ ÇALINIRKEN, TRACK SAYISININ OKUNMASI EKRAN ÇÖZÜNÜRLÜĞÜ DEĞİŞTİRME BMP RESMİNİN PANOYA YAPIŞTIRILMSI VE PANODAN KOPYALAMASI BİR EXE DEKİ İKONUN ALINP BAŞKA BİR YERE ÇİZİLMESİ İKON RESMİNİN, BUTON ÜZERİNDE KULLANILMASI PANOYA RESİM KOPYALAMA BİR RESMİN ŞEFFAF OLARAK BAŞKA BİR RESİM ÜZERİNE YAPIŞTIRILMASI PALET DEĞİŞTİRME PANODAKİ METNİN DİSKTEKİ BİR DOSYAYA KAYDEDİLMESİ FORM VE PENCERE İŞLEMLERİ Masa üstündeki ikonların saklanması BÜTÜN AÇIK PENCERELERİN LİSTELENMESİ FARKLI BİR PENCERE ÜZERİNE BIRAKILAN DOSYALARA DUYARLI FORM FORM BAŞLIĞININ SAKLANMASI STANDART DIŞI FORMLAR FORM POZİSYONU EKRAN ÇÖZÜNÜRLÜĞÜ FORM BAŞLIK ALANI ÜZERİNDE SAAT GÖSTERİLMESİ FORM BAŞLIĞININ GİZLENMESİ FORMUN BAŞLIK ALANINA BUTON YERLEŞTİRME AÇILIR-KAPANIR FORM PENCERENİN TAŞINMASI DİSKET SÜRÜCÜSÜNDE DİSKET TAKILI MI ? ÇALIŞAN UYGULAMANIN BULUNDUĞU DİZİN WİNDOWS'UN STANDART "BROWSEFOLDER" DİYALOG PENCERESİNİN KULLANILMASI SEÇİLEBİLECEK, DİĞER ÖZEL KLASÖR TİPLERİ DÖKÜMAN ŞABLONLARI DOSYA KOPYALAMA BAŞKA BİR KOPYALAMA YÖNTEMİ; İKİLİ DOSYADAN OKUMA BİR DOSYANIN SALT OKUNUR OLARAK AÇILMASI SATIR SONU KARAKTERİNİN ASCİİ KODU NEDİR? DİSK SERİ NUMARASI VE ETİKETİNİN OKUNMASI DİSK SERİ NUMARASINA ERİŞİMİN BAŞKA BİR YOLU.. DİSK BİLGİLERİNİ ELDE ETMENİN BİR DİĞER YOLU İSE; BİR DOSYANIN TARİH VE SAAT BİLGİSİNİN ALINMASI BİR KLASÖRÜN ÖZELLİĞİNİN DEĞİŞTİRİLMESİ DOSYANIN SÜRÜKLENİP BIRAKILMASI WİNDOWS GEÇİCİ KLASÖRÜNÜN BULUNMASI DOSYA YARATILMA TARİHİ DOSYANIN SON KULLANILDIĞI TARİH DOSYANIN SON DEĞİŞTİRİLDİĞİ TARİH DİZİN BOŞMU? DOSYA UZANTISI HANGİ PROGRAMLA BAĞLANTILI? GERİ DÖNÜŞÜM KUTUSUNA GÖNDER. KARAKTER DİZİSİ KARŞILAŞTIRMA YÜKLENMİŞ DLL DOSYALARININ HAFIZADAN ATILMASI BİR DOS KOMUTUNUN KULLANILMASI TEDİT METNİNİN, ONCHANGE OLAYINDA DEĞİŞTİRİLMESİ TMEMO BİLEŞENİNDE, İMLEÇ HANGİ SATIRDA? ULUSAL AYARLAR TEDİTBOX BİLEŞENİNDEKİ METNİN İLK KARAKTERİNİN, BÜYÜK HARFE ÇEVİRİLMESİ WİNDOWS'UN KAPANMA ANININ TESPİTİ WİNDOWSUN KAPANDIĞINI TESPİT EDEN BİR BİLEŞEN KODU AŞAĞIDADIR. BİR MEMO VEYA RİCHEDİT BİLEŞENİNDE, İMLECİN İSTENEN YERE GÖNDERİLMESİ OTOMATİK E-MAİL

1436

MONİTÖRÜN AÇILIP KAPATILMASI WİNDOWS'UN KAPATILMASI/YENİDEN BAŞLATILMASI SİSTEMDE SES KARTI VARMI? PROGRAMIN ARKA PLANDA ÇALIŞTIRILMASI ÇALIŞAN PROGRAMIN, GÖREV ÇUBUĞU ÜZERİNDEN KALDIRILMASI OCX'KULLANIMI EKRAN ÇÖZÜNÜRLÜĞÜNDEKİ DEĞİŞİKLİKLERİN TESPİTİ PANO GÖRÜNTÜLEME CPU BİLGİLERİ ENTER TUŞUNUN TAB YERİNE KULLANILABİLECEĞİ BİR TEDİT BİLEŞENİ AYDA KAÇ GÜN VAR? GEÇEN HAFTANIN İLK GÜNÜ SONRAKİ HAFTANIN İLK GÜNÜ AYIN SON GÜNÜ GELECEK AY GEÇEN AY GÜN SONRA GELECEK AY ÖNCEKİ GÜN METİN İÇERİSİNDEN BİR KARAKTER SİLME METİN İÇERİSİNDEN, BİR KARAKTERİ DEĞİŞTİRME BİR METNİ BELLİ BİR UZUNLUĞA TAMAMLAMA METİN DEĞİŞTİRME PROGRAM İÇERİSİNDEN BAŞKA BİR UYGULAMAYA TUŞ GÖNDERME PROGRAMI DENEME SÜRÜMÜ HALİNE GETİRME LİSTBOX BİLEŞENİNE YATAY KAYDIRMA ÇUBUĞU EKLENMESİ SİSTEM TARİH/SAAT AYARININ DEĞİŞTİRİLMESİ ALT+TAB VE CTRL+ALT+DEL TUŞ KOMBİNASYONLARININ KULLANIMA KAPATILMASI EKRAN KORUYUCUNUN DEVREDEN ÇIKARILMASI PROGRAMIN, WİNDOWSUN BAŞLANGICINDA ÇALIŞTIRILMASI HATA MESAJI KONTROLÜ EKRAN KORUYUCU KURULMASI LİSTBOX YAZI TİPİNİN DEĞİŞTİRİLMESİ TAŞINABİLİR PANEL CD-ROM KAPAĞININ KAPATILMASI CD-ROM Kapağını açmak için; CD-ROM Kapağını kapatmak için; ÇALIŞMA ESNASINDA, BİLEŞEN SAYISININ KONTROLÜ FARE İMLECİNİN, İSTENEN KONTROL ÜZERİNE GETİRİLMESİ ALT-? TUŞ KOMBİNASYONU PROGRAMIN DURAKLATILMASI YAZI KARAKTERİ STİLİNİN DEĞİŞTİRİLMESİ MEVCUT BİR DAVRANIŞIN DEĞİŞTİRİLMESİ KES, KOPYALA, YAPŞTIR GETKEYBOARDSTATE SENDER PARAMETRESİNİN KULLANILMASI BÜYÜK METİNLERİN PANODAN ALINMASI WİNDOWS SÜRÜM NUMARASININ OKUNMASI PROGRAM GURUPLARININ LİSTBOX BİLEŞENİNE DOLDURULMASI TLİSTBOX VE TCOMBOBOX BİLEŞENLERİ İÇERİSİNE RESİM YERLEŞTİRİLMESİ BASİT BİR DLL ŞABLONU İPUCU PENCERESİNİN ÖZELLEŞTİRİLMESİ STRİNGRİD BİLEŞENİ İÇERİSİNDEKİ METNİN HİZALAMASI TSTRİNGGRİD BİLEŞENİNDEN BİR SATIRIN SİLİNMESİ TSTRİNGGRİD SATIRININ EN ALTA GÖNDERİLMESİ YAZDIRMA İSTENEN YAZICININ SEÇİMİ YAZICI YAZI TİPLERİ

1437

HEX TO DEC HAFIZA MİKTARI FARE HAREKET ALANININ KISITLANMASI PGUP VE PGDOWN TUŞLARI İLE FORMU AŞAĞI YUKARI KAYDIRMA ÖZEL YAZI KARAKTERİ EKRAN KORUYUCU BİR NESNEDEKİ ÖZELLİKLERİN LİSTESİ HABERLEŞME PORTLARINA ERİŞİM BİLEŞEN ÖZELLİKLERİNİN KAYIT DEFTERİNDE SAKLANMASI LİSTBOX İÇERİSİNDE ARTAN ARAMA BİR TEDİT.TEXT BİLGİSİNDEKİ DEĞİŞİKLİĞİN FARKEDİLMESİ COMBOBOX BİLEŞENİNİN, İÇİNE GİRİLDİĞİNDE AÇILMASI VE KAPANMASI YAZICIYA DOĞRUDAN BASKI GÖNDERME İŞLEMİ BİLGİSAYARI KAPATIP YENİDEN BAŞLATMA

DELPHİ PÜF NOKTALARI İÇİNDEKİLER

q q q q q q

VERİ TABANI/BDE AĞ IŞLEMLERI SES VE GRAFİK İŞLEMLERİ FORM VE PENCERE IŞLEMLERI DİSK VE DOSYA İŞLEMLERİ GENEL

VERİ TABANI/BDE Bu başlık altında, Delphi programlarında veri tabanı ve veri erişiminde kullanılan bileşenler ile ilgili püf noktaları ve gerekli kod örnekleri yer almaktadır. TTABLE/TQUERY ÜZERİNDE ARTTIRARAK ARAMA TEdit kullanarak, TTable üzerinde arttırmalı arama yapmak için, Tedid bileşeninin OnChange olay yordamına, aşağıdaki kod yazılır. procedure TForm1.Edit1Change(Sender: TObject); begin With Edit1 do if Text <> '' then Table1.FindNearest([Text]); end; Bu türlü bir arama Tquerry üzerinde yapılacaksa, procedure TForm1.Edit1Change(Sender: TObject); begin With Edit1 do if Text <> '' then begin Query1.Filter := 'code = '''+Edit1.Text+''''; Query1.FindFirst; end; end;

1438

veya procedure TForm1.Edit1Change(Sender: TObject); begin With Edit1 do if Text <> '' then Query1.Locate('code',Edit1.Text,[loPartialKey]); end; Paradox-Tablo yaratılması Kod içerisinden bir Paradox tablosu şu şekilde yaratılır. with TTable.create(self) do begin DatabaseName := 'C:\temp'; TableName := 'FOO'; TableType := ttParadox; with FieldDefs do Begin Add('Age', ftInteger, 0, True); Add('Name', ftString, 25, False); Add('Weight', ftFloat, 0, False); End; IndexDefs.Add('MainIndex','IntField', [ixPrimary, ixUnique]); CreateTable; End; DBMemo içeriğinin başka bir DBMemo bileşenine aktarılması DBMemo6.Lines:=DBMemo5.Lines.Assign; TDBNavigator bileşenin, kod içerisinden kontrol edilmesi procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn); var BtnName: string; begin case Button of nbFirst : BtnName := 'nbFirst'; nbPrior : BtnName := 'nbPrior'; nbNext : BtnName := 'nbNext'; nbLast : BtnName := 'nbLast'; nbInsert : BtnName := 'nbInsert'; nbDelete : BtnName := 'nbDelete'; nbEdit : BtnName := 'nbEdit'; nbPost : BtnName := 'nbPost'; nbCancel : BtnName := 'nbCancel'; nbRefresh: BtnName := 'nbRefresh'; end; MessageDlg(BtnName + ' button clicked.', mtInformation, [mbOK], 0); end;

DBMEMO İÇERİSİNDE BİR METNİN ARANMASI procedure Tform1.FindDialog1Find(Sender: TObject); var Buff, P, FT : PChar; BuffLen : Word; begin With Sender as TFindDialog do begin GetMem(FT, Length(FindText) + 1); StrPCopy(FT, FindText);

1439

BuffLen:= DBMemo1.GetTextLen + 1; GetMem(Buff,BuffLen); DBMemo1.GetTextBuf(Buff,BuffLen); P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength; P:= StrPos(P, FT); if P = NIL then MessageBeep(0) else begin DBMemo1.SelStart:= P - Buff; DBMemo1.SelLength:= Length(FindText); end; FreeMem(FT, Length(FindText) + 1); FreeMem(Buff,BuffLen); DBMemo1.SetFocus; end; end; Şekil 1 : Form1 kod örneği 1 : form1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 696 Height = 445 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object DBMemo1: TDBMemo Left = 16 Top = 152 Width = 657 Height = 193 DataField = 'Notes' DataSource = DataSource1 TabOrder = 0 OnDblClick = DBMemo1DblClick end object DBGrid1: TDBGrid Left = 16 Top = 16 Width = 657 Height = 120 DataSource = DataSource1 TabOrder = 1 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end object DBNavigator1: TDBNavigator Left = 432 Top = 352 Width = 240 Height = 25 TabOrder = 2

1440

end object DataSource1: TDataSource DataSet = Table1 Left = 138 Top = 364 end object Table1: TTable Active = True DatabaseName = 'dbdemos' TableName = 'BIOLIFE.DB' Left = 220 Top = 366 end object FindDialog1: TFindDialog OnFind = FindDialog1Find Left = 40 Top = 360 end end kod örneği 2 : unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, Grids, DBGrids, Db, DBTables, DBCtrls, ExtCtrls; type TForm1 = class(TForm) DBMemo1: TDBMemo; DataSource1: TDataSource; Table1: TTable; DBGrid1: TDBGrid; FindDialog1: TFindDialog; DBNavigator1: TDBNavigator; procedure FindDialog1Find(Sender: TObject); procedure DBMemo1DblClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure Tform1.FindDialog1Find(Sender: TObject); var Buff, P, FT : PChar; BuffLen : Word; begin With Sender as TFindDialog do begin GetMem(FT, Length(FindText) + 1); StrPCopy(FT, FindText); BuffLen:= DBMemo1.GetTextLen + 1; GetMem(Buff,BuffLen);

1441

DBMemo1.GetTextBuf(Buff,BuffLen); P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength; P:= StrPos(P, FT); if P = NIL then MessageBeep(0) else begin DBMemo1.SelStart:= P - Buff; DBMemo1.SelLength:= Length(FindText); end; FreeMem(FT, Length(FindText) + 1); FreeMem(Buff,BuffLen); DBMemo1.SetFocus; end; end; procedure TForm1.DBMemo1DblClick(Sender: TObject); begin finddialog1.execute; end; end.

BİR TABLONUN ALAN BİLGİLERİNİN ELDE EDİLMESİ Ttable bileşeninden yola çıkarak, bağlı olduğu tablonun alan bilgileri "FieldDefs" özelliği sayesinde elde edilebilir. GetFieldNames davranışı alan isimlerini, GetIndexNames davranışı ise tabloda mevcut olan indeks isimlerini döndürür. Şekil 2 : form1 kod örneği 3 : form1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 425 Height = 340 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 16 Top = 136 Width = 43 Height = 13 Caption = 'İndeksler' end object Label2: TLabel Left = 16 Top = 0 Width = 32 Height = 13 Caption = 'Alanlar' end object Label3: TLabel Left = 232 Top = 0 Width = 122

1442

Height = 13 Caption = 'Alan isimleri ve uzunlukları' end object Memo1: TMemo Left = 232 Top = 16 Width = 169 Height = 249 Lines.Strings = ( 'Memo1') TabOrder = 0 end object Button1: TButton Left = 240 Top = 272 Width = 153 Height = 25 Caption = 'Alan isimleri ve uzunlukları' TabOrder = 1 OnClick = Button1Click end object Button2: TButton Left = 16 Top = 272 Width = 201 Height = 25 Caption = 'Alan ve İndeks isimleri ' TabOrder = 2 OnClick = Button2Click end object ListBox1: TListBox Left = 16 Top = 16 Width = 201 Height = 113 ItemHeight = 13 TabOrder = 3 end object ListBox2: TListBox Left = 16 Top = 152 Width = 201 Height = 113 ItemHeight = 13 TabOrder = 4 end object Table1: TTable DatabaseName = 'dbdemos' TableName = 'ANIMALS.DBF' Left = 104 Top = 72 end kod örneği 4 : unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, Db, DBTables; type

1443

TForm1 = class(TForm) Memo1: TMemo; Table1: TTable; Button1: TButton; Button2: TButton; ListBox1: TListBox; ListBox2: TListBox; Label1: TLabel; Label2: TLabel; Label3: TLabel; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure ShowFields; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.ShowFields; var i : Word; begin Memo1.Lines.Clear; Table1.FieldDefs.Update; for i := 0 to Table1.FieldDefs.Count - 1 do With Table1.FieldDefs.Items[i] do Memo1.Lines.Add(Name + ' - ' + IntToStr(Size)); end; procedure TForm1.Button1Click(Sender: TObject); begin showfields; end; procedure TForm1.Button2Click(Sender: TObject); begin If Table1.State = dsInactive then Table1.Open; Table1.GetFieldNames(listbox1.items); Table1.GetIndexNames(listbox2.items); end; end.

TDBGRİD BİLEŞENİ ÜZERİNDE, KAYIT SIRALAMA Eğer bir Interbase tablosu ile çalışılıyor ise, Dbgrid üzerinde seçilen kolon başlığına göre verilerin sıralanması mümkündür. procedure TForm1.DBGrid1CellClick(Column: TColumn); begin if checkbox1.checked then with dbgrid1.datasource.dataset as ttable do indexfieldnames:=column.field.fieldname; end;

1444

MEVCUT TABLODAKİ KOLONLARIN ELENMESİ Bir tablodaki alanların "Visible" özelliğine "False" değeri verilerek, istenmeyen alanların görüntülenmesi engellenir. Table1.FieldByName().Visible := False; veya Table1.Field[].Visible := false;

BİR TABLODAKİ TMEMOFİELD TİPLİ BİR ALAN İÇERİĞİNİN TMEMO BİLEŞENİNE AKTARILMASI Procedure TMemoToTMemoField; begin TMemoField.Assign( TMemo.Lines ); end; Procedure TMemoFieldToTMemo; VAR aBlobStream : TBlobStream; Begin aBlobStream := TBlobStream.Create(tblobfield(table1.fieldbyname('Notes')), bmRead); Memo1.Lines.LoadFromStream( aBlobStream ); aBlobStream.Free; end;

BİR PARADOX TABLOSUNA İKİNCİ İNDEKS EKLENMESİ Table1.AddIndex('', 'CustNo;CustName', [ixDescending]); DBGrid kolonları üzerinde dolaşma dbgrid1.selectedindex:=dbgrid1.selectedindex+1; dbgrid1.setfocus;

DETAYI OLAN BİR TABLODAN KAYIT SİLME Master-Detay ilişki içerisindeki tablolarda, detayı olan bir ana kayıt silindiğinde, detaylar ortada kalır. Ana kayıt olmadığına göre detaylara da ihtiyaç yoktur. Bu nedenle ana kayıt silinmeden önce detayları silmek gerekir. Table1 ana tabloya, Table2 de Detay tabloya bağlı kabul edilirse, Table1' den bir kayıt silinmek istendiğinde önce Table2' deki detaylar temizlenecektir aşağıdaki örnek bunu göstermektedir. procedure TForm1.Table1BeforeDelete(DataSet: TDataset) begin with Table2 do begin DisableControls; First; While not EOF do Delete;

1445

EnableControls; end; end; DBGRİD VE MEMO ALANLAR DBGrid bileşeninde Memo/Blob alanlar olarak gösterilir. Aşağıdaki örnekte bu tür alanların da metin olarak görüntülenmesi sağlanmaktadır. Table bileşeni üzerine yüklenen kolonlardan NOTES alanı MEMO tipindedir. Bu alanın GetText yordamında Blob2Str fonksiyonu kullanılarak, alandaki veri görünür hale getirilmektedir. procedure TForm1.Table1NotesGetText(Sender: TField; var Text: String; DisplayText: Boolean); begin Text := Blob2Str(TMemoField(Sender)); end; Blob2Str fonksiyonu: function Blob2Str(TheField : TMemoField): String; var Buffer: PChar; MemSize: Integer; tmp:string; begin if TheField.IsNull then Result := '' else with TBlobStream.Create(TheField, bmRead) do begin MemSize := Size; Inc(MemSize); Buffer := AllocMem(MemSize); Read(Buffer^, memsize); Free; end; result:=strpas(buffer); end;

TABLO İÇERİĞİNİN TSTRİNGRİD BİLEŞENİNE DOLDURULMASI Tablo içeriğinin TstrinGrid bileşenine doldurulması şu şekilde olur. table.first; row := 0; grid.rowcount := table.recordCount; while not table.eof do begin for i := 0 to table.fieldCount-1 do grid.cells[i,row] := table.fields[i].asString; inc (row); table.next; end;

TTABLE VEYA TQUERY ÜZERİNDEN KAYIT NUMARASININ BULUNMASI Dataset Paradox veya dBASE tablosuna bağlı ise kayıt numarasını bulmak, birkaç BDE fonksiyon kullanmak suretiyle mümkündür. Ancak SQL tabanlı veri tabanı sunumcularında, sunumcunun kendisi buna imkan vermiyorsa, bu bilgi elde edilemez. Aşağıdaki fonksiyon parametre olarak bir Ttable bileşeni almakta ve gösterdiği Paradox/dBase tablosunudan kayıt numarasını, başarısız olduğunda ise 0 değerini döndürmektedir. Bu fonksiyonun döndürdüğü kayıt numarası, kaydın tablodaki fiziksel yeri ile ilgilidir. İndeks tanımlanmış bir TTable veya "Order by" ile sıraya sokulmuş bir sorgu kümesi döndüren Tquery bileşeninde, hatalı değer döndüğü sanılmamalıdır.

1446

uses DbiProcs, DbiTypes, DBConsts; function Form1.Recno( oTable: TTable ): Longint; var rError: DBIResult; rRecProp: RECprops; szErrMsg: DBIMSG; begin Result := 0; try oTable.UpdateCursorPos; rError := DbiGetRecord( oTable.Handle, dbiNOLOCK, nil, @rRecProp ); if rError = DBIERR_NONE then Result := rRecProp.iPhyRecNum else case rError of DBIERR_BOF: Result := 1; DBIERR_EOF: Result := oTable.RecordCount + 1; else begin DbiGetErrorString( rError, szErrMsg ); ShowMessage( StrPas( szErrMsg )); end; end; except on E: EDBEngineError do ShowMessage( E.Message ); end; end; Şekil 3 : Form1 kod örneği 5 : form1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 451 Height = 250 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 112 Top = 16 Width = 32 Height = 13 Caption = 'Label1' end object Label2: TLabel Left = 32 Top = 16 Width = 49 Height = 13 Caption = 'Kayıt No : ' end object DBGrid1: TDBGrid Left = 16

1447

Top = 32 Width = 417 Height = 120 DataSource = DataSource1 TabOrder = 0 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end object DBNavigator1: TDBNavigator Left = 192 Top = 168 Width = 240 Height = 25 DataSource = DataSource1 TabOrder = 1 end object DataSource1: TDataSource DataSet = Table1 Left = 88 Top = 168 end object Table1: TTable Active = True AfterScroll = Table1AfterScroll DatabaseName = 'dbdemos' TableName = 'ANIMALS.DBF' Left = 16 Top = 168 end end kod örneği 6 : unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, Db, DBTables; type TForm1 = class(TForm) DataSource1: TDataSource; DBGrid1: TDBGrid; DBNavigator1: TDBNavigator; Label1: TLabel; Label2: TLabel; Table1: TTable; function Recno( oTable: Ttable): Longint; procedure Table1AfterScroll(DataSet: TDataSet); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses

1448

DbiProcs, DbiTypes, DBConsts; {$R *.DFM} function TForm1.Recno( oTable: Ttable): Longint; var rError: DBIResult; rRecProp: RECprops; szErrMsg: DBIMSG; begin Result := 0; try oTable.UpdateCursorPos; rError := DbiGetRecord( oTable.Handle, dbiNOLOCK, nil, @rRecProp ); if rError = DBIERR_NONE then Result := rRecProp.iPhyRecNum else case rError of DBIERR_BOF: Result := 1; DBIERR_EOF: Result := oTable.RecordCount + 1; else begin DbiGetErrorString( rError, szErrMsg ); ShowMessage( StrPas( szErrMsg )); end; end; except on E: EDBEngineError do ShowMessage( E.Message ); end; end; procedure TForm1.Table1AfterScroll(DataSet: TDataSet); begin label1.caption:=inttostr(recno(table1)); end; end.

DBASE TABLOLARINDAN SİLİNMİŞ KAYITLARIN ATILMASI Bu işlem için DBIPackTable. İsimli BDE fonksiyonu kullanılır. Örnek kod şu şekildedir. uses DbiProcs, DbiTypes, DBConsts; procedure TForm1.Button1Click(Sender: TObject); var Error: DbiResult; ErrorMsg: String; Special: DBIMSG; begin table1.Active := False; try Table1.Exclusive := True; Table1.Active := True; Error := DbiPackTable(Table1.DBHandle, Table1.Handle, nil, szdBASE, True); Table1.Active := False; Table1.Exclusive := False;

1449

finally Table1.Active := True; end; case Error of DBIERR_NONE: ErrorMsg := 'Tamam'; DBIERR_INVALIDPARAM: ErrorMsg := 'Tablo belirsiz' + 'name is NULL'; DBIERR_INVALIDHNDL: ErrorMsg := 'Veri tabanı belirsiz'; DBIERR_NOSUCHTABLE: ErrorMsg := 'Tablo adı belirsiz'; DBIERR_UNKNOWNTBLTYPE: ErrorMsg := 'Tablo tipi belirsiz'; DBIERR_NEEDEXCLACCESS: ErrorMsg := 'Tablo exclusive modda değil'; else DbiGetErrorString(Error, Special); ErrorMsg := '[' + IntToStr(Error) + ']: ' + Special; end; MessageDlg(ErrorMsg, mtWarning, [mbOk], 0); end;

UYGULAMA İÇERİSİNDEN BDE KOD ADI (ALİAS) YARATILMASI procedure createalias(aliasname, servername, servertype, filename:string); var List: TStringList; lang, user, pdox : string; begin lang:='ANTURK'; user:='SYSDBA'; pdox:='PARADOX'; List := TStringList.Create; with List do begin Clear; if servertype='INTRBASE' then begin Add(Format('SERVER NAME=%s',[filename])); Add(Format('LANGDRIVER=%s',[lang])); Add(Format('USER NAME=%s',[user])); end; if servertype='STANDART' then begin Add(Format('DEFAULT DRIVER=%s',[pdox])); Add(Format('PATH=%s',[filename])); end; end; if session.isalias(aliasname) then Session.ModifyAlias(aliasname, List) else Session.addAlias(aliasname,servertype, List); Session.SaveConfigFile; List.Free;

1450

end;

BDE KOD ADI (ALİAS) PARAMETRELERİNİN ELDE EDİLMESİ Session.GetAliasParams('DBDEMOS',listbox1.items);

BİR DBASE (.DBF) TABLOSUNDAKİ SİLİNMİŞ KAYITLARIN GÖRÜNTÜLENMESİ dBase tablolarındaki silinmiş kayıtların görünür hale getirilmesi için DBISetProp fonksiyonu kullanılır. procedure SetDelete(oTable:TTable; Value: Boolean); var rslt: DBIResult; szErrMsg: DBIMSG; begin try oTable.DisableControls; try rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON, LongInt(Value)); if rslt <> DBIERR_NONE then begin DbiGetErrorString(rslt, szErrMsg); raise Exception.Create(StrPas(szErrMsg)); end; except on E: EDBEngineError do ShowMessage(E.Message); on E: Exception do ShowMessage(E.Message); end; finally oTable.Refresh; oTable.EnableControls; end; end;

Şekil 4 : Örnek uygulama form yapısı kod örneği 7: Form1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 559 Height = 293 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object DBGrid1: TDBGrid Left = 8

1451

Top = 8 Width = 409 Height = 177 DataSource = DataSource1 TabOrder = 0 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText TitleFont.Height = -11 TitleFont.Name = 'MS Sans Serif' TitleFont.Style = [] end object DBNavigator1: TDBNavigator Left = 8 Top = 200 Width = 240 Height = 25 DataSource = DataSource1 TabOrder = 1 end object Button1: TButton Left = 432 Top = 8 Width = 113 Height = 25 Caption = 'Silinenleri göster' TabOrder = 2 OnClick = Button1Click end object Button2: TButton Left = 432 Top = 40 Width = 113 Height = 25 Caption = 'Silinenleri sakla' TabOrder = 3 OnClick = Button2Click end object Table1: TTable Active = True DatabaseName = 'dbdemos' TableName = 'ANIMALS.DBF' Left = 440 Top = 80 end object DataSource1: TDataSource DataSet = Table1 Left = 488 Top = 80 end end kod örneği 8 : unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, Db, DBTables; type

1452

TForm1 = class(TForm) Table1: TTable; DataSource1: TDataSource; DBGrid1: TDBGrid; DBNavigator1: TDBNavigator; Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses DbiProcs, DbiTypes, DBConsts; {$R *.DFM} procedure SetDelete(oTable:TTable; Value: Boolean); var rslt: DBIResult; szErrMsg: DBIMSG; begin try oTable.DisableControls; try rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON, LongInt(Value)); if rslt <> DBIERR_NONE then begin DbiGetErrorString(rslt, szErrMsg); raise Exception.Create(StrPas(szErrMsg)); end; except on E: EDBEngineError do ShowMessage(E.Message); on E: Exception do ShowMessage(E.Message); end; finally oTable.Refresh; oTable.EnableControls; end; end; procedure TForm1.Button1Click(Sender: TObject); begin SetDelete(Table1, TRUE); end; procedure TForm1.Button2Click(Sender: TObject); begin SetDelete(Table1, False); end; end.

1453

BİR TABLODAKİ ALAN SAYISININ BULUNMASI Ttable bileşenini kullanarak, bir tablodaki alan sayısının bulunması için TableX.fieldcount Özelliğinden faydalanılabilir. Ancak tablo alanlarının bir kısmı, ttable bileşeni üzerine yüklenmişse fieldcount özelliği sadece yüklenen alan sayısını getirir. Alanları ttable üzerine kısmen yüklenmiş olan bir tablonun, gerçek alan sayısının bulunabilmesi için, aşağıdaki fonksiyon kullanılabilir. Bu kodun kullanılabilmesi için, form üzerine yerleştirileni ttable bileşenine, bağlandığı tablo alanlarının bir kısmı yüklenmelidir. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Db, DBTables, DbiErrs, DbiTypes, DbiProcs ,bde; type TForm1 = class(TForm) { Alanlar yüklendiğinde, tanımları buraya yerleşecektir. } Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function GetFieldCount(T: TTable): Integer; var curProp: CURProps; bWasOpen: Boolean; begin Result := 0; {Just in case something goes wrong.} bWasOpen := T.Active; try if not bWasOpen then T.Open; Check(DbiGetCursorProps(T.Handle, curProp)); Result := curProp.iFields; finally if not bWasOpen then T.Close; end; end; procedure TForm1.Button1Click(Sender: TObject); begin showmessage(inttostr(table1.fieldcount));

1454

showmessage(inttostr(GetFieldCount(table1))); end; end.

BİR TABLODAKİ VERİNİN, BAŞKA BİR TABLOYA EKLENMESİ Aynı yapıdaki iki ayrı tablo muhteviyatının, birleştirilmesi için kullanılabilecek olan bu fonksiyon, isimli tablodaki verileri, isimli tabloya kopyalamaktadır. Bu yöntemle veriler, farklı veri tabanları arasında da taşınabilir. Function AddTables( const SourceDatabaseName, SourceTable, DestDatabaseName, DestinationTable: string): Boolean; Var BMode : TBatchMode; Begin If IsTableKeyed(DestDatabaseName,DestinationTable) Then Begin If IsTableKeyed(SourceDatabaseName,SourceTable) Then Begin BMode := BatAppendUpdate; End Else Begin BMode := BatAppend; End; End Else Begin BMode := BatAppend; End; Result := DBRecordMove(SourceDatabaseName,SourceTable, DestDatabaseName,DestinationTable,BMode); End;

SORGUDAN TABLO YARATILMASI Karmaşık sorgular sonucunda toplanan veriler, bu fonksiyon yardımıyla yaratılan bir tablo içerisine doldurulabilir. Function DBCreateTableFromQuery( Query: TQuery; NewTableName, TableDatabaseName: String): Boolean; var D : TTable; ActiveWas : Boolean; begin D := nil; try {The Source Table} ActiveWas := Query.Active; Query.Active := true; D := TTable.Create(nil);

1455

D.Active := False; D.DatabaseName := TableDatabaseName; D.TableName := NewTableName; D.ReadOnly := False; D.BatchMove(Query,batCopy); Query.Active := ActiveWas; Result := True; finally D.Free; end; End;

SORGUDAN TABLOYA VERİ AKTARIMI Bir sorgu neticesinde elde edilen veriler, bu fonksiyon kullanılarak, mevcut bir tabloya aktarılabilir. Procedure DBAddQueryToTable( DataSet : TQuery; const DestDatabaseName, DestinationTable: string); var DTable : TTable; BMove : TBatchMove; begin DTable := TTable.Create(nil); BMove := TBatchMove.Create(nil); Try DataSet.Active := True; DTable.DatabaseName := DestDatabaseName; DTable.TableName := DestinationTable; DTable.Active := True; BMove.AbortOnKeyViol := False; BMove.AbortOnProblem := False; BMove.ChangedTableName := 'CTable'; BMove.Destination := DTable; BMove.KeyViolTableName := 'KTable'; BMove.Mode := batAppend; BMove.ProblemTableName := 'PTable'; BMove.Source := DataSet; BMove.Execute; Finally DTable.Active := False; DTable.Free; BMove.Free; End; End;

TABLODAKİ BİR ALANA AİT VERİLERİN, BAŞKA BİR ALANA KOPYALANMASI Bir tabloda bulunan alanlardan bir içerisinde bulunan veriler, başka bir alana kopyalanacağı zaman, aşağıdaki fonksiyon kullanılabilir. function DBCopyFieldAToB( DatabaseName, TableName, SourceField, DestField: String): Boolean; var Query : TQuery; CursorWas : TCursor;

1456

Sess : TSession; begin CursorWas := Screen.Cursor; Sess := DBSessionCreateNew; Sess.Active := True; Query := TQuery.Create(sess); Query.SessionName := Sess.SessionName; Sess.Active := True; Query.Active := False; Query.RequestLive := True; try Result := False; Query.DatabaseName := DatabaseName; Query.SQL.Clear; Query.SQL.Add('Select '); Query.SQL.Add(SourceField+','); Query.SQL.Add(DestField); Query.SQL.Add('From '+TableName); Query.Open; Query.First; While Not Query.EOF Do Begin ProgressScreenCursor; Try Query.Edit; Query.FieldByName(DestField).AsString := Query.FieldByName(SourceField).AsString; Query.Post; Except End; Query.Next; End; Result := True; finally Query.Free; Screen.Cursor := CursorWas; Sess.Active := False; end; end;

TABLO KOPYALAMA Bir tablo olduğu gibi , başka bir veri tabanına veya aynı veri tabanına kopyalanabilir. isimli bir tablo mevcutsa, eskisi silinir. Bu fonksiyon oldukça güçlü bir veri taşıma aracıdır. Tablolar, BDE tarafından desteklenen, herhangi bir veri tabanı ortamından, başka bir veri tabanı ortamına kopyalanabilir. Aşağıdaki örnekte, "DBDemos" veri tabanındaki "Customer.db" isimli tablo, "Sybase" veri tabanına kopyalanmaktadır., Tablo yapısı, tablosundan alınmak suretiyle, karşı tarafta yeni bir tablo yaratılmaktadır. Tarafların, lokalde veya uzakta olmaları fark etmez. Eğer karşı tarafta aynı adı taşıyan bir tablo varsa, silinir ve yerine yenisi yaratılır. Function DBCreateTableBorrowStr( SourceDatabaseName : String; SourceTableName : String; DestDatabaseName : String; DestTableName : String): Boolean; Var S : TTable; D : TTable; i,j : Integer; IMax : Integer; IndexName : String;

1457

IndexFields : String; IndexFields2 : String; Q : TQuery; IDXO : TIndexOptions; Begin S := TTable.Create(nil); D := TTable.Create(nil); Try Try S.Active := False; S.DatabaseName := SourceDatabaseName; S.TableName := SourceTableName; S.TableType := ttDefault; S.Active := True; D.DatabaseName := DestDatabaseName; D.TableName := DestTableName; D.TableType := ttDefault; D.FieldDefs.Assign(S.FieldDefs); D.CreateTable; {Similar method could be used to create the indices} {D.IndexDefs.Assign(S.IndexDefs);} S.IndexDefs.Update; D.IndexDefs.Update; D.IndexDefs.Clear; D.IndexDefs.Update; For i := 0 To S.IndexDefs.Count - 1 Do Begin If Pos('.DB',UpperCase(DestTableName)) > 0 Then Begin {Paradox or DBase Tables} If S.IndexDefs.Items[i].Name = '' Then Begin If Pos('.DB',UpperCase(DestTableName)) = 0 Then Begin IndexName := DestTableName+IntToStr(i); End Else Begin IndexName := ''; End; End Else Begin IndexName := DestTableName+IntToStr(i); End; IndexFields := S.IndexDefs.Items[i].Fields; D.AddIndex(IndexName,IndexFields, S.IndexDefs.Items[i].Options); D.IndexDefs.Update; End Else Begin {Non Local Tables} Q := TQuery.Create(nil); Try S.IndexDefs.Update; D.IndexDefs.Update; D.IndexDefs.Clear; D.IndexDefs.Update; IMax := S.IndexDefs.Count - 1; For j := 0 To IMax Do Begin

1458

Q. Active := False; Q.DatabaseName := DestDatabaseName; IndexName := DestTableName+IntToStr(i); IndexFields := S.IndexDefs.Items[i].Fields; IndexFields2 := ReplaceCharInString(IndexFields,';',','); Q.SQL.Clear; Q.SQL.Add('Create'); If ixUnique in S. IndexDefs.Items[j].Options Then Begin Q.SQL.Add('Unique'); End; If ixDescending in S.IndexDefs.Items[j].Options Then Begin Q.SQL.Add('Desc'); End Else Begin Q.SQL.Add('Asc'); End; Q.SQL.Add('Index'); Q.SQL.Add(IndexName); Q.SQL.Add('On'); Q.SQL.Add(DestTableName); Q.SQL.Add('('); Q.SQL.Add(IndexFields2); Q.SQL.Add(')'); Try Q.ExecSql; D.IndexDefs.Update; D.AddIndex(IndexName,IndexFields, S.IndexDefs.Items[j].Options); D.IndexDefs.Update; Except On E : EDBEngineError Do Begin If E.Message = 'Invalid array of index descriptors.' Then Begin Try D.IndexDefs.Update; D.DeleteIndex(IndexName); D.IndexDefs.Update; Except End; End Else Begin Try D.IndexDefs.Update; IDXO := D.IndexDefs.Items[j].Options; Except End; End; End; End; End; //i:= IMax; Finally Q.Free; End; End;

1459

End; S.Active := False; Result := True; Finally S.Free; D.Free; End; Except On E : Exception Do Begin ShowMessage('DBCreateTableBorrowStr Error: '+E.Message); Result := False; End; End; End;

TABLO SİLME Herhangi bir veri tabanından tablo silmek gerektiğinde, aşağıdaki fonksiyon kullanılabilir. Function DBDropTable(const DatabaseName, TableName : string):Boolean; var Query : TQuery; begin Result := False; If Not IsTable(DatabaseName, TableName) Then Begin Exit; End; Query := TQuery.Create(nil); try Query.DatabaseName := DatabaseName; Query.SQL.Clear; Query.SQL.Add('Drop Table '); If (Pos('.DB', UpperCase(TableName)) > 0) Or (Pos('.DBF',UpperCase(TableName)) > 0) Then Begin Query.Sql.Add('"'+TableName+'"'); End Else Begin Query.Sql.Add(TableName); End; Result := True; Try Query.ExecSQL; Except Result := False; End; finally Query.Free; end; end;

ALAN ADININ BULUNMASI Sıra numarası verilen bir tablo alanının alan adı bu fonksiyonla alınabilir. Function DBFieldNameByNo( DatabaseName : String;

1460

TableName : String; FieldNo : Integer): String; Var Table : TTable; Begin Result := ''; If Not IsTable(DatabaseName, TableName) Then Exit; If FieldNo < 0 Then Exit; If FieldNo >= DBNFields(DatabaseName, TableName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; Result := Table.FieldDefs[FieldNo].Name; Except End; Finally Table.Free; End; End;

ORTAK ALAN İSİMLERİ Bu fonksiyonda, her iki tabloda da mevcut olan alan isimleri, aralarına konan virgüllerle ayrılmış olarak dönerler. Function DBFieldNamesCommonToString( DatabaseName1 : String; TableName1 : String; DatabaseName2 : String; TableName2 : String): String; Var List1 : TStringList; List2 : TStringList; i : Integer; Suffix: String; Begin Result := ''; List1 := TStringList.Create(); List2 := TStringList.Create(); Try DBFieldNamesToTStrings( DatabaseName1, TableName1, List1); For i := 0 To List1.Count - 1 Do Begin List1[i] := UpperCase(List1[i]); End; DBFieldNamesToTStrings( DatabaseName2, TableName2, List2); For i := 0 To List2.Count - 1 Do Begin List2[i] := UpperCase(List2[i]); End; For i := 0 To List1.Count - 1 Do Begin If Result = '' Then

1461

Begin Suffix := ''; End Else Begin Suffix := ', '; End; If List2.IndexOf(List1[i]) <> -1 Then Begin Result := Result + Suffix + List1[i]; End; End; Finally List1.Free; List2.Free; End; End;

TABLODAKİ ALAN İSİMLERİ Bu fonksiyon, tablodaki alanlara ait isimleri, bir Tstrings nesnesi içerisine doldurur. Function DBFieldNamesToTStrings( DatabaseName : String; TableName : String; Strings : TStrings): Boolean; Var Table : TTable; FieldNo : Integer; Begin Result := False; If Not IsTable(DatabaseName, TableName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; Strings.Clear; For FieldNo := 0 To Table.FieldDefs.Count -1 Do Begin Strings.Add(Table.FieldDefs[FieldNo].Name); End; Result := True; Except End; Finally Table.Free; End; End;

ALAN NUMARASI Bu fonksiyon, adı bilinen bir alanın, tablo içerisindeki sırasını bulur. Function DBFieldNo(DatabaseName, TableName, FieldName: String): Integer; Var Table : TTable; FieldIndex : Integer; FieldNumber: Integer; Begin Result := -1;

1462

If Not IsTable(DatabaseName, TableName) Then Exit; If Not IsField(DatabaseName, TableName, FieldName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; FieldIndex := Table.FieldDefs.IndexOf(FieldName); FieldNumber := Table.FieldDefs[FieldIndex].FieldNo; Result := FieldNumber; Except End; Finally Table.Free; End; End;

ALAN UZUNLUĞU Tablo içerisindeki bir alanın, uzunluğu, bu fonksiyon ile bulunur. Function DBFieldSize(DatabaseName, TableName, FieldName: String): Integer; Var Table : TTable; FieldIndex : Integer; FieldSize : Integer; Begin Result := 0; If Not IsTable(DatabaseName, TableName) Then Exit; If Not IsField(DatabaseName, TableName, FieldName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; FieldIndex := Table.FieldDefs.IndexOf(FieldName); FieldSize := Table.FieldDefs[FieldIndex].Size; Result := FieldSize; Except End; Finally Table.Free; End; End;

ALAN TİPLERİ Adı bilinen bir alanın tipini bulmak için aşağıdaki fonksiyon kullanılabilir. Function TypeField(DatabaseName, TableName, FieldName: String): String; Var

1463

Table : TTable; FieldIndex : Integer; FieldType : TFieldType; Begin Result := ''; If Not IsTable(DatabaseName, TableName) Then Exit; If Not IsField(DatabaseName, TableName, FieldName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; FieldIndex := Table.FieldDefs.IndexOf(FieldName); FieldType := Table.FieldDefs[FieldIndex].DataType; If FieldType=ftUnknown Then Result := 'Unknown'; If FieldType=ftString Then Result := 'String'; If FieldType=ftSmallInt Then Result := 'SmallInt'; If FieldType=ftInteger Then Result := 'Integer'; If FieldType=ftWord Then Result := 'Word'; If FieldType=ftBoolean Then Result := 'Boolean'; If FieldType=ftFloat Then Result := 'Float'; If FieldType=ftCurrency Then Result := 'Currency'; If FieldType=ftBCD Then Result := 'BCD'; If FieldType=ftDate Then Result := 'Date'; If FieldType=ftTime Then Result := 'Time'; If FieldType=ftDateTime Then Result := 'DateTime'; If FieldType=ftBytes Then Result := 'Bytes'; If FieldType=ftVarBytes Then Result := 'VarBytes'; If FieldType=ftBlob Then Result := 'Blob'; If FieldType=ftMemo Then Result := 'Memo'; If FieldType=ftGraphic Then Result := 'Graphic'; {$IFDEF WIN32} If FieldType=ftAutoInc Then Result := 'AutoInc'; If FieldType=ftFmtMemo Then Result := 'FmtMemo'; If FieldType=ftParadoxOle Then Result := 'ParadoxOle'; If FieldType=ftDBaseOle Then Result := 'DBaseOle'; If FieldType=ftTypedBinary Then Result := 'TypedBinary'; {$ENDIF} Except End; Finally Table.Free; End; End; Yukarıdaki fonksiyon ile aynı işleve sahip bir fonksiyondur. Fakat fonksiyona alan adı değil, sıra numarası verilir. Function DBFieldTypeByNo(DatabaseName, TableName: String; FieldNo: Integer): String; Var Table : TTable; FieldIndex : Integer; FieldType : TFieldType; Begin

1464

Result := ''; If Not IsTable(DatabaseName, TableName) Then Exit; Table := TTable.Create(nil); Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; FieldIndex := FieldNo; Try FieldType := Table.FieldDefs[FieldIndex].DataType; Except FieldType := ftUnknown; End; {TFieldType Possible values are ftUnknown, ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, ftBytes, ftVarBytes, ftBlob, ftMemo or ftGraphic} If FieldType=ftUnknown Then Result := 'Unknown'; If FieldType=ftString Then Result := 'String'; If FieldType=ftSmallInt Then Result := 'SmallInt'; If FieldType=ftInteger Then Result := 'Integer'; If FieldType=ftWord Then Result := 'Word'; If FieldType=ftBoolean Then Result := 'Boolean'; If FieldType=ftFloat Then Result := 'Float'; If FieldType=ftCurrency Then Result := 'Currency'; If FieldType=ftBCD Then Result := 'BCD'; If FieldType=ftDate Then Result := 'Date'; If FieldType=ftTime Then Result := 'Time'; If FieldType=ftDateTime Then Result := 'DateTime'; If FieldType=ftBytes Then Result := 'Bytes'; If FieldType=ftVarBytes Then Result := 'VarBytes'; If FieldType=ftBlob Then Result := 'Blob'; If FieldType=ftMemo Then Result := 'Memo'; If FieldType=ftGraphic Then Result := 'Graphic'; Except End; Finally Table.Free; End; End;

TABLONUN ANAHTAR ALANLARI Bir tabloda, anahtar olarak kullanılan alanlar, Tstrings nesnesine doldurulur. Function DBKeyFieldNamesToTStrings( DatabaseName : String; TableName : String; Strings : TStrings): Boolean; Var Table : TTable; FieldNo : Integer; Begin Result := False; If Not IsTable(DatabaseName, TableName) Then Exit; Table := TTable.Create(nil);

1465

Try Try Table.Active := False; Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; Strings.Clear; For FieldNo := 0 To Table.FieldDefs.Count -1 Do Begin If IsFieldKeyed( DatabaseName, TableName, Table.FieldDefs[FieldNo].Name) Then Begin Strings.Add(Table.FieldDefs[FieldNo].Name); End; End; Result := True; Except End; Finally Table.Free; End; End;

LOOKUP YÖNTEMİYLE DEĞER SEÇME DİYALOĞU Kullanıcıya bir LookUp diyaloğu gösterip, seçtiği değeri döndüren bir fonksiyondur. Eğer kullanıcı "Cancel" butonuna basarsa, boş bir karakter dizisi döner. Function DialogLookupDetail( Const DialogCaption : string; Const InputPrompt : string; Const DefaultValue : string; Const Values : TStringList; Const ButtonSpacing : Integer; Const SpacerHeight : Integer; Const TopBevelWidth : Integer; Const PromptHeight : Integer; Const FormHeight : Integer; Const FormWidth : Integer; Const Hint_OK : string; Const Hint_Cancel : string; Const Hint_ListBox : string; Const ListSorted : Boolean; Const AllowDuplicates : Boolean ): string; Var Form : TForm; Base_Panel : TPanel; Base_Buttons : TPanel; Spacer : TPanel; Base_Top : TPanel; ButtonSlider : TPanel; ButtonSpacer : TPanel; Prompt : TPanel; ListBox : TListBox; ButtonCancelB: TPanel; ButtonOKB : TPanel; Button_Cancel: TButton; Button_OK : TButton;

1466

DefItemIndex : Integer; TempValues : TStringList; Begin Result := DefaultValue; Form := TForm.Create(Application); TempValues := TStringList.Create(); Try TempValues.Sorted := ListSorted; TempValues.Clear; If AllowDuplicates Then Begin TempValues.Duplicates := dupAccept; End Else Begin TempValues.Duplicates := dupIgnore; End; If Values <> nil Then Begin TempValues.Assign(Values); End; With Form Do Begin Try Canvas.Font := Font; BorderStyle := bsSizeable; Caption := DialogCaption; Height := FormHeight; Width := FormWidth; ShowHint := True; Position := poScreenCenter; BorderIcons := [biMaximize]; Base_Panel := TPanel.Create(Form); With Base_Panel Do Begin Parent := Form; Align := alClient; Caption := ' '; BorderWidth := 10; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; End; Base_Buttons := TPanel.Create(Form); With Base_Buttons Do Begin Parent := Base_Panel; Align := alBottom; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Height := 27; End; ButtonSlider := TPanel.Create(Form); With ButtonSlider Do Begin Parent := Base_Buttons; Align := alClient; Caption := ' '; BorderWidth := 0;

1467

BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; End; ButtonCancelB := TPanel.Create(Form); With ButtonCancelB Do Begin Parent := ButtonSlider; Align := alRight; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Width := 75+ButtonSpacing; End; ButtonSpacer := TPanel.Create(Form); With ButtonSpacer Do Begin Parent := ButtonCancelB; Align := alLeft; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Width := ButtonSpacing; End; ButtonOKB := TPanel.Create(Form); With ButtonOKB Do Begin Parent := ButtonSlider; Align := alRight; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Width := 75; End; Spacer := TPanel.Create(Form); With Spacer Do Begin Parent := Base_Panel; Align := alBottom; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Height := SpacerHeight; End; Base_Top := TPanel.Create(Form); With Base_Top Do Begin Parent := Base_Panel; Align := alClient; Caption := ' '; BorderWidth := 10;

1468

BorderStyle := bsNone; BevelOuter := bvRaised; BevelInner := bvNone; BevelWidth := TopBevelWidth; End; Prompt := TPanel.Create(Form); With Prompt Do Begin Parent := Base_Top; Align := alTop; Caption := ' '; BorderWidth := 0; BorderStyle := bsNone; BevelOuter := bvNone; BevelInner := bvNone; Caption := InputPrompt; Height := PromptHeight; Alignment := taCenter; End; Button_Cancel := TButton.Create(Form); With Button_Cancel Do Begin Parent := ButtonCancelB; Caption := 'Cancel'; ModalResult := mrCancel; Default := True; Align := alClient; Hint := Hint_Cancel; End; Button_OK := TButton.Create(Form); With Button_OK Do Begin Parent := ButtonOKB; Caption := 'OK'; ModalResult := mrOK; Default := False; Align := alClient; Hint := Hint_OK; End; ListBox := TListBox.Create(Form); With ListBox Do Begin Parent := Base_Top; Align := alClient; Hint := Hint_ListBox; Sorted := ListSorted; Focused; If TempValues <> nil Then Begin Items.Assign(TempValues); DefItemIndex := Items.IndexOf(DefaultValue); If DefItemIndex <> -1 Then Begin ItemIndex := DefItemIndex; Selected[DefItemIndex]; End Else Begin Result := '';

1469

ItemIndex := 0; Selected[0]; End; IntegralHeight := True; Button_OK.Default := True; Button_Cancel.Default := False; End Else Begin Result := ''; End; End; SetFocusedControl(ListBox); If ShowModal = mrOk Then Begin If ListBox.ItemIndex<>-1 Then Result := ListBox.Items[ListBox.ItemIndex]; End; Finally Form.Free; End; End; Finally TempValues.Free; End; End;

BİR PARADOX TABLOSUNUN YENİDEN ANAHTARLANMASI Mevcut bir Paradox tablosu, aşağıdaki fonksiyon kullanılarak yeniden anahtarlanabilir. Function DBParadoxCreateNKeys( DatabaseName : String; TableName : String; NKeys : Integer): Boolean; Var T : TTable; T2 : TTable; i : Integer; TempDBName : String; TempTblNam : String; TempTblStub: String; KeysString : String; Begin Result := False; {Select a temporary table name} TempTblStub := 'qrz'; TempDBName := DatabaseName; TempTblNam := ''; For i := 1 To 100 Do Begin TempTblNam := TempTblStub+StringPad(IntToStr(i),'0',3,False)+'.Db'; If Not IsTable(TempDBName,TempTblNam) Then Begin Break; End Else Begin

1470

If i = 100 Then Begin DBDeleteTable( TempDBName, TempTblNam); End; End; End; T := TTable.Create(nil); T2 := TTable.Create(nil); Try Try T.Active := False; T.DatabaseName := DatabaseName; T.TableName := TableName; T.Active := True; T2.Active := False; T2.DatabaseName := TempDBName; T2.TableName := TempTblNam; T2.FieldDefs.Assign(T.FieldDefs); T2.IndexDefs.Clear; KeysString := ''; For i := 0 To NKeys - 1 Do Begin If i > 0 Then Begin KeysString := KeysString + ';'; End; KeysString := KeysString + DBFieldNameByNo( DatabaseName, TableName, i); End; T2.IndexDefs.Add('',KeysString,[ixPrimary]); T2.CreateTable; T2.Active := False; T.Active := False; AddTables( DatabaseName, TableName, TempDBName, TempTblNam); DBDeleteTable(DatabaseName,TableName); T2.Active := True; T.DatabaseName := DatabaseName; T.TableName := TableName; T.FieldDefs.Assign(T2.FieldDefs); T.IndexDefs.Clear; T.IndexDefs.Add('',KeysString,[ixPrimary]); T.CreateTable; T2.Active := False; T.Active := False; AddTables( TempDBName, TempTblNam, DatabaseName, TableName); DBDeleteTable(

1471

TempDBName, TempTblNam); Result := True; Except ShowMessage('Error in Function DBParadoxCreateNKeys'); End; Finally T.Free; T2.Free; End; End;

TABLO ADININ DEĞİŞTİRİLMESİ Belirtilen tablonun adını değiştirir. Bu fonksiyon kullanılırken, veri tabanındaki referans sınırlamalarına dikkat edilmelidir. SQL tabanlı veri tabanlarında, eğer tabloya referans eden başka veri tabanı nesneleri varsa, tablonun silinmesine izin verilmeyecektir. Function DBReNameTable( DatabaseName, TableNameOld, TableNameNew: String): Boolean; Begin Result := True; Try If Not IsTable(DatabaseName, TableNameOld) Then Begin Result := False; Exit; End; {First Copy The Source Table To The New Table} If Not DBCopyTable( DatabaseName, TableNameOld, DatabaseName, TableNameNew) Then Begin Result := False; Exit; End; {Now Drop The Source Table} If Not DBDropTable(DatabaseName, TableNameOld) Then Begin Result := False; Exit; End; Except Result := False; End; End; {!~ Applies BatchMode Types As Appropriate To Source and Destination Tables} Function DBRecordMove( SourceDatabaseName, SourceTable, DestDatabaseName, DestTable: String; BMode: TBatchMode): Boolean;

1472

var S : TTable; D : TTable; B : TBatchMove; begin S := TTable.Create(nil); D := TTable.Create(nil); B := TBatchMove.Create(nil); try {Create The Source Table} S.Active := False; S.DatabaseName := SourceDatabaseName; S.ReadOnly := False; S.TableName := SourceTable; S.Active := true; {Create The Destination Table} D.Active := False; D.DatabaseName := DestDatabaseName; D.TableName := DestTable; D.ReadOnly := False; {Make the table copy} B.AbortOnKeyViol := False; B.AbortOnProblem := False; B.Destination := D; B.Source := S; B.Mode := BMode; Try B.Execute; Except End; Result := True; finally S.Free; D.Free; B.Free; end; End;

TABLO YAPILARI AYNI MI? Bu fonksiyonda, iki tablonun yapısı karşılaştırılır ve aynı ise TRUE değeri döndürülür. Function DBSchemaSame(const DatabaseName1, Table1, DatabaseName2, Table2: string): Boolean; Begin Result := IsStructureSame(DatabaseName1,Table1,DatabaseName2,Table2); End; {!~ Creates a new TSession object.} {$IFDEF WIN32} Function DBSessionCreateNew: TSession; {$ENDIF WIN32} {$IFDEF WIN32} Var List : TStringList;

1473

Seed : String; i : Integer; Ses : String; Begin Seed := 'Session'; Ses := Seed+'0'; List := TStringList.Create; Try Sessions.GetSessionNames(List); For i := 0 To 1000 Do Begin Ses := Seed + IntToStr(i); If List.IndexOf(Ses) = -1 Then Break; End; Result := Sessions.OpenSession(Ses); Finally List.Free; End; End; {$ENDIF}

BİR TABLO ALANINDAKİ DEĞERLERİN SAĞ TARAFINDAKİ BOŞLUKLARIN TEMİZLENMESİ Belirtilen alandaki değerlerin, sağ yanındaki boşlukları temizleyen bir fonksiyondur. Function DBTrimBlanksRight( DatabaseName : String; TableName : String; FieldName : String): Boolean; Var Q : TQuery; S : String; Begin { Result := False;}{zzz} Q := TQuery.Create(nil); Try Q.Active := False; Q.DatabaseName := DatabaseName; Q.RequestLive := True; Q.Sql.Clear; Q.Sql.Add('Select'); Q.Sql.Add('*'); Q.Sql.Add('From'); Q.Sql.Add('"'+TableName+'"'); Q.Active := True; Q.First; While Not Q.EOF Do Begin S := Q.FieldByName(FieldName).AsString; S := Trim(S); S := Trim(S); Q.Edit; Q.FieldByName(FieldName).AsString := S; Q.Post; Q.Next; End; Result := True; Finally Q.Free;

1474

End; End;

ARANAN ALAN, TABLODA VAR MI? Alan, belirtilen tabloda varsa fonksiyondan TRUE değeri döner. Function IsField(DatabaseName, TableName, FieldName: String): Boolean; Var Query : TQuery; T : TTable; i : Integer; UpperFN : String; TestFN : String; Begin Result := False; UpperFN := UpperCase(FieldName); If Not IsTable(DatabaseName, TableName) Then Exit; Query := TQuery.Create(nil); T := TTable.Create(nil); Try Try Query.DatabaseName := DatabaseName; Query.Sql.Clear; Query.Sql.Add('Select '); Query.Sql.Add('a.'+FieldName+' XYZ'); Query.Sql.Add('From'); If (Pos('.DB', UpperCase(TableName)) > 0) Or (Pos('.DBF',UpperCase(TableName)) > 0) Then Begin Query.Sql.Add('"'+TableName+'" a'); End Else Begin Query.Sql.Add(TableName+' a'); End; Query.Active := True; Result := True; Except Try T.Active := False; T.DatabaseName := DatabaseName; T.TableName := TableName; T.Active := True; If T.FieldDefs.IndexOf(FieldName) > -1 Then Begin Result := True; End Else Begin For i := 0 To T.FieldDefs.Count -1 Do Begin TestFN := UpperCase(T.FieldDefs[i].Name); If TestFN = UpperFN Then Begin Result := True; Break; End; End; End;

1475

T.Active := False; Except End; End; Finally Query.Free; T.Free; End; End;

ALAN ANAHTAR MI? Belirtilen alan, o tabloda mevcutsa ve anahtar olarak kullanılıyorsa, bu fonksiyondan TRUE değeri döner. Function IsFieldKeyed(DatabaseName, TableName, FieldName: String): Boolean; Var Table : TTable; FieldIndex : Integer; i : Integer; KeyCount : Integer; LocalTable : Boolean; ParadoxTbl : Boolean; DBaseTable : Boolean; TempString : String; Begin Result := False; If Not IsTable(DatabaseName, TableName) Then Exit; If Not IsField(DatabaseName, TableName, FieldName) Then Exit; TempString := UpperCase(Copy(TableName,Length(TableName)2,3)); ParadoxTbl := (Pos('.DB',TempString) > 0); TempString := UpperCase(Copy(TableName,Length(TableName)3,4)); DBaseTable := (Pos('.DBF',TempString) > 0); LocalTable := (ParadoxTbl Or DBaseTable); Table := TTable.Create(nil); Try Try Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; KeyCount := Table.IndexFieldCount; FieldIndex := Table.FieldDefs.IndexOf(FieldName); If LocalTable Then Begin If ParadoxTbl Then Begin Result := (FieldIndex < KeyCount); End Else Begin Table.IndexDefs.UpDate; For i := 0 To Table.IndexDefs.Count-1 Do Begin {Need to check if FieldName is in the Expression listing} If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Express

1476

ion))>0 Then Begin Result := True; Break; End; {Need to check if FieldName is in the Fields listing} If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Fields) )>0 Then Begin Result := True; Break; End; End; End; End Else Begin If Table. FieldDefs[FieldIndex]. Required Then Begin Result := True; End; End; Except End; Finally Table.Free; End; End;

TABLO MEVCUT MU? Bu fonksiyon, belirtilen tablo varsa TRUE değerini döndürür. Function IsTable(DatabaseName, TableName: String): Boolean; Var Query: TQuery; Begin Result := False; Query := TQuery.Create(nil); Try Try Query.DatabaseName := DatabaseName; Query.Sql.Clear; Query.Sql.Add('Select *'); Query.Sql.Add('From'); If (Pos('.DB', UpperCase(TableName)) > 0) Or (Pos('.DBF',UpperCase(TableName)) > 0) Then Begin Query.Sql.Add('"'+TableName+'"'); End Else Begin Query.Sql.Add(TableName); End; Query.Active := True; Result := True;

1477

Except End; Finally Query.Free; End; End;

TABLO MEVCUT VE ESAS ANAHTARI VAR MI Bu fonksiyon, belirtilen tablo, mevcutsa ve öncelikli anahtara sahipse TRUE değerini döndürür. Function IsTableKeyed(DatabaseName, TableName: String): Boolean; Var Table : TTable; i : Integer; IsKeyed : Boolean; Begin Result := False; IsKeyed := False; If Not IsTable(DatabaseName, TableName) Then Exit; Table := TTable.Create(nil); Try Try Table.DatabaseName := DatabaseName; Table.TableName := TableName; Table.Active := True; For i := 0 To Table.FieldDefs.Count-1 Do Begin If Table.FieldDefs[i].Required Then Begin IsKeyed := True; Break; End; End; If IsKeyed Then Begin Result := True; End Else Begin Result := False; {Need to examine indexdefs} If (Pos('.DB', UpperCase(TableName)) > 0) Then Begin {Table is either Paradox or DBase} Table.IndexDefs.UpDate; If (Pos('.DBF', UpperCase(TableName)) > 0) Then Begin {Table is a DBase Table} If Table.IndexDefs.Count > 0 Then Begin Result := True; End; End Else Begin {Table is a Paradox Table} For i := 0 To Table.IndexDefs.Count-1 Do Begin

1478

If ixPrimary in Table.IndexDefs[i].Options Then Begin Result := True; Break; End; End; End; End Else Begin Result := False; End; End; Except End; Finally Table.Free; End; End;

MEVCUT BİR TABLO İLE AYNI YAPIDA BAŞKA BİR TABLO YARATMAK Bir veri tabanı içerisinde var olan tablo ile tıpatıp aynı bir başka tablo, herhangi bir veri tabanı içerisinde yaratılabilir. "Datali" değişkenine bağlı olarak, verilerde yeni tabloya aktarılabilir. implementation uses DB, DBTables ; {$R *.DFM} function tabloaktar(SourceDB, SourceTable, DestDb, DestTable:string; datali:boolean):boolean; var tSource, TDest: TTable; i:integer; begin TSource := TTable.create(nil); with TSource do begin DatabaseName := sourcedb; TableName := Sourcetable; open; end; TDest := TTable.create(nil); with TDest do begin DatabaseName := DestDb; TableName := DestTable; FieldDefs.Assign(TSource.FieldDefs); IndexDefs.Assign(TSource.IndexDefs); CreateTable; end; tdest.open; tsource.first; if datali then

1479

begin while not tsource.eof do begin tdest.append; for i:=0 to tsource.fieldcount-1 do begin tdest.fields[i].assign(tsource.fields[i]); showmessage(tsource.fields[i].asstring) end; tsource.Next; end; end; TSource.close; tdest.close; showmessage('aktarma bitti') end;

TABLO FİLTRELEME Bir tablonun filterelenmesi, basit olarak filter özelliğine, seçim kriterinin yazılıp, filtered özelliğinin TRUE yapılması ile yapılır. Tablo seçim kriterine uyan kayıtları gösterir, diğerlerini göstermez. Filtreleme işleminin, dinamik bir sorgu niteliğinde, form üzerindeki alanlar kullanılarak yapılması, daha kullanışlı olabilir. Örneğin, Oracle formlarında, sorgu moduna girildiğinde, veri alanlarının temizlenerek, sorgu parametrelerinin yazılmasına imkan vermekte ve sorgu uygula komutu ile birlikte, belirtilen kriterlere uygun sonuç kümesi getirilmektedir. Benzer bir yapı, Delphi formlarında da kurulabilir. Bunun için takip edilecek adımlar şunlardır. · Form üzerine,"Sorgu moduna geçiş" için kullanılacak bir buton yerleştirin. · Butona basıldığında çalışması için, OnClick olay yordamı içerisinde verilecek .Insert · komutu ile, veri alanlarının temizlenmesini sağlayın · Form üzerine "Sorgu uygulama" için kullanılacak başka bir buton yerleştirip, OnClick olay yordamına, · < SorgulanacakTabloAdı >.cancel komutunu yazarak, arama kriteri olarak girilen değerlerin, · tabloya kaydedilmemesini sağlayın. · Fakat bu işlemden önce, sorgulama kriteri olarak kullanılacak alanlardaki sorgu kriterlerini değişkenlere aktararak, saklayın. · Seçilen alanların tümü, sorgu işleminde kullanılmayabilir. Bu nedenle boş bırakılan alanların, sorgulama esnasında problem yaratmaması için, aşağıdaki fonksiyonları kullanın. Eğer, sorgulama alanı boş bırakılmışsa, bu fonksiyonlar, o alana ait her türlü değerin kabul edilmesini sağlayacaktır. function nvlforstr(birinci:string;ikinci:string):string; begin if birinci='' then result:=ikinci else result:=birinci; end; function nvlforscl(birinci:string;ikinci:string):string; begin if birinci=' . . . ' then result:=ikinci else result:=birinci; end; function nvlforTEL(birinci:string;ikinci:string):string; begin if birinci='( ) ' then result:=ikinci else result:=birinci; end; function nvltoyil(s1 : string) : string; begin

1480

if length(s1)=0 then result:='*' else result:=s1; end; · ·

Filtre uygulanacak tablonun OnFilter olay yordamı parametreleri arasında bulunan ACCEPT, TRUE değerini alırsa, tablodaki o kayıt, filtreleme kriterine uygun demektir. Aksi taktirde, kayıt gösterilmeyecektir. Bu yordam aşağıdaki gibi kullanılır. Bu yordamdaki kod, tablonun her satırı için çalışarak, gereken mantıksal karşılaştırmayı yapacak ve ACCEPT parametresinin değerine göre kayıt kabul veya red edilecektir.

procedure Tf_data_ana.TableFilterRecord(DataSet: TDataSet; var Accept: Boolean); begin Accept := ((Table.FieldByName('firm_adi').AsString,nvltoyil(kurulus_adi)) and (Table.FieldByName('firm_sah').AsString, NVLtoyil(sahip_adi)) and (Table.FieldByName('VER_SCL_NO').AsString = NVLForscl(ver_sic,Table.FieldByName('VER_SCL_NO').AsString)) and (Table.FieldByName('VER_DA').AsString, nvltoyil(vrg_d)) and (Table.FieldByName('TEL').AsString= NVLForTEL(telefon,Table.FieldByName('TEL').AsString)) ); end;

ŞİFRELİ PARADOX TABLOSUNA OTOMATİK BAĞLANTI Paradox tablolarına da şifre konabilir. Bu durumda, kullanıcı bağlanırken, şifresini belirtmek zorundadır. Şifrenin uygulama tarafından otomatik olarak girilmesi için tablo açılmadan önce Session.addpassword('<şifre>'); Komutu verilmelidir.

SUBSTRİNG FONKSİYONUNUN SQL CÜMLESİNDE KULLANILMASI DBase ve Paradox veri tabanlarında sorgulama yapılırken kullanılabilecek bir fonksiyon olan SubString fonksiyonu, neredeyse hiç dökümante edilmemiştir. Bu fonksiyon, hem sorguda, hem sıralamada hem de karşılaştırma kısmında kullanılabilir. Notasyonu şu şekildedir. Substring( from to ) Örnek: Select substring(adi from 2 to 5) from customer Where substring(adi from 4 to 5)='AL' Order by substring(adi from 2 to 3)

DBCONTROLGRİD KAYDIRMA ÇUBUKLARI DbControlGrid bileşeninde, normalda sadece dikey kaydırma çubuğu vardır. Yatay kaydırma çubuğu görünmez. Eğer yatay kaydırma çubuğunun da görünmesi ve kullanılması istenirse yapılması gereken, ScrollBars özelliğinin yayınlanması ve seçime göre araç çubuklarının hazırlanmasıdır. unit EDBcgrd; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls,

1481

Forms, Dialogs, DBCGrids, Unit1 in '..\..\..\Program Files\Borland\Delphi 3\Unit1.pas' {Form1}; type scrollbartype=(sbBoth,SbNone,sbVertical,sbHorizontal); type TEDBCtrlGrid = class(TDBCtrlGrid) private { Private declarations } fsbars:scrollbartype; protected { Protected declarations } public { Public declarations } procedure CreateWnd;override; published { Published declarations } property ScrollBars:scrollbartype read fsbars write fsbars; end; procedure Register; implementation procedure TEDBctrlgrid.CreateWnd; begin inherited CreateWnd; case scrollbars of sbboth:showscrollbar(handle,sb_both,true); sbnone:showscrollbar(handle,sb_both,false); sbvertical:begin showscrollbar(handle,sb_vert,true); showscrollbar(handle,sb_horz,false); end; sbhorizontal:begin showscrollbar(handle,sb_vert,false); showscrollbar(handle,sb_horz,true); end; end; end; procedure Register; begin RegisterComponents('F1Delphi', [TEDBCtrlGrid]); end; end.

TABLODAN DOSYAYA AKTARMA Bir Ttable bileşeninin bağlı olduğu veri tabanı tablosundaki verilerin, Sabit kolon uzunluğunda veya, kolonlar arasına ayıraçlar koymak suretiyle metin dosyasına saklanması için geliştirilmiş bir Ttable türevi bileşene ait kod aşağıdadır. unit Exttab; interface uses

1482

Windows, Messages, SysUtils, Classes, Graphics, Controls,dialogs, Db, DBTables,StdCtrls,ComCtrls,WinTypes, WinProcs, ExtCtrls,DBCtrls; const LANGUAGE='TURKISH'; REGISTERED=FALSE; type TExtTab= class(Ttable) private { Private declarations } f_message:string; f_about:string; f_delimited:boolean; f_delimeter:string; f_filename:string; protected { Protected declarations } public { Public declarations } published procedure SaveToFile; property IsDelimited:boolean read f_delimited write f_delimited; property Delimeter:string read f_delimeter write f_delimeter; property FilePathAndName:string read f_filename write f_filename; property About:string read f_about write f_about; { Published declarations } end; implementation var msgid:integer; procedure TExtTab.SaveToFile; function tamamla(instr:string;x:integer;j:integer):string; var l,t:integer; begin if (IsDelimited) and (delimeter='') then delimeter:='@'; if not isdelimited then begin if length(fields[j].fieldname)>=x then x:=length(fields[j].fieldname); for l:=1 to x-length(instr) do instr:=instr+' '; result:=instr+' '; end else result:=instr+delimeter; end; var col_count:integer; row_count:integer; z,i,j:integer;

1483

row:string; f:system.text; st,et,ft:ttime; begin if not active then open; if FilePathAndName='' then begin filepathandname:= InputBox('Dikkat', 'Dosya ismini belirtiniz!', 'c:\TmpName.txt'); end; col_count:=fieldcount; row_count:=recordcount; rewrite(f,FilePathAndName); first; disablecontrols; st:=time; for j:=0 to col_count-1 do write(f,tamamla(fields[j].fieldname,fields[j].displaywidth,j) ); writeln(f,''); for i:=0 to row_count-1 do begin for j:=0 to col_count-1 do begin if ord(fields[j].datatype)<14 then begin row:=tamamla(fields[j].asstring,fields[j].displaywidth,j); write(f,row); end; end; next; writeln(f,''); end; et:=time; ft:=et-st; showmessage('Başlangıç: '+timetostr(st)+' '+' Bitiş: '+timetostr(et)+''#10#13+ 'Kayıt Sayısı: '+inttostr(fieldcount)+' Kolon X '+inttostr(recordcount)+' Satır.'#10#13+ 'İşlem tamam!'); enablecontrols; closefile(f); end; end.

SORGUDAN DOSYAYA AKTARMA Tquery bileşeni kullanarak yapılan sorgu neticesinde dönen sonuç kümesinin, metin dosyasına atılması için geliştirilmiş Tquery türevi bir bileşene ait kod örneği aşağıdadır. Bu örnekte, Dene ve al sürümü, bileşen uygulamasına örnek bir yöntem de yer almaktadır. unit ExtQuery; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

1484

Dialogs,Db, DBTables, WinTypes, WinProcs, ExtCtrls,DBCtrls; const LANGUAGE='TURKISH'; REGISTERED=FALSE; type TExtQuery = class(TQuery) private { Private declarations } f_message:string; f_about:string; f_delimited:boolean; f_delimeter:string; f_filename:string; protected { Protected declarations } public { Public declarations } published procedure SaveToFile; property IsDelimited:boolean read f_delimited write f_delimited; property Delimeter:string read f_delimeter write f_delimeter; property FilePathAndName:string read f_filename write f_filename; property About:string read f_about write f_about; constructor create(aowner:tcomponent);override; destructor destroy;override; { Published declarations } end; implementation var msgid:integer; constructor TExtquery.create(aowner:tcomponent); begin inherited; about:='Written by Faruk DEMİREL ([email protected]) 01.02.1998 Turkey'; if (not registered) AND (componentstate <> [csDesigning]) then {Eğer kayıtlı bir kullanıcı değilse ve uygulama çalışma modunda ise, uyarı ve tanıtım mesajını ver.} if language='ENGLISH' then begin showmessage ('EXTENDED QUERY'+#10#13+ 'TRIAL'+#10#13+ 'BY FARUK DEMİREL'+#10#13+ '[email protected]'); msgid:=300; end else begin showmessage ('EXTENDED QUERY'+#10#13+ 'DENE VE AL SÜRÜMÜ'+#10#13+ 'YAZAN FARUK DEMİREL'+#10#13+ '[email protected]'); msgid:=100; end;

1485

end; destructor TExtquery.destroy; begin inherited; end; procedure TExtQuery.SaveToFile; function tamamla(instr:string;x:integer):string; var l,t:integer; begin if (IsDelimited) and (delimeter='') then delimeter:='@'; if FilePathAndName='' then begin showmessage('Invalid path or filename'); exit; end; if not isdelimited then begin if length(instr)
1486

writeln(f,''); end; closefile(f); end; end.

ÖZEL BİR DBGRİD Tarih alanlarına veri girişi herzaman problemdir. Bilgisayarların tarih formatları farklı olabileceği gibi, kullanıcıların tarih kullanma alışkanlıklarındaki farklılıklar da, veri tabanına tarih girişi işlemlerinde, hata mesajlarına sebep olur. Aşağıdaki bileşen, DBGrid bileşeninden türetilmiş olup, Tarih alanına çift tıklandığında, otomatik olarak açılan bir takvimden seçim yapmak suretiyle bilgi girişini sağlamaktadır. unit ExtDbGrid; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Db, DBTables,buttons, StdCtrls, DBGrids,ComCtrls, WinTypes, WinProcs, ExtCtrls, Menus, Calendar,DBCtrls; const Tdatefieldtype=9; type TExtDbGrd = class(TDBGrid) private { Private declarations } f_message:string; f_about:string; protected { Protected declarations } public { Public declarations } published property About:string read f_about write f_about; procedure DblClick;override; procedure Takvimyap; procedure Takvimkapat; procedure mybtnclick(sender:tobject); constructor create(aowner:tcomponent);override; destructor destroy;override; { Published declarations } end; implementation {$R *.RES} var takvimform:tform; takvimpanel:tpanel; takvim:tcalendar; takvimbtn:array [1..6] of tspeedbutton; takvimedit:tedit; msgid:integer; oneinstance:boolean; constructor TExtDbGrd.create(aowner:tcomponent); begin

1487

inherited; color:=clyellow; font.color:=clblue; about:='Written by Faruk DEMİREL ([email protected]) 01.02.1998 Turkey'; end; destructor TExtdbgrd.destroy; begin inherited; end; procedure TExtDbGrd.dblclick; begin inherited; if not oneinstance then begin if ord(fields[selectedindex].datatype)=11 then SHOWMESSAGE('TarihSaat tipindeki alanlarda takvim açılmaz'); if (ord(fields[selectedindex].datatype)=TdateFieldType) then begin oneinstance:=true; takvimyap; takvim.calendardate:=strtodate(fields[selectedindex].asstring ); end; end; end; procedure TEXTDBGRD.Takvimyap; var i:integer; begin takvimform:=tform.create(self); takvimform.width:=267; takvimform.height:=195; takvimform.borderstyle:=bstoolwindow; takvimform.formstyle:=fsstayontop; takvimform.visible:=false; takvimform.BORDERICONS:=[]; {takvim paneli} takvimpanel:=tpanel.create(self); takvimpanel.width:=250; takvimpanel.height:=160; takvimpanel.parent:=takvimform; takvimpanel.left:=5 ; takvimpanel.top:=5; {takvim} takvim:=tcalendar.create(takvimpanel); takvim.parent:=takvimpanel; takvim.left:=10; takvim.top:=10; takvim.width:=200; takvim.color:=color; takvim.font.color:=font.color; {takvim butonları} for i:=1 to 6 do

1488

begin takvimbtn[i]:=tspeedbutton.create(self); takvimbtn[i].parent:=takvimpanel; takvimbtn[i].left:=215; takvimbtn[i].width:=25; takvimbtn[i].height:=22; takvimbtn[i].top:=10+25*(i-1); takvimbtn[i].onclick:=mybtnclick; takvimbtn[i].tag:=i; takvimbtn[i].showhint:=true; end; takvimbtn[1].GLYPH.Handle := LoadBitmap(HInstance,'PY'); takvimbtn[1].hint:='Önceki Yıl'; takvimbtn[2].GLYPH.Handle := LoadBitmap(HInstance,'PM'); takvimbtn[2].hint:='Önceki Ay'; takvimbtn[3].GLYPH.Handle := LoadBitmap(HInstance,'NM'); takvimbtn[3].hint:='Sonraki Ay'; takvimbtn[4].GLYPH.Handle := LoadBitmap(HInstance,'NY'); takvimbtn[4].hint:='Sonraki Yıl'; takvimbtn[5].GLYPH.Handle := LoadBitmap(HInstance,'CHOOSE'); takvimbtn[5].hint:='Seç'; takvimbtn[6].GLYPH.Handle := LoadBitmap(HInstance,'QUIT'); takvimbtn[6].hint:='Çık'; {takvim editi} takvimedit:=tedit.create(self); takvimedit.parent:=takvimpanel; takvimedit.left:=75 ; takvimedit.top:=130; takvimedit.width:=70; takvimedit.text:=datetostr(takvim.calendardate); takvimedit.readonly:=true; takvimform.formstyle:=fsstayontop; takvimform.visible:=true; takvimform.show; end; procedure TExtDbGrd.Takvimkapat; var i:integer; begin for i:=1 to 5 do takvimbtn[i].free; takvim.free; takvimedit.free; takvimpanel.free; takvimform.visible:=false; takvimform.Free; oneinstance:=false; end; procedure TExtDbGrd.mybtnclick(sender:tobject); begin case (sender as tspeedbutton).tag of 1:{- yıl}begin

1489

takvim.prevyear; takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarD ate); end; 2:{- ay}begin takvim.prevmonth; takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarD ate); end; 3:{+ yıl}begin takvim.nextmonth; takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarD ate); end; 4:{+ ay} begin takvim.nextyear; takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarD ate); end; 5:{kapat}begin datasource.dataset.edit; text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate); fields[selectedindex].value:=text; datasource.dataset.post end; 6:{İptal}begin takvimkapat; end; end; end; initialization oneinstance:=false; end. DBNavigator butonlarına erişim unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, DBCtrls, DBNavigator1; type TForm1 = class(TForm) DBNavigator1: TDBNavigator; Button1: TButton; DBNavigator11: TDBNavigator1; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var

1490

Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin DBNavigator11.setbuttonenabled(nbfirst); end; end.

AĞ İŞLEMLERİ Bu bölümde, Delphi uygulamalarında gerekebilecek, ağ uygulamaları ve ağ erişimleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır. Ağ sürücüleri Sistemde tanımlı olan ağ sürücülerinin listesini elde etmek için aşağıdaki fonksiyon kullanılabilir. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; ListBox1: TListBox; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function GetNetworkDriveMappings( sl : TStrings ) : integer; var i : integer; sNetPath : string; dwMaxNetPathLen : DWord; begin sl.Clear; dwMaxNetPathLen := MAX_PATH; SetLength( sNetPath, dwMaxNetPathLen ); for i := 0 to 25 do begin

1491

if( NO_ERROR = Windows.WNetGetConnection( PChar( '' + Chr( 65 + i ) + ':' ), PChar( sNetPath ), dwMaxNetPathLen ) )then begin sl.Add( Chr( 65 + i ) + ': ' + sNetPath ); end; end; Result := sl.Count; end; procedure TForm1.Button1Click(Sender: TObject); // // here's how to call GetNetworkDriveMappings(): // var sl : TStrings; nMappingsCount, i : integer; begin sl := TStringList.Create; nMappingsCount := GetNetworkDriveMappings( sl ); for i := 0 to nMappingsCount-1 do begin // //İstenen şeyler burada yapılabilir. // Şimdilik sadece görüntülensin // MessageBox( 0, PChar( sl.Strings[ i ] ), 'Tanımlı Ağ diskleri',MB_OK ); end; listbox1.items.assign(sl); sl.Free; end; end.

AĞ DA TANIMLI KULLANICILAR KİMLER? Ağ ortamındayken, aynı ağa giriş yapmaya yetkili kullanıcıların (bilgisayarların), isimlerini bulup getiren bir bileşene ait unit aşağıdadır. Kullanılabilmesi için, sisteme bileşen olarak tanımlanması gereklidir. Bunun için, Components | Install components menüsü kullanılır. unit NetUsers; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TNetUsers = class(TComponent) private { Private declarations }

1492

fServer : String; protected { Protected declarations } Procedure SetServer(Server : String); public { Public declarations } UserList: TStringList; Constructor Create(Owner:TComponent); override; Destructor Destroy; override; Function Execute : Boolean; published { Published declarations } property Server :String read fServer write SetServer; end; PnetResourceArr = ^TNetResource; procedure Register; implementation Procedure TNetUsers.SetServer(Server : String); Begin If fServer <> Server Then fServer := Server; End; Constructor TNetUsers.Create(Owner:TComponent); Begin Inherited Create(Owner); If Not ( csDesigning in ComponentState ) Then Begin UserList := TStringList.Create; UserList.Sorted := True; End; End; Destructor TNetUsers.Destroy; Begin If Not( csDesigning in ComponentState ) Then UserList.Destroy; Inherited Destroy; End; Function TNetUsers.Execute : Boolean; Var NetResource: TNetResource; Buf:Pointer; Count, BufSize, Res: DWORD; i : Integer; lphEnum: THandle; p : PnetResourceArr; Begin Execute := False; UserList.Clear; GetMem(Buf, 8192); Try FillChar(NetResource, SizeOf(NetResource), 0); NetResource.lpRemoteName := PChar(fServer); NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER; NetResource.dwUsage := RESOURCEUSAGE_CONTAINER; NetResource.dwScope := RESOURCETYPE_DISK;

1493

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum); If Res <> 0 then Exit; While true do Begin Count := -1; BufSize := 8192; Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize); If Res = ERROR_NO_MORE_ITEMS then Exit; If (Res <> 0) then Exit; p := PNetResourceArr(Buf); For i := 0 to Count - 1 do Begin { Ağdaki kullanıcı isimlerini Userlist listesine ekle} UserList.Add(p^.lpRemoteName + 2); Inc(p); End; End; Res := WNetCloseEnum(lphEnum); If Res <> 0 then Raise Exception(Res); Finally FreeMem(Buf); Execute := True; End; End; procedure Register; begin RegisterComponents('Sil', [TNetUsers]); end; end. //kullanımı { procedure TForm1.Button1Click(Sender: TObject); begin NETUSERS1.EXECUTE; listbox1.items.assign(netusers1.userlist) end;} Tanımlı ağ sürücüleri unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; ListBox1: TListBox; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end;

1494

var Form1: TForm1; implementation {$R *.DFM} function GetNetworkDriveMappings( sl : TStrings ) : integer; var i : integer; sNetPath : string; dwMaxNetPathLen : DWord; begin sl.Clear; dwMaxNetPathLen := MAX_PATH; SetLength( sNetPath, dwMaxNetPathLen ); for i := 0 to 25 do begin if( NO_ERROR = Windows.WNetGetConnection( PChar( '' + Chr( 65 + i ) + ':' ), PChar( sNetPath ), dwMaxNetPathLen ) )then begin sl.Add( Chr( 65 + i ) + ': ' + sNetPath ); end; end; Result := sl.Count; end;

procedure TForm1.Button1Click(Sender: TObject); var sl : TStrings; nMappingsCount, i : integer; begin sl := TStringList.Create; nMappingsCount := GetNetworkDriveMappings( sl ); for i := 0 to nMappingsCount-1 do begin MessageBox( 0, PChar( sl.Strings[ i ] ), 'Network sürücü tanımları', MB_OK ); end; listbox1.items.assign(sl); sl.Free; end; end.

SES VE GRAFİK İŞLEMLERİ 1495

Bu bölümde, delphi uygulamalarında yapılabilecek ses ve grafik işlemleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır. Farklı çizgiler TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); public DrawNow : Integer; end; var Form1: TForm1; procedure DrawPoint(x,y : Integer;lpData : LParam); stdcall; implementation {$R *.DFM} procedure DrawPoint(x,y : Integer;lpData : LParam); begin with TObject(lpData) as TForm1 do begin if DrawNow mod 4 = 0 then Canvas.Rectangle(x-2,y-2,x+3,y+3); Inc(DrawNow); end; end; procedure TForm1.FormCreate(Sender: TObject); begin DrawNow := 0; end; procedure TForm1.FormPaint(Sender: TObject); begin LineDDA(0,0,Width,Height,@DrawPoint,Integer(Self)); end;

StringGrid içerisinde BMP Şekil 5 : StringGrid bileşeni içerisinde BMP gösterimi bmpinsgrd.Pas dosyası; unit bmpinsgrd; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Grids; type TForm1 = class(TForm) StringGrid1: TStringGrid; procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Integer; Rect: TRect; State: TGridDrawState); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private Bmp : TBitmap; public

1496

{ Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} {$R BMPS.RES} procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer; Rect: TRect; State: TGridDrawState); var SRect,DRect : TRect; begin (Sender as TStringGrid).Canvas.FillRect(Rect); if (Sender as TStringGrid).Cells[Row,Col] = '@' then begin SRect := Classes.Rect(0,0,Bmp.Width,Bmp.Height); DRect.Left := Rect.Left+3; DRect.Top := Rect.Top+(Rect.Bottom-Rect.Top-Bmp.Height) div 2; DRect.Right := DRect.Left+SRect.Right+1; DRect.Bottom := DRect.Top+SRect.Bottom+1; (Sender as TStringGrid).Canvas.BrushCopy( DRect,Bmp,SRect,clOlive); end; end; procedure TForm1.FormCreate(Sender: TObject); begin Bmp := TBitmap.Create; Bmp.LoadFromResourceName(HInstance,'BMP'); StringGrid1.Cells[1,1] := '@'; StringGrid1.Cells[3,1] := '@'; end; procedure TForm1.FormDestroy(Sender: TObject); begin Bmp.Free; end; end. bmpinsgrd.DFM dosyası; object Form1: TForm1 Left = 200 Top = 108 Width = 310 Height = 258 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object StringGrid1: TStringGrid Left = 8 Top = 8

1497

Width = 289 Height = 217 TabOrder = 0 OnDrawCell = StringGrid1DrawCell ColWidths = ( 64 70 52 47 40) RowHeights = ( 24 79 24 66 12) end end Tonlamalı(Gradient) Form procedure TForm1.FormPaint(Sender: TObject); const N=100; var Y:Integer; Cl:TColor; begin for Y:=0 to N-1 do with Canvas do begin Cl:=RGB(0,0,Round(50+205*(Y/N))); Pen.Color:=Cl; Brush.Color:=cl; Rectangle(0,Round(ClientHeight*(Y/N)),ClientWidth,Round(Clien tHeight*((Y+1)/N))); end; end; procedure TForm1.FormResize(Sender: TObject); begin Invalidate; end;

EKRAN YAKALAMA Masaüstü görüntüsünün yakalanıp, form üzerine aktarılması; procedure Tform1.GrabScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; DeskTopRect := Rect(0,0,Screen.Width,Screen.Height); Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect); ReleaseDC(GetDeskTopWindow,DeskTopDC); end; veya;

1498

var width, height : word; desktop : HDC; begin width := Screen.Width; height := Screen.Height; desktop := GetWindowDC(GetDesktopWindow); Image1.Picture.Bitmap.Width := width; Image1.Picture.Bitmap.Height := height; BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0, width, height, desktop, 0, 0, SRCCOPY ); end;

BİR RESMİ, BMP FORMATINDAN JPEG FORMATINA ÇEVİRME var bmp : TImage; jpg : TJpegImage; begin bmp := TImage.Create(nil); jpg := TJpegImage.Create; bmp.picture.bitmap.LoadFromFile ( 'c:\picture.bmp' ); jpg.Assign( bmp.picture.bitmap ); jpg.SaveToFile ( 'c:\picture.jpg' ); jpg.Free; bmp.Free; end;

DUVAR KAĞIDI DEĞİŞTİRME Programınızın çalışması esnasında, arzu ettiğiniz bir duvar kağıdının kullanılmasını ister misiniz? İşte bunu halletmenin yolu… procedure TForm1.FormCreate(Sender: TObject); var Reg: TRegIniFile; begin Reg := TRegIniFile.Create('Control Panel'); Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp'); Reg.WriteString('desktop', 'TileWallpaper', '1'); Reg.Free; SystemParametersInfo(SPI_SETDESKWALLPAPER,0, nil, SPIF_SENDWININICHANGE); end;

SİSTEMİN KULLANABİLECEĞİ RENK SAYISININ BULUNMASI Garfik işlemleri yaparken, sistemde geçerli olan renk ayarına ihtiyaç olabilir. Aşağıdaki fonksiyon sistemin desteklemekte olduğu renk sayısını bulmaktadır. function GetColorsCount : integer; var h : hDC; begin Result := 0; try

1499

h := GetDC( 0 ); Result :=1 shl (GetDeviceCaps(h, PLANES) * GetDeviceCaps(h, BITSPIXEL)); finally ReleaseDC( 0, h ); end; end;

DBGRİD ALANLARININ RENKLENDİRİLMESİ TDBGrid bileşeninde gösterilen bilginin, daha kolay okunabilmesi, ve kullanıcının dikkatinin bazı özel durumlara çekilebilmesi için, hücreleri renklendirmek faydalı olabilir. procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var holdColor: TColor; begin holdColor := DBGrid1.Canvas.Brush.Color if Column.FieldName = 'EmpNo' then if (Column.Field.AsInteger mod 2 0) then begin DBGrid1.Canvas.Brush.Color := clGreen; DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State); DBGrid1.Canvas.Brush.Color := holdColor; end; end;

LİSTBOX BİLEŞENLERİNDE RENKLİ SATIRLAR Bir Tlistbox içerisinde bulunan satırların, belli şartlara göre farklı renklerde olması mümkündür. Aşağıdaki kod örneğinde bunun yapılışı gösterilmektedir. Dikkat edilmesi gereken en önemli husus, Listbox bileşeninin Style özelliği lbOwnerDrawFixed olmalıdır. //Style= lbOwnerDrawFixed olmalı… procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); begin With ( Control As TListBox ).Canvas Do Begin Case Index Of 0: Begin Font.Color := clBlue; Brush.Color := clYellow; End; 1: Begin Font.Color := clRed; Brush.Color := clLime; End; 2: Begin Font.Color := clGreen; Brush.Color := clFuchsia; End; End;

1500

FillRect(Rect); TextOut(Rect.Left, Rect.Top, ( Control As TListBox ).Items[Index]); End; end;

RENK PALETLERİNİN YARATILMASI VE KULLANIMI Delphi uygulamasında çizim yapılırken, gereken paletin yaratılması ve kullanılması nasıl olur? Eğer palet değiştirme yolu ile animasyon yapılacaksa, en az 256 renk modunda çalışılmalı ve, aşağıdaki kod örneğinde geçen bütün PC_NOCOLLAPSE değerleri PC_RESERVED olarak değiştirilmelidir. Palet yaratmanın yanı sıra, yapılması gereken diğer işlemler de şunlardır. · Formun GetPalette davranışı,yeni paleti döndürecek şekilde değiştirilmelidir. · Boyamaya başlamadan hemen önce, yeni palet seçilmelidir. OldPal := SelectPalette(Canvas.Handle, NewPalette, False); RealizePalette(Canvas.Handle); SelectPalette(Canvas.Handle, OldPal, False); · İşlem tamamlandıktan sonra palet yok edilmelidir. · Renk değeri almak için, RGB fonksiyonu yerine PaletteRGB fonksiyonu kullanılmalıdır. function CreateIdentityPalette(const aRGB; nColors : Integer) : HPALETTE; type QA = Array[0..255] of TRGBQUAD; var Palette : PLOGPALETTE; PalSize : Word; ScreenDC : HDC; I : Integer; nStaticColors : Integer; nUsableColors : Integer; begin PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256; GetMem(Palette, PalSize); try with Palette^ do begin palVersion := $0300; palNumEntries := 256; ScreenDC := GetDC(0); try if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC) then begin {$R-} for i := 0 to (nColors-1) do with palPalEntry[i], QA(aRGB)[I] do begin peRed := rgbRed; peGreen := rgbGreen; peBlue := rgbBlue; peFlags := PC_NOCOLLAPSE; end; for i := nColors to 255 do palPalEntry[i].peFlags := PC_NOCOLLAPSE; I := 255; with palPalEntry[i] do begin peRed := 255; peGreen := 255;

1501

peBlue := 255; peFlags := 0; end; with palPalEntry[0] do begin peRed := 0; peGreen := 0; peBlue := 0; peFlags := 0; end; {$R+} end else begin nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED); GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry); {$R-} nStaticColors := nStaticColors shr 1; for i:= 0 to (nStaticColors-1) do palPalEntry[i].peFlags := 0; nUsableColors := nColors - nStaticColors; for I := nStaticColors to (nUsableColors-1) do with palPalEntry[i], QA(aRGB)[i] do begin peRed := rgbRed; peGreen := rgbGreen; peBlue := rgbBlue; peFlags := PC_NOCOLLAPSE; end; for i := nUsableColors to (255-nStaticColors) do palPalEntry[i].peFlags := PC_NOCOLLAPSE; for i := (256 - nStaticColors) to 255 do palPalEntry[i].peFlags := 0; end; finally ReleaseDC(0, ScreenDC); end; end; Result := CreatePalette(Palette^); finally FreeMem(Palette, PalSize); end; end; procedure ClearSystemPalette; var Palette : PLOGPALETTE; PalSize : Word; ScreenDC : HDC; I : Word; const ScreenPal : HPALETTE = 0; begin PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255; GetMem(Palette, PalSize); try FillChar(Palette^, PalSize, 0);

1502

Palette^.palVersion := $0300; Palette^.palNumEntries := 256; {$R-} For I := 0 to 255 do With Palette^.palPalEntry[I] do peFlags := PC_NOCOLLAPSE; {$R+} ScreenDC := GetDC(0); try ScreenPal := CreatePalette(Palette^); if ScreenPal <> 0 then begin ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE); RealizePalette(ScreenDC); ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE); DeleteObject(ScreenPal); end; finally ReleaseDC(0, ScreenDC); end; finally FreeMem(Palette, PalSize); end; end;

MÜZİK CD Sİ ÇALINIRKEN, TRACK SAYISININ OKUNMASI Çalınmakta olan müzik CD'sinin, hangi Track da olduğunun anlaşılması için aşağıdaki kod örneği kullanılabilir. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, MPlayer,mmsystem; type TForm1 = class(TForm) Timer1: TTimer; Label1: TLabel; Label2: TLabel; MediaPlayer1: TMediaPlayer; procedure Timer1Timer(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation

1503

{$R *.DFM} procedure TForm1.Timer1Timer(Sender: TObject); var Trk, Min, Sec: Word; begin with MediaPlayer1 do begin Trk:= MCI_TMSF_TRACK(Position); Min:=MCI_TMSF_MINUTE(Position); Sec:=MCI_TMSF_SECOND(Position); Label1.Caption:=Format('%.2d',[Trk]); Label2.Caption:=Format('%.2d:%.2d',[Min,Sec]); end; end; end.

EKRAN ÇÖZÜNÜRLÜĞÜ DEĞİŞTİRME Bilgisayarda kullanılan ekran çözünürlüğü değerleri, normalde masa üstüne sağ fare tuşu ile tıklanarak açılan PopUp menüden, özellikler seçeneği kullanılarak yapılır. Bu işlemin kod ile yapılması gerekirse; Desteklenen ekran çözünürlükleri şu şekilde tespit edilebilir. unit unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Edit1: TEdit; ListBox1: TListBox; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var DC : THandle; Bits : Integer; HRes : Integer; VRes : Integer; DM : TDevMode; ModeNum : LongInt; Ok : Bool; begin DC := Canvas.Handle; Bits := GetDeviceCaps(DC, BITSPIXEL); HRes := GetDeviceCaps(DC, HORZRES); VRes := GetDeviceCaps(DC, VERTRES); Edit1.Text := Format('%d bits, %d x %d',[Bits, HRes, VRes]);

1504

ModeNum := 0; EnumDisplaySettings(Nil, ModeNum, DM); ListBox1.Items.Add(Format('%d bits, %d x %d', [DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight])); Ok := True; While Ok do Begin Inc(ModeNum); Ok := EnumDisplaySettings(Nil, ModeNum, DM); If Ok Then ListBox1.Items.Add(Format('%d bits, %d x %d', [DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight])); End; end; end. Çözünürlükleri listelemenin bir adım ilerisi, istenen çözünürlüğü seçip uygulamaktır. Aşağıdaki unit de tespit edilen çözünürlüklerden seçilen sisteme uygulanmaktadır. Ubit1Pas. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) ListBox1: TListBox; Button1: TButton; procedure FormCreate(Sender: TObject); procedure ListBox1Click(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var i : Integer; DevMode : TDevMode; begin i := 0; while EnumDisplaySettings(nil,i,Devmode) do begin with Devmode do ListBox1.Items.Add(Format('%dx%d %d Colors',[dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel])); Inc(i); end; end;

1505

procedure TForm1.ListBox1Click(Sender: TObject); begin Button1.Enabled := Listbox1.ItemIndex >= 0; end; procedure TForm1.Button1Click(Sender: TObject); var DevMode : TDevMode; begin EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode); ChangeDisplaySettings(DevMode,0); end; end. Unit1.dfm object Form1: TForm1 Left = 334 Top = 191 Width = 306 Height = 320 Caption = 'Ekran çözünürlükleri' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -14 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate PixelsPerInch = 120 TextHeight = 16 object ListBox1: TListBox Left = 20 Top = 10 Width = 267 Height = 218 ItemHeight = 16 TabOrder = 0 OnClick = ListBox1Click end object Button1: TButton Left = 110 Top = 241 Width = 92 Height = 32 Caption = 'Değiştir' Enabled = False TabOrder = 1 OnClick = Button1Click end end

BMP RESMİNİN PANOYA YAPIŞTIRILMSI VE PANODAN KOPYALAMASI Pano kullanımının bir başka örneğinin uygulandığı, kod örneğinde, BMP formatındaki bir resmin, panoya kopyalanması ve panodan alınması gösterilmektedir. Unit1.pas unit Unit1; interface

1506

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, clipbrd; type TForm1 = class(TForm) BaseKeyPanel: TPanel; Image2: TImage; Button1: TButton; Image1: TImage; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); Var BitMap : TBitmap; begin BitMap:=TBitMap.Create; BitMap.Height:=BaseKeyPanel.Height; BitMap.Width:=BaseKeyPanel.Width; BitBlt(BitMap.Canvas.Handle, 0 {Left}, 0{Top}, BaseKeyPanel.Width, image1.Height, GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY); Clipboard.Assign(BitMap); bitmap.free; End; procedure TForm1.Button2Click(Sender: TObject); Var BitMap : TBitmap; begin BitMap:=TBitMap.Create; bitmap.assign(clipboard); Image2.Canvas.Draw(0, 0, Bitmap); bitmap.free; end; end. Form1.dfm object Form1: TForm1 Left = 200 Top = 111 Width = 554 Height = 316 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText

1507

Font.Height = -13 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 120 TextHeight = 16 object Image2: TImage Left = 184 Top = 64 Width = 105 Height = 105 end object BaseKeyPanel: TPanel Left = 48 Top = 80 Width = 105 Height = 81 Caption = 'BaseKeyPanel' TabOrder = 0 object Image1: TImage Left = 1 Top = 1 Width = 103 Height = 79 Align = alClient end end object Button1: TButton Left = 48 Top = 32 Width = 75 Height = 25 Caption = 'Button1' TabOrder = 1 OnClick = Button1Click end object Button2: TButton Left = 192 Top = 32 Width = 75 Height = 25 Caption = 'Button2' TabOrder = 2 OnClick = Button2Click end end

BİR EXE DEKİ İKONUN ALINP BAŞKA BİR YERE ÇİZİLMESİ Herhangi bir program dosyasında kullanılan ikonun, alınmasını sağlayan bir fonksiyon. implementation USES ShellApi; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var IconIndex : word; h : hIcon;

1508

begin IconIndex := 0; h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex); DrawIcon(Form1.Canvas.Handle, 10, 10, h); end; end.

İKON RESMİNİN, BUTON ÜZERİNDE KULLANILMASI Not : image bileşenlerinin picture bilgileri, silinmiştir. object Form1: TForm1 Left = 200 Top = 108 Width = 278 Height = 372 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 96 TextHeight = 13 object SpeedButton1: TSpeedButton Left = 8 Top = 16 Width = 65 Height = 57 end object FileListBox1: TFileListBox Left = 80 Top = 16 Width = 169 Height = 313 ItemHeight = 13 TabOrder = 0 OnClick = FileListBox1Click end end unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, StdCtrls, FileCtrl; type TForm1 = class(TForm) FileListBox1: TFileListBox;

1509

SpeedButton1: TSpeedButton; procedure FileListBox1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses shellapi; {$R *.DFM} procedure TFORM1.FileListBox1Click(Sender: TObject); var MyIcon: TIcon; MyBitMap : TBitmap; strFileName:STRING; cStrFileName:PCHAR; begin MyIcon := TIcon.Create; MyBitMap := TBitmap.Create; try

{ get the file name and the icon associated with it} strFileName := FileListBox1.Items[FileListBox1.ItemIndex]; StrPCopy(cStrFileName, strFileName); MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0); { draw the icon onto the bitmap for the speed button } SpeedButton1.Glyph := MyBitMap; SpeedButton1.Glyph.Width := MyIcon.Width; SpeedButton1.Glyph.Height := MyIcon.Height; SpeedButton1.Glyph.Canvas.Draw(0,0, MyIcon);

finally MyIcon.Free; MyBitMap.Free; end; end; end. Grafik çizme işlemi Unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Image1: TImage; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure grapf; end;

1510

var Form1: TForm1; implementation {$R *.DFM} procedure tform1.grapf; var x,l: Integer; y,a: Double; begin Image1.Picture.Bitmap := TBitmap.Create; Image1.Picture.Bitmap.Width := Image1.Width; Image1.Picture.Bitmap.Height := Image1.Height; {These three lines could go in Form1.Create instead} l := Image1.Picture.Bitmap.Width; for x := 0 to l do begin a := (x/l) * 2 * Pi; {Convert position on X to angle between 0 & 2Pi} y := Sin(a); {Your function would go here} y := y * (Image1.Picture.Bitmap.Height / 2); {Scale Y so it fits} y := y * -1; {Invert Y, the screen top is 0 !} y := y + (Image1.Picture.Bitmap.Height / 2); {Add offset for middle 0} Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack; end; end; procedure TForm1.Button1Click(Sender: TObject); begin grapf end; end. Hareketli grafik çizimi Unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; PaintBox1: TPaintBox; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end;

1511

var Form1: TForm1; BitMap : TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.Width := 400; Bitmap.Height := 400; PaintBox1.Width := 200; PaintBox1.Height := 200; With Bitmap.Canvas do begin Pen.Color := clNavy; Ellipse(0,0,399,399); end; end; procedure TForm1.FormDestroy(Sender: TObject); begin Bitmap.Free; end; procedure TForm1.Button1Click(Sender: TObject); var Limit : Word; I : Word; PBBottom, PBRight : Word; begin PBBottom := PaintBox1.Height - 1; PBRight := PaintBox1.Width - 1; Limit := Bitmap.Width - PaintBox1.Width; For I := 0 to Limit do PaintBox1.Canvas.CopyRect(Rect(0,0,PBRight,PBBottom), Bitmap.Canvas, Rect(I,0,I+PBRight,PBBottom)); end; end. Unit1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 240 Height = 238 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object PaintBox1: TPaintBox

1512

Left = 64 Top = 24 Width = 105 Height = 105 end object Button1: TButton Left = 80 Top = 144 Width = 75 Height = 25 Caption = 'Button1' TabOrder = 0 OnClick = Button1Click end end

PANOYA RESİM KOPYALAMA bütün formu panoya kopyalar procedure TForm1.Button2Click(Sender: TObject); //uses clipbrd Var Image : TImage; BitMap : TBitmap; Begin Image:=TImage.Create(Self); BitMap:=TBitMap.Create; BitMap.Width:=ClientWidth; BitMap.Height:=ClientHeight; BitBlt(BitMap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight, GetDC(Handle), 0, 0, SRCCOPY); Image.Picture.Graphic:=BitMap; Clipboard.Assign(Image.Picture); BitMap.Free; Image.Free end;

BİR RESMİN ŞEFFAF OLARAK BAŞKA BİR RESİM ÜZERİNE YAPIŞTIRILMASI Unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Image1: TImage; ColorDialog1: TColorDialog; Panel1: TPanel; Button2: TButton;

1513

Image2: TImage; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor); end; var Form1: TForm1; bmp:tbitmap; clr:tcolor; implementation {$R *.DFM} procedure tform1.DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor); var bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap; oldcol: Longint; begin try bmpAND := TBitmap.Create; bmpAND.Width := s.Width; bmpAND.Height := s.Height; bmpAND.Monochrome := True; oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol)); BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); SetBkColor(s.Canvas.Handle, oldcol); bmpINVAND := TBitmap.Create; bmpINVAND.Width := s.Width; bmpINVAND.Height := s.Height; bmpINVAND.Monochrome := True; BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY); bmpXOR := TBitmap.Create; bmpXOR.Width := s.Width; bmpXOR.Height := s.Height; BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND); bmpTarget := TBitmap.Create; bmpTarget.Width := s.Width; bmpTarget.Height := s.Height; BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height,

1514

bmpXOR.Canvas.Handle, 0,0, SRCINVERT); BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY); finally bmpXOR.Free; bmpAND.Free; bmpINVAND.Free; bmpTarget.Free; end;{End of TRY section} end; procedure TForm1.Button1Click(Sender: TObject); begin DrawTransparent(image1.Canvas, 1,1, bmp, clr); image1.Invalidate; image1.repaint; end; procedure TForm1.FormCreate(Sender: TObject); begin bmp:=tbitmap.create; bmp.width:=image1.width; bmp.height:=image1.height; bmp.assign(image2.picture); // clr:=tcolor.create;; clr:=clgreen; panel1.color:=clr; end; procedure TForm1.FormDestroy(Sender: TObject); begin bmp.free; end; procedure TForm1.Button2Click(Sender: TObject); begin if colordialog1.execute then clr:=colordialog1.Color; panel1.color:=clr; end; end. Unit1.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 617 Height = 302 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Image1: TImage Left = 264 Top = 8

1515

Width = 329 Height = 201 Stretch = True end object Image2: TImage Left = 8 Top = 8 Width = 249 Height = 201 Stretch = True end object Button1: TButton Left = 144 Top = 224 Width = 75 Height = 25 Caption = 'Button1' TabOrder = 0 OnClick = Button1Click end object Panel1: TPanel Left = 304 Top = 216 Width = 113 Height = 41 Caption = 'Panel1' TabOrder = 1 object Button2: TButton Left = 22 Top = 8 Width = 75 Height = 25 Caption = 'Button2' TabOrder = 0 OnClick = Button2Click end end object ColorDialog1: TColorDialog Ctl3D = True Left = 112 Top = 352 end end

PALET DEĞİŞTİRME Palet.pas unit palet; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtDlgs; type TForm1 = class(TForm) Button1: TButton; OpenPictureDialog1: TOpenPictureDialog;

1516

SavePictureDialog1: TSavePictureDialog; Button2: TButton; Button3: TButton; procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure ScrambleBitmap; end; var Form1: TForm1; bitmap:tbitmap; pal: PLogPalette; implementation {$R *.DFM} procedure Tform1.ScrambleBitmap; var hpal: HPALETTE; i: Integer; begin {$R-} pal := nil; try GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255); pal.palVersion := $300; pal.palNumEntries := 256; for i := 0 to 255 do begin pal.palPalEntry[i].peRed := Random(255); pal.palPalEntry[i].peGreen :=Random(255); pal.palPalEntry[i].peBlue := Random(255); end; hpal := CreatePalette(pal^); if hpal <> 0 then Bitmap.Palette := hpal; finally FreeMem(pal); end; {$R+} end; procedure TForm1.FormCreate(Sender: TObject); begin bitmap:=tbitmap.create; bitmap.loadfromfile('c:\program files\borland\delphi 3\images\splash\256color\finance.bmp'); end; procedure TForm1.FormPaint(Sender: TObject); var

1517

x, y: Integer; begin y := 0; while y < Height do begin x := 0; while x < Width do begin Canvas.Draw(x, y, Bitmap); x := x + Bitmap.Width; end; y := y + Bitmap.Height; end; end; procedure TForm1.Button1Click(Sender: TObject); begin ScrambleBitmap; Invalidate; end; procedure TForm1.Button2Click(Sender: TObject); begin if openpicturedialog1.execute then bitmap.loadfromfile(openpicturedialog1.filename); end; procedure TForm1.Button3Click(Sender: TObject); begin if savepicturedialog1.execute then begin bitmap.loadfromfile(savepicturedialog1.filename); FormPaint(sender); invalidate; end; end; end. Palet.dfm object Form1: TForm1 Left = 200 Top = 108 Width = 696 Height = 480 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnCreate = FormCreate OnPaint = FormPaint PixelsPerInch = 96 TextHeight = 13 object Button1: TButton Left = 208 Top = 416 Width = 75 Height = 25 Caption = 'Palet değiştir' TabOrder = 0

1518

OnClick = Button1Click end object Button2: TButton Left = 24 Top = 416 Width = 75 Height = 25 Caption = 'Resim Aç' TabOrder = 1 OnClick = Button2Click end object Button3: TButton Left = 112 Top = 416 Width = 81 Height = 25 Caption = 'Resim Kaydet' TabOrder = 2 OnClick = Button3Click end object OpenPictureDialog1: TOpenPictureDialog Filter = 'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' + '.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' + '|Metafiles (*.wmf)|*.wmf' Left = 592 Top = 392 end object SavePictureDialog1: TSavePictureDialog Filter = 'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' + '.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' + '|Metafiles (*.wmf)|*.wmf' Left = 512 Top = 392 end end

PANODAKİ METNİN DİSKTEKİ BİR DOSYAYA KAYDEDİLMESİ unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Clipbrd, StdCtrls ; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject);

1519

private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function SaveClipboardTextDataToFile( sFileTo : string ) : boolean; var ps1, ps2 : PChar; dwLen : DWord; tf : TextFile; hData : THandle; begin Result := False; with Clipboard do begin try Open; if( HasFormat( CF_TEXT ) ) then begin hData := GetClipboardData( CF_TEXT ); ps1 := GlobalLock( hData ); dwLen := GlobalSize( hData ); ps2 := StrAlloc( 1 + dwLen ); StrLCopy( ps2, ps1, dwLen ); GlobalUnlock( hData ); AssignFile( tf, sFileTo ); ReWrite( tf ); Write( tf, ps2 ); CloseFile( tf ); StrDispose( ps2 ); Result := True; end; finally Close; end; end; end; procedure TForm1.Button1Click(Sender: TObject); begin SaveClipboardTextDataToFile('c:\sil\clip.asc'); end;

1520

end.

FORM VE PENCERE İŞLEMLERİ Bu bölümde, Delphi uygulamaları içerisinde gerekebilecek form ve pencere işlemleri ile ilgili Püf noktaları ve kod örnekleri yer almaktadır.

Masa üstündeki ikonların saklanması Aşağıdaki program çalıştırıldığında, görev çubuğu üzerindeki uyarı bölümünde bir ikon olarak görünür. Bu ikon üzerinde tıklandığında desktop üzerindeki ikonlar saklanır, bir kez daha basıldığında ise geri gelir. program DeskPop; uses Windows, Messages, ShellAPI, sysutils; {$R *.RES} const AppName = 'DeskTop Sakla'; var x: integer; tid: TNotifyIconData; WndClass: array[0..50] of char; procedure Panic (szMessage: PChar); begin if szMessage <> Nil then MessageBox (0, szMessage, AppName, mb_ok); Halt (0); end; procedure HandleCommand (Wnd: hWnd; Cmd: Word); begin case Cmd of Ord ('A'): MessageBox (0, 'Merhaba', AppName, mb_ok); Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0); end; end; function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt; stdcall; var TrayHandle: THandle; dc: hDC; i: Integer; pm: HMenu; pt: TPoint; begin DummyWindowProc := 0; StrPCopy(@WndClass[0], 'Progman'); TrayHandle := FindWindow(@WndClass[0], nil); case Msg of wm_Create: begin tid.cbSize := sizeof (tid); tid.Wnd := Wnd; tid.uID := 1; tid.uFlags := nif_Message or nif_Icon or nif_Tip;

1521

tid.uCallBackMessage := wm_User; tid.hIcon := LoadIcon (hInstance, 'MAINICON'); lstrcpy (tid.szTip,'Desktop is on'); Shell_NotifyIcon (nim_Add, @tid); end; wm_Destroy: begin Shell_NotifyIcon (nim_Delete, @tid); PostQuitMessage (0); ShowWindow(TrayHandle, SW_RESTORE); end; wm_Command: begin HandleCommand (Wnd, LoWord (wParam)); Exit; end; wm_User: // Had a tray notification - see what to do if (lParam = wm_LButtonDown) then begin if x = 0 then begin ShowWindow(TrayHandle, SW_HIDE); //tid.hIcon := LoadIcon (hInstance, 'offICON'); lstrcpy (tid.szTip,'Desktop Kapalı'); Shell_NotifyIcon (NIM_MODIFY, @tid); x:=1 end else begin ShowWindow(TrayHandle, SW_RESTORE); //tid.hIcon := LoadIcon (hInstance, 'ONICON'); lstrcpy (tid.szTip,'Desktop Açık'); Shell_NotifyIcon (NIM_MODIFY, @tid); x:= 0; end; end else if (lParam = wm_RButtonDown) then begin GetCursorPos (pt); pm := CreatePopupMenu; AppendMenu (pm, 0, Ord ('A'), 'Hakkında...'); AppendMenu (pm, mf_Separator, 0, Nil); AppendMenu (pm, 0, Ord ('E'), 'Kapat'); SetForegroundWindow (Wnd); dc := GetDC (0); if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign, pt.x,GetDeviceCaps(dc,HORZRES){pt.y}, 0, Wnd, Nil) then SetForegroundWindow (Wnd); DestroyMenu (pm) end; end; DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam); end; procedure WinMain; var Wnd: hWnd; Msg: TMsg; cls: TWndClass; begin { Previous instance running ? If so, exit }

1522

if FindWindow (AppName, Nil) <> 0 then exit; //Panic (AppName + ' is already running.'); { window Sınıfını kaydettir } FillChar (cls, sizeof (cls), 0); cls.lpfnWndProc := @DummyWindowProc; cls.hInstance := hInstance; cls.lpszClassName := AppName; RegisterClass (cls); { Boş pencereyi yarat } Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow, cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault, 0, 0, hInstance, Nil); x:= 0; if Wnd <> 0 then begin ShowWindow (Wnd, sw_Hide); while GetMessage (Msg, 0, 0, 0) do begin TranslateMessage (Msg); DispatchMessage (Msg); end; end; end; begin WinMain; end.

BÜTÜN AÇIK PENCERELERİN LİSTELENMESİ Sistemde açık olan bütün pencerelerin listelenmesi için, EnumWindows fonksiyonu kullanılır. function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean; Export; {$ifdef Win32} StdCall; {$endif} var Buffer : Array[0..99] of char; begin GetWindowText(Wnd,Buffer,100); if StrLen(Buffer) <> 0 then Form.ListBox1.Items.Add(StrPas(Buffer)); Result := True; end; procedure TForm1.Button1Click(Sender: TObject); begin EnumWindows(@EnumWindowsProc,LongInt(Self)); end;

FARKLI BİR PENCERE Standart Windows pencereleri, dikdörtgen veya kare şeklindedir. Değişik şekilli bir pencere yaratmak için; var hR : THandle; begin hR := CreateEllipticRgn(0,0,100,200); SetWindowRgn(Handle,hR,True);

1523

end; Farklı pencereye bir başka örnek; unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Buttons; type TForm1 = class(TForm) SpeedButton1: TSpeedButton; Image1: TImage; procedure FormCreate(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); private { Private declarations } procedure CreateParams(var Params: TCreateParams); override; public { Public declarations } end; var Form1: TForm1; implementation procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited createparams(params); params.style:=params.style or ws_popup xor ws_dlgframe; end; {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var formrgn:hrgn; begin form1.brush.style:=bsclear; GetWindowRgn(form1.Handle, formRgn); DeleteObject(formRgn); formrgn:= CreateroundRectRgn(0, 0,form1.width,form1.height,form1.width,form1.height); SetWindowRgn(form1.Handle, formrgn, TRUE); end; procedure TForm1.SpeedButton1Click(Sender: TObject); begin form1.close; end; end.

ÜZERİNE BIRAKILAN DOSYALARA DUYARLI FORM unit dragfile; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm2 = class(TForm) procedure FormCreate(Sender: TObject);

1524

private { Private declarations } public { Public declarations } procedure AcceptFiles( var msg : TMessage ); message WM_DROPFILES; end; var Form2: TForm2; implementation uses ShellAPI; {$R *.DFM} procedure TForm2.AcceptFiles( var msg : TMessage ); const cnMaxFileNameLen = 255; var i, nCount : integer; acFileName : array [0..cnMaxFileNameLen] of char; begin nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen ); for i := 0 to nCount-1 do begin DragQueryFile( msg.WParam, i, acFileName, cnMaxFileNameLen ); MessageBox( Handle, acFileName, '', MB_OK ); end; DragFinish( msg.WParam ); end; procedure TForm2.FormCreate(Sender: TObject); begin DragAcceptFiles( Handle, True ); end; end.

FORM BAŞLIĞININ SAKLANMASI procedure TForm1.Createparams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do Style := (Style or WS_POPUP) and (not WS_DLGFRAME); end;

STANDART DIŞI FORMLAR 1525

Windows'un standart formlarından sıkılanlar için, farklı bir form. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Panel1: TPanel; Panel2: TPanel; Panel3: TPanel; Panel4: TPanel; Panel5: TPanel; procedure FormResize(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormResize(Sender: TObject); var WindowRgn, HoleRgn : HRgn; begin WindowRgn := 0; GetWindowRgn(Handle, WindowRgn); DeleteObject(WindowRgn); WindowRgn := CreateRectRgn(0,0,Width,Height); HoleRgn := CreateRectRgn(Panel3.Width + 6, Panel1.Height + 25, Width - (Panel4.Width + 6), Height - (Panel2.Height + 6)); CombineRgn(WindowRgn, WindowRgn, HoleRgn, RGN_DIFF); SetWindowRgn(Handle, WindowRgn, TRUE); DeleteObject(HoleRgn); end; end. object Form1: TForm1 Left = 216 Top = 178 AutoScroll = False Caption = 'Form1' ClientHeight = 453 ClientWidth = 688

1526

Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OnResize = FormResize PixelsPerInch = 96 TextHeight = 13 object Button1: TButton Left = 512 Top = 352 Width = 75 Height = 25 Caption = 'Button1' TabOrder = 0 end object Panel1: TPanel Left = 0 Top = 0 Width = 688 Height = 5 Align = alTop BevelOuter = bvNone Color = clRed TabOrder = 1 end object Panel2: TPanel Left = 0 Top = 443 Width = 688 Height = 10 Align = alBottom BevelOuter = bvNone Color = clRed TabOrder = 2 end object Panel3: TPanel Left = 0 Top = 5 Width = 10 Height = 438 Align = alLeft BevelOuter = bvNone Color = clRed TabOrder = 3 end object Panel4: TPanel Left = 678 Top = 5 Width = 10 Height = 438 Align = alRight BevelOuter = bvNone Color = clRed TabOrder = 4 end object Panel5: TPanel Left = 10 Top = 5 Width = 668 Height = 438 Align = alClient

1527

BevelOuter = bvLowered Caption = 'Panel5' TabOrder = 5 end end

FORM POZİSYONU Unit1.pas unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) private { Private declarations } public { Public declarations } Procedure WMMove(Var Message : TWMMove); message WM_Move; end; var Form1: TForm1; implementation {$R *.DFM} Procedure TForm1.WMMove(Var Message : TWMMove); begin Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message. YPos); end; end.

EKRAN ÇÖZÜNÜRLÜĞÜ Tasarım ortamın gayet düzgün görünen bir formun başka bir bilgisayarda bozuk görünmesi oldukça can sıkıcıdır. Bu olayın sebebi faklı ekran çözünürlükleri ve yazı tipi ayarıdır. Bunu önlemek için uygulama içerisinde bazı kontroller yapmak gerekir.Aşağıdaki kod örneğinde form ve üzerindeki kontrollerin sistemdeki ayarlara göre yeniden ölçeklenmesi gösterilmektedir. implementation const {formlarımızın 800x600 ölçülerinde olmasını istiyorsak…} ScreenWidth: LongInt = 800; ScreenHeight: LongInt = 600; {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin scaled := true; if (screen.width <> ScreenWidth) then begin height:=longint(height)*longint(screen.height)DIV

1528

ScreenHeight; width := longint(width) * longint(screen.width) DIV ScreenWidth; scaleBy(screen.width, ScreenWidth); end; end; Bu işlemden sonra kontrollerdeki yazı tiplerinin de ölçeklenmesi gerekecektir. Bu işlem bir döngü içerisinde kolaylıkla yapılır. Fakat bu esnada ilgili bileşenin FONT özelliği bulunduğundan emin olunmalıdır. Bu kontrol için RTTI (Run Time Type Information) kullanılabilir. USES typinfo; var i: integer; begin for i := componentCount - 1 downto 0 do with components[i] do begin if GetPropInfo(ClassInfo, 'font') <> nil then font.size := (NewFormWidth DIV OldFormWidth) * font.size; end; end;

FORM BAŞLIK ALANI ÜZERİNDE SAAT GÖSTERİLMESİ Formun Caption özelliğine dokunmadan, başlık alanı üzerinde saat bilgisi gösterimi şu şekilde olur. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TForm1 = class(TForm) Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure Timer1Timer(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; dc:hdc; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin dc:=getwindowdc(handle); end;

1529

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin releasedc(handle,dc); end; procedure TForm1.Timer1Timer(Sender: TObject); var thetime: array[0..80] of char; begin strpcopy(Thetime,timetostr(time)); canvas.font.color:=clred; textout(dc,width div 2,5,thetime,strlen(thetime)); end; end.

FORM BAŞLIĞININ GİZLENMESİ Form başlıkları, çalışma esnasında gizlenip tekrar gösterilebilir. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure sakla; procedure goster; end; var Form1: TForm1; implementation {$R *.DFM} procedure tform1.sakla; var save:longint; begin if borderstyle=bsnone then exit; save:=getwindowlong(handle,gwl_style); if (save and ws_caption)=ws_caption then begin case borderstyle of

1530

bssingle,bssizeable: setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ws_border); bsdialog:setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ds_modalframe or ws_dlgframe); end; height:=height-getsystemmetrics(sm_cycaption); refresh; end; end; procedure tform1.goster; var save:longint; begin if borderstyle=bsnone then exit; save:=getwindowlong(handle,gwl_style); if (save and ws_caption)<>ws_caption then begin case borderstyle of bssingle, bssizeable: setwindowlong(handle,gwl_style,save or ws_caption or ws_border); bsdialog:setwindowlong(handle,gwl_style,save or ws_caption or ds_modalframe or ws_dlgframe); end; height:=height+getsystemmetrics(sm_cycaption); refresh; end; end; procedure TForm1.Button1Click(Sender: TObject); begin sakla end; procedure TForm1.Button2Click(Sender: TObject); begin goster end; end.

FORMUN BAŞLIK ALANINA BUTON YERLEŞTİRME Kullandığınız formların başlık alanına buton ekleyip, bu butona bazı görevler yükleyebilirsiniz. unit CapBtn; interface uses Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormResize(Sender: TObject); private CaptionBtn : TRect; procedure DrawCaptButton;

1531

procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint; procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE; procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT; procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST; procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN; public { Public declarations } end; var Form1: TForm1; implementation const htCaptionBtn = htSizeLast + 1; {$R *.DFM} procedure TForm1.DrawCaptButton; var xFrame, yFrame, xSize, ySize : Integer; R : TRect; begin //Form eni ve boyu xFrame := GetSystemMetrics(SM_CXFRAME); yFrame := GetSystemMetrics(SM_CYFRAME); //Başlık butonlarının eni ve boyu xSize := GetSystemMetrics(SM_CXSIZE); ySize := GetSystemMetrics(SM_CYSIZE); //Yeni butonun yeri CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2, yFrame + 2, xSize - 2, ySize - 4); //Forma ait DC 'yi kullanarak, //üzerine çizim yapılacak tuvali bul Canvas.Handle := GetWindowDC(Self.Handle); Canvas.Font.Name := 'Symbol'; Canvas.Font.Color := clBlue; Canvas.Font.Style := [fsBold]; Canvas.Pen.Color := clYellow; Canvas.Brush.Color := clBtnFace; try DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False); R := Bounds(Width - xFrame - 4 * xSize + 2, yFrame + 3, xSize - 6, ySize - 7); with CaptionBtn do Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W'); finally ReleaseDC(Self.Handle, Canvas.Handle);

1532

Canvas.Handle := 0; end; end; procedure TForm1.WMNCPaint(var Msg : TWMNCPaint); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCActivate(var Msg : TWMNCActivate); begin inherited; DrawCaptButton; end; procedure TForm1.WMSetText(var Msg : TWMSetText); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest); begin inherited; with Msg do if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then Result := htCaptionBtn; end; procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown); begin inherited; if (Msg.HitTest = htCaptionBtn) then ShowMessage('Hoops... yeni butona bastın'); end; procedure TForm1.FormResize(Sender: TObject); begin //Başlık çubuğunun yeniden çizilmesini sağla Perform(WM_NCACTIVATE, Word(Active), 0); end; end.

AÇILIR-KAPANIR FORM İşyeri kepengine benzer bir şekilde açılıp kapanabilen bir form yaratmak için kullanılabilecek kod örneği aşağıdadır. Açılma ve kapanma komutu, bu örnekte başlık alanı üzerinde sağ fare tuşuna basılarak verilmektedir. unit KepengForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, Printers, Buttons, ShellAPI;

1533

type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } FOldHeight : Integer; procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin FOldHeight := ClientHeight; end; procedure TForm1.WMNCRButtonDown(var Msg : TWMNCRButtonDown); var I : Integer; begin if (Msg.HitTest = HTCAPTION) then if (ClientHeight = 0) then begin I := 0; while (I < FOldHeight) do begin I := I + 40; if (I > FOldHeight) then I := FOldHeight; ClientHeight := I; Application.ProcessMessages; end; end else begin FOldHeight := ClientHeight; I := ClientHeight; //kapanma efekti için, I değerini doğrudan "0" a eşitlemek //yerine kademeli olarak azaltabilirsiniz. I := 0; ClientHeight := I; Application.ProcessMessages; end; end; end.

PENCERENİN TAŞINMASI Windows pencereleri, ekran üzerinde başlıklarından tutularak taşınırlar. Pencere alanından tutularak da taşınabilmeleri için, WM_NCHITTEST mesajının yakalanıp, yordamının değiştirilmesi gerekir.

1534

type TForm1 = class(TForm) public procedure WMNCHitTest(var M: TWMNCHitTest); message WM_NCHitTest; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCHitTest(var M: TWMNCHitTest); begin inherited; if M.Result = htClient then M.Result := htCaption; end; 5. Disk ve Dosya işlemleri Sürücü listesi procedure TForm1.Button2Click(Sender: TObject); var drives : dword; i : integer; begin drives := GetLogicalDrives; for i := 0 to 25 do //ingilizce alfabede 25 harf var if ( drives and ( 1 shl i )) > 0 then Listbox1.Items.Add( Chr( i + 65 )); end; veya procedure TForm1.Button1Click(Sender: TObject); var buffer : array[0..500] of char; temp : PChar; typ : integer; begin GetLogicalDriveStrings( sizeof( buffer ), buffer ); temp := buffer; while temp[0] <> #0 do begin typ := GetDriveType( temp ); with ListBox1.Items do case typ of DRIVE_REMOVABLE : Add( temp + ' removable' ); DRIVE_FIXED : Add( temp + ' Sabit Disk' ); DRIVE_REMOTE : Add( temp + ' Ağ üzerinde' ); DRIVE_CDROM : Add( temp + ' CD-ROM' ); DRIVE_RAMDISK : Add( temp + ' RAM-disk' ); else Add( temp + ' Bilinmiyor' ); end; temp := StrEnd( temp ) + 1; end; end;

DİSKET SÜRÜCÜSÜNDE DİSKET TAKILI MI ? {$I-} ChDir('a:\'); {$I+}

1535

if IOResult <> 0 then ShowMessage( 'A sürücüsünde Disket yok' ); Veya; function DiskInDrive(const Drive: char): Boolean; var DrvNum: byte; EMode: Word; begin result := false; DrvNum := ord(Drive); if DrvNum >= ord('a') then dec(DrvNum,$20); EMode := SetErrorMode(SEM_FAILCRITICALERRORS); try if DiskSize(DrvNum-$40) <> -1 then result := true else messagebeep(0); finally SetErrorMode(EMode); end; end;

ÇALIŞAN UYGULAMANIN BULUNDUĞU DİZİN procedure TForm1.Button1Click(Sender: TObject); var szFileName : array[0..99] of char; szModuleName : array[0..19] of char; iSize : integer; begin iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName, SizeOf(szFileName)); if iSize > 0 then ShowMessage('Tam dizin : ' + StrPas(szFileName)) else ShowMessage('Bulunamadı'); end;

WİNDOWS'UN STANDART "BROWSEFOLDER" DİYALOG PENCERESİNİN KULLANILMASI unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,ShlObj,ActiveX; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end;

1536

var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var BI:TBrowseInfo; Buf:PChar; Dir,Root:PItemIDList; Alloc:IMalloc; begin SHGetMalloc(Alloc); Buf:=Alloc.Alloc(Max_Path); // Bu satır aranacak dizinleri sınırlar. SHGetSpecialFolderLocation(Handle,CSIDL_PROGRAMS,Root); with BI do begin hwndOwner:=Form1.Handle; pidlRoot:=Root; // Eğer Nil olursa, bütün dizinler // görüntülenir. pszDisplayName:=Buf; lpszTitle:=' İstediğiniz dizini seçiniz'; ulFlags:=0; lpfn:=nil; end; try Dir:=SHBrowseForFolder(BI); if Dir<>Nil then begin SHGetPathFromIDList(Dir,Buf); // İstenen dizinin tam adı ShowMessage(Buf); Alloc.Free(Dir); end; finally Alloc.Free(Root); Alloc.Free(Buf); end; end; end.

SEÇİLEBİLECEK, DİĞER ÖZEL KLASÖR TİPLERİ CSIDL_BITBUCKET Geri dönüşüm kutusu CSIDL_CONTROLS Kontrol panel klasörleri CSIDL_DESKTOP Masaüstü klasörleri CSIDL_DESKTOPDIRECTORY Masaüstü nesnelerini barındıran klasör CSIDL_DRIVES Bilgisayarım klasörü CSIDL_FONTS Font klasörü CSIDL_NETHOOD Ağ komşuluğu klasörü

1537

CSIDL_NETWORK Yukarıdakinin bir başka versiyonu CSIDL_PERSONAL Şahsi klasör CSIDL_PRINTERS Yazıcılar klasörü CSIDL_PROGRAMS Başlat menüsündeki programlar klasörü CSIDL_RECENT Son kullanılan dökümanlar klasörü CSIDL_SENDTO Gönder (SendTo) klasörü CSIDL_STARTMENU Başlat menüsünün tümü CSIDL_STARTUP Otomatik başlat klasörü CSIDL_TEMPLATES

DÖKÜMAN ŞABLONLARI Bir dizindeki dosyaların ve alt dizinlerin tümünün silinmesi procedure removeTree (DirName: string); var FileSearch: SearchRec; begin chDir (DirName); FindFirst ('*.*', Directory, FileSearch); while (DosError = 0) do begin if (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND ( (FileSearch.attr AND Directory) <> 0) then begin if DirName[length(DirName)] = '\' then removeTree (DirName+FileSearch.Name) else removeTree (DirName+'\'+FileSearch.Name); ChDir (DirName); end; FindNext (FileSearch) end; FindFirst ('*.*', AnyFile, FileSearch); while (DosError = 0) do begin if (FileSearch.name <> '.') AND (FileSearch.name <> '..') then Remove (workdir); end; FindNext (FileSearch) end; rmDir (DirName) end;

DOSYA KOPYALAMA Aşağıdaki kodu içeren unitin Uses listesine "LZExpand"eklenmelidir. var

1538

SourceHandle, DestHandle: Integer; SName,DName: String; begin SourceHandle := FileOpen(SName,0); DestHandle := FileCreate(DName); LZCopy(SourceHandle,DestHandle); FileClose(SourceHandle); FileClose(DestHandle); End; BAŞKA BİR KOPYALAMA YÖNTEMİ; function FileCopy(source,dest: String): Boolean; var fSrc,fDst,len: Integer; size: Longint; buffer: packed array [0..2047] of Byte; begin Result := False; if source <> dest then begin fSrc := FileOpen(source,fmOpenRead); if fSrc >= 0 then begin size := FileSeek(fSrc,0,2); FileSeek(fSrc,0,0); fDst := FileCreate(dest); if fDst >= 0 then begin while size > 0 do begin len := FileRead(fSrc,buffer,sizeof(buffer)); FileWrite(fDst,buffer,len); size := size - len; end; FileSetDate(fDst,FileGetDate(fSrc)); FileClose(fDst); FileSetAttr(dest,FileGetAttr(source)); Result := True; end; FileClose(fSrc); end; end; end;

İKİLİ DOSYADAN OKUMA var f: File; c: Char; begin AssignFile(f, 'Dosyaadi.bin'); Reset(f, 1); BlockRead(f, c, sizeof(c)); CloseFile(f); end; {Yukarıdaki kod her seferinde bir karakter okur. Disk erişimi yavaş bir işlemdir. Bu nedenle bir mecburiyet yoksa, her seferinde 1 karakter yerine daha fazlası okunmalıdır.}

BİR DOSYANIN SALT OKUNUR OLARAK AÇILMASI Assignfile satırından sonra dosya açma modu belirtilmelidir.

1539

AssignFile(F, FileName); FileMode := 0; ( Salt okunur } Reset(F); CloseFile(F);

SATIR SONU KARAKTERİNİN ASCİİ KODU NEDİR? Control-Z, veya 26 numaralı ASCII karakteri

DİSK SERİ NUMARASI VE ETİKETİNİN OKUNMASI unit diskinfo; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type diskinfostructure=record DiskEtiketi:string; DiskSeriNo :string; end; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; f:system.text; blg:diskinfostructure; implementation {$R *.DFM} Function WinExecute32( FileName : String; Visibility : integer):integer; var zAppName:array[0..512] of char; zCurDir:array[0..255] of char; WorkDir:String; StartupInfo:TStartupInfo; ProcessInfo:TProcessInformation; begin StrPCopy(zAppName,FileName); GetDir(0,WorkDir); StrPCopy(zCurDir,WorkDir); FillChar(StartupInfo,Sizeof(StartupInfo),#0);

1540

StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := Visibility; if not CreateProcess(nil, zAppName, nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then Result := -1 else begin WaitforSingleObject(ProcessInfo.hProcess,INFINITE); GetExitCodeProcess(ProcessInfo.hProcess,Result); end; end; function disk(dsk:char;var bilgi:diskinfostructure):boolean; var row:array[1..50] of string; c,i:integer; vollabel,serial:string; begin assignfile(f,'c:\dir.bat'); rewrite(f); writeln(f,'dir '+dsk+':\*.zzzz> c:\dir.txt'); closefile(f); winexecute32('c:\dir.bat',0); assignfile(f,'c:\dir.txt'); reset(f); i:=1; while not eof(f) do begin readln(f,row[i]); inc(i,1); end; closefile(f); if pos('is',row[2])>0 then bilgi.DiskEtiketi:=copy(row[2],pos('is',row[2])+2,11) else bilgi.DiskEtiketi:='Disk etiketi yok'; bilgi.DiskSeriNo:= copy(row[3],pos('is',row[3])+2,15); deletefile('c:\dir.bat'); deletefile('c:\dir.txt'); result:=true; end; procedure TForm1.Button1Click(Sender: TObject); begin disk('c',blg); showmessage(blg.DiskEtiketi); showmessage(blg.DiskSeriNo); end; end. DİSK SERİ NUMARASINA ERİŞİMİN BAŞKA BİR YOLU..

1541

unit diskvol; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function GetDiskVolSerialID( cDriveName : char ) : DWord; var dwTemp1, dwTemp2 : DWord; begin GetVolumeInformation( PChar( cDriveName + ':\' ), Nil, 0, @Result, dwTemp2, dwTemp2, Nil, 0 ); end; procedure TForm1.Button1Click(Sender: TObject); begin showmessage(inttostr(GetDiskVolSerialID('C'))) end; end. DİSK BİLGİLERİNİ ELDE ETMENİN BİR DİĞER YOLU İSE; type VolInf=record Etiket:string; serino:string; tip:string; disk_Tip:string; bos_yer:string; Top_Yer:string; end;

1542

function VolInfo(var diskinfos:volinf;disk:char):boolean; type TDrvType = (dtNotDetermined, dtNonExistent, dtRemoveable, dtFixed, dtRemote, dtCDROM, dtRamDrive); var //Disk bigisi kayıtı nVNameSer : PDWORD; drv : String; pVolName : PChar; FSSysFlags, maxCmpLen : DWord; I : Integer; pFSBuf : PChar; dType : TDrvType; SectPerCls, BytesPerCls, FreeCls, TotCls : DWord; begin //Değişkenleri sıfırla drv := disk + ':\'; GetMem(pVolName, MAX_PATH); GetMem(pFSBuf, MAX_PATH); GetMem(nVNameSer, MAX_PATH); //Disk Volume bilgisini al GetVolumeInformation(PChar(drv), pVolName, MAX_PATH, nVNameSer, maxCmpLen, FSSysFlags, pFSBuf, MAX_PATH); //Sistem uzun dosya isimlerini destekliyormu? if (maxCmpLen > 8.3) then diskinfos.Etiket:= StrPas(pVolName); diskinfos.serino:=IntToStr(nVNameSer^); diskinfos.tip:=StrPas(pFSBuf);//dosyasistemi //Sürücü tipi bilgilerini al dType := TDrvType(GetDriveType(PChar(drv))); case dType of dtNotDetermined : diskinfos.disk_Tip := 'Tespit edilemedi'; dtNonExistent : diskinfos.disk_Tip := 'Mevcut değil'; dtRemoveable : diskinfos.disk_Tip := 'Portatif disk (Floppy)'; dtFixed : diskinfos.disk_Tip := 'Sabit disk'; dtRemote : diskinfos.disk_Tip := 'Uzak veya ağ sürücüsü'; dtCDROM : diskinfos.disk_Tip := 'CD-ROM sürücü'; dtRamDrive : diskinfos.disk_Tip := 'RAM sürücü'; end; //Diskteki toplam ve boş alan bilgisini al (MB) GetDiskFreeSpace(PChar(drv), SectPerCls, BytesPerCls, FreeCls, TotCls); diskinfos.bos_yer:=FormatFloat('0.00', (SectPerCls * BytesPerCls * FreeCls)/1000000) + ' MB'; diskinfos.Top_Yer:= FormatFloat('0.00', (SectPerCls * BytesPerCls * TotCls)/1000000) + ' MB'; //Hafızayı temizle FreeMem(pVolName, MAX_PATH); FreeMem(pFSBuf, MAX_PATH);

1543

FreeMem(nVNameSer, MAX_PATH); end;

BİR DOSYANIN TARİH VE SAAT BİLGİSİNİN ALINMASI procedure TForm1.Button1Click(Sender: TObject); var TheFileDate: string; Fhandle: integer; begin FHandle := FileOpen('C:\COMMAND.COM', 0); Try TheFileDate := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle))); finally FileClose(FHandle); end; SHOWMESSAGE(THEFILEDATE); end;

BİR KLASÖRÜN ÖZELLİĞİNİN DEĞİŞTİRİLMESİ Aşağıdaki kod örneğinde, bir klasörün "Hidden" özelliği değiştirilmektedir. Function DirectoryHide(Const FileString : String): Boolean; Var Attributes : Integer; Begin Result := False; Try If Not DirectoryExists(FileString) Then Exit; Attributes := faDirectory + faHidden + faSysFile; FileSetAttr(FileString,Attributes); Result := True; Except End; End; --Function DirectoryUnHide(Const FileString : String): Boolean; Var Attributes : Integer; Begin Result := False; Try If Not DirectoryExists(FileString) Then Exit; Attributes := faDirectory; FileSetAttr(FileString,Attributes); Result := True; Except End; End;

DOSYANIN SÜRÜKLENİP BIRAKILMASI Fare ile sürüklenerek, aşağıdaki unite bağlı form üzerine dosya bırakıldığında, bırakılan dosyanın dizini ve adı tespit edilmektedir.

1544

unit dragfile; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm2 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } procedure AcceptFiles( var msg : TMessage ); message WM_DROPFILES; end; var Form2: TForm2; implementation uses ShellAPI; {$R *.DFM} procedure TForm2.AcceptFiles( var msg : TMessage ); const cnMaxFileNameLen = 255; var i, nCount : integer; acFileName : array [0..cnMaxFileNameLen] of char; begin nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen ); for i := 0 to nCount-1 do begin DragQueryFile( msg.WParam, i, acFileName, cnMaxFileNameLen ); MessageBox( Handle, acFileName, '', MB_OK ); end; DragFinish( msg.WParam ); end; procedure TForm2.FormCreate(Sender: TObject); begin DragAcceptFiles( Handle, True ); end; end.

WİNDOWS GEÇİCİ KLASÖRÜNÜN BULUNMASI 1545

Windows 95 ve NT işletim sistemlerinde, geçici dosyalar için kullanılan, genellikle "TEMP" isimli bir klasör vardır. Fakat bazen kullanıcılar bu dizinin adını veya yerini değiştirirler. Aşağıdaki fonksiyon, geçici dizini tespit eder. function GetTempDirectory: String; var TempDir: array[0..255] of Char; begin GetTempPath(255, @TempDir); Result := StrPas(TempDir); end; procedure TForm1.Button1Click(Sender: TObject); begin showmessage(gettempdirectory); end; Windows sistem dizininin bulunması Var SysDir: PChar; Size: Word; SysDirInString : String[144]; Begin SysDir := ''; GetSystemDirectory(SysDir, Size); SysDirInString := StrPas(SysDir); Canvas.TextOut(10, 10, SysDirInString); end;

DOSYA YARATILMA TARİHİ Bu fonksiyon, dosyanın yaratıldığı tarihi döndürür. Function File_GetCreationDate(FileName : String): TDateTime; var SearchRec : TSearchRec; DT : TFileTime; ST : TSystemTime; begin Result := 0; If Not FileExists(FileName) Then Exit; Try SysUtils.FindFirst(FileName, faAnyFile, SearchRec); Try FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT) ; FileTimeToSystemTime(DT, ST); Result := SystemTimeToDateTime(ST); Finally SysUtils.FindClose(SearchRec); End; Except Result := 0; End; end;

DOSYANIN SON KULLANILDIĞI TARİH Bu fonksiyon, dosyanın, son olarak kullanıldığı tarihi döndürür. Function File_GetLastAccessDate(FileName : String):

1546

TDateTime; var SearchRec : TSearchRec; DT : TFileTime; ST : TSystemTime; begin Result := 0; If Not FileExists(FileName) Then Exit; Try SysUtils.FindFirst(FileName, faAnyFile, SearchRec); Try FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,D T); FileTimeToSystemTime(DT, ST); Result := SystemTimeToDateTime(ST); Finally SysUtils.FindClose(SearchRec); End; Except Result := 0; End; end;

DOSYANIN SON DEĞİŞTİRİLDİĞİ TARİH Bu fonksiyon, FileName parametresi ile gönderilen dosyanın, son olarak değiştirildiği tarihi bulmaya yarar. Function File_GetLastModifiedDate(FileName : String): TDateTime; var SearchRec : TSearchRec; DT : TFileTime; ST : TSystemTime; begin Result := 0; If Not FileExists(FileName) Then Exit; Try SysUtils.FindFirst(FileName, faAnyFile, SearchRec); Try FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT ); FileTimeToSystemTime(DT, ST); Result := SystemTimeToDateTime(ST); Finally SysUtils.FindClose(SearchRec); End; Except Result := 0; End; end;

DİZİN BOŞMU? DirName parametresi ile gönderilen dizinin boş olup olmadığını kontrol etmeye yarayan bir fonksiyon. Function IsDirEmpty(DirName: String): Boolean; Begin If IsDir(DirName) Then Begin

1547

If IsFile(DirName+'\*.*') Then Begin Result := False; End Else Begin Result := True; End; End Else Begin Result := False; End; End;

DOSYA UZANTISI HANGİ PROGRAMLA BAĞLANTILI? Bir dosyanın uzantısına bakarak, hangi program tarafından çalıştırılacağının bulunması için aşağıdaki kod örneği kullanılabilir. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); const BufferSize = {$IFDEF Win32} 540 {$ELSE} 80 {$ENDIF}; var Buffer : PChar; StringPosition : PChar; ReturnedData: Longint; begin Buffer := StrAlloc(BufferSize); try { get the first entry, don't bother about the version !} ReturnedData := BufferSize; StrPCopy(Buffer, '.pas'); RegQueryValue(hKey_Classes_Root, Buffer, Buffer, ReturnedData);

1548

if StrLen(Buffer) > 0 then begin showmessage(strpas(buffer)); end; except showmessage('bulunamadı'); end; end; end. GERİ DÖNÜŞÜM KUTUSUNA GÖNDER. Bir dosyayı, geri dönüşüm kutusuna göndererek silmek için ; unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellApi; function DF(sFileName : string ) : boolean; var fos : TSHFileOpStruct; begin FillChar( fos, SizeOf( fos ), 0 ); with fos do begin Wnd := application.handle; wFunc := FO_DELETE; pFrom := PChar( sFileName ); fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT; end; Result := ( 0 = ShFileOperation( fos ) ); end;

1549

procedure TForm1.Button1Click(Sender: TObject); begin df('c:\"WP.txt'); end; end.

GENEL Bu bölümde, diğer başlıklar altında yer almayan püf noktaları ve kod örnekleri yer almaktadır.

KARAKTER DİZİSİ KARŞILAŞTIRMA unit matchstring; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; CheckBox1: TCheckBox; Edit1: TEdit; Edit2: TEdit; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } function MatchStrings(source, pattern: String): Boolean; end; var Form1: TForm1; implementation {$R *.DFM} function tform1.MatchStrings(source, pattern: String): Boolean; var pSource: Array [0..255] of Char; pPattern: Array [0..255] of Char; function MatchPattern(element, pattern: PChar): Boolean; function IsPatternWild(pattern: PChar): Boolean; var t: Integer; begin Result := StrScan(pattern,'*') <> nil; if not Result then Result := StrScan(pattern,'?') <> nil; end;

1550

begin if 0 = StrComp(pattern,'*') then Result := True else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then Result := False else if element^ = Chr(0) then Result := True else begin case pattern^ of '*': if MatchPattern(element,@pattern[1]) then Result := True else Result := MatchPattern(@element[1],pattern); '?': Result := MatchPattern(@element[1],@pattern[1]); else if element^ = pattern^ then Result := MatchPattern(@element[1],@pattern[1]) else Result := False; end; end; end; begin StrPCopy(pSource,source); StrPCopy(pPattern,pattern); Result := MatchPattern(pSource,pPattern); end; procedure TForm1.Button1Click(Sender: TObject); begin checkbox1.checked:=matchstrings(edit1.text,edit2.text); end; end.

YÜKLENMİŞ DLL DOSYALARININ HAFIZADAN ATILMASI Kullanılmayan DLL'lerin hafızada boşuna yer işgal etmemesi için hafızadan atılması gerekebilir. Aşağıdaki kod örneğinde bu işlemin yapılması gösterilmektedir. EditDLLName isimli 1 Tedit, 1 Tamam ve 1 adet de Kapat butonu form üzerine yerleştirilmiştir. Tamam butonunun OnClick davranışına yazılan kod aşağıdadır. procedure TForm1.TamamBtnClick(Sender: TObject); var hDLL: THandle; aName : array[0..10] of char; FoundDLL : Boolean; begin if EditDLLName.Text = '' then begin MessageDlg('Çıkarılacak DLL dosyasının adını yazınız.!',mtInformation,[mbOk],0); exit; end; StrPCopy(aName, EditDLLName.Text); FoundDLL := false; repeat hDLL := GetModuleHandle(aName); if hDLL = 0 then break;

1551

FoundDLL := true; FreeLibrary(hDLL); until false; if FoundDLL then MessageDlg('Tamam!',mtInformation,[mbOk],0) else MessageDlg('DLL Bulunamadı!',mtInformation,[mbOk],0); EditDLLName.Text := ''; end;

BİR DOS KOMUTUNUN KULLANILMASI Windows 95 ortamındayken, bir DOS komutunun çalıştırılması için gereken yordam şudur. procedure doskomutu(komut:string;mesajver:boolean); var Startupinfo:TStartupinfo; ProcessInfo:TProcessInformation; begin if terminateprocess(processinfo.hProcess,0)=NULL then begin if mesajver then showmessage('Devam eden işlem iptal edilemedi'); exit; end; FillChar(StartupInfo,Sizeof(StartupInfo),#0); StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.wShowWindow := SW_HIDE; StartupInfo.dwFlags:=STARTF_USESHOWWINDOW; if not CreateProcess(nil, Pchar('c:\command.com /c '+komut), nil, nil, true, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then begin if mesajver then ShowMessage('İşlem gerçekleştirilemedi') end else begin if mesajver then ShowMessage('İşlem tamam') end; end; Bu yordamın kullanımı; procedure TForm1.Button1Click(Sender: TObject); begin doskomutu('copy c:\autoexec.bat a:\autoexec.dat',false); end;

1552

TEDİT METNİNİN, ONCHANGE OLAYINDA DEĞİŞTİRİLMESİ Eğer, bir Tedit bileşenindeki metni, aynı bileşenin OnChange olayında değiştirmeye kalkarsanız, yığın (Stack) dolana kadar sürecek bir zincirleme reaksiyon yaratırsınız. Bu işlemi yapabilmek için, OnChange olay yordamına girildiğinde, önce OnChange olayı boşaltılmalı, işlem bitince yeniden eski haline getirilmelidir. procedure Edit1Change(Sender : TObject); begin Edit1.OnChange := NIL; if Edit1.Text = 'Some Text' then Edit1.Text := 'New Text'; Edit1.OnChange := Edit1Change; end;

TMEMO BİLEŞENİNDE, İMLEÇ HANGİ SATIRDA? Bir Tmemo bileşeninde, imlecin hangi satırda olduğunu anlamak için; With Memo1 do begin Line := Perform(EM_LINEFROMCHAR,SelStart, 0); Column := SelStart - Perform(EM_LINEINDEX, Line, 0); end;

ULUSAL AYARLAR Başlangıçta, Delphi bütün Tarih/Saat ayarlarını Kontrol panelde belirtilen bölgesel ayarlardan alarak kullanır. Bu durum, özellikle tarih alanlarına değer girildiğinde, hatalara neden olabilir. Bu sorunun çözümü için, Delphi içerisinde tanımlanmış ve bu tür bilgileri taşıyan değişkenleri, isteğinizi karşılayacak şekilde değiştirebilirsiniz. DecimalSeparator := '.'; ShortDateFormat := 'mm/dd/yy';

TEDİTBOX BİLEŞENİNDEKİ METNİN İLK KARAKTERİNİN, BÜYÜK HARFE ÇEVİRİLMESİ TeditBox bileşenindeki metnin ilk karakterinin, büyük harfe çevirilmesi için aşağıdaki kod kullanılabilir. procedure TForm1.Edit1Change(Sender: TObject); var OldStart : Integer; begin With Edit1 do if Text <> '' then begin OnChange := NIL; OldStart := SelStart; Text := UpperCase(Copy(Text,1,1))+ LowerCase(Copy(Text,2,Length(Text))); SelStart := OldStart; OnChange := Edit1Change; end; end;

WİNDOWS'UN KAPANMA ANININ TESPİTİ Windows'un kapanma anının yakalanabilmesi için, Windows tarafından kapanmadan önce yayınlanan,

1553

WM_EndSession mesajı yakalanmalıdır.Mesaj yakalama yordamı, uygulama ana form sınıfının, Private bölümünde şu şekilde tanımlanır. procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION; Mesaj yakalama yordamının kendisi ise, Implementation bölümünde aşağıdaki gibi yaratılır. procedure TForm1.WMEndSession(var Msg : TWMEndSession); begin if Msg.EndSession = TRUE then ShowMessage('Windows kapatılıyor. '); inherited; end; veya procedure TForm1.WMQueryEndSession(var Msg : TWMQueryEndSession); begin if MessageDlg('Windows kapansınmı ?', mtConfirmation, [mbYes,mbNo], 0) = mrNo then Msg.Result := 0 else Msg.Result := 1; end; WİNDOWSUN KAPANDIĞINI TESPİT EDEN BİR BİLEŞEN KODU AŞAĞIDADIR. unit winshut; interface uses Messages, SysUtils, Classes, Forms, Windows; type TkapanmaOlayi = procedure (Sender: TObject; var TamamKapat: boolean) of object; type TSezonuKapat = class(TComponent) private FUYG: THandle; FParent: THandle; FESKIWINYORD: pointer; FYeniPencereYordami: pointer; KAPANIRKEN: TkapanmaOlayi; TamamKapat: boolean; procedure YeniPencereYordami(var MESAJ: TMessage); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Loaded; override; published property WINKAPANIS: TkapanmaOlayi read KAPANIRKEN write KAPANIRKEN; end; procedure Register; implementation constructor TSezonuKapat.Create (AOwner : TComponent); begin inherited Create(AOwner); TamamKapat := TRUE; FUYG := Application.Handle; FParent := (AOwner as TForm).Handle;

1554

FYeniPencereYordami := MakeObjectInstance(YeniPencereYordami); end; destructor TSezonuKapat.Destroy; begin SetWindowLong(FUYG, GWL_WndProc, longint(FESKIWINYORD)); FreeObjectInstance(FYeniPencereYordami); inherited Destroy; end; procedure TSezonuKapat.Loaded; begin inherited Loaded; FESKIWINYORD := pointer(SetWindowLong(FUYG, GWL_WndProc,longint(FYeniPencereYordami))); end; procedure TSezonuKapat.YeniPencereYordami(var MESAJ: TMessage); begin with MESAJ do begin if (Msg=WM_QUERYENDSESSION) then begin if Assigned(KAPANIRKEN) then KAPANIRKEN(Self,TamamKapat); if TamamKapat then Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam) else Result := 0; end else Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam); end; end; procedure Register; begin RegisterComponents('Kitap', [TSezonuKapat]); end; end.

BİR MEMO VEYA RİCHEDİT BİLEŞENİNDE, İMLECİN İSTENEN YERE GÖNDERİLMESİ With Memo1 do SelStart := Perform(EM_LINEINDEX, Line, 0); Windows çevirmeli ağ bağlantı penceresinin çağırılması procedure TForm1.Button1Click(Sender: TObject); begin winexec(PChar('rundll32.exe rnaui.dll,RnaDial '+Edit1.Text),sw_show); end;

OTOMATİK E-MAİL 1555

//uses satırına shellapi eklenmeli procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Handle,'open','mailto:[email protected]',' ','',sw_Normal); end;

MONİTÖRÜN AÇILIP KAPATILMASI Kapatılması; procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); timer1.enabled:=true; end; açılması için; procedure TForm1.Timer1Timer(Sender: TObject); begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1); timer1.enabled:=false; end;

WİNDOWS'UN KAPATILMASI/YENİDEN BAŞLATILMASI Kapatılması; procedure TMainForm.RestartWindowsBtnClick(Sender: TObject); begin if not ExitWindows(EW_RestartWindows, 0) then ShowMessage('Bir uyulama kapanmayı reddetti'); end; Yeniden başlatılması; procedure TMainForm.RebootSystemBtnClick(Sender: TObject); begin if not ExitWindows(EW_RebootSystem, 0) then ShowMessage(Bir uyulama kapanmayı reddetti '); end;

SİSTEMDE SES KARTI VARMI? Winmm.Dll de bulunan waveOutGetNumDevs fonksiyonu kullanılarak, sistemde ses kartı olup olmadığı anlaşılabilir. Önce interface bölümünde fonksiyon tanımlanmalıdır. function SoundCardPresent : longint; stdcall; external 'winmm.dll' name 'waveOutGetNumDevs'; Kullanımı; If SoundCardPresent = 0 then Showmessage('Ses kartı yok');

PROGRAMIN ARKA PLANDA ÇALIŞTIRILMASI Program çalıştığında, hiç bir yerde görünmediği halde, ikonunu Windows görev çubuğuna yerleştirecektir. Üzerinde sağ fare tuşuna basılarak açılacak menü ile görünür hale getirilebilir. Unit1.dfm; unit Unit1;

1556

interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, ShellAPI, Menus; const WM_MINIMALIZE = WM_USER + 1 type TForm1 = class(TForm) PopupMenu1: TPopupMenu; Show1: TMenuItem; Hide1: TMenuItem; Quit1: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Show1Click(Sender: TObject); procedure Hide1Click(Sender: TObject); procedure Quit1Click(Sender: TObject); private FIconData : TNotifyIconData; public procedure WMMinimalize(var Message : TMessage); message WM_MINIMALIZE; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var i : Integer; begin with FIconData do begin cbSize := SizeOf(FIconData); Wnd := Self.Handle; uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; hIcon := Application.Icon.Handle; uCallbackMessage := WM_MINIMALIZE; szTip := 'My own application'; end; Shell_NotifyIcon(NIM_ADD, @FIconData); end; procedure TForm1.FormDestroy(Sender: TObject); begin Shell_NotifyIcon(NIM_DELETE, @FIconData); end; procedure TForm1.WMMinimalize(var Message : TMessage); var p : TPoint; begin case Message.LParam of WM_RBUTTONUP: begin GetCursorPos(p); PopupMenu1.Popup(p.x, p.y);

1557

end; end; end; procedure TForm1.Show1Click(Sender: TObject); begin Form1.Visible := TRUE; ShowWindow(Application.Handle, SW_HIDE); end; procedure TForm1.Hide1Click(Sender: TObject); begin Self.Visible := FALSE; end; procedure TForm1.Quit1Click(Sender: TObject); begin Application.Terminate; end; end. Project1.dpr; program Project1; uses Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.ShowMainForm := FALSE; Application.Run; end. Windows görev çubuğunun gizlenmesi/Gösterilmesi Gizlenmesi; procedure TForm1.Button1Click(Sender: TObject); var MyTaskbar:Hwnd; begin MyTaskBar:= FindWindow('Shell_TrayWnd', nil); ShowWindow(MyTaskBar, SW_HIDE); end; Gösterilmesi procedure TForm1.Button2Click(Sender: TObject); var MyTaskbar:Hwnd; begin MyTaskBar:= FindWindow('Shell_TrayWnd', nil); ShowWindow(MyTaskBar, SW_SHOW); end;

ÇALIŞAN PROGRAMIN, GÖREV ÇUBUĞU ÜZERİNDEN KALDIRILMASI program Project1; uses Forms,windows,

1558

Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} var es:integer; begin Application.Initialize; ES := GetWindowLong(Application.Handle, GWL_EXSTYLE); ES := ES or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW; SetWindowLong(Application.Handle, GWL_EXSTYLE, ES); Application.CreateForm(TForm1, Form1); Application.Run; end.

OCX'KULLANIMI Programda OCX örneğin THTML kullanıldığında, programı başka bir makinede çalıştırmak, problem olabilir. Bunun sebebi, OCX'lerin, çalışabilmeleri için Sistem kayıtları veri tabanına kayıtlı olmalarının gerekmesidir. Bu işlem Regsvr32.exe kullanılarak veya programın kendi içerisinden yapılabilir. Başka bir problem nedeni ise OCX kontrolünün birden fazla dosyadan oluşması ihtimalidir. Bunların tümü diğer makineye taşınmalıdır. OCX için hangi dosyaların gerekli olduğu QuickView programı kullanılarak tespit edilebilir.Aşağıda, kullanılan OCX'leri diğer makineye kaydettiren bir yordam yeralmaktadır. function CheckOCX:Boolean; var Reg:TRegistry; begin Reg:=TRegistry.Create; try Reg.RootKey:=HKEY_CLASSES_ROOT; // Kontrolün UID bilgisi windows sistem kayıtları veri //tabanından alınmaktadır. Result:=Reg.OpenKey('CLSID\{B7FC3550-8CE7-11CF-975400AA00C00908}',False); if Result then Reg.CloseKey; finally Reg.Free; end; end; procedure RegisterOCX; var Lib:THandle; S:String; P:TProcedure; begin OleInitialize(nil); try S:=ExtractFilePath(Application.ExeName)+'HTML.OCX'; Lib:=LoadLibrary(PChar(S)); if Lib
1559

OleUninitialize; end; end; procedure Uninstall; var Lib:THandle; S:String; P:TProcedure; begin S:=ExtractFilePath(Application.ExeName)+'HTML.OCX'; Lib:=LoadLibrary(PChar(S)); if Lib
EKRAN ÇÖZÜNÜRLÜĞÜNDEKİ DEĞİŞİKLİKLERİN TESPİTİ unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) private { Private declarations } public { Public declarations } procedure WMDisplayChange( var msg : TWMDisplayChange );message wm_DisplayChange; end; var Form1: TForm1; implementation {$R *.DFM} procedure tform1.WMDisplayChange( var msg : TWMDisplayChange ); begin showmessage('Renk=2 üzeri '+inttostr(msg.BitsPerPixel)+ ' En='+inttostr(msg.width)+ ' Boy='+inttostr(msg.height)) end; end.

1560

PANO GÖRÜNTÜLEME Panoya kopyalanan metnin, görüntülenmesi unit ClipboardViewer; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private FNextViewerHandle : THandle; procedure WMDrawClipboard (var message : TMessage); message WM_DRAWCLIPBOARD; procedure WMChangeCBCHain (var message : TMessage); message WM_CHANGECBCHAIN; public end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin FNextViewerHandle := SetClipboardViewer(Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin ChangeClipboardChain(Handle, FNextViewerHandle); end; procedure TForm1.WMDrawClipboard (var message : TMessage); begin message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0); memo1.lines.clear; memo1.PasteFromClipboard end; procedure TForm1.WMChangeCBCHain (var message : TMessage); begin if message.wParam = FNextViewerHandle then begin FNextViewerHandle := message.lParam; message.Result := 0; end else begin message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN, message.wParam, message.lParam);

1561

end; end; end.

CPU BİLGİLERİ Bilgisayardaki mikro işlemcinin tipinin ve üreticisinin tespit edilmesi için, aşağıdaki unit kullanılabilir. unit CpuInfo; interface type TFeatures = record case integer of 0: (RegEAX, RegEBX, RegEDX, RegECX:integer); 1 : (I :array [0..3] of integer); 2 : (C :array [0..15] of char); 3 : (B :array [0..15] of byte) end; const {$IFNDEF WIN32} i8086 = 1; i80286 = 2; i80386 = 3; {$ENDIF} i80486=4; Chip486=4; iPentium= 5; Chip586=5; iPentiumPro=6; Chip686=6; Intel='GenuineIntel'; AMD='AuthenticAMD'; var CpuType:byte = 0; VendorId:string [12]= ''; Features:TFeatures procedure LoadFeatures (I : integer); implementation {$O-} const CpuId = $0a20f; var CpuIdFlag:boolean = false; MaxCPUId:integer; procedure GetF; asm dw CpuId mov [Features.RegEAX], eax mov [Features.RegEBX], ebx mov [Features.RegECX], ecx

1562

mov [Features.RegEDX], edx end; procedure ClearF; asm mov edi, offset Features xor eax, eax mov ecx, eax mov cl, 4 cld rep stosd end; procedure CheckOutCpu; asm {$IFNDEF WIN32} pushf pop ax mov cx, ax and ax, 0fffh push ax popf pushf pop ax and ax, 0f000h cmp ax, 0f000h mov [CPUType], 1 je @@2 or cx, 0f000h push cx popf push pop ax and ax, 0f000h mov [CPUType], 2 jz @@2 pushfd pop eax mov ecx, eax xor eax, 40000h push eax popfd pushfd pop eax xor eax, ecx mov [CPUType], 3 jz @@2 push ecx popfd {$ENDIF} mov [CPUType], 4 mov eax, ecx xor eax, 200000h push eax popfd pushfd pop eax xor eax, ecx je @@2

1563

mov [CPUIdFlag], 1 push ebx mov eax,0 dw CpuId mov [MaxCPUId], eax mov [byte ptr VendorId], 12 mov [dword ptr VendorId+1], ebx mov [dword ptr VendorId+5], edx mov [dword ptr VendorId+9], ecx callClearF mov eax, 1 cal GetF shr eax, 8 and eax, 0fh mov [CPUType], al @@1: pop ebx @@2: end; procedure LoadFeatures (I : integer); asm call ClearF cmp [CpuIdFlag], 0 je @@1 mov eax, [I] cmp [MaxCpuId], eax jl @@1 call GetF @@1: end; initialization CheckOutCPU; end. {CPU tipi ile ilgili bilgiler, "Cputype", ve "vendorid" değişkenlerine yüklenmektedirler.;} Aynı maksatla kullanılabilecek başka bir kod örneği de şudur. unit cpuinfo; interface uses Windows, SysUtils; type Freq_info = Record Raw_Freq: Cardinal; Norm_Freq: Cardinal; In_Cycles: Cardinal; Ex_Ticks: Cardinal; end;

// Ham CPU frekansı MHz. // Ortalama CPU frekansı MHz. // Sistem saati hizi // Test süresi

TCpuInfo = Record VendorIDString: String; Manufacturer: String; CPU_Name: String; PType: Byte; Family: Byte; Model: Byte; Stepping: Byte; Features: Cardinal;

1564

MMX: Boolean; Frequency_Info: Freq_Info; IDFDIVOK: Boolean; end; Const InfoStrings: Array[0..1] of String = ('FDIV instruction is Flawed', 'FDIV instruction is OK'); Const // CPU değerlerinin tespitinde kullanılacak sabitler // Örnek IF (Features and FPU_FLAG = FPU_FLAG) ise CPU'da Floating-Point birim vardır. FPU_FLAG = $00000001; VME_FLAG = $00000002; DE_FLAG = $00000004; PSE_FLAG = $00000008; TSC_FLAG = $00000010; MSR_FLAG = $00000020; PAE_FLAG = $00000040; MCE_FLAG = $00000080; CX8_FLAG = $00000100; APIC_FLAG = $00000200; BIT_10 = $00000400; SEP_FLAG = $00000800; MTRR_FLAG = $00001000; PGE_FLAG = $00002000; MCA_FLAG = $00004000; CMOV_FLAG = $00008000; BIT_16 = $00010000; BIT_17 = $00020000; BIT_18 = $00040000; BIT_19 = $00080000; BIT_20 = $00100000; BIT_21 = $00200000; BIT_22 = $00400000; MMX_FLAG = $00800000; BIT_24 = $01000000; BIT_25 = $02000000; BIT_26 = $04000000; BIT_27 = $08000000; BIT_28 = $10000000; BIT_29 = $20000000; BIT_30 = $40000000; BIT_31 = $80000000; Procedure GetCPUInfo(Var CPUInfo: TCpuInfo); Function GetRDTSCCpuSpeed: Freq_Info; Function CPUID: TCpuInfo; Function TestFDIVInstruction: Boolean; implementation Procedure GetCPUInfo(Var CPUInfo: TCpuInfo); begin CPUInfo := CPUID; CPUInfo.IDFDIVOK := TestFDIVInstruction; IF (CPUInfo.Features and TSC_FLAG = TSC_FLAG) then CPUInfo.Frequency_Info := GetRDTSCCpuSpeed; If (CPUInfo.Features and MMX_FLAG) = MMX_FLAG then

1565

CPUInfo.MMX := True else CPUInfo.MMX := False; end; Function GetRDTSCCpuSpeed: Freq_Info; var Cpu_Speed: Freq_Info; t0, t1: TLargeInteger; freq, freq2, freq3, Total: Cardinal; Total_Cycles, Cycles: Cardinal; Stamp0, Stamp1: Cardinal; Total_Ticks, Ticks: Cardinal; Count_Freq: TLargeInteger; Tries, IPriority, hThread: Integer; begin freq := 0; freq2 := 0; freq3 := 0; tries := 0; total_cycles := 0; total_ticks := 0; Total := 0; hThread := GetCurrentThread(); if (Not QueryPerformanceFrequency(count_freq)) then begin Result := cpu_speed; end else begin while ((tries < 3 ) or ((tries < 20) and ((abs(3 * freq - total) > 3) or (abs(3 * freq2-total) > 3) or (abs(3 * freq3-total) > 3)))) do begin inc(tries); freq3 := freq2; freq2 := freq; QueryPerformanceCounter(t0); t1.LowPart := t0.LowPart; t1.HighPart := t0.HighPart; iPriority := GetThreadPriority(hThread); if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) then

begin

SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL); end; while ((t1.LowPart - t0.LowPart) < 50) do begin QueryPerformanceCounter(t1); asm push eax push edx db 0Fh db 31h MOV stamp0, EAX

1566

pop edx pop eax end; end; t0.LowPart := t1.LowPart; t0.HighPart := t1.HighPart; while ((t1.LowPart - t0.LowPart) < 1000) do begin QueryPerformanceCounter(t1); asm push eax push edx db 0Fh db 31h MOV stamp1, EAX pop edx pop eax end; end; then

if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) begin SetThreadPriority(hThread, iPriority); end; cycles := stamp1 - stamp0; ticks := t1.LowPart - t0.LowPart; ticks := ticks * 100000; ticks := Round(Ticks / (count_freq.LowPart/10)); total_ticks := Total_Ticks + ticks; total_cycles := Total_Cycles + cycles; freq := Round(cycles / ticks);

total := (freq + freq2 + freq3); end; freq3 := Round((total_cycles * 10) / total_ticks); freq2 := Round((total_cycles * 100) / total_ticks); If (freq2 - (freq3 * 10) >= 6) then inc(freq3); cpu_speed.raw_freq := Round(total_cycles / total_ticks); cpu_speed.norm_freq := cpu_speed.raw_freq; freq := cpu_speed.raw_freq * 10; if((freq3 - freq) >= 6) then inc(cpu_speed.norm_freq); cpu_speed.ex_ticks := total_ticks; cpu_speed.in_cycles := total_cycles; Result := cpu_speed; end; end; Function CPUID: TCpuInfo; type

1567

regconvert = record bits0_7: Byte; bits8_15: Byte; bits16_23: Byte; bits24_31: Byte; end; var CPUInfo: TCpuInfo; TEBX, TEDX, TECX: Cardinal; TString: String; VString: String; temp: regconvert; begin asm MOV [CPUInfo.PType], 0 MOV [CPUInfo.Model], 0 MOV [CPUInfo.Stepping], 0 MOV [CPUInfo.Features], 0 MOV [CPUInfo.Frequency_Info.Raw_Freq], 0 MOV [CPUInfo.Frequency_Info.Norm_Freq], 0 MOV [CPUInfo.Frequency_Info.In_Cycles], 0 MOV [CPUInfo.Frequency_Info.Ex_Ticks], 0 push push push push push push push

eax ebp ebx ecx edi edx esi

@@Check_80486: MOV [CPUInfo.Family], 4 MOV TEBX, 0 MOV TEDX, 0 MOV TECX, 0 PUSHFD POP EAX MOV ECX, EAX XOR EAX, 200000H PUSH EAX POPFD PUSHFD POP EAX XOR EAX, ECX JE @@DONE_CPU_TYPE @@Has_CPUID_Instruction: MOV EAX, 0 DB 0FH DB 0A2H MOV TEBX, EBX MOV TEDX, EDX MOV TECX, ECX MOV EAX, 1 DB 0FH DB 0A2H MOV [CPUInfo.Features], EDX

1568

MOV ECX, EAX AND EAX, 3000H SHR EAX, 12 MOV [CPUInfo.PType], AL MOV EAX, ECX AND EAX, 0F00H SHR EAX, 8 MOV [CPUInfo.Family], AL MOV EAX, ECX AND EAX, 00F0H SHR EAX, 4 MOV [CPUInfo.MODEL], AL MOV EAX, ECX AND EAX, 000FH MOV [CPUInfo.Stepping], AL @@DONE_CPU_TYPE: pop pop pop pop pop pop pop end;

esi edx edi ecx ebx ebp eax

If (TEBX = 0) and (TEDX = 0) and (TECX = 0) and (CPUInfo.Family = 4) then begin CPUInfo.VendorIDString := 'Unknown'; CPUInfo.Manufacturer := 'Unknown'; CPUInfo.CPU_Name := 'Generic 486'; end else begin With regconvert(TEBX) do begin TString := CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31); end; With regconvert(TEDX) do begin TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31); end; With regconvert(TECX) do begin TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31); end; VString := TString; CPUInfo.VendorIDString := TString; If (CPUInfo.VendorIDString = 'GenuineIntel') then begin

1569

CPUInfo.Manufacturer := 'Intel'; Case CPUInfo.Family of 4: Case CPUInfo.Model of 1: CPUInfo.CPU_Name := 'Intel 486DX Processor'; 2: CPUInfo.CPU_Name := 'Intel 486SX Processor'; 3: CPUInfo.CPU_Name := 'Intel DX2 Processor'; 4: CPUInfo.CPU_Name := 'Intel 486 Processor'; 5: CPUInfo.CPU_Name := 'Intel SX2 Processor'; 7: CPUInfo.CPU_Name := 'Write-Back Enhanced Intel DX2 Processor'; 8: CPUInfo.CPU_Name := 'Intel DX4 Processor'; else CPUInfo.CPU_Name := 'Intel 486 Processor'; end; 5: CPUInfo.CPU_Name := 'Pentium'; 6: Case CPUInfo.Model of 1: CPUInfo.CPU_Name := 'Pentium Pro'; 3: CPUInfo.CPU_Name := 'Pentium II'; else CPUInfo.CPU_Name := PChar(Format('P6 (Model %d)', [CPUInfo.Model])); end; else CPUInfo.CPU_Name := Format('P%d', [CPUInfo.Family]); end; end else if (CPUInfo.VendorIDString = 'CyrixInstead') then begin CPUInfo.Manufacturer := 'Cyrix'; Case CPUInfo.Family of 5: CPUInfo.CPU_Name := 'Cyrix 6x86'; 6: CPUInfo.CPU_Name := 'Cyrix M2'; else CPUInfo.CPU_Name := Format('%dx86', [CPUInfo.Family]); end; end else if (CPUInfo.VendorIDString = 'AuthenticAMD') then begin CPUInfo.Manufacturer := 'AMD'; Case CPUInfo.Family of 4: CPUInfo.CPU_Name := 'Am486 or Am5x86'; 5: Case CPUInfo.Model of 0: CPUInfo.CPU_Name := 'AMD-K5 (Model 0)'; 1: CPUInfo.CPU_Name := 'AMD-K5 (Model 1)'; 2: CPUInfo.CPU_Name := 'AMD-K5 (Model 2)'; 3: CPUInfo.CPU_Name := 'AMD-K5 (Model 3)'; 6: CPUInfo.CPU_Name := 'AMD-K6'; else CPUInfo.CPU_Name := 'Unknown AMD Model'; end; else CPUInfo.CPU_Name := 'Unknown AMD Chip'; end; end else begin CPUInfo.VendorIDString := TString; CPUInfo.Manufacturer := 'Unknown'; CPUInfo.CPU_Name := 'Unknown'; end; end; Result := CPUInfo; end;

1570

Function TestFDIVInstruction: Boolean; var TestDividend: Double; TestDivisor: Double; TestOne: Double; ISOK: Boolean; begin TestDividend := 4195835.0; TestDivisor := 3145727.0; TestOne := 1.0; asm PUSH EAX FLD [TestDividend] FDIV [TestDivisor] FMUL [TestDivisor] FSUBR [TestDividend] FCOMP [TestOne] FSTSW AX SHR EAX, 8 AND EAX, 01H MOV ISOK, AL POP EAX end; Result := ISOK; end; end.

ENTER TUŞUNUN TAB YERİNE KULLANILABİLECEĞİ BİR TEDİT BİLEŞENİ Enter (Return) tuşuna basıldığında Tab tuşuna basılmış etkisi yaratmak için aşağıdaki kod kullanılabilir. procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if key=#13 then begin perform(wm_nextdlgctl,0,0); key:=#0; end; end; Aşağıdaki bileşen kodu, standart bir Tedit bileşenini, değiştirerek Enter ve Ok tuşlarına tepki verebilecek yeni bir Edit kontrolü haline getirmektedir. unit Entedit; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TEnterEdit = class(TEdit) private protected procedure KeyPress(var Key: Char); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; public

1571

published end; procedure Register; implementation procedure Register; begin RegisterComponents('Kitap', [TEnterEdit]); end; procedure TEnterEdit.KeyPress(var Key: Char); var MYForm: TcustomForm; begin if Key = #13 then begin MYForm := GetParentForm( Self ); if not (MYForm = nil ) then SendMessage(MYForm.Handle, WM_NEXTDLGCTL, 0, 0); Key := #0; end; if Key <> #0 then inherited KeyPress(Key); end; procedure TEnterEdit.KeyDown(var Key: Word; Shift: TShiftState); var MYForm: TcustomForm; CtlDir: Word; begin if (Key = VK_UP) or (Key = VK_DOWN) then begin MYForm := GetParentForm( Self ); if Key = VK_UP then CtlDir := 1 else CtlDir :=0; if not (MYForm = nil ) then SendMessage(MYForm.Handle, WM_NEXTDLGCTL, CtlDir, 0); end else inherited KeyDown(Key, Shift); end; end. Tarih doğru mu Function Tarihgecerlimi(DateString: String): Boolean; Begin Try StrToDateTime(DateString); Result := True; Except Result := False; End; End;

AYDA KAÇ GÜN VAR? Function AydakiGunSayisi(DateValue: TDateTime): Integer; var yil : Word;

1572

ay : Word; gün : Word; yeniyil : Word; yeniay : Word; yenigun : Word; sayacr : Integer; yenitarih : TDateTime; Begin Result := 30; Try DecodeDate(DateValue, Yil, ay, gun); NewDate := EncodeDate(yil, ay, 26); For sayac := 26 To 32 Do Begin yenitarih := NewDate+1; DecodeDate(yenitarih, yeniyil, yeniay, yenigun); If MonthNew <> MonthIn Then Begin DecodeDate(yenitarih-1, Yeniyil, yeniay, yenigun); Result := yenigun; Break; End; End; Except End; End;

GEÇEN HAFTANIN İLK GÜNÜ Function GecenHaftaninIlkGunu(DateValue: TDateTime): TDateTime; Begin Result := HaftaninIlkGunu(DateValue-7); End; Sonraki Ayın ilk Günü Function SonrakiAyinIlkGunu(DateValue: TDateTime): TDateTime; Begin Try Result := AyinSonGunu(DateValue)+1; Except Result := DateValue; End; End;

SONRAKİ HAFTANIN İLK GÜNÜ Function SonrakiHaftaninIlkGunu(DateValue: TDateTime): TDateTime; Begin Result := HaftaninIlkGunu(DateValue+7); End; Haftanın ilk günü Function HaftaninIlkGunu(DateValue: TDateTime): TDateTime; Begin Try Result := DateValue - (DayOfWeek(DateValue)) +1; Except Result := 0; End; End;

1573

AYIN SON GÜNÜ Function AyinSonGunu(DateValue: TDateTime): TDateTime; Var LastDay : String; Begin LastDay := IntToStr(AydakiGunSayisi(DateValue)); Result := StrToDate( FormatDateTime('mm',DateValue)+ '/'+ LastDay+ '/'+ FormatDateTime('yyyy',DateValue)); End; Ay Function Ay(DateValue: TDateTime): Integer; Var Year, Month, Day: Word; Begin Result := -1; Try DecodeDate(DateValue, Year, Month, Day); Result := Integer(Month); Except Result := -1; End; End;

GELECEK AY Function GelecekAy(DateValue: TDateTime): Integer; Var Year, Month, Day: Word; CurMonth : Integer; NewMonth : Integer; Begin Result := -1; Try DecodeDate(DateValue, Year, Month, Day); CurMonth := Integer(Month); NewMonth := ((CurMonth + 12 + 1) mod 12); If NewMonth = 0 Then NewMonth := 12; Result := NewMonth; Except Result := -1; End; End;

GEÇEN AY Function GecenAy(DateValue: TDateTime): Integer; Var Year, Month, Day: Word; CurMonth : Integer; NewMonth : Integer; Begin Result := -1; Try DecodeDate(DateValue, Year, Month, Day);

1574

CurMonth := Integer(Month); NewMonth := ((CurMonth + 24 - 1) mod 12); If NewMonth = 0 Then NewMonth := 12; Result := NewMonth; Except Result := -1; End; End;

GÜN SONRA Function nGunSonra( DateValue : TDateTime; DateMovement : Integer): TDateTime; Begin Result := DateValue + DateMovement; End;

GELECEK AY Function GelecekAy(DateValue: TDateTime): TDateTime; Begin Result := nGumSonra(DateValue,1); End;

ÖNCEKİ GÜN Function onceki_gun(DateValue: TDateTime): TDateTime; Begin Result := NGunSonra(DateValue,-1); End; Geçen hafta Function GecenHaftak(DateValue: TDateTime): TDateTime; Begin Result := nGunSonra(DateValue,-7); End;

METİN İÇERİSİNDEN BİR KARAKTER SİLME Function DeleteCharacterInString(InputCharacter,InputString: String): String; Var CharPos : Integer; Begin Result := InputString; While True Do Begin CharPos := Pos(InputCharacter,InputString); If Not (CharPos = 0) Then Begin Delete(InputString,CharPos,1); End Else Begin Break; End; End; Result := InputString; End;

1575

METİN İÇERİSİNDEN, BİR KARAKTERİ DEĞİŞTİRME Function ReplaceCharInString(S,OldChar,NewChar :String): String; Var NewString : String; i : Integer; L : Integer; C : String; Begin Result := ''; NewString := ''; L := Length(S); If L = 0 Then Exit; If Pos(UpperCase(OldChar),UpperCase(S)) = 0 Then Begin Result := S; Exit; End; For i := 1 To L Do Begin C := SubStr(S,i,1); If UpperCase(C) = UpperCase(OldChar) Then Begin NewString := NewString + NewChar; End Else Begin NewString := NewString + C; End; End; Result := NewString; End;

BİR METNİ BELLİ BİR UZUNLUĞA TAMAMLAMA Function StringPad( InputStr,//tamamlanacak metin FillChar: String;//tamamlama karakteri StrLen: Integer;//uzunluk StrJustify: Boolean): String;//tamamlama yönü Var TempFill: String; Counter : Integer; Begin If Not (Length(InputStr) = StrLen) Then Begin If Length(InputStr) > StrLen Then Begin InputStr := SubStr(InputStr,1,StrLen); End Else Begin TempFill := ''; For Counter := 1 To StrLen-Length(InputStr) Do Begin TempFill := TempFill + FillChar; End;

1576

If StrJustify Then Begin InputStr := InputStr + TempFill; End Else Begin InputStr := TempFill + InputStr ; End; End; End; Result := InputStr; End;

METİN DEĞİŞTİRME Function String_Replace( OldSubString : String;//atılacak metin NewSubString : String;//atılanın yerine konacak metin SourceString : String): String;//üzerinde değişiklik yapılacak metin Var P : Integer; S : String; R : String; LOld : Integer; LNew : Integer; Begin S := SourceString; R := ''; LOld := Length(OldSubString); LNew := Length(NewSubString); Result := S; If OldSubString = '' Then Exit; If SourceString = '' Then Exit; P := Pos(OldSubString,S); If P = 0 Then Begin R := S; End Else Begin While P <> 0 Do Begin Delete(S,P,LOld); R := R + Copy(S,1,P-1)+NewSubString; S := Copy(S,P,Length(S)-(P-1)); P := Pos(OldSubString,S); If P = 0 Then R := R + S; End; End; Result := R; End;

PROGRAM İÇERİSİNDEN BAŞKA BİR UYGULAMAYA TUŞ GÖNDERME WinHand := FindWindow(nil,'Untitled - Notepad'); SetForegroundWindow(WinHand); keybd_event(VK_MENU, 0, 0, 0); keybd_event(VK_Menu, 0, KEYEVENTF_KEYUP, 0);

1577

keybd_event(VK_right, 0, 0, 0); keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0); keybd_event(VK_right, 0, 0, 0); keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0); keybd_event(VK_right, 0, 0, 0); keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0); keybd_event(VK_down, 0, 0, 0); keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0); keybd_event(VK_down, 0, 0, 0); keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0); keybd_event(VK_return, 0, 0, 0); keybd_event(VK_return, 0, KEYEVENTF_KEYUP, 0);

PROGRAMI DENEME SÜRÜMÜ HALİNE GETİRME Programcıların kabusu, ürünlerinin kolaylıkla bedavacıların eline geçmesidir. Bu durum ürünlerin tanıtım sürümlerinin dağıtılmasında bir takım tedbirleri gerektirir. Bunun çok çeşitli yolları vardır. İşte bunlardan birisi. Aşağıdaki fonksiyon, Windows'un global atom tablosuna belirli bir not yazarak, çalışma esnasında bu notu okumaktadır. Şayet not okunabilirse, programın daha önce çalıştırılmış olduğu ortaya çıkar ve uyarı mesajını takiben çalışması durdurulur. Programın yeniden çalıştırılabilmesi için, Windowsun yeniden başlatılması gerekir. procedure TForm1.FormShow(Sender : TObject); var atom : integer; CRLF : string; begin if GlobalFindAtom('Kontrol için kullanılacak metin') = 0 then atom := GlobalAddAtom(' Kontrol için kullanılacak metin ') else begin CRLF := #10 + #13; ShowMessage('Bu program, her windows oturumunda 1 kez çalışır.'+crlf+'+ Windows'u yeniden başlatın.'+crlf+ 'Ya da bizi arayıp satın alın'); Close; end; end;

LİSTBOX BİLEŞENİNE YATAY KAYDIRMA ÇUBUĞU EKLENMESİ Delphi'nin TlistBox Bileşeni, satır sayısı gösterebileceğinden fazla ise, otomatik olarak dikey kaydırma çubuğunu kullanıma açar. Fakat satır uzunluğu gösterebileceği genişlikten daha fazla ise, bir kolaylık sağlamaz. Aşağıdaki kod kullanılarak, yatay kaydırma çubuğununda eklenmesi sağlanabilir. Aşağıdaki kod, formun OnCrate olay yordamına yazılmalıdır. procedure TForm1.FormCreate(Sender: TObject); var i, MaxWidth: integer; begin MaxWidth := 0; for i := 0 to ListBox1.Items.Count - 1 do if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]); SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT,

1578

MaxWidth+2, 0); end; Kod öncelikle, listbox içerisindeki en uzun satırın uzunluğunun Piksel cinsinden hesaplar. Ondan sonra LB_SETHORIZONTALEXTENT mesajını kullanarak, yatay kaydırma çubuğunu ayarlar.Kontrol panel apletlerinin Delphi içerisinden kullanılmasıBazı sistem ayarları, kontrol panelden yapılmaktadır. Program içerisinden bu ayarlara müdahele etmek gerektiğinde, en kolay yol yine kontrol panel apletlerini kullanmaktır. Aşağıdaki fonksiyon, istenen kontrol panel apletini çalıştırmaktadır. unit open_cpl; interface function RunControlPanelApplet( sAppletFileName : string) : integer; implementation uses Windows; //sAppletFileName değeri aşağıdaki tablodan seçilebilir. function RunControlPanelApplet( sAppletFileName : string) : integer; begin Result := WinExec( PChar('rundll32.exe shell32.dll,'+ 'Control_RunDLL '+sAppletFileName), SW_SHOWNORMAL); end; end.

Windows95 ve NT de ortak olan kontrol panel apletleri şunlardır. 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

SİSTEM TARİH/SAAT AYARININ DEĞİŞTİRİLMESİ Sistemin tarih ve saat ayarları programsal olarak da değiştirilebilir. Bunun için Aşağıdaki fonksiyonu kullanabilirsiniz. function SetPCSystemTime(tDati: TDateTime): Boolean; var tSetDati: TDateTime; vDatiBias: Variant; tTZI: TTimeZoneInformation; tST: TSystemTime; begin GetTimeZoneInformation(tTZI);

1579

vDatiBias := tTZI.Bias / 1440; tSetDati := tDati + vDatiBias; with tST do begin wYear := StrToInt(FormatDateTime('yyyy', tSetDati)); wMonth := StrToInt(FormatDateTime('mm', tSetDati)); wDay := StrToInt(FormatDateTime('dd', tSetDati)); wHour := StrToInt(FormatDateTime('hh', tSetDati)); wMinute := StrToInt(FormatDateTime('nn', tSetDati)); wSecond := StrToInt(FormatDateTime('ss', tSetDati)); wMilliseconds := 0; end; SetPCSystemTime := SetSystemTime(tST); end; procedure TForm1.Button1Click(Sender: TObject); var tti:tdatetime; begin tti:=strtodatetime('11.11.98 14:15:20'); Setpcsystemtime(tti)

ALT+TAB VE CTRL+ALT+DEL TUŞ KOMBİNASYONLARININ KULLANIMA KAPATILMASI Eğer programınız çalışırken, kullanıcıların bu tuş kombinasyonlarını kullanmasını istemiyorsanız, aşağıdaki kod örneği tam size göre uses WinProcs; {$R *.RES} var Dummy : integer; begin Dummy := 0; //ALT+TAB kombinasyonu için SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0); //CTRL+ALT+DEL kombinasyonu için SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0); end.

EKRAN KORUYUCUNUN DEVREDEN ÇIKARILMASI SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, Addr(SaverActive), 0); if SaverActive then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, SPIF_UPDATEINIFILE); {Burada "SaverActive" global bir Boolean değişkendir. Ekran koruyucu tekrar aktif hale getirilmek istendiğinde ise} if SaverActive then SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, SPIF_UPDATEINIFILE);

1580

{Diğer bir yol ise, şu şekildedir. Bir ekran koruyucu çalışmaya başlamadan önce "WM_SYSCOMMAND" mesajı gönderir. Bu mesaj yakalanarak ekran koruyucunun devreye girmesi engellenir. TApplication nesnesinin OnMessage. Olayı yerine kullanılacak yeni bir davranış yaratıp bu mesajı herkesden önce yakalayabiliriz. Bu işlem şöyle olur.} procedure AppMessage(var Msg: TMsg; var Handled: Boolean); {Daha sonra ana formun OnCreate davranışı içerisinde,} Application.OnMessage := AppMessage; {Appmessage yordamında yakalanan mesajın WM_sysCommand ve Wparam değerinin de SC_ScreenSave olup olmadığı kontrol edilir. Eğer öyle ise, Handled parametresi True yapılarak, o mesajın işlem gördüğü imajı yaratılarak, windows'un ekran koruyucuyu başlatması engellenir.} procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean); begin if (Msg.Message = WM_SYSCOMMAND) and ((Msg.wParam) = SC_SCREENSAVE) then begin Handled := True; end; end;

PROGRAMIN, WİNDOWSUN BAŞLANGICINDA ÇALIŞTIRILMASI Windows Startup klasörüne konan programlar, windowsun başlaması ile birlikte çalışmaya başlarlar. Fakat bunu program içerisinden yapmak istiyorsanız, veya programınız, bir kereye mahsus başlangıçta çalışsın istiyorsanız,aşağıdaki fonksiyonu kullanarak geçici veya kalıcı olarak gerekeni yapabilirsiniz. procedure RunOnStartup( sProgTitle, sCmdLine var sKey : string; reg : TRegIniFile; begin if( bRunOnce )then sKey := 'Once' else sKey := '';

: string; bRunOnce

: boolean );

reg := TRegIniFile.Create( '' ); reg.RootKey := HKEY_LOCAL_MACHINE; reg.WriteString( 'Software\Microsoft' + '\Windows\CurrentVersion\Run' + sKey + #0, sProgTitle, sCmdLine ); reg.Free; end;

HATA MESAJI KONTROLÜ Herhangi bir iş yapılırken, örneğin, diskete erişilmek istendiğinde, eğer sürücüde disket yoksa, windows bir hata mesajı verir. Bu tür mesajlara krıtik hata mesajı denir. Eğer kendiniz bu hataları kontrol edip, gereğini yapacaksanız, windowsun mesaj vermesinin engellenmesi gerekir.Bu işlem "SetErrorMode" fonksiyonu ile yapılabilir. var wOldErrorMode : Word;

1581

begin wOldErrorMode := SetErrorMode( SEM_FAILCRITICALERRORS ); try {hata mesajına sebep olabilecek kod buraya yazılır. } finally { bir önceki hata moduna dön. } SetErrorMode( wOldErrorMode ); end; end;

EKRAN KORUYUCU KURULMASI Sistemde tanımlı olan ekran koruyucunun değiştirilmesi veya en baştan tanımlanması için gereken kod aşağıdadır. Uses listesine eklenmesi gereken fmxutil.pas demos\doc dizini altında bulunmaktadır. //uses ..\demos\doc\fmxutil.pas procedure TForm1.Button1Click(Sender: TObject); begin ExecuteFile('rundll32.exe', 'desk.cpl,InstallScreenSaver C:\Windows\gpf.scr',' ',SW_SHOW); end;

LİSTBOX YAZI TİPİNİN DEĞİŞTİRİLMESİ Tek bir satır kod yazarak wm_SetFont mesajına duyarlı bileşenlerin, yazı tipleri değiştirilebilir. SendMessage( Listbox1.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);

TAŞINABİLİR PANEL Programın çalışması esnasında, form üzerindeki bileşenlerin yerleri ancak, program içerisinden verilecek komutlarla değiştirilebilir. Aşağıdaki kod örneği ile çalışan bir programda, normal bir panel, fare yardımı ile taşınabilir hale gelmektedir. Bu kod panelin OnMouseDown olay yordamı içerisine yazılmalıdır. procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const SC_DragMove = $F012; begin ReleaseCapture; panel1.perform(WM_SysCommand, SC_DragMove, 0); end;

CD-ROM KAPAĞININ KAPATILMASI TmediaPlayer, bir CD-ROM'a komuta ediyorsa, Eject tuşuna basıldığında,, CD-ROM kapağını açabilir. Fakat tekrar Eject tuşuna basıldığında açık durumdaki kapağı kapatamaz. Bu nedenle bir adet kapat butonu kullanılmalıdır. Aşağıdaki kod örneğinde, başka bir buton kullanılarak kapağın kapatılması gösterilmektedrir. procedure TForm1.Button1Click(Sender: TObject); begin if MediaPlayer1.Mode = mpOpen then begin mciSendCommand(MediaPlayer1.DeviceID, MCI_SET,MCI_SET_DOOR_CLOSED,0);

1582

Button1.Caption := '&Open' end else begin mciSendCommand(MediaPlayer1.DeviceID ,MCI_SET,MCI_SET_DOOR_OPEN,0); Button1.Caption := '&Close'; end; end; {Genel olarak bu işlemin yapılması için ise Mmsystem uniti kullanılarak, aşağıdaki fonksiyonlar kullanılabilir.} CD-ROM Kapağını açmak için; mciSendString('Set cdaudio door open wait', nil, 0, handle); CD-ROM Kapağını kapatmak için; mciSendString('Set cdaudio door closed wait', nil, 0, handle);

ÇALIŞMA ESNASINDA, BİLEŞEN SAYISININ KONTROLÜ Uygulama tarafından kullanılmakta olan bileşen sayısının bulunması mümkündür. Henüz yaratılmamış olanlar, bu sayıya dahil edilmeyecektir. Uygulamalar tarafından kullanılmakta olan formların tümü Screen nesnesi ne bağlıdırlar. Her formun üzerindeki bileşenlerin sayısı ise ComponentCount özelliğinde saklanmaktadır. Aşağıdaki kod örneğinde bu özelliklerden yararlanılarak, uygulama üzerindeki toplam bileşen sayısı bulunmaktadır. function BilesenSayisi : Integer; var TopBilesen, F_Form : Integer; begin TopBilesen := 0; for F_Form := 0 to (Screen.FormCount - 1) do begin TopBilesen := TopBilesen + Screen.Forms[F_Form].ComponentCount; end; Result := TopBilesen; end;

FARE İMLECİNİN, İSTENEN KONTROL ÜZERİNE GETİRİLMESİ Fare imlecinin form üzerindeki kontrollerden birisi, örneğin bir buton üzerine getirilmesi için Butonun orta noktası hesaplanmalıdır. Örneğin butonun eni 24 ve boyu da 24 ise xC := Buton.Left + ( buton.width div 2 ); yC := buton.Top + ( buton.height div 2 ); Bulunan değerler Tpoint kayıt tipi içerisine yerleştirilir. ptBtn : TPoint; Btn := Point( xC, yC ); Butonun orta noktasına karşılık gelen ekran koordinatları bulunmalıdır. ptBtn:=buton.Parent.ScreenToClient( buton.ClientToScreen (ptBtn )); Fere imlecinin pozisyonunu, bulunan ekran koordinatı değeri kullanılarak değiştirilir. SetCursorPos( ptBtn.X, ptBtn.Y );

1583

ALT-? TUŞ KOMBİNASYONU Bir çok uygulamaya, programcılar tarafından çeşitli maksatlarla, genellikle de geliştirme ekibi hakkında bilgi vermek için, gizli, sürpriz pencereler yerleştirilmektedir. Zaman zaman dergilerde bu tür uygulamalarla ilgili bilgiler yayınlanmaktadır. Bu tekniği kendi programlarınız içerisinde de kullanabilirsiniz.. Aşağıdaki kod örneğinde, form üzerinde tuşa basıldığında, karakterler bir dizi haline getirilip, listedekilerle karşılaştırılmaktadır. listedekilerden bir tanesi ile çakıştığında ise bir mesaj gösterilmektedir. unit surpriz; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type Tst=array[1..4] of string; const strings:Tst= ('merhaba','güle güle','sürüm','sürpriz'); type TForm1 = class(TForm) procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } s:string; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var i:integer; tamam:integer; begin if (shift=[ssalt]) and (key>=$41) and (key<=$5A) then begin s:=s+chr(key); tamam:=0; for i:=1 to 4 do begin if (s=copy(strings[i],1,length(s))) then Tamam:=-i; if (s=strings[i]) then Tamam:=i; end; if Tamam=0 then s:=''; if Tamam>0 then showmessage(strings[Tamam]);

1584

end; end; procedure TForm1.FormCreate(Sender: TObject); begin S:=''; end; end.

PROGRAMIN DURAKLATILMASI Uses .... Winprocs ....; Procedure delay(millisecs : longint); { Milisaniyelik duraklatma } var Bitir : longint; begin bitir := gettickcount + millisecs; while bitir - gettickcount < 0 do Application.ProcessMessages; end; { delay } Delay(5000), 5 saniyelik bir duraklamaya sebep olur.

YAZI KARAKTERİ STİLİNİN DEĞİŞTİRİLMESİ with edit1 do begin Font.Style := Font.Style + [fsStrikeOut]; Font.Style := Font.Style + [fsUnderline]; Font.Style := Font.Style - [fsBold]; end;

MEVCUT BİR DAVRANIŞIN DEĞİŞTİRİLMESİ Bir sınıf elemanı olan davranışın, alt sınıflarda değiştirilerek kullanılması şu şekilde olur. Sınıf tanımının Protected bölümündeki tanımlama; … procedure Click ; override ; …

Implementation bölümündeki tanımlama procedure TYeniButton.Click ; begin inherited Click ; (Owner as TForm).Close ; end ;

KES, KOPYALA, YAPŞTIR Kesme, Kopyalama ve Yapıştırma işlemlerini, Klavye kullanılarak yapmak oldukça kolaydır. Bu işlemler menü elemanları vasıtasıyla da yapılabilir. Şayet bileşen, bu komutları aldığında ne yapacağını biliyorsa, Windows mesajlarını kullanmak en uygun hareket tarzıdır.

1585

Kesme; if GetFocus <> 0 then { Seçili bir pencere varmı? } SendMessage( GetFocus, WM_CUT, 0, 0 Kopyalama; if GetFocus <> 0 then { Seçili bir pencere varmı? } SendMessage( GetFocus, WM_COPY, 0, 0 Yapıştırma; if GetFocus <> 0 then { Seçili bir pencere varmı? } SendMessage( GetFocus, WM_PASTE, 0, 0); Fare imlecinin, pencere üzerinde olup olmadığının kontrolü Form'un OnMouseMove olayında; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var P : TPoint; begin P.X := X; P.Y := Y; if PtInRect (ClientRect,P) then {bütün pencere için sadece "rect"} MouseCapture := True else begin MouseCapture := False; ShowMessage ('Benim üzerimde değil'); end; end;

GETKEYBOARDSTATE Sistem tuşlarının durumunu öğrenmenin en kolay yolu, klavye üzerindeki LED'lere bakmaktır. Kod içerisinden bunu anlamanın yolu ise aşağıdadır.Tuş durumları, paneller üzerindeki yazının sönük veya koyu olması ile gösterilmektedir. Bu nedenle form üzerine 4 adet panel yerleştirip isimlerini Captio özelliklerini ayarlayın. Ttimer bileşeninin OnTimer olayına da aşağıdaki kodu yazın. procedure TForm1.Timer1Timer(Sender: TObject); const vkconsts: array[0..3] of Word=(vk_Scroll, vk_Insert, vk_Capital, vk_NumLock); PanelColor: array[Boolean] of TColor=(clGray, clBlack); var Toggles: array[0..3] of Bool; Panels: array[0..3] of TPanel ; I: Integer; begin for I := Low(vkconsts) to High(vkconsts) do begin Toggles[I] := Bool(GetKeyState(vkconsts[I]) and 1); if stToggles[I]<>Toggles[I] then begin stToggles[I] := Toggles[I]; case i of 0:PanelScrollLock.Font.Color:=PanelColor[Toggles[I]]; 1:PanelINS.Font.Color:=PanelColor[Toggles[I]]; 2: PanelCAPS.Font.Color:=PanelColor[Toggles[I]]; 3:PanelNUM.Font.Color:=PanelColor[Toggles[I]];

1586

end; end; end; end; {Olay yakalama yordamlarının dinamik olarak atanması Dinamik olarak bir PopUp menü yaratıldığında, menü elemanlarının altına, seçildiklerinde yapacakları işlerle ilgili olarak doğrudan kod yazmak mümkün değildir. Bunun yerine, hangi menü elemanının ne yapacağını bilen tek bir yordam yazıp, gerektiğinde çağırabilirsiniz. Sender özelliğine göre, seçilen menü elemanı da tespit edilip, gereken kod çalıştırılabilir.} procedure MyPopUpClick(Sender : TObject); begin end; Yukarıdaki yordam PopUp menünün OnClick olayına şu şekilde eşitlenir. procedure TForm1.TestButtonClick(Sender: TObject); begin : MyPopUp.OnClick = MyPopUpClick; : end;

SENDER PARAMETRESİNİN KULLANILMASI with Sender as TEdit do begin case Tag of 1: birşeyler yap 2: Başka birşeyler yap end; {case} end;

BÜYÜK METİNLERİN PANODAN ALINMASI var Buffer: PChar; MyHandle : THandle; TextLength : Integer; begin MyHandle := Clipboard.GetAsHandle(CF_TEXT); Buffer := GlobalLock(MyHandle); If Buffer = Nil then begin GlobalUnlock(MyHandle); exit; end; TextLength := StrLen(buffer);

WİNDOWS SÜRÜM NUMARASININ OKUNMASI GetVersion api fonksiyonu kullanılarak, çalışmakta olan Windows'un sürüm numarası nasıl alınabilir. Bu fonksiyonun dödürdüğü sonuç içerisinde sürüm numarası nasıl ayıklanır? program Winvrsn; uses

1587

WinTypes, WinProcs, SysUtils; procedure TForm1.Button2Click(Sender: TObject); var WinVersion : Word; DosVersion : Word; VersionString : String; begin WinVersion := GetVersion and $0000FFFF; DosVersion := (GetVersion and $FFFF0000) shr 16; VersionString := 'DOS : ' + IntToStr(Hi(DOSVersion)) + '.' + IntToStr(Lo(DOSVersion)) + #13 + 'Windows : '+ IntToStr(Lo(WinVersion)) + '.' + IntToStr(Hi(WinVersion)) + #0; MessageBox(0, @VersionString[1],'Version Information', MB_ICONINFORMATION or MB_OK) end;

PROGRAM GURUPLARININ LİSTBOX BİLEŞENİNE DOLDURULMASI Sistemde tanımlı olan program guruplarının elde edilip, bir listbox içerisine doldurulması için neler yapılmalıdır? unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, DdeMan; type TForm1 = class(TForm) Button1: TButton; FGroupsList: TListBox; FDDEClient: TDdeClientConv; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } Procedure ReadGroups; end; var Form1: TForm1; implementation {$R *.DFM} Procedure TForm1.ReadGroups; Var GroupData : PChar; TmpStr : String; FNumGroups, i : integer;

1588

begin GroupData := FDDEClient.RequestData('Groups'); FGroupsList.Clear; FNumGroups := 0; if GroupData = nil then exit else begin i := 0; TmpStr := ''; While GroupData[i] <> #0 do begin if GroupData[i] = #13 then begin FGroupsList.items.Add(TmpStr); TmpStr := ''; i := i + 1; end else TmpStr := TmpStr + GroupData[i]; i := i + 1; end; end; StrDispose(GroupData); end; procedure TForm1.Button1Click(Sender: TObject); begin ReadGroups end; end.

Yukarıdaki kod için kullanılan form ise şu şekildedir. object Form1: TForm1 Left = 200 Top = 111 Width = 374 Height = 486 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -13 Font.Name = 'MS Sans Serif' Font.Style = [] PixelsPerInch = 120 TextHeight = 16 object Button1: TButton Left = 280 Top = 408 Width = 75 Height = 41 Caption = 'Button1' TabOrder = 0 OnClick = Button1Click end object FGroupsList: TListBox Left = 8 Top = 0 Width = 265 Height = 449

1589

ItemHeight = 16 TabOrder = 1 end object FDDEClient: TDdeClientConv DdeService = 'progman' Left = 48 Top = 88 LinkInfo = ( 'Service progman' 'Topic ') end end

TLİSTBOX VE TCOMBOBOX BİLEŞENLERİ İÇERİSİNE RESİM YERLEŞTİRİLMESİ ListBox ve ComboBox bileşenleri içerisine yerleştirilen seçimlik elemanların, sadece metin değil, aynı zamanda BMP formatındaki resimleri de içermesi, tasarladığınız kullanıcı arayüzlerinin, diğerlerinden farklı olmasını sağlar. Bunun için hazırlanmış olan örnek kod aşağıdadır. Unit1.pas; unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) ComboBox1: TComboBox; ListBox1: TListBox; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); private { Private declarations } public { Public declarations } end; var Form1: TForm1; TheBitmap1, TheBitmap2, TheBitmap3, TheBitmap4, TheBitmap5 : TBitmap;

1590

implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin TheBitmap1 := TBitmap.Create; TheBitmap1.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\globe.bmp'); TheBitmap2 := TBitmap.Create; TheBitmap2.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\video.bmp'); TheBitmap3 := TBitmap.Create; TheBitmap3.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\gears.bmp'); TheBitmap4 := TBitmap.Create; TheBitmap4.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\key.bmp'); TheBitmap5 := TBitmap.Create; TheBitmap5.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\tools.bmp'); ComboBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1); ComboBox1.Items.AddObject('Bitmap2: Video', TheBitmap2); ComboBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3); ComboBox1.Items.AddObject('Bitmap4: Key', TheBitmap4); ComboBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5); ListBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1); ListBox1.Items.AddObject('Bitmap2: Video', TheBitmap2); ListBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3); ListBox1.Items.AddObject('Bitmap4: Key', TheBitmap4); ListBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin TheBitmap1.Free; TheBitmap2.Free; TheBitmap3.Free; TheBitmap4.Free; TheBitmap5.Free; end; procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var Bitmap: TBitmap; Offset: Integer; begin with (Control as TComboBox).Canvas do begin FillRect(Rect); Bitmap := TBitmap(ComboBox1.Items.Objects[Index]); if Bitmap <> nil then begin BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed);

1591

Offset := Bitmap.width + 8; end; { display the text } TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index]) end; end; procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index:Integer; var Height: Integer); begin height:= 20; end; procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var Bitmap: TBitmap; Offset: Integer; begin with (Control as TListBox).Canvas do begin FillRect(Rect); Bitmap := TBitmap(ListBox1.Items.Objects[Index]); if Bitmap <> nil then begin BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed); Offset := Bitmap.width + 8; end; { display the text } TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index]) end; end; procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); begin height:= 20; end; end. Unit1.dfm object Form1: TForm1 Left = 211 Top = 155 Width = 526 Height = 320 Caption = 'Form1' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -16 Font.Name = 'System' Font.Style = [] OnClose = FormClose OnCreate = FormCreate

1592

PixelsPerInch = 120 TextHeight = 20 object ComboBox1: TComboBox Left = 33 Top = 38 Width = 206 Height = 22 Style = csOwnerDrawVariable ItemHeight = 16 TabOrder = 0 OnDrawItem = ComboBox1DrawItem OnMeasureItem = ComboBox1MeasureItem end object ListBox1: TListBox Left = 270 Top = 35 Width = 189 Height = 209 ItemHeight = 16 Style = lbOwnerDrawVariable TabOrder = 1 OnDrawItem = ListBox1DrawItem OnMeasureItem = ListBox1MeasureItem end end

BASİT BİR DLL ŞABLONU Delphi'de DLL hazırlamak hiç te zor değil. Aşağıdaki kod örneği derlendiğinde, uzantısı otomatik olarak,DLL olarak verilecektir.. Bu DLL "Fonksiyon" isimli tek bir fonksiyon ihraç etmektedir. library Dllframe; uses WinTypes; function Fonksiyon : string ; export ; begin Result := 'DLL' den merhaba!' ; end; exports Fonksiyon; begin end.

İPUCU PENCERESİNİN ÖZELLEŞTİRİLMESİ Standart ipucu penceresi, kısmen de olsa özelleştirilebilir. İşte örneği. Type TMyHintWindow = Class (THintWindow) Constructor Create (AOwner: TComponent); override; end; var Form1: TForm1; implementation Constructor TMyHintWindow.Create (AOwner: TComponent);

1593

begin Inherited Create (AOwner); canvas.brush.color:=clwhite; Canvas.Font.Name := 'Courier New'; Canvas.Font.Size := 72; end; procedure TForm1.FormCreate(Sender: TObject); begin Application.ShowHint := false; HintWindowClass := TMyHintWindow; Application.ShowHint := True; end; Dizi sabiti tanımı TYPE NAME1 = Array[1..4,1..10] of Integer; Const NAME2 : NAME1 = ((1,2,3,4,5,6,7,8,9,10), (1,2,3,4,5,6,7,8,9,10),(1,2,3,4,5,6,7,8,9,10), (1,2,3,4,5,6,7,8,9,10));

STRİNGRİD BİLEŞENİ İÇERİSİNDEKİ METNİN HİZALAMASI StringGrid bileşeni hücrelerindeki metin, Grid1DrawCell olay yordamına eklenecek birkaç satır kodla hizalanabilir. procedure Tform1.Grid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState); var l_oldalign : word; begin if (row=0) or (col<2) then grid1.canvas.font.style:=grid1.canvas.font.style+[fsbold]; if col<>1 then begin l_oldalign:=settextalign(grid1.canvas.handle,ta_right); grid1.canvas.textrect(rect,rect.right-2, Rect.top+2,grid1.cells[col,row]); settextalign(grid1.canvas.handle,l_oldalign); end else begin grid1.canvas.textrect(rect,rect.left+2,rect.top+2,grid1.cells [col,row]); end; grid1.canvas.font.style:=grid1.canvas.font.style-[fsbold]; end; end.

TSTRİNGGRİD BİLEŞENİNDEN BİR SATIRIN SİLİNMESİ Bu fonksiyonu "RowNumber" parametresi ile belirtilen satırı StringGrid bileşeninden siler.

1594

procedure GridDeleteRow(RowNumber : Integer; Grid : TStringGrid); Var i : Integer; Begin Grid.Row := RowNumber; If (Grid.Row = Grid.RowCount -1) Then Begin {On the last row} Grid.RowCount := Grid.RowCount - 1; End Else Begin {Not the last row} For i := RowNumber To Grid.RowCount - 1 Do Begin Grid.Rows[i] := Grid.Rows[i+ 1]; End; Grid.RowCount := Grid.RowCount - 1; End; End;

TSTRİNGGRİD SATIRININ EN ALTA GÖNDERİLMESİ Bu fonksiyon, "RowNumber" parametresi ile belirtilen satırı, StringGrid bileşeninin en son satırına gönderir. procedure GridMoveRowToBottom(RowNumber : Integer; Grid : TStringGrid); Var i : Integer; Begin Grid.Row := RowNumber; Grid.RowCount := Grid.RowCount + 1; Grid.Rows[Grid.RowCount-1] := Grid.Rows[Grid.Row]; For i := RowNumber+1 To Grid.RowCount -1 Do Begin Grid.Rows[i-1] := Grid.Rows[i]; End; Grid.RowCount := Grid.RowCount - 1; End; Sistemde tanımlı yazıcıların listelenmesi //uses printers var printer:tprinter; begin printer:=tprinter.create; listbox1.items.assign(printer.printers) end;

YAZDIRMA Kullanıcı butona bastığında, bir adet Bitmap nesnesi yaratılıp, içeriği dosyadan alınmakta ve kağıdı ortalayacak şekilde resim basılmaktadır. //uses printers procedure TForm1.Button1Click(Sender: TObject); var

1595

TBitmap bmp; begin bmp = TBitmap.Create; bmp.LoadFromFile('MyBitmap.bmp'); with Printer do begin BeginDoc; Canvas.Draw((PageWidth - bmp.Width) div 2, (PageHeight - bmp.Height) div 2,bmp); EndDoc; end; bmp.Free; end;

İSTENEN YAZICININ SEÇİMİ Sistemde tanımlı birden fazla yazıcı varsa, yazıcılar 0'dan başlayacak şekilde numaralanır. İstenen yazıcının kullanılabilmesi veya hangi yazıcının seçili olduğunun öğrenilmesi için, Tprinter nesnesininin Printerindex özelliği kullanılır. Kullanılmakta olan yazıcının numarası bu özellikte saklanır. Değiştirilecek ise, kullanılacak yazıcının numarası, yine bu özelliğe atanır. Bu özellikte "-1" değeri varsa, varsayılan yazıcı seçili muamelesi görür. //uses printers var printer:tprinter; begin printer:=tprinter.create; printer.printerindex:=0; end;

YAZICI YAZI TİPLERİ Seçili durumaki yazıcı tarafından desteklenmekte olan yazı tipleri aşağıdaki yöntemle listelenir. //uses printers var printer:tprinter; begin printer:=tprinter.create; listbox1.items.assign(printer.fonts) end;

HEX TO DEC Aşağıdaki fonksiyon, 16 tabanındaki bir sayının ondalık sayıya çevirilmesi için kullanılabilecek bir fonksiyondur. procedure TForm1.Button1Click(Sender: TObject); CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15); VAR str : String; Int, i : integer; BEGIN STR:=EDIT1.TEXT; Int := 0; FOR i := 1 TO Length(str) DO IF str[i] < 'A' THEN Int := Int * 16 + ORD(str[i]) - 48

1596

ELSE Int := Int * 16 + HEX[str[i]]; edit1.text:=inttostr(int); end;

HAFIZA MİKTARI unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} Function MyGetExt: Integer; Assembler; asm Mov AX,$3031; Out $70,AL; NOP; IN AL,$71; XCHG AH,AL; Out $70,AL; NOP; IN AL,$71; end; procedure TForm1.Button1Click(Sender: TObject); begin showmessage(inttostr(MyGetExt)) end; end.

FARE HAREKET ALANININ KISITLANMASI Aşağıdaki kod örneğinde, farenin sol tuşuna basılıyken, imleç form üzerinden başka bir yere taşınamamaktadır. unit Unit1; interface

1597

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var r:trect; begin canvas.pen.mode:=pmxor; canvas.Pen.style:=psdot; r:=boundsrect; inflaterect(r,-30,-30); clipcursor(@r); end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin clipcursor(nil); end; end.

PGUP VE PGDOWN TUŞLARI İLE FORMU AŞAĞI YUKARI KAYDIRMA Kalabalık veya küçültülmüş formlarda, bazı kontroller, görünmeyen bölgede kalırlar. Gerektiğinde Kaydırma çubukları ile formun görünmeyen bölgelerine ulaşmak elbetteki mümkündür. Bu işlem, klavye kullanılarak da şu şekilde yapılabilir. Form.Keypreview özelliği TRUE olmalıdır. unit Unit1; interface uses

1598

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Edit1: TEdit; Memo1: TMemo; ListBox1: TListBox; procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); const delta=10; begin with vertscrollbar do if key=vk_next then position:=position+delta else if key=vk_prior then position:=position-delta; end; end.

ÖZEL YAZI KARAKTERİ Kendi yazı karakterinizi kullanın. unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1;

1599

implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var dc:hdc; thefont:hfont; begin dc:=getdc(handle); thefont:=createfont( 24, //yükseklik 16, //ortalama karakter genişliği 0, //yatış açısı 0, //yönlendiröe açısı 400,//yazı karakteri ağırlığı 0, //italiklik bayrağı 0, //alt çizgi bayrağı 0, //vurgu bayrağı oem_charset,// karakter seti out_default_precis,//çıkış vurgusu clip_default_precis,//kesme vurgusu default_quality,//çıktı kalitesi default_pitch or ff_script,//vurgu ve aile 'script'//ad ); selectobject(dc,thefont); textout(dc,10,10,'Merhaba Dünya',24); releasedc(handle,dc); deleteobject(thefont); end; end.

EKRAN KORUYUCU Bir ekran koruyucusu nasıl olur. İşte örneği: · Proje dosyasına, projenin ekran koruyucu olacağına dair bir bilgi satırı eklenmelidir. {$D SCRSAVE · Ana formdaki kenarlıklar, ve ikonlar tamamen kaldırılmalıdır. · Form aktif hale gelirken, Left ve Top değerleri "0" a eşitlenmelidir. · Form.Windowstate=WsMaximized olmalıdır. · Formun yaratılması esnasında, Application.Onmessage olay yordamına, Ekran koruyucunun devreden çıkmasını sağlayacak yordam atanmalıdır. · Program parametrelerine "/c" eklenmelidir. (Run | Parameters menüsünden) · Program derlendikten sonra uzantısı "SCR" olarak değiştirilmeli ve Windows dizinine kopyalanmalıdır. Scrn.PAS unit Scrn; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TScrnFrm = class(TForm) tmrTick: TTimer; procedure tmrTickTimer(Sender: TObject);

1600

procedure FormShow(Sender: TObject); procedure FormHide(Sender: TObject); procedure FormActivate(Sender: TObject); private { Private declarations } procedure DrawSphere(x, y, size : integer; color : TColor); procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean); public { Public declarations } end; var ScrnFrm: TScrnFrm; implementation {$R *.DFM} var crs : TPoint; {Fare imlecinin orjinal yeri.} function Min(a, b : integer) : integer; begin if b < a then Result := b else Result := a; end; {Min} procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor); var i, dw : integer; cx, cy : integer; xy1, xy2 : integer; r, g, b : byte; begin with Canvas do begin {Fırça ve kalem şekilleri.} Pen.Style := psClear; Brush.Style := bsSolid; Brush.Color := color; {Renk karışımları.} r := GetRValue(color); g := GetGValue(color); b := GetBValue(color); {Topların çizimi.} dw := size div 16; for i := 0 to 15 do begin xy1 := (i * dw) div 2; xy2 := size - xy1; Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255), Min(b + (i * 8), 255)); Ellipse(x + xy1, y + xy1, x + xy2, y + xy2); end; end; end; {TScrnFrm.DrawSphere} procedure TScrnFrm.DeactivateScrnSaver(var Msg : TMsg; var

1601

Handled : boolean); var done : boolean; begin if Msg.message = WM_MOUSEMOVE then done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or (Abs(HIWORD(Msg.lParam) - crs.y) > 5) else done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN); if done then Close; end; {TScrnFrm.DeactivateScrnSaver} procedure TScrnFrm.tmrTickTimer(Sender: TObject); const sphcount : integer = 0; var x, y : integer; size : integer; r, g, b : byte; color : TColor; begin Inc(sphcount); x := Random(ClientWidth); y := Random(ClientHeight); size := 25; x := x - size div 2; y := y - size div 2; r := Random($80); g := Random($80); b := Random($80); DrawSphere(x, y, size, RGB(r, g, b)); end; {TScrnFrm.tmrTickTimer} procedure TScrnFrm.FormShow(Sender: TObject); begin GetCursorPos(crs); tmrTick.Interval := 100; tmrTick.Enabled := true; Application.OnMessage := DeactivateScrnSaver; ShowCursor(false); end; {TScrnFrm.FormShow} procedure TScrnFrm.FormHide(Sender: TObject); begin Application.OnMessage := nil; tmrTick.Enabled := false; ShowCursor(true); end; {TScrnFrm.FormHide} procedure TScrnFrm.FormActivate(Sender: TObject); begin WindowState := wsMaximized;

1602

end; {TScrnFrm.FormActivate} end. Spheres.DPR program Spheres; uses Forms, SysUtils, Scrn in 'SCRN.PAS' {ScrnFrm}; {$R *.RES} {$D SCRNSAVE Spheres Ekran koruyucu} begin {Sadece birkez çalışmalı.} if hPrevInst = 0 then begin if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin Application.CreateForm(TScrnFrm, ScrnFrm); application.initialize; Application.Run; end else application.Terminate; end; end.

BİR NESNEDEKİ ÖZELLİKLERİN LİSTESİ procedure ObjectInspector( Obj : TObject; Items : TStrings ); var n : integer; PropList : TPropList; begin n := 0; GetPropList( Obj.ClassInfo, tkProperties + [ tkMethod ], @PropList ); while( (Nil <> PropList[ n ]) and (n < High(PropList)) ) do begin Items.Add( PropList[ n ].Name + ': ' + PropList[ n ].PropType^.Name ); Inc( n ); end; end;

HABERLEŞME PORTLARINA ERİŞİM Haberleşme kanallarından bilgi almak veya kanallara bilgi yazmak için aşağıdaki fonksiyonlar kullanılabilir. Belirtilen numaradaki kanala her seferinde bir Byte bilgi yazılabilir veya kanaldan 1 Byte''ık bilgi okunabilir. function ReadPortB ( wPort : Word ) : Byte; begin asm

1603

mov dx, wPort in al, dx mov result, al end; end; procedure WritePortB ( wPort : Word; bValue : Byte ); begin asm mov dx, wPort mov al, bValue out dx, al end; end;

BİLEŞEN ÖZELLİKLERİNİN KAYIT DEFTERİNDE SAKLANMASI Bileşenlerin, Published tipindeki özellikleri, kayıt defterine yazılarak, gelecekte tekrar kullanılmak üzere saklanabilir. Örnek kod aşağıdadır. unit unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,registry,TypInfo, StdCtrls; type TForm1 = class(TForm) xxzzbtn1: TButton; procedure xxzzbtn1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry); procedure SaveToKey(Obj: TPersistent; const KeyPath: string); procedure SaveSetToRegistry(const Name: string; Value: Integer; gTypeInfo: PTypeInfo; Reg: TRegistry); procedure SaveObjToRegistry(const Name: string; Obj: TPersistent; Reg: TRegistry); procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;Reg: TRegistry); var Form1: TForm1; implementation {$R *.DFM} {integer sayıların, bitlerine ulaşabilmek için, bir tip kümesi oluşturulmalıdır. } const

1604

BitsPerByte = 8; type TIntegerSet = set of 0..SizeOf(Integer)*BitsPerByte - 1; { Özellik kümesini, ayrı bir alt anahtar altına BOLLEAN olarak kaydederek, sonradan REGEDIT vasıtasıyla düzeltme imkanı elde edilir. } procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry); var PropList: PPropList; PropCount: Integer; I: Integer; begin { Published özelliklerin listesini oluştur. } PropCount := GetTypeData(Obj.ClassInfo)^.PropCount; GetMem(PropList, PropCount*SizeOf(PPropInfo)); try GetPropInfos(Obj.ClassInfo, PropList); { Her özelliği, mevcut anahtara ait bir değer olarak sakla } for I := 0 to PropCount-1 do SavePropToRegistry(Obj, PropList^[I], Reg); finally FreeMem(PropList, PropCount*SizeOf(PPropInfo)); end; end; { Published özellikleri, verilen anahtarın altına değer olarak yaz. Bu anahtar, HKEY_CURRENT_USER.anahtarının altında yer alacaktır. } procedure SaveToKey(Obj: TPersistent; const KeyPath: string); var Reg: TRegistry; begin Reg := TRegistry.Create; try if not Reg.OpenKey(KeyPath, True) then raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[KeyPath]); SaveToRegistry(Obj, Reg); finally Reg.Free; end; end; procedure SaveSetToRegistry(const Name: string; Value: Integer; gTypeInfo: PTypeInfo; Reg: TRegistry); var OldKey: string; I: Integer; pppTypeInfo:PPTypeInfo; begin pppTypeInfo := GetTypeData(gTypeInfo)^.CompType; OldKey := '\' + Reg.CurrentPath; if not Reg.OpenKey(Name, True) then raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[Name]); { Enumarated tipli değişken değerlerini teker teker dolaş } with GetTypeData(gTypeInfo)^ do

1605

for I := MinValue to MaxValue do { her küme elemanı için, bir BOOLEAN değer yaz. } Reg.WriteBool(GetEnumName(gTypeInfo, I), I in TIntegerSet(Value)); { Üst anahtara dön. } Reg.OpenKey(OldKey, False); end; {Bütün alt nesnelerin özelliklerini, alt anahtar altına yaz} procedure SaveObjToRegistry(const Name: string; Obj: TPersistent;Reg: TRegistry); var OldKey: string; begin OldKey := '\' + Reg.CurrentPath; { Nesne için bir alt anahtar aç. } if not Reg.OpenKey(Name, True) then raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[Name]); { Nesne özelliklerini sakla } SaveToRegistry(Obj, Reg); {Üst anahtara dön } Reg.OpenKey(OldKey, False); end; { Bir davranışın kayıt defterine saklanması. } procedure SaveMethodToRegistry(const Name: string; const Method:TMethod;Reg: TRegistry); var MethodName: string; begin { Method işaretçisi nil ise sadece boş bir karakter dizisi yaz. } if Method.Code = nil then MethodName := '' else { davranışın adını bul. } MethodName := TObject(Method.Data).MethodName(Method.Code); Reg.WriteString(Name, MethodName); end; { Tek bir özelliği kayıt defterine mevcut anahtarın altına kaydetmek için } procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;Reg: TRegistry); begin with PropInfo^ do case PropType^.Kind of tkInteger, tkChar, tkWChar: begin { ordinal özellikleri integer olarak sakla. } Reg.WriteInteger(Name, GetOrdProp(Obj, PropInfo)); end; tkEnumeration: { enumerated değerleri kendi isimleriyle sakla. }

1606

Reg.WriteString(Name, GetEnumName(PropType^, GetOrdProp(Obj,PropInfo))); tkFloat: { floating point değerleri Double olarak sakla. } Reg.WriteFloat(Name, GetFloatProp(Obj, PropInfo)); tkString, tkLString: { Store değerler strin olarak kalsın. } Reg.WriteString(Name, GetStrProp(Obj, PropInfo)); tkVariant: { variant değerler string olarak saklansın. } Reg.WriteString(Name, GetVariantProp(Obj, PropInfo)); tkSet: { kümeler alt anahtara saklansın. } SaveSetToRegistry(Name, GetOrdProp(Obj, PropInfo), PropType^,Reg); tkClass: { sınıflar da alt sınıf olarak saklansın, özellikleri de bu anahtarın altına değer olarak yazılsın.} SaveObjToRegistry(Name, TPersistent(GetOrdProp(Obj, PropInfo)),Reg); tkMethod: { davranışlar isim olarak yazılsın. } SaveMethodToRegistry(Name, GetMethodProp(Obj, PropInfo), Reg); end; end; procedure TForm1.xxzzbtn1Click(Sender: TObject); var r:tregistry; begin r:=tregistry.create; r.openkey('f1delphi\'+form1.name,true); SaveToRegistry(form1, R); r.free; end; end.

LİSTBOX İÇERİSİNDE ARTAN ARAMA Bir listbox içerisinden seçilerek başka bir alana, örneğin bir edit kontrolüne atanacak değerlerin seçim için, artan arama yapılabilir. Artan arama , edit içerisine yazdığınız bilgiye uygun olan ListBox elemanının otomatik olarak seçili hale gelmesi demektir.Kod örneği aşağıdadır. unit incsearch; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) ListBox1: TListBox; Edit1: TEdit; procedure FormCreate(Sender: TObject); procedure Edit1Change(Sender: TObject);

1607

procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin // ComboBox'un içine birşeyler doldurun end; procedure TForm1.Edit1Change(Sender: TObject); var S : Array[0..255] of Char; begin StrPCopy(S, Edit1.Text); with ListBox1 do ItemIndex := Perform(LB_SELECTSTRING, 0, LongInt(@S)); end; procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if key=vk_return then edit1.text:=listbox1.Items[listbox1.itemindex]; end; end. Sistem menüsünün geliştirilmesi unit sysmenu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } public {Aşağıdaki tanım, mesaj yakalama yordamı içindir. Yeni eklenen menü elemanına tıklandığının tespiti için kullanılacaktır.} procedure WinMsgHandler(var Msg : TMsg; var Handled : Boolean); end; var Form1: TForm1;

1608

const MyItem = 100; {Herhangi bir WORD değer olabilir.} implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin {Varolandan farklı bir mesaj yakalama yordamı kullanılacak} Application.OnMessage := WinMsgHandler; {Menüye Bir ayıraç ekleniyor.} AppendMenu(GetSystemMenu(Self.Handle, False), MF_SEPARATOR, 0, ''); {Mevcut sistem menüsünün en sonuna, Yeni menü ekleniyor} AppendMenu(GetSystemMenu(Self.Handle, False), F_BYPOSITION, MyItem, 'Yeni &Menü'); end; procedure TForm1.WinMsgHandler(var Msg : TMsg; var Handled : Boolean); begin {Eğer mesaj, sistem mesajı ise...} if Msg.Message=WM_SYSCOMMAND then if Msg.wParam = MyItem then {Menünüzün yapacağı işle ilgili kod buraya yazılacak} ShowMessage('Yenü menüye tıkladınız!!!'); end; end.

BİR TEDİT.TEXT BİLGİSİNDEKİ DEĞİŞİKLİĞİN FARKEDİLMESİ var changed:boolean; i:integer; begin changed:=false; for i:=0 to componentcount-1 do if components[i] is tedit then changed:=(components[i] as tedit).modified; if changed then showmessage('değişti'); end;

COMBOBOX BİLEŞENİNİN, İÇİNE GİRİLDİĞİNDE AÇILMASI VE KAPANMASI Sendmessage(combobox1.handle,cb_showdropdown,integer(true),0); Sendmessage(combobox1.handle,cb_showdropdown,integer(false),0);

1609

YAZICIYA DOĞRUDAN BASKI GÖNDERME İŞLEMİ unit Esc1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation uses Printers; {$R *.DFM} { "PASSTHROUGH" yapısını belirle } type TPrnBuffRec = record BuffLength : word; Buffer : array [0..255] of char; end; procedure TForm1.Button1Click(Sender: TObject); var Buff : TPrnBuffRec; TestInt : integer; s : string; begin { "PASSTHROUGH" işleminin desteklendiğinden emin ol } TestInt := PASSTHROUGH; if Escape(Printer.Handle, QUERYESCSUPPORT, sizeof(TestInt), @TestInt, nil) > 0 then begin { Baskıyı başlat } Printer.BeginDoc; { Doğrudan gönderilecek metni hazırla } s := ' Test satırı '; { Mtni Buffer'a kopyala } StrPCopy(Buff.Buffer, s);

1610

{ Buffer uzunluğunu ayarla } Buff.BuffLength := StrLen(Buff.Buffer); { Gönder} Escape(Printer.Canvas.Handle, PASSTHROUGH, 0, @Buff, nil); { Baskıyı bitir } Printer.EndDoc; end; end; end.

BİLGİSAYARI KAPATIP YENİDEN BAŞLATMA Bilgisayarı kapatıp, yeniden başlatmak için kullanılabilecek bir kod parçacığı aşağıdadır. Not : Bu kodu denemeden önce, dosyalarınızı kaydedin. asm cli @@WaitOutReady: {Meşgul- 8042 yeni bir komut için hazır olana kadar bekle} in al,64h {8042 durumunu oku} test al,00000010b { 1 nolu bit veri giriş bufferinin dolu olduğunu gösterişri } jnz @@WaitOutReady mov al,0FEh { "reset" = 8042 pin 0 } out 64h,al { PC kapanıp yeniden açılacak } End;

1611

SQL (STRUCTURED QUERY LANGUAGE) YAPISAL PROGRAMLAMA DİLİ Veri tabanı işlemleri yaparken, bilgilerin ortak özelliklerine göre sorgularının yapılmasını SQL dili ile sağlarız. SQL dili ile bir Query yani sorgulama oluşturmak oldukça basittir. SQL dilinde kullanılan belli baslı önemli komutlar aşağıda anlatılmaktadır. Bundan önce Select Komutu ile SQL de kullanılan komutları kalıp halinde yazalım, daha sonra bunları açıklayacağız. Select Tablo1.Alan1, Tablo1.Alan2, ... [ * ] From TabloAdi Where Sorgulama İfadesi Group By Gruplanacak Hücreler Order By Küçükten büyüğe yada Büyükten küçüğe Hücrelerin sıralanması Having Gruplanan yada birleştirilen kayıtların hangi kritere göre sorgulanması Select ile kullanılmayan SQL komutlarından bazıları da şunlardır : Insert Into Tablo1 (Alan1,Alan2) Values ('String İfade',Sayısal İfade ...) Delete * From Tablo1 Where Sorgulama İfadesi Update Tablo1 set Tablo1.Alan1='String İfade',Tablo1.Alan2=Sayısal İfade, ... Where Sorgulama İfadesi

SQL Komutları FROM Deyimi From deyimi sorgulanacak ve kullanılacak bilgilerin hangi tablodan alınacağını belirtir. Tablodan hangi hücrelerin içindeki bil-gilerin kullanılacağını ise; TabloAdi.Hücre1, TabloAdi.Hücre2, ... veya * jokeri ile belirleriz. Bir örnek ile daha iyi anlayacağız. Öğrenci Tablosu; ADI SOYADI NO metin[20] metin[20] sayı Örnek : Öğrenci tablosu ADI, SOYADI, NO olmak üzere 3 hücreden oluşan bir tablo olsun. SQL ile, Bu tablodan ADI ve SOYADI hücrelerini seçerek yeni bir tablo (Bu bir sorgudur{Query} ) oluşturunuz. Select Öğrenci.ADI, Öğrenci.SOYADI From Öğrenci Eğer tüm hücreleri seçin deseydik ; o zaman yazacağımız SQL cümlesi söyle olmalı idi. : Select Öğrenci.ADI, Öğrenci.SOYADI, Öğrenci.NO From Öğrenci yada Select * From Öğrenci

WHERE Deyimi Where deyimini de ; bir tablodan istediğimiz hücreleri seçerken, o tabloda bulunan kayıtlardan hangilerini, hangi kriterlere göre almak istersek kullanırız. Yani tabloda bulunan kayıtlardan hangilerini almak istiyorsak istediğimiz koşulu where deyiminden sonra kullanarak bu kayıtları elde edebiliriz. Aşağıdaki örnekleri inceleyelim... Örnek 1 : Yine Öğrenci tablosunda bulunan kayıtlardan Adi Serkan olan öğrencileri seçmemizi sağlayan SQL cümlesi şöyledir: Select * From Öğrenci Where Öğrenci.ADI = "Serkan" Örnek 2: Yada soyadında " r " harfi geçen öğrencileri Aşağıdaki SQL cümlesi ile seçeriz..: Select * From Öğrenci Where Öğrenci.SOYADI = "%r%" Örnek 3: Eğer Tabloda bulunan kayıtlardan diyelim ki; numarası 1044 ile 2866 arasında olan öğrencileri seçmek istersek Aşağıdaki SQL cümlesini kullanırız..: Select * From Öğrenci Where 1044<Öğrenci.NO<2866

GROUP BY Deyimi Group by deyimi SUM, COUNT kullanarak toplam bir sonuç ile bir tablodan istenilen kritere göre istenilen hücreler alınır ve yine group by 'dan sonra yazılan hücrelere göre gruplanır. GROUP BY isteğe bağlıdır. SELECT deyiminde SQL toplam işlevi yoksa özet değerler göz ardı edilir.

1612

Örnek 1 : Yine Öğrenci tablomuzu kullanaraktan soyadı Türkel olan öğrencileri seçerek AD, SOYAD ve NO fieldlarina göre gruplandıralım...: Select Öğrenci.AD, ögreci.SOYAD, Öğrenci.NO From Öğrenci Where Öğrenci.SOYAD='Türkel' Group By Öğrenci.AD, ögreci.SOYAD, Öğrenci.NO

ORDER BY Deyimi Order By deyimi ile de; sorgulama sonucunda bulunan kayıtlar verilen hücrelere göre, Büyükten küçüğe yada Küçükten büyüğe doğru sıralanır. Örnek 1 : Adi Serkan olan Öğrencilerin numaralarını Küçükten büyüğe doğru sıralayınız..: Select * From Öğrenci Where Öğrenci.AD='Serkan' Order By Öğrenci.NO [asc] asc yi yazmasak da burada default değer olduğu için Küçükten büyüğe doğru sıralama yapardı. Eğer büyükten küçüğe doğru sırala dese idik o zaman söyle bir SQL cümlesi yazmalıydık...: Select * From Öğrenci Where Öğrenci.AD='Serkan' Order By Öğrenci.NO Desc

HAVING Deyimi Having Deyimi de; GROUP BY yan tümcesi olan bir SELECT deyiminde hangi gruplandırılmış kayıtların görüntüleneceğini belirler. Yani GROUP BY kayıtları birleştirdikten sonra, HAVING deyimi de, HAVING yan tümcesinin koşullarını sağlayan ve GROUP BY yan tümcesi ile gruplandırılmış kayıtları görüntüler. Örnek 1 Öğrenci tablosundan AD, SOYAD ve NO fieldlarini alıp bunları gruplayan ve sonra bunları da numarası 1000 ile 2000 arasında olan kayıtlara göre listeleyen SQL cümlesini yazınız..: Select Öğrenci.AD, Öğrenci.SOYAD, Öğrenci.NO From Öğrenci Group By Öğrenci.AD, Öğrenci.SOYAD, Öğrenci.NO Having 1000<Öğrenci.NO<2000

INSERT INTO Deyimi Insert Into Deyimi bir tabloya bir veya daha çok sayıda kayıt eklemeye yarayan SQL komutudur. Buna ekleme sorgusu da denir. Esas kullanılma kalıbı Aşağıdaki gibidir..: Çok sayıda kayıt ekleme sorgusu: INSERT INTO TabloAdi [(alan1[, alan2[, ...]])] [IN disveritabani] SELECT [kaynak.]alan1[, alan2[, ...] FROM tabloifadesi Tek kayıt ekleme sorgusu: INSERT INTO TabloAdi [(alan1[, alan2[, ...]])] VALUES (deger1[, deger2[, ...]) Örnek 1 : Öğrenci tablosuna AD = "Serkan" SOYAD = "Türkel" NO = 4683 bilgilerini ekleten SQL cümlesini yazın..: Insert Into Öğrenci (AD,SOYAD,NO) Values('Serkan','Türkel',4683)

DELETE Deyimi Delete deyimini bir tablodan bir yada daha fazla kayıt silmek için kullanırız. Aşağıdaki gibi bir yazılış kalıbı vardır..: DELETE [Tablo.*] FROM Tablo WHERE sorgulama ifadesi Örnek 1 : Yine Öğrenci tablosundan numarası 4556 olan öğrencinin kaydını silen SQL cümlesiniz yazınız..: Delete * From Öğrenci Where Öğrenci.NO=4556

UPDATE Deyimi Belirtilen kriterlere göre tablodan ilgili kayıt/kayıtları alarak değerlerini değiştirmeye yarayan SQL komutudur. Kullanılış kalıbı Aşağıdaki gibidir..: UPDATE Tablo SET yenideger WHERE Sorgulama İfadesi Örnek 1 : Öğrenci tablosuna eklediğimiz 4683 numaraları Serkan Türkel 'in adini ve soyadını değiştirelim. Adi = "Ali", soyadı = "Sert" olsun. SQL cümlesini yazın...: UPDATE Öğrenci SET Öğrenci.AD = 'Ali',Öğrenci.SOYAD = 'Sert' Where Öğrenci.NO = 4683 SQL Fonksiyonları

1613

SQL yazılımında sorgulama yapılırken kullanılabilecek aritmetik fonksiyonlar tabloda verilmiştir... SUM Yapılan sorgulamada kriteri karşılayan sayısal bilgilerin toplamını verir. AVG Yapılan sorgulamada kritere karşılık gelen sayısal bilgilerin aritmetik ortalamasını alır. COUNT Yapılan sorgulamada kritere uyan sayısal bilgilerin adetini hesaplar. MAX Yapılan sorgulamada kritere uyan sayısal bilgilerin en büyük değerini yakalar. MIN Yapılan sorgulamada kritere uyan sayısal bilgilerin en küçük değerini yakalar. STDEV Yapılan sorgulamada kritere uyan sayısal bilgilerin standart sapmasını alır. STDEVP Yapılan sorgulamada kritere uyan sayısal bilgilerin istatistiksel standart sapmasını alır. VAR Yapılan sorgulamada kritere uyan sayısal bilgilerin varyansını alır. VARP Yapılan sorgulamada kritere uyan sayısal bilgilerin istatistiksel varyansını alır.

1614

SQL SQL (Structured Query Language) veri tabanlarındaki verileri işlemek için kullanılan yapısal sorgulama dilidir. Bu dil yardımıyla veritabanlarındaki tüm işlemler yapılabilir. Backup almadan tutunda bir tabloya veri girmeye varıncaya kadar herşey. SQL'i şu anda piyasada bulunan hemen hemen her veritabanında kullanabilirsiniz. SQL'de her veritabanında kullanılan ortak ifadeler olmasına karşın, veritabanlarının kendine özgü ifadeleri de vardır. Mesela Oracle’da SQL ile yapabildiğiniz bazı şeyleri başka veritabanlarında yapamayabilirsiniz. SQL temel olarak şu ifadelerle kullanılır. SELECT, FROM, WHERE, ORDER BY, GROUP BY, HAVING, UPDATE, DELETE, INSERT. Burada kullandığımız SQL cümleleri ISCI adlı bir tablo üzerine yazılmıştır. Alanlar. ISCI_NO

ISCI_ADI

YAS

GIRIS_TARIHI

MAAS

SELECT: Tablodan seçmek istediğimiz alanları belirtmek için kullanılır. Eğer tablodan tüm alanları seçmek istiyorsak o zaman alan isimleri yerine * işareti konur. FROM: Üzerinde işlem yapılacak tablo/tabloları belirtmek için kullanılır. WHERE: Tablodan eğer tüm kayıtları değilde istediğimiz bazı kayıtları elde etmek istiyorsak, örnekte maaşı 250 milyondan fazla olan işçilerin numarası ve adi gibi, o zaman buraya istediğimiz kriteri yazarız. SELECT ISCI_NO, ISCI_ADI FROM ISCI WHERE MAAS>250000000 DISTINCT: Birbirinin aynı olan satırların listelenmemesi için bu ifade kullanılır. Mesela ISCI tablosunda bulunan birbirinin aynı olmayan isimleri listelemek istersek SELECT DISTINCT ISCI_ADI FROM ISCI şeklinde bir SQL ifadesi yazarız. IN: Koşul belirtirken kullanırız. Mesela ismi AHMET, ALİ veya MUSTAFA olan işçilerin bilgilerini listelemek için SELECT * FROM ISCI WHERE ISCI_ADI=’AHMET’ OR ISCI_ADI=’ALİ’ OR ISCI_ADI=’MUSTAFA’ şeklinde bir ifade kullanırız. Bunun yerine SELECT * FROM ISCI WHERE ISCI_ADI IN (’AHMET’ ,’ALİ’ ,’MUSTAFA’) ifadesini de kullanabiliriz. Yani listenin içindeki herhangi bir değerin bulunması kayıtın seçilmesi için yeterlidir. LIKE: Eğer aradığımız kayıtın bulunması için tam bir karşılaştırma yapamıyorsak o zaman kullanırız. Mesela isminin baş harfi A ile başlayan isimleri bulmak için SELECT * FROM ISCI WHERE ISCI_ADI LIKE ‘A%’ ifadesi kullanılır. % işareti uzunluğu önemsiz olmak üzere yazıldığı yere her türlü ifade gelebilir anlamındadır. ? işareti ise bir karakter olmak üzere her türlü değeri alabilir anlamındadır. Mesela isminin sondan üçüncü harfi A, ve son harfi Z olan kayıtları listelemek istersek sondan ikinci harfin ne olduğu önemli değildir. O zaman o harf yerine aşağıda görüldüğü üzere ? işaretini kullanırız.

1615

SELECT * FROM ISCI WHERE ISCI_ADI LIKE ‘%A?Z’ ifadesi kullanılır. BETWEEN: Koşul belirtirken iki değer arasını belirtmek için kullanılır. Örnek: Yaşı 30 ile 40 arasındaki işçilerin kayıtlarını listelemek için SELECT * FROM ISCI WHERE YAS BETWEEN 30 AND 40 ifadesi kullanılır. Bunu aynı zamanda aşağıdaki ifade ile de yapabilirsiniz. BETWEEN yazım kolaylığı sağlar. SELECT * FROM ISCI WHERE YAS>=30 AND YAS<=40 SUM: Seçilen değerlerin toplamını bulur. İşçilerin aldığı toplam ücreti görmek için SELECT SUM(UCRET) FROM ISCI ifadesi kullanılır. MAX, MIN, AVG: Verilen değerin en büyüğünü, en küçüğünü ve ortalamasını bulur. 1999 yılında giren işçilerin en yüksek ücretinin, en düşük ücretinin ve ortalamasının ne kadar olduğunu öğrenmek istersek aşağıdaki ifadeyi kullanırız. SELECT MAX(UCRET), MIN(UCRET), AVG(UCRET) FROM ISCI WHERE GIRIS_TARIHI>’01.01.1999’ MAX en büyük değeri, MIN en küçük değeri, AVG ise seçilen değerlerin ortalmasını bulur. ORDER BY: Tablodan seçtiğimiz kayıtları sıralamak için kullanılır. Yukardaki örnekte isimleri alfabetik sıra ile görmek istersek SELECT DISTINCT ISCI_ADI FROM ISCI ORDER BY ISCI_ADI yazarız. Eğer sıralamayı tersine çevirmek istersek SELECT DISTINCT ISCI_ADI FROM ISCI ORDER BY ISCI_ADI DESC yazarız. GROUP BY: Genelde istatistik amaçlar için kullanılır. Mesela hangi tarihte kaç işçinin işe alındığını bulmak için SELECT GIRIS_TARIHI,COUNT(*) FROM ISCI GROUP BY GIRIS_TARIHI yazmanız yeterli olacaktır. Bu ifade size gün bazında kaç işçinin işe alındığını gösterecektir. Eğer belli bir tarihten önce ya da sonrasını isterseniz veya sadece sayının 10’dan büyük olduğu günleri görmek isterseniz o zaman ifadeyi şu şekilde yazmak gerekir. SELECT GIRIS_TARIHI,COUNT(*) FROM ISCI WHERE GIRIS_TARIHI>’01.01.1999’ GROUP BY GIRIS_TARIHI HAVING COUNT(*)>10 HAVING, grup fonksiyonlarının kriterleri için kullanılır. SUM, COUNT vb. gibi. UPDATE: Tabloda bulunan bir istediğiniz bir veya daha fazla alanın güncellenmesi amacıyla kullanılır. Mesela işçilerin maaşlarına % 20 zam yapıldığını düşünürsek aşağıdaki ifade ile bunu tabloda gerçekleştirebiliriz. UPDATE ISCI SET MAAS=MAAS*1.2 Eğer maaşlarla birlikte aldıkları primleri de %20 oranında artırmak isterseniz UPDATE ISCI SET MAAS=MAAS*1.2 , PRIM=PRIM*1.2 şeklinde bir ifade kullanılır. Aynı zamanda WHERE ifadesini kullanarak sadece belli kayıtlar üzerinde güncelleme yapabilirsiniz. DELETE: Tabloda bulunan kayıtları silmek için kullanılır. Eğer DELETE FROM ISCI

1616

derseniz tüm kayıtları gönderirsiniz. DELETE ifadesini kullanırken dikkatli olun. Buradada yine WHERE ifadesini kullanarak sadece belli kritere uyan kayıtların silinmesini sağlayabilirsiniz. Kötü bir örnek ama olsun, patron 45 yaşından büyük işçileri işten attı (burası Türkiye, olmaz demeyin) ve kayıtlarının silinmesi isteniyor. O zaman DELETE FROM ISCI WHERE YAS>45 ifadesi kullanılır. INSERT: Tablolara veri girişi yapmak amacıyla kullanılır. INSERT INTO ISCI (ISCI_NO,ADI,SOYADI) VALUES (1000,’AHMET’,’SAVAŞ’); Eğer giriş yaparken tablonun bütün alanları kullanılacaksa alan isimlerini vermeye gerek yoktur. Not: UPDATE, DELETE ve INSERT ifadelerini kullanırken dikkatli olmalısınız. Eğer SQL tabanlı bir veri tabanı kullanıyorsanız bu ifadeleri veritabanlarının kendi tool’ları üzerinde kullanın. Çünkü Delphi ile gelen SQL Explorer’da işaretine basmayı unutursanız yaptığınız işlemin geri dönüşü olmayabilir. Yani en son yaptığınız işlemi Rollback yapamazsınız ve eğer gerçek veritabanı üzerinde yaptıysanız işlemi başınız bayağı ağrıyabilir veya o iş yerinde yazdığınız son SQL ifadesi olabilir. :-)) İKİ TABLODAN BİRDEN KAYIT SEÇMEK: İşçilerin kimlik bilgilerinin ISCI_KIMLIK tablosunda tutulduğunu kabul ederek bizden ÇORUM doğumlu olanların listesinin istendiğini varsayalım. Tablolar birbirine ISCI_NO alanı üzerinden ilişkili olsun. SELECT A.ISCI_NO, A.ISCI_ADI, B.DOGUM_YERI FROM ISCI A, ISCI_KIMLIK B WHERE B.DOGUM_YERI=’ÇORUM’ AND A.ISCI_NO=B.ISCI_NO şeklinde bir ifade yazarak listemizi elde edebiliriz. Burada WHERE koşuluna yazdığınız sıranın pek bir önemi yoktur. Her şartta aynı sonuçları elde ederseniz. Fakat performans açısından biraz farkeder. Yukardaki ifade SELECT A.ISCI_NO, A.ISCI_ADI, B.DOGUM_YERI FROM ISCI A, ISCI_KIMLIK B WHERE A.ISCI_NO=B.ISCI_NO B.DOGUM_YERI=’ÇORUM’ ifadesinden daha hızlı çalışır. Çünkü ilk ifadede önce doğum yeri ÇORUM olan kayıtlar seçilir daha bu kayıtlara işçi tablosu birleştirilir. Sonraki ifadede ise önce tüm kayıtlar birleştirilir, bunların arasından doğum yeri ÇORUM olanlar seçilir. DISTINCT

TEKRARSIZ

TANIM: SQL’de tablo içinde birbirinin aynı datalar bulunabilir.Aynı satırların listeleme esnasında bir kez yazılması ÖRNEK: 1)Par _sat dosyasından sat_no’ları tekrarsız olarak listelenecektir. ORDER BY

SIRALA

TANIM: Tablodaki sütunlardan ,belirli bir sütuna göre listelemek için SEÇ komutuna, SIRALA eklenir. ÖRNEK: 1)Personel dosyasından,sicil,ad,soyad,brüt sütunlarını seç ve brüt(maaşa)göre büyükten küçüğe sırala. SELECT sicil,ad,soyad,brüt

SEÇ sicil,ad,soyad,brüt

FROM personel

GELİŞ personel

ORDER BY brüt ASC; DESC

SIRALA brüt B-K;

Küçükten büyüğe sırala

ASC

Büyükten küçü ğe sırala

İİ)BİRDEN ÇOK ALANA GÖRE SIRALAMA: TANIM:Bir tablo içinde ,birden fazla sütundan aynı anda sıralamak için kullanılır. ÖRNEK 1)Personel dosyasından seçilen sütunlarını aynı anda hem ad,hem de otomatik olarak sıralar. SELECT sicil,ad,soyad,brüt


1617

FROM personel

GELİŞ personel

ORDER BY ad,brüt;

SIRALA ad,brüt;

ÖRNEK 2)Personel tablosundan seçili sütunları öncelik adda olmak üzere (B-K) adı bozmadan soyadı (K-B) sıralı listeler. SELECT sicil,ad,soyad,brüt


FROM personel

GELİŞ personel

ORDER BY ad ASC,soyad DESC,

SIRALA ad B-K,soyad K-B,

brüt ASC;

brüt B-K;

veya; SELECT sicil,ad,soyad,brüt


FROM personel

GELİŞ personel

ORDER BY ad,soyad DESC,brüt;

SIRALA ad,soyad K-B,brüt;

DESC’li durumda yanına yazıp belirtilir,yazılmazsa ASC direct kabul edilir. KOŞULA BAĞLI OLARAK LİSTELEME: WHERE OLAN TANIM:Verilen koşulu sağlayanlar listelenir.İki veri birbiriyle karşılaştırılmaktadır. Karşılaştırılan verilerin türü aynı olmalıdır. SELECT * SEÇ * FROM personel GELİŞ personel WHERE brüt > 5000000; OLAN brüt > 5000000; KARŞILAŞTIRMA OPERATÖRLERİ: OPERATÖR ANLAMI < ...den daha küçük > ...den daha büyük = Eşit <= Küçük veya eşit >= Büyük veya eşit <> Eşit değil != Eşit değil !< ...den küçük değil !> ...den büyük değil ÇEŞİTLİ VERİ TİPLERİ İÇİN BASİT SORGULAMALAR: i)NÜMERİK VERİ TİPLERİ: ÖRNEK: Maaşı 8000000TL’den fazla olmayan personeli listele. SELECT *

SEÇ *

FROM personel

GEL İŞ personel

WHERE brüt <= 8000000

OLAN brüt <= 8000000;

ii)KARAKTER VERİ TİPLERİ (CHAR): Karakter çift veya tek tırnak ile gösterilir. ÖRNEK: Adı Ali olmayan personele ait kayıtları listele. SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE ad <> “Ali”;

OLAN ad <> “Ali”;

1618

İİİ)TARİH VERİ TİPİ: Tarih veri tipleri { } sembolleri içinde yazılır. ÖRNEK: Hangi personelin doğum tarihi 1960 yılından daha öncedir? SELECT *

SEÇ *

FROM personel

GEL İŞ personel

WHERE dog_tar <={12/31/59}

OLAN dog_tar <={12/31/59}; MANTIKSAL (LOJİK) VERİ TİPİ:

Mantıksal veriler için mümkün olabilen sadece iki değer sözkonusudur.DOĞRU D(TRUE T) , YANLIŞ Y (FALSE F) ile simgelenir. ÖRNEK: Personel tablosunda personelin cinsiyetini belirten cins adlı alan mantıksal(logical) olarak tanımlanmıştır.Cinsiyeti erkek olanları D,kadın olanları y ile tanımlarsak erkek olanları listele. SELECT *

SEÇ *

FROM personel WHERE cins = .T.;

GELİŞ personel OLAN cins =.D.;

BİRDEN ÇOK KOŞULA DAYALI SORGULAMALAR: (NOT,AND,OR) TANIM:Mantıksal operatörlerin yardımı ile birden çok koşulun gerçekleştirmesine bağlı olarak ifade edilebilecek (karmaşık yada birleşik koşullu listelemeleri gerçekleştirilmektedir.) AND VE ÖRNEK:Maaşı 5000000’dan fazla olan ve cinsiyeti erkek olan personelin listelenmesi istenir yani iki koşul verilmektedir ve ikisininde olması istenir. SELECT * SEÇ * FROM personel GELİŞ personel WHERE brüt >5000000 AND cins =.T.; OLAN brüt > 5000000 AND cins =.D. NOT DEĞİL OR VEYA ÖRNEKLER: i)Doğum tarihi 1960’dan önce olan maaşı 6000000 – 10000000 arasındaki bayan personelin listele. SELECT * SEÇ * FROM dog_tar < {01/01/60} AND GELİŞ dog_tar < {01/01/60} VE brüt > = 6000000 AND brüt < =10000000 brüt > = 6000000 VE brüt < =10000000 AND cins = .F.; VE cins =.Y.; İİ)Satış bölümüyle muhasebe bölümündekiler kimlerdir? (Satış bölümünün böl_no’sunun 1 ve muhasebe bölümünün böl_no’sunun 2 olduğu varsayılmaktadır.) SELECT * SEÇ * FROM personel GELİŞ personel WHERE bol_no =1 OR bol_no = 2; OLAN bol_no = 1 VEYA bol_no =2; İİİ)Bölümü Satış yada Muhasebe olamayan 1960’dan sonra doğmuş bayan personeli listele. 1.YAZILIM: SELECT * SEÇ * FROM personel GELİŞ personel WHERE NOT (böl_no =1 OR OLAN DEĞİL (böl_no =1 VEYA böl_no =2) AND dog_tar > ={01/01/60} böl_no =2)VE dog_tar >={01/01/60} AND cins=.F.; VE cins=.Y.; 2.YAZILIM: SELECT * SEÇ * FROM personel FROM personel WHERE böl_no <> 1 AND OLAN böl_no <> 1 VE böl_no <> 2 AND dog_tar > ={01/01/60} böl_no <> 2 AND dog_tar > = {01/01/60} AND cins =.F.; VE cins =.Y.; BİR VERİ KÜMESİNDE ARAMA –IN OPERATÖRÜ IN

İÇİNDE

1619

“IN” operatörü DEĞİL(NOT) ile kullanılılabilir. ÖRNEK:i) Bölümü 1,2,3 olmayan personel kimlerden oluşmaktadır? SELECT * SEÇ * FROM personel GELİŞ personel WHERE bol_no NOT IN (1,2,3); OLAN böl_no DEĞİL İÇİNDE (1,2,3); ÖRNEK:ii) Böl_no’su 1,2 yada 3 olan personeli listele. SELECT * SEÇ * FROM personel GELİŞ personel WHERE böl_no = 1 OR böl_no= 2 OR OLAN böl_no =1 VEYA böl_no =2 VEYA böl_no=3; böl_no = 3; Bu örneğin IN ile yapılmış şekli daha kısadır. SELECT * SEÇ * FROM personel GELİŞ personel WHERE NOT böl_no IN (1,2,3); OLAN DEĞİL böl_no İÇİNDE (1,2,3); ARALIK SORGULAMA SÖZCÜĞÜ: BETWEEN ARASINDA ÖRNEK:Maaşı 5- 10 milyon arasında olan personel kimlerdir? SELECT * SEÇ * FROM personel GELİŞ personel WHERE brüt > =5000000 AND OLAN brüt > =5000000 VE brüt < = 10000000; brüt < = 10000000; BETWEEN (ARASINDA) komutu ile daha kısa olacaktır. SELECT * SEÇ * FROM personel GELİŞ personel WHERE brüt BETWEEN 5000000 OLAN brüt ARASINDA 5000000 AND 10000000; VE 10000000; KARAKTER TÜRÜ BİLGİ İÇİNDE ARAMA YAPMA –LIKE SÖZCÜĞÜ: TANIM ÖRNEĞİ: Adres sutunu içerisinde semt bölümüne ait ayrıca bir sutun olmadığını varsayarak semt adı adres sutunu içerisinde yer alır ve buradan da LIKE (BULUNAN) komutuyla adres sutunu içerisinde Taksim semtinde oturan personeli listele. SELECT * SEÇ * FROM personel GELİŞ personel WHERE adres LIKE ‘% TAKSİM %’ ; OLAN adres LIKE ‘% TAKSİM%’ ; Adres LIKE ‘%TAKSİM%’ ifadesi adres içinde her hangi bir yerde TAKSİM yazan yerde oturan personeli listeleyecektir. LIKE sözcüğünü ,alt çizgi (-) sembolü ile birlikte kullanmakta mümkündür. SELECT * SEÇ * FROM personel GELİŞ personel WHERE ad LIKE ‘Mehmet -----‘; OLAN ad BULUNAN ‘Mehmet ----‘; Şekildeki komut ile ad alanı “Mehmet “ ile başlayan ve ad alanı uzunluğu 10 karakter olan isimlere sahip personeli listeleyecektir.”Mehmet Ali”,”Mehmet Can”- “Mehmetcik” gibi isimler listeleyecektir.Anlaşılacağı gibi - sembolü , tek karakterlik bir bilgiyi temsil etmektedir.

SQL’DE ARİTMETİKSEL İFADELER VE FNKSİYONLAR : KÜME FONKSİYONLARI: SUM FONKSİYONU: SUM TOPLA Fonksiyonun argümanı olarak belirtilen sütun ile ilişkili olana toplama işlemini gerçekleştirir. ÖRNEK:İşletmedeki personelin brüt maaşlar toplamı ne kadardır? SELECT SUMbrüt) SEÇ TOPLA(brüt) FROM personel; GELİŞ personel; AVG FONKSİYONU: AVG

ORT

Aritmetiksel ortalama (average) hesaplamak için kullanılır. SELECT AVG(brüt) SEÇ ORT (brüt) FROM personel; GELİŞ personel; MAX FONKSİYONU:

1620

MAX

ÜST

Tablo içinde ,belirtilen sutun (alan)içindeki en büyük değeri bulur. ÖRNEK:İşletme içindeki en yüksek maaş ne kadardır? SELECT MAX (brüt) SEÇ ÜST (brüt) FROM personel; GELİŞ personel; MIN FONKSİYONU: MIN ALT Tablo içinde,belirlenen sutun alan içindeki en küçük değeri bulur. ÖRNEK:İşletme içinde 4 Mayıs 1970’den önce doğanlar için,asgari ücret nedir? SELECT MIN(brüt) SEÇ ALT(brüt) FROM personel GELİŞ personel WHERE dog_tar<05/04/70}; OLAN dog_tar < {05/04/70}; COUNT FONKSİYONU: COUNT

SAY

Tablo içinde ,her hangi bir sayma işlemi gerçekleştirmek için kullanılır. ÖRNEK:Ücreti 6000000’dan olan personel sayısı nedir? SELECT COUNT (*) SEÇ SAY(*) FROM personel GELİŞ personel WHERE brüt>6000000; OLAN brüt > 6000000; COUNT (SAY) fonksiyonu DISTINCT (TEKRARSIZ)sözcüğü ile de kullanılır. ÖRNEK:Personel tablosunda mevcut personelin işletme içinde kaç tane farklı bölümde çalıştığını bul. SELECT COUNT(DISTINCT böl_no) FROM personel; COUNT (böl_no)

SEÇ SAY (TEKRARSIZ böl_no) GELİŞ personel; SAY (böl_no) GRUPLANDIRARAK İŞLEM YAPMA:

GROUP BY GRUPLA ÖRNEK: Her bölümdeki ortalama maaş nedir? SELECT böl_no,AVG (brüt) SEÇ böl_no FROM personel GELİŞ personel GOUP BY böl_no; GRUPLA böl_no; HAVING: HAVING SAHİP Gruplandırarak kümeleme fonksiyonunu uygularken koşulda verilebilir.Bu durumda grup üzerindeki hesaplamalarla ilgili koşul belirtilirken HAVING (SAHİP) sözcüğü kullanılır. ÖRNEK:En yüksek maaşın 9000000’dan fazla olduğu bölümlerdeki personele ait ortalama maaşları listele. SELECT böl_no,AVG (brüt) SEÇ böl_no, ORT(brüt) FROM personel GELİŞ personel GROUP BY böl_no GRUPLA böl_no HAVING AVG(brüt)> 9000000; SAHİP ORT(brüt)> 9000000; HAVING(SAHİP) sözcüğü SELECT(SEÇ) konusunda GROUP BY(GRUPLA) bulunmadığı zaman geçersizdir.HAVING(SAHİP) sözcüğünü izleyen ifade içinde ,SUM(TOPLA), COUNT(*)(SAY),AVG(ORT),MAX(ÜST) yada MIN(ALT) fonksiyonlarından en az biri bulunmalıdır. HAVING (SAHİP) sözcüğü sadece gruplanmış veriler üzerindeki işlemlerde geçerlidir. WHERE (OLAN) sözcüğü bir tablonun tek tek satırları üzerinde işlem yapan koşullar içinde geçerlidir. Bazı durumlarda HAVING(SAHİP) ve WHERE(OLAN) sözcükleri ile birlikte SELECT(SEÇ) komutu içinde kullanılabilir. ÖRNEK:Personel tablosu içinde her bölümde erkek personele ait maaşlar için ortalamanın 9000000’dan fazla olduğu bölümleri listele. SELECT böl_no, AVG(brüt) SEÇ böl_no, ORT (brüt) FROM personel GELİŞ personel WHERE cins= .T. OLAN cins= .D. GROUP BY böl_no GRUPLA böl_no HAVING AVG (brüt) > 9000000; SAHİP ORT(brüt) > 9000000; BİRDEN FAZLA TABLOYU İLİŞKİLENDİRMEK:

1621

JOIN

İLİŞKİLENDİR

ÖRNEK: Personel ve bölüm adlı 2 tablo bulunmaktadır. Çalışan her personel ve personelin yöneticisi ile ilişkili bilgiler nelerdir? SELECT * SEÇ * FROM personel,bölüm GELİŞ personel,bölüm WHERE personel .böl_no=bölüm.bölüm_no ; OLAN personel.böl_no = bölüm.bölüm_no; SELECT sicil,ad,soyad,böl_no,yön_s_g_n SEÇ sicil,ad,soyad,böl_no,yön_s_g_n FROM personel,bölüm

GEL İŞ personel,bölüm

WHERE personel .böl_no = bölüm .bölüm_no; SELF-JOIN:

OLAN personel .böl_no = bölüm.bölüm_no; KENDİSİYLE -İLİŞKİLENDİR

TANIM:Bir tablonun kendisi ile birleştirilmesine “KENDİSİYLE-İLİŞKiLENDİR” denir.(SELFJOIN) SELECT A. sicil , A.ad , A.soyad,B .ad , B.soyad , B.dog_tar SEÇ A. sicil , A.ad , A.soyad, B .ad , B.soyad , B.dog_tar FROM personel A , personel B

GELİŞ personel A , personel B

WHERE A. yon_sos_g_n =B .sosy_g_no;

OLAN A. yon_sos_g_n =B .sosy_g_no; NESTED SELECTS:

İÇİÇE TANIM:İç içe geçmiş SELECT(SEÇ)komutlarından oluşur.İçteki. seç komutunun bulduğu sonucu dış takı SEÇ komutumuz işlevini yerine getirmesi için kullanılır. ÖRNEK:Parça numarası 24 olan parçayı ,projelerde kullanan çalışan personeli listele. SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE sosy_g_no

OLAN sosy_g_no

IN(SELECT per_s_g_no

İÇİNDE(SEÇ per_s_g_no

FROM parça,proje,çalışma

GELİŞ parça,proje,çalışma

WHERE pr_no = proj_no AND

OLAN pr_no = proj_no VE

proj_no =proj_no AND

proj_no = proj_no VE

par_no =24);

par_no =24);

ÖRNEK: Fatih’te oturan personelin çalıştığı projelerin adlarını ve yerlerini listele. SELECT proj_ad,yer

SEÇ proj_ad,yer

FROM proje

GELİŞ proje

WHERE proj_no IN

OLAN proj_no İÇİNDE

(SELECT proje_no

(SEÇ proje_no

FROM personel,çalışma

GELİŞ sosy_g_no = per_s_g_no

WHERE sosy_g_no = per_s_g_no

OLAN sosy_g_no = per_s_g_no

AND adres LIKE “% fatih %”);

VE adres BULUNAN “% fatih %); UNION SÖZCÜĞÜ:

UNION

BİRLEŞİM

1622

TANIM:İki ayrı SEÇ komutunun sonucunda elde edilen tabloların birleşimi işlemini gerçekleştirir. ÖRNEK:Adı Ahmet ve Soyadı Caner olan kişi yada kişileri işletmenin yürüttüğü projelerde çalışan bir kişi (sıradan bir personel yada bölüm yöneticisi)olarak bulunduran projelerin isimlerini ve projelerin yürütüldüğü yerleri listele. (SELECT proj_ad,yer

(SEÇ proj_ad,yer

FROM proj,bölüm,personel

GELİŞ proj,bölüm,personel

WHERE bl_no=bölüm_no AND

OLAN bl_no=bölüm_no VE

y_sos gno = sosy_g_no

y_sos gno = sosy_g_no

AND ad =”Ahmet”AND soyad =”Caner”)

VE ad =”Ahmet” VE soyad =”Caner”)

UNION (SELECT proj_ad,yer

BİRLEŞİM (SEÇ proj_ad,yer

FROM proje,çalışma,personel

GELİŞ proje,çalışma,personel

WHERE proj_no = proje_no AND

OLAN proj_no = proje_no VE

Per_s_g_no = sosy_g_no AND ad =”Ahmet”

Per_s_g_no = sosy_g_no VE ad ”Ahmet”

AND soyad=”Caner”)

VE soyad =”Caner”) KOŞULLAR:

UNION (BİRLEŞİM) sözcüğü ile ,iki yada daha çok kişi SELECT (SEÇ)’in sonucu olan tabloların küme birleşimi işlemine tabi tutulması için 2 koşul gereklidir. 1)SELECT (SEÇ) komutları sonucunda elde edilecek tablolar aynı sayıda kolon içermelidirler. 2)Sonuç tabloları karşılıklı olarak kolonların aynı veri tipi ve aynı genişlikte olmalıdır. ANY : ANY

HER HANGİ BİRİ

ÖRNEK:Satış bölümünde çalışan personelin her hangi birinden daha düşük maaş alan ve mühendislik bölümündeki kişileri listele. SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE brüt < ANY

OLAN brüt < HER HANGİ BİRİ

(SELECT brüt

(SEÇ brüt

FROM personel

GELİŞ personel


OLAN böl_no = 2) VE böl_no =1;

EŞ DEĞERİ İFADE: SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE brüt < (SELECT MAX (brüt )

OLAN brüt < (SEÇ ÜST (brüt )

FROM personel

GELİŞ personel

WHERE böl_no = 2) AND böl_no =1;


ALL: ALL

HEPSİ

1623

ÖRNEK:Satış bölümünde çalışan ve mühendislik bölümündeki personelin hepsinden daha fazla maaş alan personeli listele.Bu örnekte satış bölümü kodu = 2 ve mühendislik bölümü kodu = 1 alınmıştır. YAPILIŞ YOLU: 1)SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE brüt >

OLAN brüt >

ALL (SELECT brüt

HEPSİ (SEÇ brüt

FROM personel

GELİŞ personel


OLAN böl_no =1) VE böl_no =2;

2)SELECT *

SEÇ

*

FROM personel

GELİŞ personel

WHERE brüt >

OLAN brüt >

(SELECT MAX (brüt)

(SEÇ ÜST (brüt)

FROM personel

GELİŞ personel

WHERE böl_no = 1) AND böl_no =2;


EXISTS: EXISTS

MEVCUT

VE ,VEYA ,DEĞİL operatörleri ile kullanılabilir. ÖRNEK: 27 no’lu parçayı satan satıcılarla ilişkili tüm bilgileri listele. SELECT *

SEÇ *

FROM satıcı

GELİŞ satıcı

WHERE EXISTS

OLAN MEVCUT

(SELECT *

(SEÇ *

FROM par_sat

GELİŞ par_sat

WHERE sat_no = satıcı_n

OLAN sat_no = satıcı_n

AND parça_n =27);

VE parça_n = 27);

NOT EXISTS: NOT EXISTS

MEVCUT DEĞİL

VE ,VEYA ,DEĞİL operatörleri ile kullanılabilir. ÖRNEK: 27 no’lu parçayı satmayan satıcılar kimlerdir? SELECT *

SEÇ *

FROM satıcı

GELİŞ satıcı

WHERE NOT EXISTS

OLAN MEVCUT DEĞİL

(SELECT *

(SEÇ *

FROM par_sat

GELİŞ par_sat

WHERE sat_no = satıcı_n

OLAN sat_no = satıcı_n

1624

AND parça_n =27);

VE parça_n = 27);

EXCEPT: EXCEPT

FARKLI

Tablo-1 - Tablo-2 işlemi sonuç(iki kümenin farkı) elde edilecek tabloda,Tablo-1’de bulunup, Tablo-2’de bulunmayan veriler mevcut olacaktır. ÖRNEK:Satış bölümündeki personel adlarından,mühendislik bölümünde bulunmayanları listele. SELECT *

FROM

SEÇ *

GELİŞ

(SELECT ad FROM personel

(SEÇ ad GELİŞ personel

WHERE bol_no=1

OLAN böl_no = 1

EXCEPT

FARKLI

SELECT ad FROM personel

SEÇ ad GELİŞ personel

WHERE bol_no =2);

OLAN böl_no =2);

INTERSECT: INTERSECT

KESİŞİM

ÖRNEK: Hem Ankara’da,hem de İstanbul’daki projelerde görev alan bölümleri listele. SELECT * FROM

SEÇ * GELİŞ

(SELECT bl_no FROM proje

(SEÇ bl_no GELİŞ proje

WHERE yer LIKE “%Ankara%”

OLAN yer BULUNAN “%Ankara%”

INTERSECT

KESİŞİM

SELECT bl_no FROM proje

SEÇ bl_no GELİŞ proje

WHERE yer LIKE “%İstanbul%”);

OLAN yer BULUNAN “%İstanbul%”);

SAVE TO TEMP: SAVE TO TEMP

SAKLA

ÖRNEK: Bayan personeli,bayan adlı bir tablo içinde sakla. SELECT *

SEÇ

*

FROM personel

GELİŞ personel

WHERE cins =.F. SAVE TO TEMP bayan;

OLAN cins =.Y. SAKLA bayan;

KEEP: KEEP

KALICI

ÖRNEK: SELECT *

SEÇ *

FROM personel

GELİŞ personel

WHERE cins = .F.

OLAN cins =.Y.

SAVE TO TEMP bayan KEEP;

GEÇİCİ SAKLA bayan KALICI;

TABLOLARDA DEĞİŞİKLİK YAPMAK:

1625

INSERT: INSERT

EKLE İÇİNE

INTO VALUES

DEĞERLER

ÖRNEK:Bir personel tablosuna sicil_no’su 275 olan personel ile ilişkili bilgileri ekle. INSERT INTO personel(sicil,

EKLE İÇİNE personel(sicil,

sosy_g_no,ad,soyad,doğ_tar

sosy_g_no,ad,soyad,doğ_tar

adres,cins,brüt,böl_no,yön_s_g_no

adres,cins,brüt,böl_no,yön_s_g_no

VALUES(‘275’,’27652418’,’Ali’,’Caner’,

DEĞERLER (‘275’,’27652418’,’Ali’,’Caner’,

{10/05/1962},’Merkez caddesi 46 –Fatih-İstanbul’, {10/05/1962},’Merkez caddesi 46 –Fatih-İstanbul’, .T.,27000000,2,’876215342’);

.D.,27000000,2,’876215342’);

DELETE: DELETE

SİL

ÖRNEK:2 no’lu bölümdeki personelin tümü tablodan sil. DELETE FROM personel

SİL GELİŞ personel

WHERE böl_no = 2;

OLAN böl_no = 2;

5 ROWS DELETED

5 SATIR SİLİNDİ

ÖRNEK:Brüt maaş alanı boş olmayan tüm personeli sil. DELETE FROM personel

SİL GELİŞ personel

WHERE brüt IS NOT NULL;

OLAN brüt DEĞERSİZ;

25 ROWS DELETED

25 SATIR SİLİNDİ

UPDATE : UPDATE

GÜNCELLE

SET

YAP

ÖRNEK:2’inci bölümün yürüttüğü projelerde kullanılan tüm parçaların fiyatlarını % 7 zam yap. UPDATE parça

GÜNCELLE parça

SET fiyat = fiyat *1,07

YAP fiyat = fiyat *1,07

WHERE pr_no IN

OLAN pr_no İÇİNDE

(SELECT proj_no

(SEÇ proj_no

FROM proje

GELİŞ proje

WHERE bl_no = 2;

OLAN bl_no =2 ;

CREATE INDEX: CREATE INDEX ON

INDEKS YARAT İÇİN

CREATE INDEX ındeks adı

INDEKS YARAT ındeks adı

1626

ON tablo adı(kolon adı 1,kolon adı 2,.,.kolon adı n); İÇİN tablo adı(kolon adı 1,kolon adı 2,.,.kolon adı n); TEK BİR ALAN A GÖRE ARTAN SIRADA İNDEKSLEME : ÖRNEK:İşletmede çalışan personeli brüt maaşlarına göre artan sırada listele.(Brüt alana göre bir indeks oluşturmalıyız) CREATE INDEX pers_maas INDEKS YARAT pers_maas ON personel(brüt); İÇİN personel(brüt); INDEX CREATED 127 ROWS İNDEKS YARATILDI 127 SATIR 127 satırlık personel tablosu ile ilişkili olarak brüt kolonu indeks anahtarı olarak kullanan pers_maas adlı indeks oluşturulmuştur.Bu durumda; SELECT * SEÇ * FROM personel;

GELİŞ personel;

Şeklinde listeleme komutu sonucunda personel tablosundaki tüm personel, brüt maaşlarına göre sıralı olarak listelenecektir. TEK BİR ALANA GÖRE AZALAN SIRADA İNDEKSLEME : DESC

Küçükten büyüğe (K-B)

ÖRNEK:İşletmede çalışan personeli brüt maaşlarına göre azalan sırada (yüksek maaştan düşük maaşa doğru)listelemek istersek ,brüt alanına göre aşağıdaki şekilde oluşturmak gerekir. CREATE INDEX

INDEKS YARAT

ON personel (brüt DESC);

İÇİN PERSONEL(BRÜT K-B); BİRDEN FAZLA ALANA GÖRE İNDEKSLEME :

ÖRNEK:İşletmedeki personelin öncelikle adlarına göre,aynı adda olanların soyadlarına göre ,hem adı hemde soyadı aynı olanların maaşlarına göre sıralanmış olarak listele. CREATE INDEX p_ad_soy_m İNDEKS YARAT p_ad_soy_m ON personel(ad,soyad,brüt); İÇİN personel (ad,soyad,brüt); Bu durumda; SELECT *

SEÇ *

FROM personel;

GELİŞ personel; ile tablo görüntülenir.

UNİQUE SÖZCÜĞÜ: UNIQUE

TEK

Bir tablo,seçilen bir sutüna (alana) göre indekslenirken , indeksleme alanı olarak seçilen sutündaki verilerintekrarlanmasına müsaade edilmesi istenmiyorsa,indeksleme yapılırken ,CREATE ,INDEX komutu iinde UNİQUE sözcüğü kullanılmalıdır. CREATE UNİQUE İNDEX pers_sicil

TEK INDEKS YARAT pers_sicil

ON personel (sicil);

İÇİN personel (sicil);

EKLEME İÇİN: Personel tablosuna INSERT INTO Personel

EKLE İÇİNE Personel

VALUES(53768 ,’27241685’,’ayşe’,

DEĞERLER (53768 ,’27241685’,’ayşe’ ,

‘şen’{01/04/63},’Merkez cad. 82 –

‘şen’{01/04/63},’Merkez cad. 82 –

Kadıköy’.F. ,27000000 ,2, ‘34261578’);

Kadıköy’.Y. ,27000000 ,2, ‘34261578’);

MEVCUT BİR İNDEKSİN SİLİNMESİ: DROP IPTAL

1627

İPTAL İNDEKS pers_in;

DROP INDEX pers_in; Komutu ile INDEX DROPPED (İNDEKS SİLİNDİ) TABLONUN YAPISINDA DEĞİŞİKLİK YAPMAK: ALTER TABLE

TABLO DEĞİŞTİR

MEVCUT BİR TABLOYA KOLON EKLEMEK: ADD

EKLE

DATE

TARİH

ALTER TABLE (TABLO DEĞİŞTİR) komutu içinde ADD (EKLE) ile satır ekle. ÖRNEK:Personel tablosuna ,işe başlama tarihini belirten bir kolon ekle ALTER TABLE personel

TABLO DEĞİŞTİR personel

ADD iş_baş_tar DATE;

EKLE iş_baş_tar TARİH;

ADD (EKLE)iş_baş_tar DATE NOT NULL (TARİH DEĞERSİZ) bu şekilde kullanılsaydı bu kolon satırı gene boş kalırdı ; fakat bu kolon ile ilişkili yeni boş değerler eklemek istendiğinde buna müsaade edilmeyecekti. MEVCUT BİR TABLONUN KOLONLARINDA DEĞİŞİKLİK YAPMAK : MODIFY KOMUTU: MODIFY

ONAR MEVCUT BİR TABLODAN BİR KOLON SİLMEK:

DROP KOMUTU : DROP

İPTAL

ÖRNEK:Personel tablosundan iş_baş_tar kolonunu sil. ALTER TABLE personel TABLO DEĞİŞTİR personel DROP iş_baş_tar ; İPTAL iş_baş_tar; Birden fazla kolonda silinebilir.Birden fazla kolon silmek için virgülle ayrılarak silinir. BİR TABLONUN ADINI DEĞİŞTİRMEK: RENAME KOMUTU: RENAME

TABLO YENİ AD

ALTER TABLE personel

TABLO DEĞİŞTİR personel

RENAME TABLE elemanlar;

TABLO YENİ AD elemanlar;

MEVCUT Bİ TABLONUN BİR KOLONUNUN ADININ DEĞİŞTİRİLMESİ: RENAME: RENAME

YENİ AD

ALTER TABLE personel RENAME brüt br-maaş; MEVCUT BİR TABLONUN TÜMÜYLE SİLİNMESİ DROP TABLE

TABLO İPTAL

ÖRNEK:Proje tablosunu sil. DROP TABLE proje;

TABLO İPTAL proje;

1628

VERİ GÜVENLİĞİ: CREATE VİEW

GÖRÜŞ ALANI YARAT

ÖRNEK:Personel adlı temel tablodan persview adlı bir view oluştur. CREATE VİEW perswiew

GÖRÜŞ ALANI YARAT persview

AS SELECT sicil,sos_g_no,ad,soyad,doğ_tar,

GİBİ SEÇ sicil,sos_g_no,ad,soyad,doğ_tar,

adres,cins,böl_no,yon_s_g_no FROM personel;

adres,cins,böl_no,yon_s_g_no GELİŞ personel;

VERİ BÜTÜNLÜĞÜNÜN SAĞLANMASI: WITH CHECK OPTİON

KONTROLLÜ

CREATE VIEW UST_PER_ VIEW

Önce bir vıew oluşturulsun

AS SELECT FROM personel WHERE brüt >25000000 WITH CHECK OPTİON; GÖRÜŞ ALANI YARAT UST_PER_VIEW GİBİ SEÇ GELİŞ personel OLAN brüt >25000000 KONTROLLÜ; Burada, maaşı 25000000’ün üzerinde olan personelden oluşan bir UST_PER_VIEW adlı view oluşturulmuştur.Bu vıew’a brüt maaşı 13000000 olan bir personel eklemek istediği zaman hata mesajı verecektir. CHECK opsiyonu kullanılmasaydı hata mesajı alınmadan bu veri VİEW içine yükleyecekti. EKLEME INSERT INTO UST_PER_VIEW EKLE İÇİNE UST_PER_VIEW VALUES (27521 ,’27865427’,’ayşe’, DEĞERLER (27521 ,’27865427’,’ayşe’, ‘okan’ ,{01/05/1962}’Cumh. Cad. 46 – Taksim’, ‘okan’ ,{01/05/1962}’Cumh. Cad. 46 – Taksim’, .F.,13000000 ,1 ,’27651112’); .F.,13000000 ,1 ,’27651112’); VIEW İÇİNDE SATIR SİLME: ÖRNEK:UST_PER_VIEW içinden,maaşı 2500000’den az olan kişileri sil. DELETE FROM UST_PER_VIEW SİL GELİŞ UST_PER_VIEW WHERE brüt < 25000000; OLAN brüt < 25000000; VIEW SATIRLARI ÜZERİNDE GÜNCELLEME : ÖRNEK: UST_PER_VIEW adlı view’de sicili 27251 olan kişnin maaşını 37000000 olarak değiştir. UPDATE UST_PER_VIEW GÜNCELLE UST_PER_VIEW SET brüt = 37000000 YAP brüt = 37000000 WHERE sicil = 27251; OLAN sicil = 27251; BİR VIEW’U SİLMEK: DROP VIEW GÖRÜŞ ALANI İPTALİ DROP VIEW UST_PER_VIEW; GÖRÜŞ ALANI İPTALİ UST_PER_VIEW; SQL’in amacı bu komutları yan yana yazdığımızda bir cümlenin ortaya çıkmasıdır. SELECT .... FROM .... WHERE ....,ORDER BY ....,GROUP BY .........HAVING.... ......(DEN).....GELİŞ.....OLAN.. ,.......SIRALA....,GRUPLA......SAHİP....SEÇ

1629

{ Article: Pictures inside a database http://delphi.about.com/library/weekly/aa030601a.htm Chapter three of the free Delphi Database Course for beginners. Displaying images (BMP, JPEG, ...) inside an Access database with ADO and Delphi. For the .zip file of this project click here. } unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ExtCtrls, StdCtrls, Db, ADODB, Grids, DBCtrls, DBGrids; type TForm1 = class(TForm) ADOTable1: TADOTable; DataSource1: TDataSource; btnShowImage: TButton; ADOImage: TImage; ADOTable1Name: TWideStringField; ADOTable1Description: TWideStringField; ADOTable1Author: TWideStringField; ADOTable1Type: TWideStringField; ADOTable1Size: TFloatField; ADOTable1Cost: TBCDField; ADOTable1DateUpl: TDateTimeField; ADOTable1Picture: TBlobField; DBGrid1: TDBGrid; procedure btnShowImageClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } end; const JPEGstarts = 'FFD8'; BMPstarts = '424D'; //BM var Form1: TForm1; implementation uses jpeg; {$R *.DFM} function JpegStartsInBlob (PicField:TBlobField):integer; var bS : TADOBlobStream; buffer : Word; hx : string; begin Result := -1; bS := TADOBlobStream.Create(PicField, bmRead);

1630

try while (Result = -1) and (bS.Position + 1 < bS.Size) do begin bS.ReadBuffer(buffer, 1); hx:=IntToHex(buffer, 2); if hx = 'FF' then begin bS.ReadBuffer(buffer, 1); hx:=IntToHex(buffer, 2); if hx = 'D8' then Result := bS.Position - 2 else if hx = 'FF' then bS.Position := bS.Position-1; end; //if end; //while finally bS.Free end; //try end; procedure TForm1.btnShowImageClick(Sender: TObject); var bS : TADOBlobStream; Pic : TJpegImage; begin bS := TADOBlobStream.Create(AdoTable1Picture, bmRead); try bS.Seek(JpegStartsInBlob(AdoTable1Picture), soFromBeginning); Pic:=TJpegImage.Create; try Pic.LoadFromStream(bS); ADOImage.Picture.Graphic:=Pic; finally Pic.Free; end; finally bS.Free end; end; procedure TForm1.FormCreate(Sender: TObject); var sDBPath, sCons: string; begin //change the sDBPath to point to your database! sDBPath := 'c:\!Gajba\About\aboutdelphi.mdb'; sCons := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + sDBPath + ';Persist Security Info=False'; ADOTable1.ConnectionString := sCons; ADOTable1.TableName := 'Applications'; DataSource1.DataSet := ADOTable1; DBGrid1.DataSource := DataSource1; ADOTable1.Active:=True; end; procedure TForm1.FormDestroy(Sender: TObject); begin ADOTable1.Active:=False; end; //Extra!! save JPG to table procedure SaveJpegToTable(Table: TADOTable; PicField:TBlobField; sPicPath: string); { Usage:

1631

SPicFileName := 'C:\!gajba\cdcovers\cdcover1.jpg'; SaveJpegToTable(ADOTable1, ADOTable1Picture, SPicFileName);

} var fS : TFileStream; begin fs:=TFileStream.Create(sPicPath, fmOpenRead); try Table.Edit; PicField.LoadFromStream(fs); Table.Post; finally fs.Free; end; end; end.

{ ******************************************** Zarko Gajic, BSCS About.com Guide to Delphi Programming http://delphi.about.com email: [email protected] free newsletter: http://delphi.about.com/library/blnewsletter.htm forum: http://forums.about.com/ab-delphi/start/ ******************************************** }

1632

Borland Developer Network Home > Delphi & Kylix

Extracting A Bitmap From A BLOB Field - by Borland Developer Support Staff Technical Information Database TI791D.txt Extracting A Bitmap From A BLOB Field Category :Database Programming Platform :All Product :Delphi All Description: Extracting a bitmap from a dBASE or Paradox blob field -- without first saving the bitmap out to a file -- is a simple process of using the Assign method to store the contents of the BLOB field to an object of type TBitmap. A standalone TBitmap object or the Bitmap property of the Picture object property of a TIMage component are examples of compatible destinations for this operation. Here is an example demonstrating using the Assign method to copy a bitmap from a BLOB field into a TImage component. procedure TForm1.Button1Click(Sender: TObject); begin Image1.Picture.Bitmap.Assign(Table1Bitmap); end; In this example, the TBLOBField object Table1Bitmap is a BLOB field in a dBASE table. This TBLOBField object was created using the Fields Editor. If the Fields Editor is not used to create TFields for the fields in the table, the fields must be referenced using either the FieldByName method or the Fields property, both part of the TTable and TQuery components. In cases where one of those means is used to reference the BLOB field in a table, the field reference must be type-cast as a TBLOBField object prior to using the Assign method. For example: procedure TForm1.Button1Click(Sender: TObject); begin Image1.Picture.Bitmap.Assign(TBLOBField(Table1.Fields[1])); end; A bitmap stored in a BLOB field may also be copied directly to a standalone TBitmap object. Here is an example showing the creation of a TBitmap object and storing into it a bitmap from a BLOB field. procedure TForm1.Button2Click(Sender: TObject); var B: TBitmap; begin B := TBitmap.Create; try B.Assign(Table1Bitmap); Image1.Picture.Bitmap.Assign(B); finally B.Free; end; end;

1633

Loading Bitmaps Into dBASE And Paradox BLOB Fields - by Borland Developer Support Staff Technical Information Database TI779D.txt Loading Bitmaps Into dBASE And Paradox BLOB Fields Category :Database Programming Platform :All Product :Delphi 1.0 Description: There are a number of ways to load a bitmap image into the BLOB field of a dBASE or Paradox table. Three of the easier methods involve 1) copying the data from the Windows clipboard into a TDBImage component connected to the BLOB field, 2) using the LoadFromFile method of the TBLOBField component, and 3) using the Assign method to copy an object of type TBitmap into the Picture property of a TBDBImage. The first method, copying the bitmap from the clipboard, is probably most handy when an application needs to add bitmaps to a table when the enduser is running the application. A TDBImage component is used to act as an interface between the BLOB field in the table and the image stored in the clipboard. The PasteFromClipboard method of the TDBImage component is invoked to copy the bitmap data from the clipboard into the TDBImage. When the record is posted, the image is stored into the BLOB field in the table. Because the Windows clipboard can contain data in formats other than just bitmap, it is advisable to check the format prior to calling the CopyFromClipboard method. To do this, a TClipboard object is created and its HasFormat method is used to determine if the data in the clipboard is indeed of bitmap format. Note that to use a TClipboard object, the Clipbrd unit must be included in the Uses section of the unit that will be creating the object. Here is an example showing the contents of the clipboard being copied into a TDBImage component, if the contents of the clipboard are of bitmap format: procedure TForm1.Button1Click(Sender: TObject); var C: TClipboard; begin C := TClipboard.Create; try if Clipboard.HasFormat(CF_BITMAP) then DBImage1.PasteFromClipboard else ShowMessage('Clipboard does not contain a bitmap!'); finally C.Free; end; end; The second method of filling a BLOB field with a bitmap involves loading the bitmap directly from a file on disk into the BLOB field. This method lends itself equally well to uses at run-time for the end-user as for the developer building an application's data. This method uses the LoadFromFile method of the TBLOBField component, the Delphi representation of a dBASE for Windows Binary field or a Paradox for Windows Graphic field, either of which may be used to store bitmap data in a table. The LoadFromFile method of the TBLOBField component requires a single

1634

parameter: the name of the bitmap file to load, which is of type String. The value for this parameter may come from a number of sources from the end-user manually keying in a valid file name to the program providing a string to the contents of the FileName property of the TOpenDialog component. Here is an example showing the use of the LoadFromFile method for a TBLOBField component named Table1Bitmap (a field called Bitmap in the table associated with a TTable component named Table1): procedure TForm1.Button2Click(Sender: TObject); begin Table1Bitmap.LoadFromFile( 'c:\delphi\images\splash\16color\construc.bmp'); end; The third method uses the Assign method to copy the contents of an object of type TBitmap into the Picture property of a TDBImage component. An object of type TBitmap might be the Bitmap property of the Picture object property of a TImage component or it may be a stand-alone TBitmap object. As with the method copying the data from the clipboard into a TDBImage component, the bitmap data in the TDBImage component is saved into the BLOB field in the table when the record is successfully posted. Here is an example using the Assign method. In this case, a stand-alone TBitmap object is used. To put a bitmap image into the TBitmap, the LoadFromFile method of the TBitmap component is called. procedure TForm1.Button3Click(Sender: TObject); var B: TBitmap; begin B := TBitmap.Create; try B.LoadFromFile('c:\delphi\images\splash\16color\athena.bmp'); DBImage1.Picture.Assign(B); finally B.Free; end; end;

1635

var AParams: TParams; BinFile: TFileStream; Buffer: String; begin SQLConnection1.Connected := True; AParams := TParams.Create( nil ); BinFile := TFileStream.Create( lblConFileName.Caption, fmOpenRead or fmShareDenyWrite ); try SetLength( Buffer, BinFile.Size ); BinFile.Read( Buffer[1], BinFile.Size ); AParams.CreateParam( ftBlob, 'TEXTBLOBDATA', ptInput ); AParams.ParamByName( 'TEXTBLOBDATA' ).AsBlob := mmoConMemo.Lines.Text; AParams.CreateParam( ftBlob, 'BINBLOBDATA', ptInput ); AParams.ParamByName( 'BINBLOBDATA' ).AsBlob := Buffer; SQLConnection1.Execute( 'insert into BLOBS (TEXT_BLOB, BIN_BLOB) values( :TEXTBLOBDATA, :BINBLOBDATA );', AParams ); finally FreeAndNil( AParams ); FreeAndNil( BinFile ); end;

or

var SQLDataSet: TSQLDataSet; BinFile: TFileStream; Buffer: String; begin BinFile := TFileStream.Create( lblDataSetFileName.Caption, fmOpenRead or fmShareDenyWrite ); try SetLength( Buffer, BinFile.Size ); BinFile.Read( Buffer[1], BinFile.Size ); SQLDataSet := TSQLDataSet.Create( nil ); try SQLDataSet.SQLConnection := SQLConnection1; SQLDataSet.CommandText := 'insert into BLOBS (BIN_BLOB, TEXT_BLOB) Values( :BinBlobData, :TextBlobData );'; SQLDataSet.ParamByName('BinBlobData').AsBlob := Buffer; SQLDataSet.ParamByName('TextBlobData').AsBlob := mmoDataSetMemo.Text; // asString doesn't seem to work...strange. SQLDataSet.ExecSQL; finally FreeAndNil( SQLDataSet );

1636

end; finally FreeAndNil( BinFile ); end;

1637

Newsletter Tips - March - 2000 Did you miss a tip? Check out the Delphi Programming Tip Archives.

13/2000. TMediaPlayer: What track am I on? { Drop a TMediaPlayer component on the form, with all the properties correctly set and bound to the CD player. Also, add "MMSystem" to the uses clause in the calling form. To complete, create a TTimer and put the code below in its OnTimer event: } uses MMSystem; var Trk, Min, Sec : word; begin with MediaPlayer1 do begin Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position); Sec := MCI_TMSF_SECOND(Position); Label1.Caption := Format('%.2d',[Trk]); Label2.Caption := Format('%.2d:%.2d',[Min,Sec]); end;

end; 12/2000. Which Type a Variant Currently Is?

1638

{ How do we get a glimpse into the contents of a variant type variable? Does it hold a string or an integer or something else? A variant can have most any kind of value assigned to it. How can we tell which it is? This is how: } function GetVariantType(const v: variant): string; begin case TVarData(v).vType of varEmpty: result := 'Empty'; varNull: result := 'Null'; varSmallInt: result := 'SmallInt'; varInteger: result := 'Integer'; varSingle: result := 'Single'; varDouble: result := 'Double'; varCurrency: result := 'Currency'; varDate: result := 'Date'; varOleStr: result := 'OleStr'; varDispatch: result := 'Dispatch'; varError: result := 'Error'; varBoolean: result := 'Boolean'; varVariant: result := 'Variant'; varUnknown: result := 'Unknown'; varByte: result := 'Byte'; varString: result := 'String'; varTypeMask: result := 'TypeMask'; varArray: result := 'Array'; varByRef: result := 'ByRef'; end; // case

end; 11/2000. Memo Printing {Simple procedure that prints the content of a Memo component} uses printers; procedure TForm1.PrintIt(Sender: TObject); var PrintBuf: TextFile; begin AssignPrn(PrintBuf); Rewrite(PrintBuf); try for i := 0 to Memo1.Lines.Count-1 do WriteLn(PrintBuf, Memo1.Lines[i]); finally CloseFile(PrintBuf); end;

end; 10/2000. Determine the Actual Size of a Blob Field in the Table { Here is a function GetBlobSize that returns the size of a given blob, memo, or graphic field. } Function GetBlobSize(Field: TBlobField): Longint; begin with TBlobStream.Create(Field, bmRead) do

1639

with TBlobStream.Create(Field, bmRead) do try Result := Seek(0, 2); finally Free; end; end; {Usage:} procedure TForm1.Button1Click(Sender: TObject); begin {This sets the Edit1 edit box to display the size of} {a memo field named Notes.} Edit1.Text := IntToStr(GetBlobSize(Notes));

1640

Exporting Memos and BLOB's by Lance Leonard

Posted: 10 December 2001 Applies to: Paradox 5.0 and later Audience: Intermediate

Question: By default, Paradox does not export memo or BLOB fields to delimited text files. Is there any way to do this? Answer: Yes. Try manually exporting the table, as shown in the following code sample: proc fixup( strInput String ) String ; -------------------------------------------------------------; If strInput contains CRLF's, this replaces them with "\n" ; and returns the result; otherwise, returns the original value. ; -------------------------------------------------------------var astrLines Array[] String strRetval String siCounter smallInt endVar strRetval = strInput if strRetval.search( "\n" ) > 0 then ; separate CRLF's strRetval.breakApart( astr, chr( 13 ) + chr( 10 ) ) strRetval = "" ; reassemble the string using "\n" instead of CRLF's for siCounter from 1 to astrLines.size() if ( astrLines[ siCounter ] <> "" ) then strRetval = strRetval + astrLines[ siCounter ] if siCounter < astrLines.size() then ; add "\n" strRetval = strRetval + "\\n" endIf endIf endFor endIf return strRetval endProc method run(var eventInfo Event) var tc ts endVar

TCursor TextStream

const DATAFILE = ":priv:rtlerrors" TEXTFILE = "c:\\errors.txt" STDERROR = "If [>>] is enabled, choose it for more details." endConst enumRTLErrors( DATAFILE ) ; create the data table if not tc.open( DATAFILE ) then errorShow( "Can't Open Errors Table", STDERROR ) else if not ts.open( TEXTFILE, "nw" ) then

1641

errorShow( "Can't Open Output File", STDERROR ) else scan tc : message( "Writing ", tc.recNo(), " of ", tc.nRecords(), "..." ) ts.writeLine( "\"", tc.(1), "\"|", "\"", tc.(3), "\"|", "\"", fixup( tc.(4) ), "\"" ) endScan ; Add additional error-checking for full sanity. ts.commit() ts.close() tc.close() beep() message( "Done!" ) endIf endIf endMethod

While this example looks involved, a careful review shows it's rather straightforward. There are two main elements to pay attention to: 1. Note that the fixup procedure declares the strinput parameter as a string. If you call fixup() with the contents of a memo field, your formatted data will become unformatted, much the same way that string( tc.formattedfield ) also returns unformatted data. This may or may be a problem for you. 2. The breakapart() call in fixup() shows how to remove CRLF pairs from memo data. Note that you need to skip certain elements in the resulting array to completely replace CRLF's with "\n" characters.

1642

1643

Delphi Huge Tricks

Recommend Documents

Delphi ActiveX Test Page

Delphi 4 ActiveX Test Page