“更换图标”对话框(50分)

莫名 · 2002-01-11

比如在桌面上有个快捷方式（以LNK为扩展名的）， 在你的鼠标右键上不是有个属性吗？单击后是不是有个对话框， 然后这个对话框里有个“更换图标”的按钮吗？单击后之后， 出现的就是我要得到的“更换图标”对话框。 请问如何得到这个“更换图标”对话框??更好写点代码给我……

Pipi. · 2002-01-11

现成的不知道有没有，不过如果自己做的话，可以利用win32 api ExtractIconEx 或者 ExtractIcon 取得可执行文件、dll、或者图标文件的图标

莫名 · 2002-01-12

不是的怎么读取图标，我要的是更换图标对话框，比如象魔法兔子那样的， 那好象是有个专门的函数

Ale. · 2002-01-12

我以前的练习 ========================================================================= dlgUnit.pas =========== unit dlgUnit; interface uses   Windows, Messages, SysUtils, Classes, Graphics, Controls,   Forms, Dialogs,StdCtrls, ExtCtrls; type   TForm1 = class(TForm)     Button1: TButton;     Button2: TButton;     Button3: TButton;     Button4: TButton;     Button5: TButton;     Label1: TLabel;     CheckBox1: TCheckBox;     Button6: TButton;     Bevel1: TBevel;     Img: TImage;     Button7: TButton;     Memo1: TMemo;     procedure Button2Click(Sender: TObject);     procedure Button6Click(Sender: TObject);   private     procedure WMQueryEndSession(var Msg: TMessage);       message WM_QueryEndSession; // 这个消息是为防止                                   // 真的退出而设 //    function InitIconFileName: string;   public     { Public declarations }   end; var   Form1: TForm1; // 退出系统的关机函数 procedure ExitWindowsDialog(ParentWnd: HWND); stdcall;                       external 'Shell32.dll' index 60; // 设备变化后的关机重启选择函数的标志说明 // Logoff: Flags := EWX_LOGOFF; // Shutdown: Flags := EWX_SHUTDOWN; // Reboot: Flags := EWX_REBOOT; // Restart: Flags := EW_RESTARTWINDOWS; function RestartDialog(ParentWnd: HWND; Reason: PAnsiChar;                         Flags: LongInt): LongInt; stdcall;                           external 'Shell32.dll' index 59; // 选择图标的函数 function PickIconDlgA(OwnerWnd: HWND; lpstrFile: PAnsiChar;         var nMaxFile: LongInt; var lpdwIconIndex: LongInt):          LongBool;stdcall; external 'SHELL32.DLL' index 62; // 运行对话框函数 procedure RunFileDlgA(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PAnsiChar;          lpstrTitle: PAnsiChar; lpstrDescription: PAnsiChar; Flags: LongInt);          stdcall; external 'Shell32.dll' index 61; implementation  uses ShellAPI;  Const App='Windows 未文档化的函数演示';  Flags: LongInt = 0;  RFF_NOBROWSE = 1; {$R *.DFM} procedure TForm1.WMQueryEndSession(var Msg: TMessage); begin // 只演示,不要真的退出 Windows 消息响应   if CheckBox1.Checked then Msg.Result := 0   else Msg.Result := 1; end; {function TForm1.InitIconFileName: string; var   MSysDir: array[0..MAX_PATH - 1] of Char;   SysDir: string; begin   GetSystemDirectory(MSysDir, 255);   SysDir := StrPas(MSysDir);   if SysDir[Length(SysDir)] <> '/' then   begin     SysDir := SysDir + '/';   end;   Result := SysDir + 'SHELL32.DLL'; end; } procedure TForm1.Button2Click(Sender: TObject); {====实际使用这个函数作为过渡==== function RestartExecute: Boolean; begin if RestartDialog(0,nil,Flags) = IDYES then  begin   Result := True;  end else  Result := False; end; =================================} begin Flags := Flags or RFF_NOBROWSE;   case (Sender as TButton).tag of     0: RestartDialog(self.Handle, '', EWX_SHUTDOWN);     1: RestartDialog(self.Handle, '', EWX_LOGOFF);     2: RestartDialog(self.Handle, '', EWX_REBOOT);     3: RestartDialog(self.Handle, '', EW_RESTARTWINDOWS);     4: ExitWindowsDialog(self.Handle);      { 下一句文字显示在 Win2000 中有问题，没时间了，不搞了}     5: RunFileDlgA(self.Handle,self.Icon.Handle,'C:/',        '运行','',Flags);   end; end; procedure TForm1.Button6Click(Sender: TObject); var // 本段在调试中老放CPU画面，但实际却可以用。   fFileName,Temp: string;   S: array [0..MAX_PATH - 1] of WideChar;//StrPas //  Tem: array [0..MAX_PATH - 1] of Char;   fSize, fIndex: LongInt;   I:Integer;   Icon: TIcon; begin   // 我没有办法解决发出的 PAnsiChar 如何保证         // 既能送出PAnsiChar又能接收PWideChar!!   SetLength(fFileName, 255);  // 给fFileName设定长度   GetSystemDirectory(PChar(fFileName), 255);// 取得系统目录   {  获得实际的fFileName  }   SetLength(fFileName, StrLen(PChar(fFileName)));   {   拼接Shell32.dll  }   fFileName:=fFileName + '/' + 'SHELL32.DLL';   fSize := MAX_PATH;   { 我用了以下的办法解决我的困惑 }  For I:=Low(S) to Length(fFileName) do    S:=WideChar(fFileName);   if PickIconDlgA(self.Handle,PAnsiChar(@S),fSize, fIndex)                                    and (fIndex <> -1) then   begin   SetLength(Temp, MAX_PATH-1);   Temp := S; // 将WideString转换回来，这里的 S              // 已经是 PAnsiChar 了   Icon := TIcon.Create;   Form1.Caption :=App+'   '+ 'FileName:'+Temp+' ,'                              +'Icon:'+ IntToStr(fIndex);   Icon.Handle := ExtractIcon(hInstance, PChar(Temp), fIndex);   Img.Picture.Icon := Icon;   Form1.Icon := Img.Picture.Icon;   Icon := nil;   Icon.Free;   end; end; end. ==================================================================== dlgUnit.dfm =================== object Form1: TForm1   Left = 207   Top = 143   BorderIcons = [biSystemMenu, biMinimize]   BorderStyle = bsSingle   Caption = 'Windows 未文档化的函数演示'   ClientHeight = 400   ClientWidth = 632   Color = clBtnFace   Font.Charset = GB2312_CHARSET   Font.Color = clWindowText   Font.Height = -12   Font.Name = '宋体'   Font.Style = []   Icon.Data = {     0000010001002020000000000000A80800001600000028000000200000004000     0000010008000000000080040000000000000000000000000000000000000000     0000000080000080000000808000800000008000800080800000C0C0C000C0DC     C000F0CAA6000020400000206000002080000020A0000020C0000020E0000040     0000004020000040400000406000004080000040A0000040C0000040E0000060     0000006020000060400000606000006080000060A0000060C0000060E0000080     0000008020000080400000806000008080000080A0000080C0000080E00000A0     000000A0200000A0400000A0600000A0800000A0A00000A0C00000A0E00000C0     000000C0200000C0400000C0600000C0800000C0A00000C0C00000C0E00000E0     000000E0200000E0400000E0600000E0800000E0A00000E0C00000E0E0004000     0000400020004000400040006000400080004000A0004000C0004000E0004020     0000402020004020400040206000402080004020A0004020C0004020E0004040     0000404020004040400040406000404080004040A0004040C0004040E0004060     0000406020004060400040606000406080004060A0004060C0004060E0004080     0000408020004080400040806000408080004080A0004080C0004080E00040A0     000040A0200040A0400040A0600040A0800040A0A00040A0C00040A0E00040C0     000040C0200040C0400040C0600040C0800040C0A00040C0C00040C0E00040E0     000040E0200040E0400040E0600040E0800040E0A00040E0C00040E0E0008000     0000800020008000400080006000800080008000A0008000C0008000E0008020     0000802020008020400080206000802080008020A0008020C0008020E0008040     0000804020008040400080406000804080008040A0008040C0008040E0008060     0000806020008060400080606000806080008060A0008060C0008060E0008080     0000808020008080400080806000808080008080A0008080C0008080E00080A0     000080A0200080A0400080A0600080A0800080A0A00080A0C00080A0E00080C0     000080C0200080C0400080C0600080C0800080C0A00080C0C00080C0E00080E0     000080E0200080E0400080E0600080E0800080E0A00080E0C00080E0E000C000     0000C0002000C0004000C0006000C0008000C000A000C000C000C000E000C020     0000C0202000C0204000C0206000C0208000C020A000C020C000C020E000C040     0000C0402000C0404000C0406000C0408000C040A000C040C000C040E000C060     0000C0602000C0604000C0606000C0608000C060A000C060C000C060E000C080     0000C0802000C0804000C0806000C0808000C080A000C080C000C080E000C0A0     0000C0A02000C0A04000C0A06000C0A08000C0A0A000C0A0C000C0A0E000C0C0     0000C0C02000C0C04000C0C06000C0C08000C0C0A000F0FBFF00A4A0A0008080     80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000     0000000000000000000000000000000000000000000000000000000000000000     000000000000000000000000000000A4A4A4F700000000000000000000000000     0000000000000000000000000098FC0000000000000000010100000000000000     00000000000000000000FC000000000000FC989898FC0000009BA40000000000     0000000000000000FC00000000FC98FCFCFCFCFCFC0000000A0001A400000000     0000000000000000000000FC98FCFCFC000000FC00000000000A010100000000     000000000000000000FC98FCFCFC0000B7A400000000000000031D0000000000     00000000000000ACAC00FCFC000007B7F76EA4000101011F0100000000000000     000000000000E3D9D9000000B707B7F76EA40001016EA4011F00EC0000000000     00000000F4E1D9DADADA000007B7076EA46E00A46EF76EA400EC000000000000     000000F4E1D9D9D1D19999000007B7F700000000006EA400ECA4000000000000     0000F4E0D1D09090D0905900006E076EA46EA4B7A4006E00EC9B000000000000     0000EAD090D0D0D0D090000000006E07B707B707B70000000000000000000000     0009D090D0D0D0D0D8000000000000B707B7F76EF7006EF76EF7000000000000     00EAD0D0D0D8D8D8D80000000000B7F7B7F7B707B700006EF7B7000000000000     09D8D0D0D8D8D8D80000000000B707B7F7B7F6B707B707006EF7000000000000     09D0D0D8D8D8D8E0000000000007B707B7F6B7F6B707006EF76E000000000000     EBD0D8D8D8E0E0E0000000000000076EF7B70700F7B700F7B7076EF700000000     EBD8D8D8E0E0A80600000000000000006EF7B700000000B7076EF70000000000     EBD8D8E0E06828E00000000000000000006E07B7070A00F700076E0000000000     EBD8E0E068292972000000000000000000006E07B707006E0000000B00000000     09D8E0E02932323200000000000000000000006EF7B700F76EF70A0B00000000     09E0E0E0323273737300000000000000000000000000006EF7B7F70000000000     09EAE0693273737CBC000000000000000000000000000A006EF76E0000000000     0009683273737CF409BD000000000000000000000A0A00000000000000000000     00097332737C7CF5080808FF00000000000A0A0A000000000000000000000000     0000097373BBBCBD08F60809BC73730A0A000000000000000000000000000000     00000009B2B3BCF509080809BC733269E8000000000000000000000000000000     0000000008BCB3F4F5F5F5BC7C737272E0E0E0EA080000000000000000000000     00000000000909F4F3BCBC7C73733229E8E9F408000000000000000000000000     000000000000000809F4F4BCF2B2B3F309090000000000000000000000000000     000000000000000000090909090909090000000000000000000000000000FFFF     FFFFFFFF87FFFFFE001FFFF00007FFC00003FFC00003FFC00003FF800003FF00     0007FC00000FF800000FF000000FF000000FE0000007E0000007C0000007C000     0003C0000001C0000003C0000003C0000003C0000003C0000003C0000001E000     0001E0000001F0000003F800000FFC0001FFFE0003FFFF800FFFFFE03FFF}   OldCreateOrder = False   PixelsPerInch = 96   TextHeight = 12   object Bevel1: TBevel     Left = 11     Top = 217     Width = 36     Height = 36     Shape = bsFrame   end   object Label1: TLabel     Left = 8     Top = 3     Width = 189     Height = 12     Caption = '以下均在 Windows 2000 中编制'     Font.Charset = GB2312_CHARSET     Font.Color = clBlack     Font.Height = -12     Font.Name = '宋体'     Font.Style = [fsBold]     ParentFont = False     Transparent = True   end   object Img: TImage     Left = 13     Top = 219     Width = 32     Height = 32     Transparent = True   end   object Button1: TButton     Tag = 4     Left = 11     Top = 54     Width = 171     Height = 25     Caption = '关机重新启动效果'     TabOrder = 0     OnClick = Button2Click   end   object Button2: TButton     Left = 11     Top = 87     Width = 171     Height = 25     Caption = '是否立即关机效果'     TabOrder = 1     OnClick = Button2Click   end   object Button3: TButton     Tag = 1     Left = 11     Top = 119     Width = 171     Height = 25     Caption = '设置改变重新启动效果 A'     TabOrder = 2     OnClick = Button2Click   end   object Button4: TButton     Tag = 2     Left = 11     Top = 152     Width = 171     Height = 25     Caption = '设置改变重新启动效果 B'     TabOrder = 3     OnClick = Button2Click   end   object Button5: TButton     Tag = 3     Left = 11     Top = 184     Width = 171     Height = 25     Caption = '设置改变重新启动效果 C'     TabOrder = 4     OnClick = Button2Click   end   object CheckBox1: TCheckBox     Left = 7     Top = 28     Width = 193     Height = 17     Caption = '只演示,不要真的退出 Windows'     Checked = True     State = cbChecked     TabOrder = 5   end   object Button6: TButton     Left = 66     Top = 222     Width = 115     Height = 25     Caption = '图标选择效果'     TabOrder = 6     OnClick = Button6Click   end   object Button7: TButton     Tag = 5     Left = 11     Top = 258     Width = 171     Height = 25     Caption = '运行对话框效果'     TabOrder = 7     OnClick = Button2Click   end   object Memo1: TMemo     Left = 204     Top = 1     Width = 426     Height = 397     Color = clInfoBk     Font.Charset = ANSI_CHARSET     Font.Color = clWindowText     Font.Height = -12     Font.Name = 'Courier New'     Font.Style = []     Lines.Strings = (       'unit dlgUnit;'       ''       'interface'       ''       'uses'       '  Windows, Messages, SysUtils, Classes, Graphics, '       'Controls,'       '  Forms, Dialogs,StdCtrls, ExtCtrls;'       ''       'type'       '  TForm1 = class(TForm)'       '    Button1: TButton;'       '    Button2: TButton;'       '    Button3: TButton;'       '    Button4: TButton;'       '    Button5: TButton;'       '    Label1: TLabel;'       '    CheckBox1: TCheckBox;'       '    Button6: TButton;'       '    Bevel1: TBevel;'       '    Img: TImage;'       '    Button7: TButton;'       '    Memo1: TMemo;'       '    procedure Button2Click(Sender: TObject);'       '    procedure Button6Click(Sender: TObject);'       '  private'       '    procedure WMQueryEndSession(var Msg: TMessage);'       '      message WM_QueryEndSession; // 这个消息是为防止'       '                                  // 真的退出而设'       '//    function InitIconFileName: string;'       '  public'       '    { Public declarations }'       '  end;'       ''       'var'       '  Form1: TForm1;'       '// 退出系统的关机函数'       'procedure ExitWindowsDialog(ParentWnd: HWND); stdcall;'       '                      external '#39'Shell32.dll'#39' index 60;'       ''       '// 设备变化后的关机重启选择函数的标志说明'       '// Logoff: Flags := EWX_LOGOFF;'       '// Shutdown: Flags := EWX_SHUTDOWN;'       '// Reboot: Flags := EWX_REBOOT;'       '// Restart: Flags := EW_RESTARTWINDOWS;'       'function RestartDialog(ParentWnd: HWND; Reason: '       'PAnsiChar;'       '                        Flags: LongInt): LongInt; '       'stdcall;'       '                          external '#39'Shell32.dll'#39' index '       '59;'       ''       '// 选择图标的函数'       'function PickIconDlgA(OwnerWnd: HWND; lpstrFile: '       'PAnsiChar;'       '        var nMaxFile: LongInt; var lpdwIconIndex: '       'LongInt):'       '         LongBool;stdcall; external '#39'SHELL32.DLL'#39' index '       '62;'       ''       '// 运行对话框函数'       'procedure RunFileDlgA(OwnerWnd: HWND; Icon: HICON; '       'lpstrDirectory: PAnsiChar;'       '         lpstrTitle: PAnsiChar; lpstrDescription: '       'PAnsiChar; '       'Flags: LongInt);'       '         stdcall; external '#39'Shell32.dll'#39' index 61;'       ''       'implementation'       ' uses ShellAPI;'       ' Const App='#39'Windows 未文档化的函数演示'#39';'       ' Flags: LongInt = 0;'       ' RFF_NOBROWSE = 1;'       '{$R *.DFM}'       ''       'procedure TForm1.WMQueryEndSession(var Msg: TMessage);'       'begin // 只演示,不要真的退出 Windows 消息响应'       '      // 这里不能自己表示，要以非模态处理!!'       '  if CheckBox1.Checked then Msg.Result := 1'       '  else Msg.Result := 0;'       'end;'       ''       '{function TForm1.InitIconFileName: string;'       'var'       '  MSysDir: array[0..MAX_PATH - 1] of Char;'       '  SysDir: string;'       'begin'       '  GetSystemDirectory(MSysDir, 255);'       '  SysDir := StrPas(MSysDir);'       '  if SysDir[Length(SysDir)] <> '#39'/'#39' then'       '  begin'       '    SysDir := SysDir + '#39'/'#39';'       '  end;'       '  Result := SysDir + '#39'SHELL32.DLL'#39';'       'end; }'       ''       'procedure TForm1.Button2Click(Sender: TObject);'       '{====实际使用这个函数作为过渡===='       'function RestartExecute: Boolean;'       'begin'       'if RestartDialog(0,nil,Flags) = IDYES then'       ' begin'       '  Result := True;'       ' end'       'else'       ' Result := False;'       'end;'       '=================================}'       'begin'       'Flags := Flags or RFF_NOBROWSE;'       '  case (Sender as TButton).tag of'       '    0: RestartDialog(self.Handle, '#39#39', EWX_SHUTDOWN);'       '    1: RestartDialog(self.Handle, '#39#39', EWX_LOGOFF);'       '    2: RestartDialog(self.Handle, '#39#39', EWX_REBOOT);'       '    3: RestartDialog(self.Handle, '#39#39', EW_RESTARTWINDOWS);'       ''       '    4: ExitWindowsDialog(self.Handle);'       '     { 下一句文字显示在 Win2000 中有问题，没时间了，不搞了}'       '    5: RunFileDlgA(self.Handle,self.Icon.Handle,'#39'C:/'#39','       '       '#39'运行'#39','#39#39',Flags);'       '  end;'       'end;'       ''       'procedure TForm1.Button6Click(Sender: TObject);'       'var // 本段在调试中老放CPU画面，但实际却可以用。'       '  fFileName,Temp: string;'       '  S: array [0..MAX_PATH - 1] of WideChar;//StrPas'       '//  Tem: array [0..MAX_PATH - 1] of Char;'       '  fSize, fIndex: LongInt;'       '  I:Integer;'       '  Icon: TIcon;'       'begin   // 我没有办法解决发出的 PAnsiChar 如何保证'       '        // 既能送出PAnsiChar又能接收PWideChar!!'       '  SetLength(fFileName, 255);  // 给fFileName设定长度'       ''       '  GetSystemDirectory(PChar(fFileName), 255);// 取得系统目录'       '  {  获得实际的fFileName  }'       '  SetLength(fFileName, StrLen(PChar(fFileName)));'       '  {   拼接Shell32.dll  }'       '  fFileName:=fFileName + '#39'/'#39' + '#39'SHELL32.DLL'#39';'       '  fSize := MAX_PATH;'       '  { 我用了以下的办法解决我的困惑 }'       ' For I:=Low(S) to Length(fFileName) do'       '   S:=WideChar(fFileName);'       ''       '  if PickIconDlgA(self.Handle,PAnsiChar(@S),fSize, '       'fIndex)'       '                                   and (fIndex <> -1) '       'then'       '  begin'       '  SetLength(Temp, MAX_PATH-1);'       '  Temp := S; // 将WideString转换回来，这里的 S'       '             // 已经是 PAnsiChar 了'       ''       '  Icon := TIcon.Create;'       '  Form1.Caption :=App+'#39'   '#39'+ '#39'FileName:'#39'+Temp+'#39' ,'#39       '                             +'#39'Icon:'#39'+ IntToStr(fIndex);'       '  Icon.Handle := ExtractIcon(hInstance, PChar(Temp), '       'fIndex);'       '  Img.Picture.Icon := Icon;'       '  Form1.Icon := Img.Picture.Icon;'       '  Icon := nil;'       '  Icon.Free;'       '  end;'       ''       'end;'       ''       'end.')     ParentFont = False     ScrollBars = ssVertical     TabOrder = 8   end end

