Programlama yapalım ve Öğrenelim.

TestDialog

unit TestDialog;

interface

uses Windows, Messages, SysUtils, CommDlg, Classes, Graphics, Controls,

Forms, StdCtrls, Dialogs, ComCtrls, ExtCtrls, Dlgs, CommCtrl;

type

TTestDialog = class(TOpenDialog)

private

FPanel: TPanel;

FStatus: TStatusBar;

protected

procedure DoShow; override;

procedure WndProc(var Message: TMessage); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

end;

implementation

constructor TTestDialog.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

Template := 'YOURDLGTEMPLATE';

Options := [ofHideReadOnly,ofFileMustExist];

FPanel := TPanel.Create( Self );

FStatus := TStatusBar.Create( Self );

end;

destructor TTestDialog.Destroy;

begin

FPanel.Free;

FStatus.Free;

inherited Destroy;

end;

procedure TTestDialog.DoShow;

var

rc: TRect;

begin

GetClientRect(Handle, Rc);

FPanel.BoundsRect := Rc;

FPanel.Left := 424;

FPanel.BevelOuter := bvNone;

FPanel.Width := (Rc.Right - Rc.Left) - FPanel.Left;

FPanel.Caption := 'Hello !';

FPanel.ParentWindow := Handle;

FStatus.Align := alNone;

FStatus.BoundsRect := Rc;

FStatus.Top := FStatus.Top + FStatus.Height - 30;

FStatus.Height := 30;

FStatus.Width := FStatus.Width - FPanel.Width - 2;

FStatus.SimplePanel := True;

FStatus.ParentWindow := Handle;

end;

procedure TTestDialog.WndProc(var Message: TMessage);

function ExtractFileNameOnly( s: String ): String;

var tmp: String;

begin

Result := ExtractFilename( s );

tmp := ExtractFileExt( Result );

if tmp <> '' then

Result := Copy( Result, 1, Length( Result ) - length( tmp ) );

end;

const

AddSize = 150;

cNum = 7;

Control: Array [0..cNum-1] of integer =

( stc3, stc2, //The two label ctrls

edt1, cmb1, //Edit and combo ctrls

IDOK, IDCANCEL, //The dialog buttons

lst1 ); //The Explorer window

var

pLV,LV: HWND;

Style: Longint;

I,pos: integer;

buf: array[0..254] of char;

S: String;

wndDlg,wndCtrl: HWND;

Rc,cRc: TRect;

begin

Message.Result := 0;

case Message.Msg of

WM_INITDIALOG:

begin

wndDlg := GetParent(Handle); // Get a pointer to the parent window.

GetWindowRect(wndDlg,Rc); //Get rect of parent window

// Change the size of parent window according to

SetWindowPos( wndDlg, HWND(NiL), 0, 0,

Rc.right - Rc.left,

Rc.bottom - Rc.top + AddSize,

SWP_NOMOVE );

//Move all controls to a compensate for the new parent size

for i:=0 to cNum-1 do

begin

wndCtrl := GetDlgItem(wndDlg,Control[i]); //Fetch control

GetWindowRect(wndCtrl, cRc); //Get control's rect

MapWindowPoints( 0, wndDlg, cRc, 2 );

if (Control[i] <> lst1) then //For any control except the lst1

//move the control appropriately

SetWindowPos( wndCtrl, HWND(NiL),

cRc.left, cRc.top + AddSize,

0, 0, SWP_NOSIZE )

else //size the folder view control appropriately

SetWindowPos( wndCtrl, HWND(NiL), 0, 0,

cRc.right - cRc.left,

cRc.bottom - cRc.top + AddSize,

SWP_NOMOVE );

end;

WM_NOTIFY:

begin

case POFNotify(Message.LParam)^.hdr.code of

// Can also trap:

// CDN_FILEOK, CDN_FOLDERCHANGE, CDN_HELP, CDN_INITDONE, CDN_SELCHANGE,

// CDN_SHAREVIOLATION, CDN_TYPECHANGE.

CDN_SELCHANGE:

begin

// get the ACTUAL ListView handle (not lst1)

pLV := GetDlgItem( GetParent(Handle), lst2 );

LV := GetDlgItem( pLV, 1 );

Style := GetWindowLong(LV, GWL_STYLE);

Style := Style and (not LVS_TYPEMASK);

Style := Style or LVS_ICON;

SetWindowLong(LV, GWL_STYLE, Style);

// currently selected item

pos := ListView_GetNextItem ( LV, -1, LVNI_ALL or LVNI_SELECTED );

if ( pos <> -1 ) then

