customctrls.pas

Clock 桌面时钟 日历 阴历 看到的delphi程序 转发

Unit CustomCtrls;

Interface
Uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  ExtCtrls,
  Jpeg,
  ComCtrls,
  StdCtrls,
  Math,
  MacForm;

Type
  TPositionEvent = Procedure(Sender: TObject; pt: TPoint) Of Object;

  TIconPanel = Class;
  TPicturePanel = Class;

  TPicData = Class
  Private
    Width, Height, ImageIndex: Integer;
  End;

  TPictureListBox = Class(TCustomListBox)
  Private
    FBorderSize: Integer;
    FPreviewIcon: Boolean;
    Bitmap: Tbitmap;
    Images: TImageList;
    FUpdateCount: Integer;
    FObjList: TList;
    Procedure GetPrevIcon(AName: String; aData: TPicData);
  Protected

    Procedure SetBorderSize(Value: Integer);
    Procedure SetPreviewIcon(Value: Boolean);
    Procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
      Override;
    Procedure AddFile(FileName: String);
  Public
    Procedure Clear; Override;
    Procedure OpenPath(s: String);
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
    Procedure BeginUpdate;
    Procedure EndUpdate;
    Procedure FindOver;
    Procedure FindNext;
    Property BorderSize: Integer Read FBorderSize Write SetBorderSize;
    Property PreviewIcon: Boolean Read FPreviewIcon Write SetPreviewIcon;
  Published
    Property Popupmenu;
    Property Align;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
    Property Visible;
    Property OnClick;
  End;

  TGraphicPanel = Class(TCustomPanel)
  Private
    Bmp: TBitmap;
  Protected
    Procedure Paint; Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
  End;

  TPicturePanel = Class(TGraphicPanel)
  Private
    Icon: TBitmap;
    PL: TIconPanel;
    AssignedIcon: Boolean;

    ConstrainRect: TRect;
    FCaptured: Boolean;
    OldX, OldY: Integer;
    FOnPositionChg: TPositionEvent;
  Protected
    Procedure SetFileName(Const Value: String);
    Procedure Paint; Override;
    Procedure PLMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    Procedure PLMouseDown(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState;
      X, Y: Integer);
    Procedure PLMouseUp(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState;
      X, Y: Integer);
    Procedure CopyBitmap(src: TBitmap);
    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer);
      Override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
    Property FileName: String Write SetFileName;
    Property MovePanel: TIconPanel Read PL Write PL;
  Published
    Property OnPositionChg: TPositionEvent Read FOnPositionChg Write
      FOnPositionChg;
    Property Align;
  End;

  TIconPanel = Class(TGraphicPanel)
  Private
    Procedure SetBitmap(Value: TBitmap);
  Public
    Property Bitmap: TBitmap Write SetBitmap;
  End;

  TUpdateThread = Class(TThread)
  Private
    Name: String;
    picBox: TPictureListBox;
  Protected
    Procedure Execute; Override;
    Procedure UpdateBox;
  Public
    Constructor Create(aBox: TPictureListBox);
  End;

  TPicThread = Class(TThread)
  Private
    Path: String;
    picBox: TPictureListBox;
  Protected
    Procedure Execute; Override;
  Public
    Constructor Create(aBox: TPictureListBox; aPath: String);
  End;

Procedure Register;

Function GetBitmap(FileName: String): TBitmap;
Function ScreenCap: TBitmap;

Function IsValidFile(FileName: String): Boolean;

Function IsJpegFile(FileName: String): Boolean;

Function IsBmpFile(FileName: String): Boolean;

Procedure AddFileName(aBox: TPictureListBox; sName: String);

Function GetFileName: String;

Implementation
Uses Main,
  IpcThrd;

Const
  DEFAULTSIZE = 64;
Var
  FileList: TStringList;
  FileListMutex: TMutex;
  FileThrdCount: Integer = 0;

Procedure Register;
Begin
  RegisterComponents('Custom', [TPictureListBox]);
End;

Function GetBitmap(FileName: String): TBitmap;
Var
  jp: TJPEGImage;
Begin
  Result := Nil;
  If Not IsValidFile(FileName) Then
    exit;

  Result := TBitmap.Create;

  If IsJpegFile(FileName) Then
  Begin
    jp := TJPEGImage.Create;
    Try
      jp.LoadFromFile(FileName);
      Result.Assign(jp);
    Except
      FreeAndNil(Result);
    End;
    jp.Free;
  End
  Else
    If IsBmpFile(FileName) Then
    Begin
      Try
        Result.LoadFromFile(FileName)
      Except
        FreeAndNil(Result);
      End;
    End
    Else
      FreeAndNil(Result);
End;

Function ScreenCap: TBitmap;
Var
  //  Bhandle : HBITMAP ;
  SourceDC, DestDC: HDC;
  Sw, Sh: Integer;
  Bhandle: integer;
  Bitmap: TBitmap;

Begin
  Sw := Screen.Width;
  Sh := Screen.Height;

  SourceDC := CreateDC('DISPLAY', '', '', Nil);
  DestDC := CreateCompatibleDC(SourceDC);

  Bhandle := CreateCompatibleBitmap(SourceDC, Sw, Sh);
  SelectObject(DestDC, Bhandle);
  BitBlt(DestDC, 0, 0, Sw, Sh, SourceDC, 0, 0, SRCCOPY);

  Bitmap := TBitmap.Create;
  Bitmap.Handle := BHandle;
  Result := TBitmap.Create;

  Result.Assign(Bitmap);

  Bitmap.Free;
  DeleteDC(DestDC);
  ReleaseDC(Bhandle, SourceDC);
End;

Function IsValidFile(FileName: String): Boolean;
Begin
  Result := (IsJpegFile(FileName) Or IsBmpFile(FileName));
End;

Function IsJpegFile(FileName: String): Boolean;
Var
  s: String;
Begin
  s := ExtractFileExt(FileName);
  Result := FileExists(FileName) And (AnsiSameText(s, '.jpg') Or
    AnsiSameText(s, '.jpeg'));
End;

Function IsBmpFile(FileName: String): Boolean;
Var
  s: String;
Begin
  s := ExtractFileExt(FileName);
  Result := FileExists(FileName) And AnsiSameText(s, '.bmp');
End;

Procedure AddFileName(aBox: TPictureListBox; sName: String);
Begin
  If FileListMutex.Get(1000 * 60) Then
  Begin
    FileList.Add(sName);

    If FileThrdCount < 50 Then
    Begin
      InterlockedIncrement(FileThrdCount);
      TUpdateThread.Create(aBox);
    End;

    FileListMutex.Release;
  End;
End;

Function GetFileName: String;
Begin
  Result := '';
  If FileListMutex.Get(1000 * 60) Then
  Begin
    If FileList.Count > 0 Then
    Begin
      Result := FileList[0];
      FileList.Delete(0);
    End;
    FileListMutex.Release;
  End;
End;

Constructor TPicturePanel.Create(AOwner: TComponent);
Begin
  Inherited;

  Icon := TBitmap.Create;
  Icon.Width := 153;
  Icon.Height := 111;
  Bmp.LoadFromResourceID(hInstance, 1001);

  Height := Bmp.Height;
  Width := Bmp.Width;

  SetRect(ConstrainRect, 11, 15, 167, 126);

  PL := TIconPanel.Create(self);

  With PL Do
  Begin
    Cursor := crSizeAll;

    OnMouseDown := PLMouseDown;
    OnMouseMove := PLMouseMove;
    OnMouseUp := PLMouseUp;

    SetBounds(Width - 60, 18, 40, 40);
    FullRepaint := false;
    ParentBackground := false;
  End;

  InsertControl(PL);

  FCaptured := false;
  CopyBitmap(ScreenCap);
End;

Destructor TPicturePanel.Destroy;
Begin
  Icon.Free;
  PL.Free;
  Inherited;
End;

Procedure TPicturePanel.Paint;
Var
  Rt: TRect;
Begin
  Inherited;

  If HandleAllocated Then
  Begin
    Rt := ClientRect;
    Canvas.BrushCopy(Rt, Bmp, Rt, Bmp.Canvas.Pixels[0, 0]);
    If AssignedIcon Then
      Canvas.CopyRect(ConstrainRect, Icon.Canvas, Rect(0, 0, 153, 111));
  End;
End;

Procedure TPicturePanel.SetFileName(Const Value: String);
Begin
  CopyBitmap(GetBitmap(Value));
End;

Procedure TPicturePanel.PLMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
Var
  x1, x2, y1, y2: Integer;
Begin
  If Not FCaptured Then
    exit;

  With Pl Do
  Begin

    x1 := X - OldX + Left;
    If x1 < ConstrainRect.Left Then
      x1 := ConstrainRect.Left;

    y1 := Y - OldY + Top;
    If y1 < ConstrainRect.Top Then
      y1 := ConstrainRect.Top;

    x2 := x1 + Width;
    If x2 > ConstrainRect.Right Then
      x1 := ConstrainRect.Right - Width;

    y2 := y1 + Height;
    If y2 > ConstrainRect.Bottom Then
      y1 := ConstrainRect.Bottom - Height;

    If (x1 <> Left) And (y <> Top) Then
    Begin
      MoveWindow(Handle, x1, y1, Width, Height, true);
      If Assigned(FOnPositionChg) Then
        FOnPositionChg(self, Point(x1 - ConstrainRect.Left, y1 -
          ConstrainRect.Top));
    End;
  End;
End;

Procedure TPicturePanel.PLMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
Begin
  FCaptured := true;
  OldX := X;
  OldY := Y;