picset.pas

销售帐目管理

unit PicSet;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Spin, ExtCtrls, PicShow, SUIForm, SUIButton, FileCtrl,
  SUIDlg, SUIEdit ;

type
  TFrmPicSet = class(TForm)
    suiForm1: TsuiForm;
    pnl1: TPanel;
    pnlRunningFilename1: TPanel;
    pnlNextFilename1: TPanel;
    PicShow: TPicShow;
    pnl2: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    bvl1: TBevel;
    bvl2: TBevel;
    Label3: TLabel;
    seStep1: TSpinEdit;
    seStyle1: TSpinEdit;
    chkThreaded1: TCheckBox;
    rbManualStyle1: TRadioButton;
    rbTurnStyle1: TRadioButton;
    rbRandomStyle1: TRadioButton;
    seDelay1: TSpinEdit;
    pnl3: TPanel;
    Label4: TLabel;
    bvl3: TBevel;
    bvl4: TBevel;
    chkAuto1: TCheckBox;
    seShowPause1: TSpinEdit;
    chkClearOldImage1: TCheckBox;
    Timer: TTimer;
    ScrollBar: TScrollBar;
    suiMessageDialog1: TsuiMessageDialog;
    pnl4: TPanel;
    suiButton1: TsuiButton;
    bvl5: TBevel;
    procedure FormShow(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
    procedure PicShowCustomDraw(Sender: TObject; Picture, Screen: TBitmap);
    procedure PicShowDblClick(Sender: TObject);
    procedure suiButton1Click(Sender: TObject);
    procedure seStyle1Change(Sender: TObject);
    procedure rbManualStyle1Click(Sender: TObject);
    procedure rbTurnStyle1Click(Sender: TObject);
    procedure rbRandomStyle1Click(Sender: TObject);
    procedure seStep1Change(Sender: TObject);
    procedure seDelay1Change(Sender: TObject);
    procedure chkThreaded1Click(Sender: TObject);
    procedure chkAuto1Click(Sender: TObject);
    procedure seShowPause1Change(Sender: TObject);
    procedure chkClearOldImage1Click(Sender: TObject);
    procedure PicShowProgress(Sender: TObject);
    procedure PicShowStart(Sender: TObject; Picture, Screen: TBitmap);
    procedure PicShowStop(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    Pictures: TStringList;
    FirstActivate: Boolean;
    ShownImage: String;
    LoadedImage: String;
    procedure CheckTimer;
    procedure ShowNextImage;
    procedure LoadNextImage;
    procedure CreateImageList(const Path: String);
    procedure UpdateMemoryStatus(Sender: TObject; var Done: Boolean);
  public
    { Public declarations }
  end;

var
  FrmPicSet: TFrmPicSet;

implementation

uses PubUnit;

{$R *.dfm}

// Turns timer on or off according to state of controls
procedure TFrmPicSet.CheckTimer;
var T : Boolean ;
begin
  T := ((not PicShow.Busy) and chkAuto1.Checked and
        (not rbManualStyle1.Checked) and (Pictures.Count > 0));
  Timer.Enabled := T ;
end;

// Begins animating the currently loaded image
procedure TFrmPicSet.ShowNextImage;
begin
  Timer.Enabled := False;
  // if there is not any image in the list exit
  if Pictures.Count = 0 then Exit;
  // if PicShow is playing, stops it
  if PicShow.Busy then
    PicShow.Stop;
  // Sets the animation style according to user sellection
  if rbRandomStyle1.Checked then
    seStyle1.Value := Random(High(TShowStyle))+1
  else if rbTurnStyle1.Checked then
    if seStyle1.Value < High(TShowStyle) then
      seStyle1.Value := seStyle1.Value + 1
    else
      seStyle1.Value := 1;
  // Updates image name status
  ShownImage := LoadedImage;
  pnlRunningFilename1.Caption := 'Showing: ' + ShownImage;
  pnlRunningFilename1.Update;
  // Begins the animation
  PicShow.Execute;
end;

// Selects randomly an image from the image list and loades it into PicShow
procedure TFrmPicSet.LoadNextImage;
var
  Index: Integer;
begin
  LoadedImage := EmptyStr;
  if Pictures.Count > 0 then
  begin
    repeat
      Index := Random(Pictures.Count);
    until (Pictures.Count <= 1) or (ShownImage <> Pictures[Index]);
    LoadedImage := Pictures[Index];
    PicShow.Picture.LoadFromFile(PicPath + LoadedImage);
  end;
  pnlNextFilename1.Caption := 'Next: ' + LoadedImage;
  pnlNextFilename1.Update;
end;

// Creates a list of image filenames found in the path
procedure TFrmPicSet.CreateImageList(const Path: String);
var
  FileList: TFileListBox;
begin
  FileList := TFileListBox.Create(nil);
  try
    FileList.Visible := False;
    FileList.Parent := Self;
    FileList.Mask := GraphicFileMask(TGraphic);
    FileList.Directory := Path;
    if FileList.Items.Count > 0 then
    begin
      Pictures.Assign(FileList.Items);
      if (Length(Path) > 0) and (Path[Length(Path)] <> '\') then
        PicPath := Path + '\'
      else
        PicPath := Path;
    end
    else
      with suiMessageDialog1 do
      begin
        Caption := suiForm1.Caption ;
        Text := '请您马上设置相册的路径！';
        ButtonCount := 1 ;
        Button1Caption := '确定';
        Button1ModalResult := mrOk ;
        IconType := suiStop ;
      end ;
  finally
    FileList.Free;
  end;
end;

procedure TFrmPicSet.UpdateMemoryStatus(Sender: TObject; var Done: Boolean);
var
  MemoryStatus: TMemoryStatus;
begin
{  GlobalMemoryStatus(MemoryStatus);
  pnlFreeMemory1.Caption := Format('Free Memory: %%%.1f',
      [100. * MemoryStatus.dwAvailPhys / MemoryStatus.dwTotalPhys]);
  pnlFreeMemory1.Update;}
end;

procedure TFrmPicSet.FormShow(Sender: TObject);
begin
  ReadIni ;
  
  Timer.Interval := P_ShowPause * 1000;
  PicShow.Style := P_StyleValue ;
  PicShow.Threaded := P_Threaded ;
  PicShow.Step := P_StepValue ;
  PicShow.Delay := P_DelayValue ;
  PicShow.OverDraw := not P_ClearOldImage ;

  Randomize;
  {$IFNDEF VER100}
  ScrollBar.Align := alBottom;
  {$ENDIF}
  // Updates controls by PicShow properties
  seStyle1.MaxValue := High(TShowStyle);

  if P_TurnStyle then
     seStyle1.Value := 1//PicShow.Style;
  else
     seStyle1.Value := P_StyleValue;
  chkThreaded1.Checked := P_Threaded;//PicShow.Threaded;
  seStep1.Value := P_StepValue;//PicShow.Step;
  seDelay1.Value := P_DelayValue;//PicShow.Delay;
  PicShow.Manual := false ;
  rbManualStyle1.Checked := PicShow.Manual;
  ScrollBar.Enabled := rbManualStyle1.Checked;
  chkClearOldImage1.Checked := P_ClearOldImage;//not PicShow.OverDraw;
  seShowPause1.Value := P_ShowPause ;
  rbTurnStyle1.Checked := P_TurnStyle ;
  rbRandomStyle1.Checked := P_RandomStyle ;
  chkAuto1.Checked := P_AutoStyle ;

  // On idle time shows percentage of free physical memory
  Application.OnIdle := UpdateMemoryStatus;
  // Creates list of images and fills it by images found in the program path
  Pictures := TStringList.Create;
  if DirectoryExists(PicPath) then
     CreateImageList(PicPath)
  else
     CreateImageList(ExtractFilePath(Application.ExeName));
  // Loads an image into Picshow
  Timer.Interval := {ShowPause.Value}P_ShowPause * 1000;
  LoadNextImage;
  FirstActivate := True;
end;

procedure TFrmPicSet.FormActivate(Sender: TObject);
begin
  if FirstActivate then
  begin
    FirstActivate := False;
    Update;
    ShowNextImage;
  end;
end;

procedure TFrmPicSet.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    P_RandomStyle := rbRandomStyle1.Checked ;//随机方式
    P_TurnStyle := rbTurnStyle1.Checked ;  //顺序改变
    P_StyleValue := StrToInt(seStyle1.Text); //图片显示方式
    P_ManualStyle := rbManualStyle1.Checked ;// Boolean ;//手动方式切换
    P_AutoStyle := chkAuto1.Checked ;// Boolean ;  //自动方式切换
    P_ClearOldImage := chkClearOldImage1.Checked ;// Boolean ;//显示新的图片前清除老的图片
    P_Threaded := chkThreaded1.Checked ;// Boolean;      //采用线程模式显示
    P_ShowPause := StrToInt(seShowPause1.Text);// Integer ;    //显示间隔时间
    P_StepValue := StrToInt(seStep1.Text);// integer ;    //
    P_DelayValue := StrToInt(seDelay1.Text);// integer ;
    WriteIni ;
end;

procedure TFrmPicSet.FormDestroy(Sender: TObject);
begin
  Pictures.Free;
end;

procedure TFrmPicSet.PicShowCustomDraw(Sender: TObject; Picture,
  Screen: TBitmap);
var
  Text: String;
begin
  Text := Format('CUSTOM: PROGRESS = %d%%', [PicShow.Progress]);
  Screen.Canvas.Draw(0, 0, Picture);
  Screen.Canvas.Font.Style := [fsBold];
  SetTextAlign(Screen.Canvas.Handle, TA_CENTER or TA_BASELINE);
  Screen.Canvas.TextOut(Screen.Width div 2, Screen.Height div 2, Text);
end;

procedure TFrmPicSet.PicShowDblClick(Sender: TObject);
begin
  PicShow.Enabled := False; // To perevent reentrance
  try
    ShowNextImage;
  finally
    PicShow.Enabled := True;
  end;
end;

procedure TFrmPicSet.suiButton1Click(Sender: TObject);
var
  Path: String;
begin
  Path := PicPath;
  if SelectDirectory(Path, [], 0) then
  begin
    CreateImageList(Path);
    CheckTimer;
  end;
end;

procedure TFrmPicSet.seStyle1Change(Sender: TObject);
{$IFNDEF VER100}
{$IFNDEF VER120}
var
  CursorPos: TPoint;
{$ENDIF}
{$ENDIF}
begin
  PicShow.Style := seStyle1.Value;
  seStyle1.Hint := PicShow.StyleName;
  {$IFNDEF VER100}
  {$IFNDEF VER120}
  GetCursorPos(CursorPos);
  if PtInRect(seStyle1.BoundsRect, seStyle1.Parent.ScreenToClient(CursorPos)) then
    Application.ActivateHint(CursorPos);
  {$ENDIF}
  {$ENDIF}
end;

procedure TFrmPicSet.rbManualStyle1Click(Sender: TObject);
begin
  if not Timer.Enabled then Exit ;
  PicShow.Manual := rbManualStyle1.Checked;
  ScrollBar.Enabled := rbManualStyle1.Checked;
  if PicShow.Manual then
  begin
    // When PicShow is in manual mode, we must first call execute and after it
    // we can change the progress. If PicShow is already busy, calling execute
    // is not required.
    if not (PicShow.Busy or PicShow.Empty) then
      PicShow.Execute;
    ScrollBar.Position := PicShow.Progress;
  end;
  CheckTimer;
end;

procedure TFrmPicSet.rbTurnStyle1Click(Sender: TObject);
begin
  if not Timer.Enabled then Exit ;
  PicShow.Manual := rbTurnStyle1.Checked;
  ScrollBar.Enabled := rbTurnStyle1.Checked;
  if PicShow.Manual then
  begin
    // When PicShow is in manual mode, we must first call execute and after it
    // we can change the progress. If PicShow is already busy, calling execute
    // is not required.
    if not (PicShow.Busy or PicShow.Empty) then
      PicShow.Execute;
    ScrollBar.Position := PicShow.Progress;
  end;
  CheckTimer;
end;

procedure TFrmPicSet.rbRandomStyle1Click(Sender: TObject);
begin
  if not Timer.Enabled then Exit ;
  PicShow.Manual := rbRandomStyle1.Checked;
  ScrollBar.Enabled := rbRandomStyle1.Checked;
  if PicShow.Manual then
  begin
    // When PicShow is in manual mode, we must first call execute and after it
    // we can change the progress. If PicShow is already busy, calling execute
    // is not required.
    if not (PicShow.Busy or PicShow.Empty) then
      PicShow.Execute;
    ScrollBar.Position := PicShow.Progress;
  end;
  CheckTimer;
end;

procedure TFrmPicSet.seStep1Change(Sender: TObject);
begin
  PicShow.Step := seStep1.Value;
end;

procedure TFrmPicSet.seDelay1Change(Sender: TObject);
begin
  PicShow.Delay := seDelay1.Value;
end;

procedure TFrmPicSet.chkThreaded1Click(Sender: TObject);
begin
  PicShow.Threaded := chkThreaded1.Checked;
end;

procedure TFrmPicSet.chkAuto1Click(Sender: TObject);
begin
  CheckTimer;
end;

procedure TFrmPicSet.seShowPause1Change(Sender: TObject);
begin
  Timer.Interval := seShowPause1.Value * 1000;
end;

procedure TFrmPicSet.chkClearOldImage1Click(Sender: TObject);
begin
  PicShow.OverDraw := not chkClearOldImage1.Checked;
end;

procedure TFrmPicSet.PicShowProgress(Sender: TObject);
begin
  if ScrollBar.Enabled then
    ScrollBar.Position := PicShow.Progress;
end;

procedure TFrmPicSet.PicShowStart(Sender: TObject; Picture,
  Screen: TBitmap);
begin
  CheckTimer;
  // When PicShow begins transaction, we can load the next image into the
  // control. This is possible because PicShow converts the image to Bitmap
  // and use this copy during its process.
  LoadNextImage;
end;

procedure TFrmPicSet.PicShowStop(Sender: TObject);
begin
  CheckTimer;
end;

procedure TFrmPicSet.TimerTimer(Sender: TObject);
begin
  ShowNextImage;
end;

procedure TFrmPicSet.FormCreate(Sender: TObject);
begin
  ChangeInterface(Self,suiForm1);
end;

end.