bsskinshellctrls.pas

BusinessSkinForm_v6.07_FS,delphi皮肤

    procedure PreviewPanelRePaint;
  published
    property ToolButtonsTransparent: Boolean
      read FToolButtonsTransparent write FToolButtonsTransparent;
    property OverwritePromt: Boolean read FOverwritePromt write FOverwritePromt;
    property DialogWidth: Integer read FDialogWidth write FDialogWidth;
    property DialogHeight: Integer read FDialogHeight write FDialogHeight;
    property DialogMinWidth: Integer read FDialogMinWidth write FDialogMinWidth;
    property DialogMinHeight: Integer read FDialogMinHeight write FDialogMinHeight;
    property PaintPanelSize: Integer read FPaintPanelSize write FPaintPanelSize;
    property CheckFileExists: Boolean read FCheckFileExists write  FCheckFileExists;
    property MultiSelection: Boolean read FMultiSelection write FMultiSelection;
    property AlphaBlend: Boolean read FAlphaBlend write FAlphaBlend;
    property AlphaBlendValue: Byte read FAlphaBlendValue write FAlphaBlendValue;
    property AlphaBlendAnimation: Boolean
      read FAlphaBlendAnimation write FAlphaBlendAnimation;
    property CtrlAlphaBlend: Boolean read FCtrlAlphaBlend write FCtrlAlphaBlend;
    property CtrlAlphaBlendValue: Byte read FCtrlAlphaBlendValue write FCtrlAlphaBlendValue;
    property CtrlAlphaBlendAnimation: Boolean
      read FCtrlAlphaBlendAnimation write FCtrlAlphaBlendAnimation;
    property LVHeaderSkinDataName: String
     read FLVHeaderSkinDataName write FLVHeaderSkinDataName;
    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 SetFileName;
    property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
    property OnPreviewPanelPaint: TbsPaintPanelEvent
      read FOnPreviewPanelPaint write FOnPreviewPanelPaint;
  end;

  TbsSkinSavePreviewDialog = class(TbsSkinOpenPreviewDialog)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TbsOpenSoundDlgForm = class(TForm)
  private
    SaveMode: Boolean;
    FolderHistory: TList;
    StopAddToHistory: Boolean;
    CtrlSD: TbsSkinData;
    NewFolderCount: Integer;
  public
    OverwritePromt: Boolean;
    FOnPanelPaint: TbsPaintPanelEvent;
    FileName: String;
    BSF: TbsBusinessSkinForm;
    FileListViewPanel,
    BottomPanel: TbsSkinPanel;
    FLVHScrollBar, FLVVScrollBar: TbsSkinScrollBar;
    FileListView: TbsSkinFileListView;
    FileNameEdit: TbsSkinEdit;
    FilterComboBox: TbsSkinFilterComboBox;
    ShellBox: TbsSkinShellComboBox;
    OpenButton, CancelButton: TbsSkinButton;
    PlayButton, StopButton: TbsSkinSpeedButton;
    Drivelabel, OpenFileLabel, FileTypeLabel: TbsSkinStdLabel;
    ToolPanel: TbsSkinToolBar;
    NewFolderToolButton, UpToolButton, BackToolButton: TbsSkinSpeedButton;
    StyleToolButton: TbsSkinMenuSpeedButton;
    StylePopupMenu: TbsSkinPopupMenu;
    IconMenuItem, SmallIconMenuItem, ReportMenuItem, ListMenuItem: TMenuItem;
    OnFolderChange: TNotifyEvent;
    CheckFileExists: Boolean;
    //
    SoundPanel: TbsSkinToolBar;
    //
    constructor CreateEx(AOwner: TComponent; ASaveMode: Boolean;
                         ACtrlSkinData: TbsSkinData;
                         AToolButtonsTransparent: Boolean);
    destructor Destroy; override;
    procedure FLVChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure FLVPathChange(Sender: TObject);

    procedure FCBChange(Sender: TObject);
    procedure OpenButtonClick(Sender: TObject);
    procedure FLVDBLClick(Sender: TObject);
    procedure FLVKeyPress(Sender: TObject; var Key: Char);
    procedure EditKeyPress(Sender: TObject; var Key: Char);
    procedure UpToolButtonClick(Sender: TObject);
    procedure BackToolButtonClick(Sender: TObject);
    procedure NewFolderToolButtonClick(Sender: TObject);
    procedure ReportItemClick(Sender: TObject);
    procedure ListItemClick(Sender: TObject);
    procedure SmallIconItemClick(Sender: TObject);
    procedure IconItemClick(Sender: TObject);
    procedure InitHistory;
  end;

  TbsSkinOpenSoundDialog = class(TComponent)
  private
    FToolButtonsTransparent: Boolean;
    FOverwritePromt: Boolean;
    FOnPlayButtonClick: TNotifyEvent;
    FOnStopButtonClick: TNotifyEvent;
    FDialogWidth, FDialogHeight: Integer;
    FDialogMinWidth, FDialogMinHeight: Integer;
    FPaintPanelSize: Integer;
    FOnFolderChange: TNotifyEvent;
    FCheckFileExists: Boolean;
    FMultiSelection: Boolean;
    FSD: TbsSkinData;
    FCtrlFSD: TbsSkinData;
    FLVHeaderSkinDataName: String;
    FDefaultFont: TFont;
    FTitle: String;
    FDlgFrm: TbsOpenSoundDlgForm;
    FOnChange: TNotifyEvent;
    FInitialDir: String;
    FFilter: String;
    FFileName: String;
    FFilterIndex: Integer;
    FAlphaBlend: Boolean;
    FAlphaBlendValue: Byte;
    FAlphaBlendAnimation: Boolean;
    FCtrlAlphaBlend: Boolean;
    FCtrlAlphaBlendValue: Byte;
    FCtrlAlphaBlendAnimation: Boolean;
    FFiles: TStringList;
    function GetTitle: string;
    procedure SetTitle(const Value: string);
    procedure SetDefaultFont(Value: TFont);
    procedure SetFileName(const Value: String);
  protected
    FSaveMode: Boolean;
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
    procedure Change;
  public
    ListViewStyle: TViewStyle;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean;
    property Files: TStringList read FFiles;
    function GetSelectedFile: String;
  published
    property ToolButtonsTransparent: Boolean
      read FToolButtonsTransparent write FToolButtonsTransparent;
    property OverwritePromt: Boolean read FOverwritePromt write FOverwritePromt;
    property DialogWidth: Integer read FDialogWidth write FDialogWidth;
    property DialogHeight: Integer read FDialogHeight write FDialogHeight;
    property DialogMinWidth: Integer read FDialogMinWidth write FDialogMinWidth;
    property DialogMinHeight: Integer read FDialogMinHeight write FDialogMinHeight;
    property PaintPanelSize: Integer read FPaintPanelSize write FPaintPanelSize;
    property CheckFileExists: Boolean read FCheckFileExists write  FCheckFileExists;
    property MultiSelection: Boolean read FMultiSelection write FMultiSelection;
    property AlphaBlend: Boolean read FAlphaBlend write FAlphaBlend;
    property AlphaBlendValue: Byte read FAlphaBlendValue write FAlphaBlendValue;
    property AlphaBlendAnimation: Boolean
      read FAlphaBlendAnimation write FAlphaBlendAnimation;
    property CtrlAlphaBlend: Boolean read FCtrlAlphaBlend write FCtrlAlphaBlend;
    property CtrlAlphaBlendValue: Byte read FCtrlAlphaBlendValue write FCtrlAlphaBlendValue;
    property CtrlAlphaBlendAnimation: Boolean
      read FCtrlAlphaBlendAnimation write FCtrlAlphaBlendAnimation;
    property LVHeaderSkinDataName: String
     read FLVHeaderSkinDataName write FLVHeaderSkinDataName;
    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 SetFileName;
    property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
    property OnPlayButtonClick: TNotifyEvent
      read FOnPlayButtonClick write FOnPlayButtonClick;
    property OnStopButtonClick: TNotifyEvent
      read FOnStopButtonClick write FOnStopButtonClick;
  end;

  TbsSkinSaveSoundDialog = class(TbsSkinOpenSoundDialog)
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure InvokeContextMenu(Owner: TWinControl; AFolder: TbsShellFolder; X, Y: Integer);


