更改快捷方式的图标 VB

Question

先说下想实现的功能，一个小程序，可以实现更改桌面某快捷方式图标。 
我已经做了一些测试：如下 
Private Sub fnShellLinkObjectSetIconLocationVB() 
Dim objShell As Shell32.Shell 
Dim objFolder As Shell32.Folder Set objShell = New Shell 
Set objFolder = objShell.NameSpace(ssfPROGRAMS) 
If (Not objFolder Is Nothing) Then 
Dim objFolderItem As FolderItem Set objFolderItem = objFolder.ParseName("Internet Explorer.lnk") 
If (Not objFolderItem Is Nothing) Then 
Dim objShellLink As ShellLinkObject Set objShellLink = objFolderItem.GetLink 
If (Not objShellLink Is Nothing) Then 
objShellLink.SetIconLocation objShellLink.path, 1 
objShellLink.Save 
End If 
Set objShellLink = Nothing 
End If 
Set objFolderItem = Nothing 
End If 
Set objFolder = Nothing 
Set objShell = Nothing 
End Sub 但在 
objShellLink.SetIconLocation objShellLink.path, 1 
，即方法SetIconLocation(bs As String, iIcon As Long)时，必须提供一个iIcon，这个iIcon好像只能是快捷方式已有的，或者操作系统的一些，而不能是我自己的。 如何实现提供一个ICON文件的路径，将快捷方式的图标改称这个？？ 
或者改称我的小程序的图标,这样会不会容易些？另外如果可以更改应用程序的图标，也请赐教阿，狂加分。附：我知道右键点击可以更改，但我想代码里实现这个功能。

Answer 1

Public Sub mShellLnk(ByVal LnkName As String, IconFileIconIndex As String, ByVal FilePath As String, Optional ByVal FileName As String, Optional ByVal StrArg As String, Optional ByVal HookKey As String = "", Optional ByVal StrRe As String = "", Optional ByVal strDesktop As String = "")    Dim WshShell As Object, WScript As Object, oShellLink As Object        Set WshShell = CreateObject("WScript.Shell")    If strDesktop = "" Then strDesktop = WshShell.SpecialFolders("Desktop")                      '桌面路径    If UCase(Right(LnkName, 4)) = ".LNK" Then        Set oShellLink = WshShell.CreateShortcut(strDesktop & "\" & LnkName)                   '创建快捷方式,参数为路径和名称    Else        Set oShellLink = WshShell.CreateShortcut(strDesktop & "\" & LnkName & ".lnk")    End If    oShellLink.TargetPath = FilePath & "\" & FileName    oShellLink.Arguments = StrArg    oShellLink.WindowStyle = 1       '风格    oShellLink.Hotkey = HookKey       '热键    oShellLink.IconLocation = IconFileIconIndex       '图标    oShellLink.Description = StrRe       '快捷方式备注内容    oShellLink.WorkingDirectory = FilePath       '源文件所在目录    oShellLink.Save         '保存创建的快捷方式    Set WshShell = Nothing    Set oShellLink = NothingEnd Sub
测试的话,调用: mShellLnk "TestLnk","mspaint.exe","C:\windows\","notepad.exe" 

Answer 2

http://topic.csdn.net/u/20080513/09/70f5e934-3504-40d1-a4b1-538480faf9c1.html2楼我的回复

Answer 3

谢谢，可以实现了，那么如何修改EXE文件的图标呢？？

Answer 4

过分了啊修改EXE图标要修改PE文件滴，豆子貌似有现成源码。

Answer 5

要不发我邮箱
[email protected]
谢谢

Answer 6

改EXE图标,搜索了一下,有现成的....如下:Option ExplicitPrivate Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function BeginUpdateResource Lib "kernel32" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Private Declare Function UpdateResource Lib "kernel32" Alias "UpdateResourceA" (ByVal hUpdate As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function EndUpdateResource Lib "kernel32" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetLastError Lib "kernel32" () As LongPrivate Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_READ = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const OPEN_EXISTING = 3
Private Const RT_ICON = 3&
Private Const DIFFERENCE As Long = 11
Private Const RT_GROUP_ICON As Long = (RT_ICON + DIFFERENCE)Private Type ICONDIRENTRY
    bWidth As Byte
    bHeight As Byte
    bColorCount As Byte
    bReserved As Byte
    wPlanes As Integer
    wBitCount As Integer
    dwBytesInRes As Long
    dwImageOffset As Long
End TypePrivate Type ICONDIR
    idReserved As Integer
    idType As Integer
    idCount As Integer
    'idEntries As ICONDIRENTRY
End TypePrivate Type GRPICONDIRENTRY
    bWidth As Byte
    bHeight As Byte
    bColorCount As Byte
    bReserved As Byte
    wPlanes As Integer
    wBitCount As Integer
    dwBytesInRes As Long
    nID As Integer
End TypePrivate Type GRPICONDIR
    idReserved As Integer
    idType As Integer
    idCount As Integer
    idEntries As GRPICONDIRENTRY
End Type
'//////////////////////////////////////////////
'//函数说明：修改EXE图标
'//
'//参    数：IconFile 图标文件
'//              ExeFile 被修改的EXE文件
'//
'//返回值： 成功为True，否则False
'/////////////////////////////////////////////////////
Private Function ChangeExeIcon(ByVal IconFile As String, ByVal ExeFile As String) As Boolean
    On Error GoTo cw
    
    Dim stID As ICONDIR
    Dim stIDE As ICONDIRENTRY
    Dim stGID As GRPICONDIR
    
    Dim hFile As Long
    Dim pIcon() As Byte, pGrpIcon() As Byte
    Dim nSize As Long, nGSize As Long
    Dim dwReserved As Long
    Dim hUpdate As Long
    Dim ret As Long
    
    hFile = CreateFile(IconFile, GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = INVALID_HANDLE_VALUE Then Exit Function    ret = ReadFile(hFile, stID, Len(stID), dwReserved, ByVal 0&)
    If ret = 0 Then GoTo cw
    
    ret = ReadFile(hFile, stIDE, Len(stIDE), dwReserved, ByVal 0&)    nSize = stIDE.dwBytesInRes
    ReDim pIcon(nSize - 1)
    SetFilePointer hFile, stIDE.dwImageOffset, ByVal 0&, FILE_BEGIN
    ret = ReadFile(hFile, pIcon(0), nSize, dwReserved, ByVal 0&)
    If ret = 0 Then GoTo cw
    
    With stGID
        .idType = 1
        .idCount = stID.idCount
        .idReserved = 0
        CopyMemory stGID.idEntries, stIDE, 12
        .idEntries.nID = 0
    End With
    
    nGSize = Len(stGID)
    ReDim pGrpIcon(nGSize - 1)
    CopyMemory pGrpIcon(0), stGID, nGSize
    
        
    hUpdate = BeginUpdateResource(ExeFile, False)
    ret = UpdateResource(hUpdate, RT_GROUP_ICON, 1, 0, pGrpIcon(0), nGSize)
    ret = UpdateResource(hUpdate, RT_ICON, 1, 0, pIcon(0), nSize)
    EndUpdateResource hUpdate, False    If ret = 0 Then GoTo cw
    ChangeExeIcon = True
    
cw:
    CloseHandle hFile
End Functio调用:Call ChangeExeIcon("D:\temp\123.ico", "D:\temp\123.exe")转自:http://hi.baidu.com/cxwr/blog/item/9d7f53387efe5af1b211c780.html来吧~~~我不会嫌分多的~~~:)

Answer 7

靠 被老马抢先了 bsing楼主测试一下，如果不妥我再帮你找。分我是抢定了 哇咔咔