begin

ListView_GetItemText( LV, pos, 0, buf, 255 );

S := ExtractFilePath( Filename ) + ExtractFileNameOnly(buf) ;

if FileExists(S + ExtractFileExt( Filename )) then

FStatus.SimpleText := 'File: ' + s + ExtractFileExt( Filename )

else

FStatus.SimpleText := 'Folder: '+s;

end;

inherited WndProc(Message);

end;

end.

Delphi - .....................................

TextAnimator

unit TextAnim;

interface

uses

{$IFDEF WIN32} Windows {$ELSE} WinTypes, WinProcs {$ENDIF}, Messages,

SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls;

type

PIntArray = ^TIntArray;

TIntArray = array[0..16383] of Integer;

PShortIntArray = ^TShortIntArray;

TShortIntArray = array[0..16383] of ShortInt;

TTextAnimStyle = (taAll, taRandom, taWave, taWind);

{ TTextAnimator }

TTextAnimator = class(TGraphicControl)

private

fDelay: Word;

fActive: Boolean;

fAutoSize: Boolean;

fAlignment: TAlignment;

fMaxFontStep: Word;

fStep: Word;

fColorAnimation: Boolean;

fColorStart: TColor;

fColorStop: TColor;

fStyle: TTextAnimStyle;

fTransparent: Boolean;

CharWidth: PIntArray;

CharStep: PIntArray;

CharDir: PShortIntArray;

MaxTextSize: TSize;

TextLen: Integer;

Timer: TTimer;

IsFontChanged: Boolean;

ColorDir: Integer;

ThisColor: Byte;

MaxDeltaRGB: Integer;

OffScreen: TBitmap;

Drawing: Boolean;

StartRGB: array[1..3] of Byte;

DeltaRGB: array[1..3] of Integer;

procedure SetDelay(Value: Word);

procedure SetStep(Value: Word);

procedure SetStyle(Value: TTextAnimStyle);

procedure SetActive(Value: Boolean);

procedure SetAutoSize(Value: Boolean);

procedure SetMaxStep(Value: Word);

procedure SetAlignment(Value: TAlignment);

procedure SetTransparent(Value: Boolean);

procedure SetColorStart(Value: TColor);

procedure SetColorStop(Value: TColor);

function IsFontStored: Boolean;

function IsSizeStored: Boolean;

procedure TimerExpired(Sender: TObject);

procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;

procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;

procedure ResetAnimation(ResetAll: Boolean);

procedure ResetColors;

function MakeFontColor: TColor;

procedure PaintFrame(ACanvas: TCanvas);

protected

procedure Paint; override;

procedure Loaded; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure AdjustClientSize;

procedure NextFrame;

published

property Active: Boolean read fActive write SetActive default True;

property Align;

property Alignment: TAlignment read fAlignment write SetAlignment default taCenter;

property AutoSize: Boolean read fAutoSize write SetAutoSize default True;

property Caption;

property ColorAnimation: Boolean read fColorAnimation write fColorAnimation default True;

property ColorStart: TColor read fColorStart write SetColorStart default clYellow;

property ColorStop: TColor read fColorStop write SetColorStop default clRed;

property Color;

property Delay: Word read fDelay write SetDelay default 70;

property DragCursor;

property DragMode;

property Enabled;

property Font stored IsFontStored;

property Height stored IsSizeStored;

property MaxStep: Word read fMaxFontStep write SetMaxStep default 20;

property ParentColor;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property Step: Word read fStep write SetStep default 2;

property Style: TTextAnimStyle read fStyle write SetStyle default taWind;

property Transparent: Boolean read fTransparent write SetTransparent default True;

property Visible;

property Width stored IsSizeStored;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

end;

procedure Register;

implementation

{$IFDEF WIN32}

{$R *.d32}

{$ELSE}

{$R *.d16}

{$ENDIF}

type

TParentControl = class(TWinControl);

{ This procedure copied exactly from RxLibrary VCLUtils. }

procedure CopyParentImage(Control: TControl; Dest: TCanvas);

var

I, Count, X, Y, SaveIndex: Integer;

DC: HDC;

R, SelfR, CtlR: TRect;

begin

if (Control = nil) or (Control.Parent = nil) then Exit;

Count := Control.Parent.ControlCount;

DC := Dest.Handle;

{$IFDEF WIN32}

with Control.Parent do ControlState := ControlState + [csPaintCopy];

try

{$ENDIF}

with Control do begin

SelfR := Bounds(Left, Top, Width, Height);

X := -Left; Y := -Top;

end;