wind2000 · 2002-01-12

我主页http://ph11.126.com上正好有此控件(带源码),你下载一下吧！ http://go8.163.com/windstorm2000/vcls/ICONDLG.ZIP

莫名 · 2002-01-12

好，先请了。偶先看看去

莫名 · 2002-01-13

To Ale. 你是个高手呀！可以交个朋友吗？我的QQ：6102278 但那个程序读出来的路径是乱码呀？

Ale. · 2002-01-14

你的程序是在 98 里吧,就用下面的过程: unit Unit1; interface uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type   TForm1 = class(TForm)     Button1: TButton;     procedure Button1Click(Sender: TObject);   end; // 选择图标的 API 函数 function PickIconDlgA(OwnerWnd: HWND; lpstrFile: PAnsiChar;   var nMaxFile: LongInt; var lpdwIconIndex: LongInt):   LongBool; stdcall; external 'SHELL32.DLL' index 62; var   Form1: TForm1; implementation uses   ShellAPI; // 这个单元一定要加 !!! const   App = '98 中选择图标的函数演示'; {$R *.DFM} //******************* Button1Click ************************* procedure TForm1.Button1Click(Sender: TObject); var   fFileName: string;   fSize, fIndex: LongInt; begin   SetLength(fFileName, 255);                      // 给fFileName设定长度,其实是分配内存.   GetSystemDirectory(PChar(fFileName), 255);      // 调用 API 取得系统目录   SetLength(fFileName, StrLen(PChar(fFileName))); //   获得实际的fFileName   fFileName := fFileName + '/' + 'SHELL32.DLL';   //   拼接Shell32.dll   fSize := MAX_PATH;   if PickIconDlgA(self.Handle, PAnsiChar(fFileName), fSize, fIndex) // 调用图标选择 API 函数     and (fIndex <> -1) then   begin     Form1.Caption := App + '   ' + 'FileName:' + fFileName + ' ,'   // 在 Form 的标题栏显示文件名       + 'Icon:' + IntToStr(fIndex);     Form1.Icon.Handle := ExtractIcon(hInstance,   // 把选择的图标赋给 Form 的标题栏图标               PChar(fFileName), fIndex);   end; end; end.

“更换图标”对话框(50分)

莫名

Unregistered / Unconfirmed

Pipi.

Unregistered / Unconfirmed

莫名

Unregistered / Unconfirmed

Ale.

Unregistered / Unconfirmed

wind2000

Unregistered / Unconfirmed

莫名

Unregistered / Unconfirmed

莫名

Unregistered / Unconfirmed

Ale.

Unregistered / Unconfirmed

Similar threads