試一試這個比较Cool的工具欄，支持拖放，很省地方哦(有源码2002/02/25更新) (0分)

  • 主题发起人 主题发起人 luyear
  • 开始时间 开始时间
不好意思！注解是繁体的copy过来变成乱码了
 
真的没什么意思，IE4.0以后的东西都有这个功能
 
说我无权访问smiling那个项目：（
 
To woolgate：
我这个可是比IE哪个有意思阿 ！
To 悲酥清风：
你要smiling的权限很简单，到www.smiling.com.cn申请就可以了
 
看到了，可是那儿也有繁体的乱码。
 
现在可以了！！请看楼上！我已经更改了上面的注解
请多多指教
 
提个建议：
定义按钮时，打开对话框最好放些常用的文件类型，如 *.exe, *.doc什么的，在文件多
的时候好找一些。
 
leejames的建议很好，接受这个建议
目前这个软件有时间限制，因为我还在经常更新，目的提醒大家
下载最新的程序，到我不再更新的时候就去掉日期限制
 
DEMO1.03版的主要源代码如下:请多指教
代码: 
unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  fcImage, fcimageform, Buttons, ExtCtrls, shellApi, StdCtrls, MMSYSTEM, IniFiles,
  ComCtrls, ImgList, Menus;
type
  TForm1 = class(TForm)
    SB1: TSpeedButton;
    SB2: TSpeedButton;
    SB3: TSpeedButton;
    Sb4: TSpeedButton;
    Sb5: TSpeedButton;
    Sb6: TSpeedButton;
    Sb7: TSpeedButton;
    Sb8: TSpeedButton;
    Sb9: TSpeedButton;
    Sb10: TSpeedButton;
    Sb11: TSpeedButton;
    Sb12: TSpeedButton;
    Sb13: TSpeedButton;
    Sb14: TSpeedButton;
    sb15: TSpeedButton;
    sb16: TSpeedButton;
    sb17: TSpeedButton;
    sb18: TSpeedButton;
    sb19: TSpeedButton;
    sb20: TSpeedButton;
    sb21: TSpeedButton;
    sb22: TSpeedButton;
    sb23: TSpeedButton;
    sb24: TSpeedButton;
    sb25: TSpeedButton;
    Timer1: TTimer;
    sb26: TSpeedButton;
    sb27: TSpeedButton;
    sb28: TSpeedButton;
    sb29: TSpeedButton;
    sb30: TSpeedButton;
    sb31: TSpeedButton;
    sb32: TSpeedButton;
    sb33: TSpeedButton;
    sb34: TSpeedButton;
    sb35: TSpeedButton;
    sb36: TSpeedButton;
    sb37: TSpeedButton;
    sb38: TSpeedButton;
    Memo1: TMemo;
    sb39: TSpeedButton;
    sb40: TSpeedButton;
    fcImageForm1: TfcImageForm;
    BB1: TSpeedButton;
    BB2: TSpeedButton;
    BB3: TSpeedButton;
    BB4: TSpeedButton;
    BB5: TSpeedButton;
    OpenDlg1: TOpenDialog;
    DTP1: TDateTimePicker;
    ImageList1: TImageList;
    procedure fcImageForm1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
      Y: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure fcImageForm1DblClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
    procedure sb38Click(Sender: TObject);
    procedure sb39Click(Sender: TObject);
    procedure SB1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure BB1Click(Sender: TObject);
    procedure BB2Click(Sender: TObject);
    procedure SB1MouseDown(Sender: TObject;
Button: TMouseButton;
      Shift: TShiftState;
X, Y: Integer);
    procedure BB3MouseDown(Sender: TObject;
Button: TMouseButton;
      Shift: TShiftState;
X, Y: Integer);
    procedure FormDragDrop(Sender, Source: TObject;
X, Y: Integer);
  private
    { Private declarations }
    Ficon:Ticon;
    procedure findfile(j: short);
    procedure MyDrawIcon(i:short);
    PROCEDURE FileIsDropped( VAR Msg : TMessage ) ;
    Message WM_DropFiles ;//消息处理
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  inifile: string;
  MyInifile: TIniFile;
  openfilen: array[1..40] of string;
