bsskinshellctrls.pas

实现网络流量的生成,为cs结构,可以控制流量大小

  TbsSkinDirectoryEdit = class(TbsSkinEdit)
  protected
    FDlgSkinData: TbsSkinData;
    FDlgCtrlSkinData: TbsSkinData;
    SD: TbsSkinSelectDirectoryDialog;
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ButtonClick(Sender: TObject);
  published
    property DlgSkinData: TbsSkinData read FDlgSkinData write FDlgSkinData;
    property DlgCtrlSkinData: TbsSkinData read FDlgCtrlSkinData write FDlgCtrlSkinData;
  end;

  TbsSkinFileEdit = class(TbsSkinEdit)
  protected
    FDlgSkinData: TbsSkinData;
    FDlgCtrlSkinData: TbsSkinData;
    OD: TbsSkinOpenDialog;
    FLVHeaderSkinDataName: String;
    function GetFilter: String;
    procedure SetFilter(Value: String);
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ButtonClick(Sender: TObject);
  published
    property Filter: String read GetFilter write SetFilter;
    property DlgSkinData: TbsSkinData read FDlgSkinData write FDlgSkinData;
    property DlgCtrlSkinData: TbsSkinData read FDlgCtrlSkinData write FDlgCtrlSkinData;
    property LVHeaderSkinDataName: String
      read FLVHeaderSkinDataName write FLVHeaderSkinDataName;
  end;

  TbsSkinSaveFileEdit = class(TbsSkinEdit)
  protected
    FDlgSkinData: TbsSkinData;
    FDlgCtrlSkinData: TbsSkinData;
    OD: TbsSkinSaveDialog;
    FLVHeaderSkinDataName: String;
    function GetFilter: String;
    procedure SetFilter(Value: String);
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ButtonClick(Sender: TObject);
  published
    property Filter: String read GetFilter write SetFilter;
    property DlgSkinData: TbsSkinData read FDlgSkinData write FDlgSkinData;
    property DlgCtrlSkinData: TbsSkinData read FDlgCtrlSkinData write FDlgCtrlSkinData;
    property LVHeaderSkinDataName: String
      read FLVHeaderSkinDataName write FLVHeaderSkinDataName;
  end;

  TbsOpenPictureDlgForm = class(TForm)
  private
    FromFLV: Boolean;
    FromFTV: Boolean;
    FromDCB: Boolean;
    SaveMode: Boolean;
  public
    FileName: String;
    BSF: TbsBusinessSkinForm;
    DirTreeViewPanel: TbsSkinExPanel;
    FileListViewPanel,
    BottomPanel: TbsSkinPanel;
    Splitter, Splitter2: TbsSkinSplitter;
    DTVHScrollBar, DTVVScrollBar,
    FLVHScrollBar, FLVVScrollBar: TbsSkinScrollBar;
    DirTreeView: TbsSkinDirTreeView;
    FileListView: TbsSkinFileListView;
    FileNameEdit: TbsSkinEdit;
    FilterComboBox: TbsSkinFilterComboBox;
    OpenButton, CancelButton: TbsSkinButton;
    OpenFileLabel, FileTypeLabel: TbsSkinStdLabel;
    ToolPanel: TbsSkinPanel;
    ListToolButton, ReportToolButton,
    IconToolButton, SmallIconToolButton, BackToolButton: TbsSkinSpeedButton;
    Bevel1, Bevel2, Bevel3: TbsSkinBevel;
    DriveBox: TbsSkinShellDriveComboBox;
    SortNameToolButton, SortSizeToolButton, SortDateToolButton: TbsSkinSpeedButton;
    //
    ImagePanel: TbsSkinPanel;
    Image: TImage;
    ScrollBox: TbsSkinScrollBox;
    SBVScrollBar, SBHScrollBar: TbsSkinScrollBar;
    Bevel4: TbsSkinBevel;
    StretchButton: TbsSkinSpeedButton;
    constructor CreateEx(AOwner: TComponent; ASaveMode: Boolean);
    procedure DCBChange(Sender: TObject);
    procedure FLVChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure DTVChange(Sender: TObject; Node: TTreeNode);
    procedure FCBChange(Sender: TObject);
    procedure OpenButtonClick(Sender: TObject);
    procedure ToolPanelOnResize(Sender: TObject);
    procedure FLVDBLClick(Sender: TObject);
    procedure EditKeyPress(Sender: TObject; var Key: Char);

    procedure StretchButtonClick(Sender: TObject);
    procedure ReportToolButtonClick(Sender: TObject);
    procedure ListToolButtonClick(Sender: TObject);
    procedure SmallIconToolButtonClick(Sender: TObject);
    procedure IconToolButtonClick(Sender: TObject);
    procedure BackToolButtonClick(Sender: TObject);

    procedure SortNameToolButtonClick(Sender: TObject);
    procedure SortSizeToolButtonClick(Sender: TObject);
    procedure SortDateButtonClick(Sender: TObject);
  end;

  TbsSkinOpenPictureDialog = class(TComponent)
  private
    FSkinMessage: TbsSkinMessage;
    FLVHeaderSkinDataName: String;
    FAlphaBlend: Boolean;
    FAlphaBlendValue: Byte;
    FAlphaBlendAnimation: Boolean;
    FSD: TbsSkinData;
    FCtrlFSD: TbsSkinData;
    FDefaultFont: TFont;
    FTitle: String;
    FDlgFrm: TbsOpenPictureDlgForm;
    FOnChange: TNotifyEvent;
    FInitialDir: String;
    FFilter: String;
    FFileName: String;
    FFilterIndex: Integer;
    function GetTitle: string;
    procedure SetTitle(const Value: string);
    procedure SetDefaultFont(Value: TFont);
  protected
    FSaveMode: Boolean;
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
    procedure Change;
  public
    ImagePanelWidth, TreePanelWidth: Integer;
    TreePanelRollState: Boolean;
    ListViewStyle: TViewStyle;
    DialogWidth, DialogHeight: Integer;
    DialogStretch: Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean;
  published
    property SkinMessage: TbsSkinMessage
       read FSkinMessage write FSkinMessage;
    property LVHeaderSkinDataName: String
     read FLVHeaderSkinDataName write FLVHeaderSkinDataName;
    property AlphaBlend: Boolean read FAlphaBlend write FAlphaBlend;
    property AlphaBlendValue: Byte read FAlphaBlendValue write FAlphaBlendValue;
    property AlphaBlendAnimation: Boolean
      read FAlphaBlendAnimation write FAlphaBlendAnimation;
    property SkinData: TbsSkinData read FSD write FSD;
    property CtrlSkinData: TbsSkinData read FCtrlFSD write FCtrlFSD;
    property DefaultFont: TFont read FDefaultFont write SetDefaultFont;
    property Title: string read GetTitle write SetTitle;
    property InitialDir: String read FInitialDir write FInitialDir;
    property Filter: String read FFilter write FFilter;
    property FilterIndex: Integer read FFilterIndex write FFilterIndex;
    property FileName: String read FFileName write FFileName;
  end;

  TbsSkinSavePictureDialog = class(TbsSkinOpenPictureDialog)
  public
    constructor Create(AOwner: TComponent); override;
  end;


