楼主想得轻松，想得美，呵呵。。。
不过，幸好碰到了我，我的一个爱好就是成人之美。
先在你的 D 盘上新建一个 Icons 文件夹。
代码如下：

Option Explicit

Private Type PICTDESC
  Size As Long
  Type As Long
  hBmpOrIcon As Long
  hPal As Long
End Type
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Sub Command1_Click()
Dim i As Integer, IconCount As Integer, ihdc As Long, aGuid(0 To 3) As Long
Dim OpenName As String, SaveName As String
Dim lpPictDesc As PICTDESC, NewIco As IPicture, Pic As StdPicture

OpenName = "%SystemRoot%\system32\SHELL32.dll"  '这个文件中有237个图标
IconCount = ExtractIcon(0, OpenName, -1)
If IconCount = 0 Then MsgBox "该文件不含图标": Exit Sub
For i = 1 To IconCount
  ihdc = ExtractIcon(0, OpenName, i)
  If ihdc Then
    lpPictDesc.Size = Len(lpPictDesc)
    lpPictDesc.Type = vbPicTypeIcon
    lpPictDesc.hBmpOrIcon = ihdc
    aGuid(0) = &H7BF80980
    aGuid(1) = &H101ABF32
    aGuid(2) = &HAA00BB8B
    aGuid(3) = &HAB0C3000
    OleCreatePictureIndirect lpPictDesc, aGuid(0), True, NewIco
    Set Pic = NewIco
    SaveName = "D:\Icons\" & i & ".ico"
    SavePicture Pic, SaveName
  End If
Next
End Sub

但是，还有一点儿遗憾，看你能否发现？

我发现我对LZ的问题有阅读障碍

回一楼的！
保存后的图标变样了啊，颜色不对。
能不能不先建文件夹呢？

我上传图片了啊，怎么看不到图片呢？图片要如何上传呢？

不先建文件夹
OpenName = "%SystemRoot%\system32\SHELL32.dll"  '这个文件中有237个图标
前加上
If Len(Dir("D:\Icons", vbDirectory)) = 0 Then MkDir "D:\Icons"


好像是savepicture的问题吧,明明显示出来是32色的，一保存就变16色了

[quote]楼主想得轻松，想得美，呵呵。。。
不过，幸好碰到了我，我的一个爱好就是成人之美。
先在你的 D 盘上新建一个 Icons 文件夹。
代码如下：

Option Explicit

Private Type PICTDESC
  Size As Long
  Type As Long
  hBmpOrIcon As Long
  hPal As Long
End Type
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Sub Command1_Click()
Dim i As Integer, IconCount As Integer, ihdc As Long, aGuid(0 To 3) As Long
Dim OpenName As String, SaveName As String
Dim lpPictDesc As PICTDESC, NewIco As IPicture, Pic As StdPicture

OpenName = "%SystemRoot%\system32\SHELL32.dll"  '这个文件中有237个图标
IconCount = ExtractIcon(0, OpenName, -1)
If IconCount = 0 Then MsgBox "该文件不含图标": Exit Sub
For i = 1 To IconCount
  ihdc = ExtractIcon(0, OpenName, i)
  If ihdc Then
    lpPictDesc.Size = Len(lpPictDesc)
    lpPictDesc.Type = vbPicTypeIcon
    lpPictDesc.hBmpOrIcon = ihdc
    aGuid(0) = &H7BF80980
    aGuid(1) = &H101ABF32
    aGuid(2) = &HAA00BB8B
    aGuid(3) = &HAB0C3000
    OleCreatePictureIndirect lpPictDesc, aGuid(0), True, NewIco
    Set Pic = NewIco
    SaveName = "D:\Icons\" & i & ".ico"
    SavePicture Pic, SaveName
  End If
Next
End Sub

但是，还有一点儿遗憾，看你能否发现？[/quote]

提取的图标不是32色的啊？

这就是我所说的遗憾。真彩变成了16色，可能是没有引入系统调色板，我正在做试验，目前暂无进展。。。

[quote]这就是我所说的遗憾。真彩变成了16色，可能是没有引入系统调色板，我正在做试验，目前暂无进展。。。[/quote]
我试了很多代码都不能保存真色彩的图标，保存的都是16色的。
等您的消息！

PS：我有个这样的小软件，不过不知道怎么上传！这个软件是可以提取并保存真色彩图标的。只是没有源代码。截图也不能上传！

我有个软件好像可以实现，是用VB编写的，下次回家我把源代码发上来。

[quote]我有个软件好像可以实现，是用VB编写的，下次回家我把源代码发上来。[/quote]
什么时间啊！快点啊！呵呵！

要提取真菜色的图标，只能分析Icon文件和BMP文件的结构，然后自己用二进制写入。

我当年写过，不过是VC代码来的（现在已经找不着了），在MSDN里面找到的参考例子。