{ Copy parent control image }

SaveIndex := SaveDC(DC);

try

SetViewportOrgEx(DC, X, Y, nil);

IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,

Control.Parent.ClientHeight);

with TParentControl(Control.Parent) do begin

Perform(WM_ERASEBKGND, DC, 0);

PaintWindow(DC);

end;

finally

RestoreDC(DC, SaveIndex);

end;

{ Copy images of graphic controls }

for I := 0 to Count - 1 do begin

if Control.Parent.Controls[I] = Control then Break

else if (Control.Parent.Controls[I] <> nil) and

(Control.Parent.Controls[I] is TGraphicControl) then

begin

with TGraphicControl(Control.Parent.Controls[I]) do begin

CtlR := Bounds(Left, Top, Width, Height);

if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin

{$IFDEF WIN32}

ControlState := ControlState + [csPaintCopy];

{$ENDIF}

SaveIndex := SaveDC(DC);

try

SaveIndex := SaveDC(DC);

SetViewportOrgEx(DC, Left + X, Top + Y, nil);

IntersectClipRect(DC, 0, 0, Width, Height);

Perform(WM_PAINT, DC, 0);

finally

RestoreDC(DC, SaveIndex);

{$IFDEF WIN32}

ControlState := ControlState - [csPaintCopy];

{$ENDIF}

end;

{$IFDEF WIN32}

finally

with Control.Parent do ControlState := ControlState - [csPaintCopy];

end;

{$ENDIF}

end;

{ TTextAnimator }

constructor TTextAnimator.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle := ControlStyle + [csOpaque {$IFDEF WIN32}, csReplicatable {$ENDIF}];

Randomize;

OffScreen := TBitmap.Create;

fActive := False;

fAutoSize := True;

fAlignment := taCenter;

fTransparent := True;

fColorAnimation := True;

fColorStart := clYellow;

fColorStop := clRed;

fStyle := taWind;

fStep := 2;

fDelay := 70;

fMaxFontStep := 20;

Font.Name := 'Times New Roman';

Font.Size := 10;

Font.Style := [fsBold];

IsFontChanged := False;

TextLen := 0;

CharWidth := nil;

CharStep := nil;

CharDir := nil;

Drawing := False;

ResetAnimation(True);

ResetColors;

Active := True;

end;

destructor TTextAnimator.Destroy;

begin

Active := False;

OffScreen.Free;

if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));

if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));

if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));

inherited Destroy;

end;

procedure TTextAnimator.Loaded;

begin

inherited Loaded;

if fAutoSize then AdjustClientSize;

end;

procedure TTextAnimator.Paint;

begin

if not Drawing then

begin

Drawing := True;

try

OffScreen.Width := ClientWidth;

OffScreen.Height := ClientHeight;

PaintFrame(OffScreen.Canvas);

Canvas.Draw(0, 0, OffScreen);

finally

Drawing := False;

end;

procedure TTextAnimator.CMTextChanged(var Msg: TMessage);

begin

inherited;

ResetAnimation(True);

if fAutoSize then AdjustClientSize;

end;

procedure TTextAnimator.CMFontChanged(var Msg: TMessage);

begin

inherited;

ResetAnimation(False);

IsFontChanged := True;

if fAutoSize then AdjustClientSize;

end;

procedure TTextAnimator.AdjustClientSize;

begin

if not (csReading in ComponentState) then

SetBounds(Left, Top, MaxTextSize.CX , MaxTextSize.CY);

end;

procedure TTextAnimator.SetDelay(Value: Word);

begin

if fDelay <> Value then

begin

fDelay := Value;

if Assigned(Timer) then Timer.Interval := fDelay;

end;

procedure TTextAnimator.SetMaxStep(Value: Word);

begin

if fMaxFontStep <> Value then

begin

fMaxFontStep := Value;

ResetAnimation(False);

if fAutoSize then AdjustClientSize;

if fStep > fMaxFontStep then

fStep := fMaxFontStep;

end;

procedure TTextAnimator.SetStep(Value: Word);

begin

if Value > fMaxFontStep then

Value := fMaxFontStep;

if fStep <> Value then

fStep := Value;

end;

procedure TTextAnimator.SetStyle(Value: TTextAnimStyle);

begin

if fStyle <> Value then

begin

fStyle := Value;

ResetAnimation(False);

end;

procedure TTextAnimator.SetActive(Value: Boolean);

begin

if fActive <> Value then

begin

fActive := Value;

if fActive then

begin

Timer := TTimer.Create(Self);

Timer.Interval := fDelay;

Timer.OnTimer := TimerExpired;