implementation

{$R bsSkinShellCtrls}

const
  DefaultMask = '*.*';

  FILE_SUPPORTS_ENCRYPTION = 32;
  FILE_SUPPORTS_OBJECT_IDS = 64;
  FILE_SUPPORTS_REPARSE_POINTS = 128;
  FILE_SUPPORTS_SPARSE_FILES = 256;
  FILE_VOLUME_QUOTAS = 512;
  SHGFI = SHGFI_SYSICONINDEX or SHGFI_SMALLICON;

var
  drives: set of 0..25;
  CurPath: String;

function GetMediaPresent(Value: TDiskSign) :Boolean;
var
  ErrorMode: Word;
  bufRoot :pchar;
  a,b,c,d :dword;
begin
  if (Value = 'A:') or (Value = 'B:')
  then
    begin
      Result := False;
      Exit;
    end;
  bufRoot := stralloc(255);
  strpcopy(bufRoot,Value + '\');
  ErrorMode:=SetErrorMode(SEM_FailCriticalErrors);
  try
    try
      result:=GetDiskFreeSpace(bufRoot,a,b,c,d);
    except
      result:=False;
    end;
  finally
    strdispose(bufroot);
    SetErrorMode(ErrorMode);
  end;
end;

constructor TbsSkinFileListView.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 ReadOnly := True;
 fselectedfiles:=tStringlist.create;
 Createimages;
 ShortDateFormat:='mm/dd/yyyy';
 LongTimeFormat:='hh:nn';
 FMask:=DefaultMask;
 FSortForward:=True;
 FSortColumn:=0;
 OnCompare:=CompareFiles;
 OnColumnClick:=ColumnClick;
 if csdesigning in componentstate then fdirectory := 'c:\';
 FSkinMessage := nil;
end;

procedure TbsSkinFileListView.Notification;
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FSkinMessage)
  then
    FSkinMessage := nil;
end;

destructor TbsSkinFileListView.Destroy;
begin
 LImageList.Free;
 SImageList.Free;
 fSelectedFiles.Free;
 inherited Destroy;
end;

function TbsSkinFileListView.IsFile;
begin
  Result := Item.SubItems[5]='file';
end;

function TbsSkinFileListView.GetSelectedNum: Integer;
begin
  Result:=SelCount;
  if Result=0 then
    Result:=Items.Count;
end;

function TbsSkinFileListView.GetSelectedSize: Integer;
var
  i, FSize: UInt;
  FName: String;
  FInfo: TWin32FindData;
  hFindFile: THandle;