implementation
{$R *.DFM}
PROCEDURE TForm1.FileIsDropped( VAR Msg : TMessage ) ;
VAR  //支持拖放的单元
 hDrop : THandle ;
 fName : ARRAY[0..254] OF CHAR ;
 NumberOfFiles,i : INTEGER ;
 filefull: boolean;
begin
 hDrop := Msg.WParam ;
 NumberOfFiles := DragQueryFile(hDrop,0,fName,254);
 // ShowMessage(fname);
 //你想干吗就干吗
 filefull:=true;
 for i:= 1 to 40do
   if openfilen[i]='' then
 begin
      openfilen[i]:= fname;
      MyIniFile := TIniFile.Create(inifile);
      MyIniFile.WriteString('file', 'file' + intToStr(i), fname);
      MyIniFile.Free;
      try
       Ficon:=TIcon.Create;
       Mydrawicon(i);
       FIcon.Free ;
      except
       showmessage('不能读取该程序的图标') ;//不能读取该程序的图标！！
      end;
      filefull:=false;
      break;
   end ;
 if filefull then
 MessageBox(handle,'工具栏已满！','提示',MB_IconQuestion+MB_OK);
 DragFinish ( hDrop);
end;

function openExe(filen: string): boolean;
begin
  if fileExists(filen) then
 begin
    result := true;
    shellExecute(0, nil, pchar(filen), nil, nil, SW_ShowNormal);
  end
  else
    result := false;
end;

procedure TForm1.MyDrawIcon(i:short);
var
  SHFileInfo: TSHFILEINFO;
begin
  ImageList1.Clear ;
  //用这个函数效果好，可以获得各种图标，比如和文件相关联的程序图标
  ShGetFileInfo(Pchar(OpenFilen[i]), 0, SHFileInfo, SizeOf(SHFileInfo),
                SHGFI_ICON or SHGFI_SMALLICON);
    Ficon.handle:=SHFileInfo.hIcon;
  ImageList1.addicon(Ficon);
 (FindComponent('sb' + intToStr(i)) as TSpeedbutton).hint:= OpenFilen[i];
  with (Form1.FindComponent('sb' + intToStr(i)) as TSpeedbutton).Glyphdo
 begin
    Width := ImageList1.Width;
    Height := ImageList1.Height;
    Canvas.Brush.Color := clFuchsia;//! for lack of a better color
    Canvas.FillRect(Rect(0,0, Width, Height));
    ImageList1.Draw(Canvas, 0, 0, 0);
  end;

end;

procedure Tform1.findfile(j: short);
begin
  if opendlg1.execute then
 begin
     MyIniFile := TIniFile.Create(inifile);
     MyIniFile.WriteString('file', 'file' + intToStr(j), OpenDlg1.filename);
     MyIniFile.Free;
     OpenFilen[j] := OpenDlg1.filename;
     //(FindComponent('sb' + intToStr(j)) as TSpeedbutton).hint:= OpenFilen[j];
     try
       Ficon:=TIcon.Create;
       Mydrawicon(j);
       FIcon.Free ;
     except
       showmessage('不能读取该程序的图标') ;//不能读取该程序的图标！！
     end;
     openExe(OpenFilen[j]);
  end
end;


procedure TForm1.fcImageForm1MouseMove(Sender: TObject;
Shift: TShiftState;
  X, Y: Integer);
begin
  if form1.Left < 0 then
 begin
    form1.Left := 0;
    form1.top := 0;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var Cur: Tpoint;
begin
//GetCursor(Cur);
  GetCursorPos(cur);
//Cur:=form1.ScreenToClient(cur);
  if ((form1.Left >= 0) or (form1.Left >= 0)) and
    ((Cur.X > 190) or (Cur.Y > 185)) then
 begin
    form1.Left := -145;
    form1.top := -155;
  end;
  //label1.Caption := intToStr(Cur.X);
end;

procedure TForm1.FormCreate(Sender: TObject);
var i: short;
  h: hicon;
  iconindex: word;