resourcestring
  SShellNoDetails = 'Unable to retrieve folder details for "%s". Error code $%x';
  SCallLoadDetails = '%s: Missing call to LoadColumnDetails';
  SPalletePage = 'Samples';
  SPropertyName = 'Root';
  SRenamedFailedError = 'Rename to %s failed';
  SErrorSettingPath = 'Error setting path: "%s"';

const
  SRFDesktop = 'rfDesktop';
  SCmdVerbOpen = 'open';
  SCmdVerbRename = 'rename';
  SCmdVerbDelete = 'delete';
  SCmdVerbPaste = 'paste';


implementation

{$R bsSkinShellCtrls}

uses ShellAPI, ComObj, TypInfo, Consts, Math, bsConst, Masks, bsmessages;

const
  nFolder: array[TRootFolder] of Integer =
    (CSIDL_DESKTOP, CSIDL_DRIVES, CSIDL_NETWORK, CSIDL_BITBUCKET, CSIDL_APPDATA,
    CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU,
    CSIDL_COMMON_STARTUP, CSIDL_CONTROLS, CSIDL_DESKTOPDIRECTORY, CSIDL_FAVORITES,
    CSIDL_FONTS, CSIDL_INTERNET, CSIDL_PERSONAL, CSIDL_PRINTERS, CSIDL_PRINTHOOD,
    CSIDL_PROGRAMS, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_STARTMENU, CSIDL_STARTUP,
    CSIDL_TEMPLATES);

  SHGFI = SHGFI_SYSICONINDEX or SHGFI_SMALLICON;   