begin
  Result:=0;
  FSize:=0;
  hFindFile:=0;
  if SelCount=0 then
    exit;
  for i:=0 to Items.Count-1 do begin
    if Items[i].selected then begin
      FName:=ExtractFileName(Items[i].SubItems[4]+#0);
      hFindFile:=FindFirstFile(pChar(FName),FInfo);
      if hFindFile<>INVALID_HANDLE_VALUE then
        FSize:=FSize+((FInfo.nFileSizeHigh*MAXDWORD)+FInfo.nFileSizeLow);
    end;
  end;
  Windows.FindClose(hFindFile);
  Result:=FSize;
end;

function TbsSkinFileListView.GetDirectory: String;
begin
  Result:=FDirectory;
end;

procedure TbsSkinFileListView.SetDirectory(NewDir: String);

function IsDrive(S: String): Boolean;
var
  D: Char;
  ErrorMode: Word;
begin
  if (Length(S) = 3) and (Pos(':\', S) <> 0)
  then
    begin
      D := S[1];
      if D in ['a'..'z'] then Dec(D, $20);
      ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
      try
        if DiskSize(Ord(D) - $40) = -1
        then
          begin
            MessageBeep(MB_IconHand);
            if FSkinMessage = nil
            then
               MessageDlg('There is no disk in Drive or Drive is not ready', mtWarning, [mbOK], 0)
            else
              SkinMessage.MessageDlg('There is no disk in Drive or Drive is not ready',
                mtWarning, [mbOK], 0);
            Result := False
          end
        else
          Result := True;
      finally
        SetErrorMode(ErrorMode);
      end;
    end
  else
    Result := True;
end;

begin
  if AnsiCompareText(NewDir,FDirectory) = 0 then Exit;
  if (UpperCase(NewDir)='DRIVES')
  then
    begin
      FDirectory:=NewDir;
      UpdateFileList;
    end
  else
   begin
     if not IsDrive(NewDir) then Exit;
     if not DirectoryExists(NewDir) then Exit;
     NewDir := IncludeTrailingBackslash(NewDir);
     SetCurrentDir(NewDir);
     FDirectory:=NewDir;
     UpdateFileList;
   end;
end;

procedure TbsSkinFileListView.SetMask(const NewMasks: String);
begin
  if FMask<>NewMasks then begin
    FMask:=NewMasks;
    UpdateFileList;
  end;
end;

function TbsSkinFileListView.GetFileName: String;
begin
  Result:=FFileName;
end;

procedure TbsSkinFileListView.SetFileName(NewFile: String);
begin
  if FFileName <> NewFile then FFileName:=NewFile;
end;

procedure TbsSkinFileListView.SetFileType(NewFileType: TFileType);
begin
  if NewFileType<>FFileType then begin
    FFileType:=NewFileType;
    UpdateFileList;
  end;
end;

procedure TbsSkinFileListView.Createimages;
var
  SysImageList: uint;
  SFI: TSHFileInfo;
begin
  Largeimages:=TImageList.Create(self);
  SysImageList:=SHGetFileInfo('',0,SFI,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_LARGEICON);
  if SysImageList<>0 then begin
    Largeimages.Handle:=SysImageList;
    Largeimages.ShareImages:=TRUE;
  end;
  Smallimages:=TImageList.Create(Self);
  SysImageList:=SHGetFileInfo('',0,SFI,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  if SysImageList<>0 then begin
    Smallimages.Handle:=SysImageList;
    Smallimages.ShareImages:=TRUE;
  end;
end;

procedure TbsSkinFileListView.CreateWnd;
begin
  inherited;

  if Columns.Count=0 then begin
    with Columns.Add do begin
      Caption:='名称';
      Width:=200;
    end;
    with Columns.Add do	begin
      Caption:='大小';
      Width:=70;
      Alignment:=taRightJustify;
    end;
    with Columns.Add do	begin
      Caption:='类型';
      Width:=90;
    end;
    with Columns.Add do	begin
      Caption:='修改日期';
      Width:=100;
    end;
    with Columns.Add do	begin
      Caption:='属性';
      width:=60;
    end;
    UpdateFileList;
  end;
  
end;

procedure TbsSkinFileListView.ColumnClick(Sender: TObject;
  Column: TListColumn);
var
  required_column: integer;
begin
  required_column:=Column.Index;
  if required_column=FSortColumn then
    FSortForward:=not FSortForward
  else begin
    FSortColumn:=required_column;
    FSortForward:=True;
  end;
  SortType:=stData;
  SortType:=stNone;
end;

procedure TbsSkinFileListView.CompareFiles(Sender: TObject; Item1,
	Item2: TListItem; Data: Integer; var Compare: Integer);
var
  s1,s2,Caption1, Caption2: String;
  size1, size2: Double;
  result: integer;
begin
  Result := 0;
  if (UpperCase(FDirectory) = 'DRIVES') then Exit;
  if (Item1.SubItems[0] = ' ') and (Item2.SubItems[0] <> ' ')
  then
    Result := -1
  else
  if (Item1.SubItems[0] <> ' ') and (Item2.SubItems[0] = ' ')
  then