begin
  DragAcceptFiles( Handle,True ) ;//这句表示支持文件拖放
  Application.HintPause:=100;{提示延迟}
  Application.HintColor:=clAqua;{提示的颜色}
  Application.HintHidePause:=3500;{显示提示3.5秒}
  Application.HintShortPause:=100;
  //隐含任务栏上的图标
  SetWindowLong( Application.Handle, GWL_EXSTYLE,
                 GetWindowLong(Application.Handle, GWL_EXSTYLE) or
                 WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);
  //ShowWindow(Application.Handle, SW_HIDE);
  //SetWindowLong(handle,GWL_ExStyle,WS_EX_toolWindow);
  form1.Left := -145;
  form1.top := -155;
  i := length(paramstr(0));
  inifile := Copy(ParamStr(0), 1, i - 3) + 'INI';
  bb3.Hint:='左键打开CD-ROM'+#13+'右键关闭CD-ROM';
end;

procedure TForm1.FormShow(Sender: TObject);
var i: integer;
 h:hicon;
 iconindex:word;
 ShFileInfo: TSHFILEINFO;
begin
  if not (FileExists(iniFile)) then
 begin
    memo1.Lines.SaveToFile(inifile);
    MyIniFile := TIniFile.Create(inifile);
  end
  else
 begin
    MyIniFile := TIniFile.Create(inifile);
    Ficon:=TIcon.Create;
    for i := 1 to 40do
 begin
      OpenFilen[i] := MyIniFile.ReadString('file', 'file' + IntToStr(i), '');
      if OpenFilen[i] <> '' then
 begin
        (form1.FindComponent('sb' + intToStr(i)) as TSpeedbutton).hint := OpenFilen[i];
        //
        iconindex:=0;
        try
          Mydrawicon(i);
        except
         ;
        end;
        end
      else
 (form1.FindComponent('sb' + intToStr(i)) as TSpeedbutton).hint :='点击按钮定义你的关联文件'
    end;
    FIcon.Free ;
  end;
  //
  MyIniFile.Free;
end;

procedure TForm1.fcImageForm1DblClick(Sender: TObject);
begin
  close;
end;

procedure TForm1.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
//  if messagebox(handle, 'Are you want to close?', 'information', MB_IconQuestion + MB_YesNO) = ID_No then
//  CanClose := false;
end;