end

else

begin

Timer.Free;

Timer := nil;

end;

procedure TTextAnimator.SetAutoSize(Value: Boolean);

begin

if fAutoSize <> Value then

begin

fAutoSize := Value;

if fAutoSize then AdjustClientSize;

end;

procedure TTextAnimator.SetAlignment(Value: TAlignment);

begin

if fAlignment <> Value then

begin

fAlignment := Value;

Invalidate;

end;

procedure TTextAnimator.SetTransparent(Value: Boolean);

begin

if fTransparent <> Value then

begin

fTransparent := Value;

Invalidate;

end;

procedure TTextAnimator.SetColorStart(Value: TColor);

begin

if fColorStart <> Value then

begin

fColorStart := Value;

ResetColors;

end;

procedure TTextAnimator.SetColorStop(Value: TColor);

begin

if fColorStop <> Value then

begin

fColorStop := Value;

ResetColors;

end;

function TTextAnimator.IsFontStored: Boolean;

begin

Result := IsFontChanged;

end;

function TTextAnimator.IsSizeStored: Boolean;

begin

Result := not fAutoSize;

end;

procedure TTextAnimator.ResetAnimation(ResetAll: Boolean);

var

I: Integer;

begin

if ResetAll then

begin

if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));

if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));

if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));

TextLen := Length(Caption);

GetMem(CharWidth, TextLen * SizeOf(Integer));

GetMem(CharStep, TextLen * SizeOf(Integer));

GetMem(CharDir, TextLen * SizeOf(ShortInt));

end;

for I := 0 to TextLen-1 do

begin

CharDir^[I] := 1;

case fStyle of

taAll: CharStep^[I] := 0;

taRandom: CharStep^[I] := Random(fMaxFontStep+1);

taWave: CharStep^[I] := Trunc(Sin(I / TextLen * PI) * fMaxFontStep);

taWind: CharStep^[I] := I * fMaxFontStep div TextLen;

end;

OffScreen.Canvas.Font := Font;

OffScreen.Canvas.Font.Size := Font.Size + fMaxFontStep - 1;

MaxTextSize.CX := 0;

for I := 0 to TextLen-1 do

begin

CharWidth^[I] := OffScreen.Canvas.TextWidth(Caption[I+1]);

Inc(MaxTextSize.CX, CharWidth^[I]);

end;

MaxTextSize.CY := OffScreen.Canvas.TextHeight('X');

end;

procedure TTextAnimator.ResetColors;

var

I: Integer;

StartColor, StopColor: LongInt;

begin

StartColor := ColorToRGB(fColorStart);

StopColor := ColorToRGB(fColorStop);

StartRGB[1] := LoByte(LoWord(StartColor));

StartRGB[2] := HiByte(LoWord(StartColor));

StartRGB[3] := LoByte(HiWord(StartColor));

DeltaRGB[1] := LoByte(LoWord(StopColor)) - StartRGB[1];

DeltaRGB[2] := HiByte(LoWord(StopColor)) - StartRGB[2];

DeltaRGB[3] := LoByte(HiWord(StopColor)) - StartRGB[3];

MaxDeltaRGB := 0;

for I := 1 to 3 do

if MaxDeltaRGB < Abs(DeltaRGB[I]) then

MaxDeltaRGB := Abs(DeltaRGB[I]);

ThisColor := 0;

ColorDir := 1;

end;

function TTextAnimator.MakeFontColor: TColor;

var

I: Integer;

ColorRGB: array[1..3] of Byte;

begin

for I := 1 to 3 do

begin

ColorRGB[I] := StartRGB[I];

if ThisColor > Abs(DeltaRGB[I]) then

Inc(ColorRGB[I], DeltaRGB[I])

else if DeltaRGB[I] > 0 then

Inc(ColorRGB[I], ThisColor mod (DeltaRGB[I]+1))

else if DeltaRGB[I] < 0 then

Dec(ColorRGB[I], ThisColor mod (DeltaRGB[I]-1));

end;

Result := TColor(RGB(ColorRGB[1], ColorRGB[2], ColorRGB[3]));

Inc(ThisColor, ColorDir);

if (ThisColor = MaxDeltaRGB) or (ThisColor = 0) then ColorDir := -ColorDir;

end;

procedure TTextAnimator.NextFrame;

var

I: Integer;

begin

for I := 0 to TextLen-1 do

begin

Inc(CharStep^[I], fStep * CharDir^[I]);

if CharStep^[I] > fMaxFontStep then

begin

CharStep^[I] := 2 * fMaxFontStep - CharStep^[I];

