?? customctrls.pas
字號:
SetCapture(PL.Handle);
End;
Procedure TPicturePanel.PLMouseUp(Sender: TObject; Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
Begin
ReleaseCapture;
FCaptured := false;
End;
Procedure TPicturePanel.CopyBitmap(src: TBitmap);
Begin
AssignedIcon := src <> Nil;
If Not AssignedIcon Then
exit;
Icon.FreeImage;
Icon.Canvas.StretchDraw(Rect(0, 0, 153, 111), src);
Src.Free;
Invalidate;
End;
Procedure TPicturePanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
Begin
Inherited;
End;
Procedure TPicturePanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
Integer);
Begin
Inherited;
End;
Constructor TGraphicPanel.Create(AOwner: TComponent);
Begin
Inherited;
Bmp := TBitmap.Create;
BevelOuter := bvNone;
BevelInner := bvNone;
End;
Destructor TGraphicPanel.Destroy;
Begin
Bmp.Free;
Inherited;
End;
Procedure TGraphicPanel.Paint;
Var
Rt: TRect;
Begin
Inherited;
If HandleAllocated And Not Bmp.Empty Then
Begin
Rt := ClientRect;
Brush.Style := bsClear;
Canvas.BrushCopy(Rt, Bmp, Rt, Bmp.Canvas.Pixels[0, 0]);
End;
End;
Procedure TIconPanel.SetBitmap(Value: TBitmap);
Begin
If Value <> Nil Then
Bmp.Assign(Value);
End;
Procedure TPicThread.Execute;
Var
sr: TSearchRec;
Ext, s: String;
f: Boolean;
Begin
s := IncludeTrailingPathDelimiter(Path);
f := True;
If DirectoryExists(s) And Assigned(picBox) Then
Begin
If FindFirst(s + '*.*.', faArchive Or faReadOnly, sr) = 0 Then
Begin
f := False;
Repeat
Ext := ExtractFileExt(sr.Name);
If AnsiSameText(Ext, '.jpg') Or AnsiSameText(Ext, '.jpeg') Or
AnsiSameText(Ext, '.bmp') Then
Begin
AddFileName(picBox, s + sr.Name);
Application.ProcessMessages;
End;
Until Terminated Or Application.Terminated Or (FindNext(sr) <> 0);
FindClose(sr);
End;
End;
If f Then
picBox.FindOver;
End;
Constructor TPicThread.Create(aBox: TPictureListBox; aPath: String);
Begin
Inherited Create(False);
Path := aPath;
picBox := aBox;
FreeOnTerminate := True;
End;
Procedure TPictureListBox.AddFile(FileName: String);
Var
aData: TPicData;
Begin
If Not IsValidFile(FileName) Then
exit;
aData := TPicData.Create; //
FObjList.Add(aData);
GetPrevIcon(FileName, aData);
Items.AddObject(FileName, aData);
End;
Procedure TPictureListBox.OpenPath(s: String);
Begin
PostMessage(frmMain.Handle, WM_OPENFILEBEGIN, 0, 0);
Clear;
Images.Clear;
TPicThread.Create(Self, s);
End;
Constructor TPictureListBox.Create(AOwner: TComponent);
Begin
Inherited;
FPreviewIcon := True;
FUpdateCount := 0;
ControlStyle := ControlStyle + [csOpaque];
BorderStyle := bsNone;
BevelInner := bvSpace;
BevelKind := bkFlat;
BevelOuter := bvLowered;
FObjList := TList.Create;
Images := TImageList.Create(self);
With Images Do
Begin
Height := DEFAULTSIZE;
Width := DEFAULTSIZE;
End;
Bitmap := Tbitmap.Create;
Bitmap.LoadFromResourceID(hinstance, 4000);
BorderSize := 2;
ItemHeight := DEFAULTSIZE + 2 * BorderSize;
Style := lbOwnerDrawFixed;
Height := 210;
Width := 300;
End;
Destructor TPictureListBox.Destroy;
Var
i: Integer;
Begin
For i := 0 To FObjList.Count - 1 Do
TObject(FObjList[i]).Free;
FObjList.Free;
Images.Free;
Bitmap.Free;
Inherited Destroy;
End;
Procedure TPictureListBox.Clear;
Var
i: Integer;
Begin
For i := 0 To FObjList.Count - 1 Do
TObject(FObjList[i]).Free;
FObjList.Clear;
Inherited Clear;
End;
Procedure TPictureListBox.DrawItem(Index: Integer; Rect: TRect; State:
TOwnerDrawState);
Var
l: integer;
aData: TPicData;
Begin
If (FUpdateCount > 0) Or (index >= Items.Count) Or
Not RectVisible(Canvas.Handle, Rect) Then
Exit;
l := BorderSize + Rect.Top;
Canvas.FillRect(Rect);
aData := Items.Objects[index] As TPicData;
If FPreviewIcon Then
Begin
If (aData.ImageIndex = -1) Or (aData.ImageIndex > Images.Count - 1) Then
canvas.BrushCopy(Bounds(BorderSize, l, DEFAULTSIZE, DEFAULTSIZE),
Bitmap, Bounds(0, 0, DEFAULTSIZE, DEFAULTSIZE), clblack)
Else
Images.Draw(Canvas, BorderSize, l, aData.ImageIndex);
End
Else
Begin
Canvas.BrushCopy(Bounds(BorderSize, l, DEFAULTSIZE, DEFAULTSIZE),
Bitmap, Bounds(0, 0, DEFAULTSIZE, DEFAULTSIZE), clblack);
End;
With Canvas Do
Begin
TextOut(DEFAULTSIZE + 2 * BorderSize, l, Items[index]);
Inc(l, TextHeight('H'));
TextOut(DEFAULTSIZE + 2 * BorderSize, l, 'Width : ' +
IntToStr(aData.Width) + ' Pixels');
Inc(l, TextHeight('H'));
TextOut(DEFAULTSIZE + 2 * BorderSize, l, 'Height : ' +
IntToStr(aData.Height) + ' Pixels');
End;
End;
Procedure TPictureListBox.SetBorderSize(Value: Integer);
Begin
If FBorderSize <> Value Then
Begin
FBorderSize := Value;
Invalidate;
End;
End;
Procedure TPictureListBox.SetPreviewIcon(Value: Boolean);
Begin
If FPreviewIcon <> Value Then
Begin
FPreviewIcon := Value;
If Not FPreviewIcon Then
Images.Clear;
Invalidate;
End;
End;
Procedure TPictureListBox.GetPrevIcon(AName: String; aData: TPicData);
Var
bmp, tmp: TBitmap;
h, w, h1, w1: Integer;
hw: Extended;
f: Boolean;
Begin
If Not IsValidFile(AName) Then
exit;
tmp := GetBitmap(AName);
f := tmp = Nil;
If f Then
tmp := Bitmap;
bmp := TBitmap.Create;
With bmp Do
Begin
Width := DEFAULTSIZE;
Height := DEFAULTSIZE;
End;
Application.ProcessMessages;
hw := DEFAULTSIZE / Max(tmp.Height, tmp.Width);
w := trunc(hw * tmp.Width);
h := trunc(hw * tmp.Height);
h1 := (DEFAULTSIZE - h) Div 2;
w1 := (DEFAULTSIZE - w) Div 2;
bmp.Canvas.StretchDraw(Rect(w1, h1, w1 + w, h1 + h), tmp);
Images.Add(bmp, Nil);
aData.Width := tmp.Width;
aData.Height := tmp.Height;
aData.ImageIndex := Images.Count - 1;
If Not f Then
tmp.Free;
bmp.Free;
End;
Procedure TPictureListBox.BeginUpdate;
Begin
inc(FUpdateCount);
End;
Procedure TPictureListBox.EndUpdate;
Begin
dec(FUpdateCount);
If FUpdateCount < 0 Then
FUpdateCount := 0;
If FUpdateCount = 0 Then
Invalidate;
End;
Procedure TPictureListBox.FindOver;
Begin
Postmessage(frmMain.Handle, WM_OPENFILEOVER, 0, 0);
End;
Procedure TPictureListBox.FindNext;
Begin
SendMessage(frmMain.Handle, WM_OPENFILENEXT, 0, 0);
End;
Procedure TUpdateThread.Execute;
Begin
Name := GetFileName;
While (Name <> '') And (Not Terminated) Do
Begin
If Application.Terminated Then
Break;
Synchronize(UpdateBox);
Sleep(5);
Name := GetFileName;
End;
InterlockedDecrement(FileThrdCount);
If FileThrdCount <= 0 Then
Begin
FileThrdCount := 0;
picBox.FindOver;
End;
End;
Constructor TUpdateThread.Create(aBox: TPictureListBox);
Begin
Inherited Create(False);
picBox := aBox;
FreeOnTerminate := True;
End;
Procedure TUpdateThread.UpdateBox;
Begin
Application.ProcessMessages;
If Application.Terminated Then
Exit;
picBox.AddFile(Name);
picBox.FindNext;
End;
Initialization
FileList := TStringList.Create;
FileListMutex := TMutex.Create('File_Mutex_' + FormatDateTime('hh:mm:ss:zzz',
Now));
Finalization
FileList.Free;
FileListMutex.Free;
End.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -