customctrls.pas

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

  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.