var
  cmvProperties: PChar = 'properties';  { Do not localize }
  ICM: IContextMenu = nil;
  ICM2: IContextMenu2 = nil;
  DesktopFolder: TbsShellFolder = nil;
  CS : TRTLCriticalSection;

{ PIDL manipulation }

procedure debug(Comp:TComponent; msg:string);
begin
  ShowMessage(Comp.Name + ':' + msg);
end;

function CreatePIDL(Size: Integer): PItemIDList;
var
  Malloc: IMalloc;
begin
  OleCheck(SHGetMalloc(Malloc));

  Result := Malloc.Alloc(Size);
  if Assigned(Result) then
    FillChar(Result^, Size, 0);
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
  Result := IDList;
  Inc(PChar(Result), IDList^.mkid.cb);
end;

procedure StripLastID(IDList: PItemIDList);
var
  MarkerID: PItemIDList;
begin
  MarkerID := IDList;
  if Assigned(IDList) then
  begin
    while IDList.mkid.cb <> 0 do
    begin
      MarkerID := IDList;
      IDList := NextPIDL(IDList);
    end;
    MarkerID.mkid.cb := 0;
  end;
end;

function GetItemCount(IDList: PItemIDList): Integer;
begin
  Result := 0;
  while IDList^.mkid.cb <> 0 do
  begin
    Inc(Result);
    IDList := NextPIDL(IDList);
  end;
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
  Result := 0;
  if Assigned(IDList) then
  begin
    Result := SizeOf(IDList^.mkid.cb);
    while IDList^.mkid.cb <> 0 do
    begin
      Result := Result + IDList^.mkid.cb;
      IDList := NextPIDL(IDList);
    end;
  end;
end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
  Size: Integer;
begin
  Size := GetPIDLSize(IDList);
  Result := CreatePIDL(Size);
  if Assigned(Result) then
    CopyMemory(Result, IDList, Size);
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
  cb1, cb2: Integer;
begin
  if Assigned(IDList1) then
    cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
  else
    cb1 := 0;

  cb2 := GetPIDLSize(IDList2);

  Result := CreatePIDL(cb1 + cb2);
  if Assigned(Result) then
  begin
    if Assigned(IDList1) then
      CopyMemory(Result, IDList1, cb1);
    CopyMemory(PChar(Result) + cb1, IDList2, cb2);
  end;
end;

procedure DisposePIDL(PIDL: PItemIDList);
var
  MAlloc: IMAlloc;
begin
  OLECheck(SHGetMAlloc(MAlloc));
  MAlloc.Free(PIDL);
end;

function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
begin
  Result := AbsoluteID;
  while GetItemCount(Result) > 1 do
     Result := NextPIDL(Result);
  Result := CopyPIDL(Result);
end;

function CreatePIDLList(ID: PItemIDList): TList;
var
  TempID: PItemIDList;
begin
  Result := TList.Create;
  TempID := ID;
  while TempID.mkid.cb <> 0 do
  begin
    TempID := C