CharDir^[I] := -1;

end;

if CharStep^[I] <= 0 then

begin

CharStep^[I] := -CharStep^[I];

CharDir^[I] := 1;

end;

Refresh;

end;

procedure TTextAnimator.PaintFrame(ACanvas: TCanvas);

var

I, X, Y: Integer;

begin

case fAlignment of

taLeftJustify: X := 0;

taRightJustify: X := ClientWidth - MaxTextSize.CX;

else

X := (ClientWidth - MaxTextSize.CX) div 2;

end;

Y := (ClientHeight - MaxTextSize.CY) div 2;

ACanvas.Font := Font;

ACanvas.Brush.Color := Color;

if fTransparent then

begin

CopyParentImage(Self, ACanvas);

ACanvas.Brush.Style := bsCLear;

end

else

begin

ACanvas.FillRect(ClientRect);

ACanvas.Brush.Style := bsSolid;

end;

for I := 0 to TextLen-1 do

begin

if fColorAnimation then ACanvas.Font.Color := MakeFontColor;

ACanvas.Font.Size := Font.Size + CharStep^[I];

ACanvas.TextOut(X, Y, Caption[I+1]);

Inc(X, CharWidth^[I])

end;

procedure TTextAnimator.TimerExpired(Sender: TObject);

begin

NextFrame;

end;

procedure Register;

begin

RegisterComponents('Samples', [TTextAnimator]);

end;

end.

Delphi - .....................................

TextStream

unit TextStream;

interface

uses

SysUtils, Classes;

procedure AssignStream(var T: TextFile; AStream: TStream);

implementation

{ We need to redefine a new TTextRec-UserData type. This can be used to store

internal data of our textfile. Use as little space as possible. Even better,

add only a pointer to a larger structure. }

type

StreamData = record

Stream: TStream;

Filler: array[1..16] of Char;

end;

{ The function that is called when the TextBuffer is flushed or full. }

function StreamWrite(var F: TTextRec): Integer; far;

begin

StreamData(Pointer(@F.UserData)^).Stream.WriteBuffer(F.BufPtr^, F.BufPos);

F.BufPos := 0;

Result := 0;

end;

{ The function that is called when there's nothing left to read in the

TextBuffer. }

function StreamRead(var F: TTextRec): Integer; far;

begin

F.BufEnd := StreamData(Pointer(@F.UserData)^).Stream.Read(F.BufPtr^, F.BufSize);

F.BufPos := 0;

Result := 0;

end;

{ The Open-function for the TextFile. }

function StreamOpen(var F: TTextRec): Integer; far;

begin

if (F.Mode = fmInput) then begin

{ Gonna read. }

F.InOutFunc := @StreamRead;

F.FlushFunc := Nil;

StreamData(Pointer(@F.UserData)^).Stream.Position := 0;

Result := 0;

end

else if (F.Mode = fmOutput) then begin

{ Gonna write }

F.Mode := fmOutput;

F.InOutFunc := @StreamWrite;

F.FlushFunc := @StreamWrite;

StreamData(Pointer(@F.UserData)^).Stream.Position := 0;

Result := 0;

end

else begin

{ Gonna complain... Illegal function. }

Result := 1;

end;

{ The Close-function for the TextFile. }

function StreamClose(var F: TTextRec): Integer; far;

begin

StreamData(Pointer(@F.UserData)^).Stream.Position := 0;

F.InOutFunc := Nil;

F.FlushFunc := Nil;

Result := 0;

end;

{ What to do when assigning the stream? }

procedure AssignStream(var T: TextFile; AStream: TStream);

begin

with TTextRec(T) do begin

{ Streams have no handle... }

Handle := 0;

{ After assigning, the file is closed. }

Mode := fmClosed;

{ A TTextRec includes a Buffer. Just set it's size... }

BufSize := SizeOf(Buffer);

{ Position inside the buffer: start & Stop. }

BufPos := 0;

BufEnd := 0;

{ Pointer to the buffer. (Changes when we call SetTextBuf procedure...) }

BufPtr := @Buffer;

{ Initialize function-calls. }

OpenFunc := @StreamOpen;

InOutFunc := Nil; { Closed, so no input/Output routine. }

FlushFunc := Nil; { Closed, so no Flush routine. }

CloseFunc := @StreamClose; { Also used as Flush-function when writing. }

{ Set the filename: No name... }

Name[0] := #0;

{ And finally, our own data... Assign the stream to the file... }

StreamData(Pointer(@UserData)^).Stream := AStream;

end;

end.

Delphi - .....................................