procedure TForm1.sb38Click(Sender: TObject);
begin
  MCISendString('Set CDAudiodo
or open wait', nil, 0, handle);
end;

procedure TForm1.BB3MouseDown(Sender: TObject;
Button: TMouseButton;
  Shift: TShiftState;
X, Y: Integer);
begin
if button=mbRight then
 begin
  MCISendString('Set CDAudiodo
or closed wait', nil, 0, handle);
end
end;

procedure TForm1.sb39Click(Sender: TObject);
begin
MessageBox(handle, '鼠标左键点击打开你定义的程序'+#13+
           '鼠标右键点击(重新)定义链接程序'+#13+
           '直接拖放的话，按顺序排列图标。'+#13+
           '主页: http://go7.163.com/luyear/delphi.htm'+#13+
           '感谢以下网友和DFW的支持:'+#13+
           'redsky.l,Gary Sun,omvm ...' ,'Cool Toolsbar 1.1 帮助',MB_IconQuestion+MB_OK);
end;

procedure TForm1.SB1Click(Sender: TObject);
var i: short;
begin
if DTP1.Date<now then
  begin
  if MessageBox(handle,'这个测试软件已经过期! 要取得新版本吗？(Free)',
            '提示',MB_IconQuestion+MB_YESNO)=idyes then
            BB2Click(Sender);
  close;
  end
else
 begin

  i := (Sender as TspeedButton).tag;
  if OpenFilen[i] <> '' then
 begin
    if openExe(OpenFilen[i]) = false then
      if messageBox(0, pchar('找不到' + Openfilen[i] + '. 重新找 ?'),
        '错误', MB_ICONError + MB_YESNO) = IDYES then
 findfile(i);
  end
  else
    if messageBox(0, pchar('这个按钮还没有定义，要现在定义吗？ '),
      '提示', MB_ICONQuestion + MB_YESNO) = IDYES then
 findfile(i);
//窗体会缩???
  form1.Left := -145;
  form1.top := -155;
end;
end;


procedure TForm1.BB1Click(Sender: TObject);
begin
ShellAbout(handle,pchar('关于 Cool Toolsbar Demo1.1#''s emulant: CopyRight by Luyear 2001  '),
  pchar('E-mail:luyearli@163.com  Page:luyear.yeah.net'),
  Application.icon.handle);
end;

procedure TForm1.BB2Click(Sender: TObject);
begin
shellExecute(handle,nil,pchar('http://go7.163.com/luyear/delphi.htm'),nil,nil,SW_ShowNormal);
end;

procedure TForm1.SB1MouseDown(Sender: TObject;
Button: TMouseButton;
  Shift: TShiftState;
X, Y: Integer);
Var i:short;
begin
if button=mbRight then
 begin
i := (Sender as TspeedButton).tag;
  if OpenFilen[i] <> '' then
 begin
     if messageBox(0, pchar('这个按钮已经指向一个程序，重新定义吗？'),
        '提示', MB_ICONQuestion + MB_YESNO) = IDYES then
 findfile(i);
  end
  else
    if messageBox(0, pchar('这个按钮还没有定义，要现在定义吗？ '),
      '提示', MB_ICONQuestion + MB_YESNO) = IDYES then
 findfile(i);
end;
end;
//

procedure TForm1.FormDragDrop(Sender, Source: TObject;
X, Y: Integer);
begin
//fileisdropped(1);
MessageBox(handle,'???','提示',MB_IconQuestion+MB_OK);
end;

end.
 
为什么不能下？请作者看看。
 
可以啊！我刚看了！有时可能是网易服务器的问题
大富翁的上载区也有，另外有镜象站 http://luyear.51.net
 
[blue]Welldo
ne![/blue][:)]
 
小雨哥：谢谢你的试用和宝贵建议
1.winnt 和 一些系统目录，和一些超长目录(100多字符)我试验过，
没有出现你说的情况，你是怎么加路径的？
2.马上运行的问题，还在考虑是否改。如果你不想马上运行，可以用拖放的方式定义捷径
3.暂时没有考虑多用户的问题，基本大家共享捷径，如有必要以后可能修改
 
NTFS我还没有试验过，我只是试验了98se，me,2000都是fat32磁盘格式
明天找台NTFS的机器试一下看看
 
今天在两台NTFS格式的window 2000 server的机器上试了，没有问题啊！！！
新申請了一個留言板！以後大家可以留言了
 
好久没有更新了,今天终于更新了
去掉了所有的第三方控件,程序小了10K,增加三种内码(GB,BIG5,Eng)的自动识别
这几天吃饱饭没有事情干的时候就看DFW的离线数据库,看到很多好的宝物,自己再琢磨了一下
原来做现状古怪的窗体根本用不了那么多行代码,看我哪个窗体,15行就搞定了
DFW离线库真的好多宝,大家千万不要错过
 
luyear:
确实非常漂亮。
特殊窗体的建立：
http://delphi.about.com/library/weekly/aa120898.htm
 
我创建那个古怪窗体不是我的目的,只是为了省地方
 
接受答案了.
 
to 小雨哥:这个问题我已经结束了,我用Delphi6好久了,但是这个程序没有用delphi6编译
那样文件大了30K,好象没有必要
 
您必须登录或注册才可回复。

Similar threads

P
我等只会 选择组件-> 放在容器里头-> 调整位置和大小->调整属性-> 按两下-> 填写事件处理函数 的“程式女工”应该看看的文
回复
2
查看
451
Andersonchan
A
W
Windows 原生開發工具的瑰寶 – Delphi 6 (李维)(0分)
回复
6
查看
311
wagxu
W
S
转贴:【深度探索】 【李维读者专区】文章 "學 Kylix? 免談!續集:峰迴路轉 "(0分)
回复
4
查看
375
浪里白条
浪
C
漫談 程序員與編程 (转自侯捷网站）(0分)
回复
5
查看
520
cheka
C
后退
顶部