更改快捷方式的图标 VB

[cc850107]

先说下想实现的功能，一个小程序，可以实现更改桌面某快捷方式图标。
我已经做了一些测试：如下
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文件的路径，将快捷方式的图标改称这个？？
或者改称我的小程序的图标,这样会不会容易些？

另外如果可以更改应用程序的图标，也请赐教阿，狂加分。

附：我知道右键点击可以更改，但我想代码里实现这个功能。

[CathySun118]

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 StrRemark 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 = StrRemark '快捷方式备注内容

oShellLink.WorkingDirectory = FilePath '源文件所在目录

oShellLink.Save '保存创建的快捷方式

Set WshShell = Nothing

Set oShellLink = Nothing

End Sub




测试的话,调用:

mShellLnk "TestLnk","mspaint.exe","C:\windows\","notepad.exe"

[cc850107]

自己先顶一下。

[cc850107]

在顶一下，不会让我再开贴吧？要不明天再加点分。

[aiguoa3]

关注.... 帮顶一下

[cc850107]

要不发我邮箱
[e-mail]
谢谢

[a5878431]

为了这分，我顶！（感觉真龌龊，为了分还顶一下，唉！）

[杨哥儿]

[Quote=引用 13 楼 a5878431 的回复:]
为了这分，我顶！（感觉真龌龊，为了分还顶一下，唉！）
[/Quote]

[cc850107]

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

[迈克揉索芙特]

[Quote=引用 5 楼 cc850107 的回复:]
谢谢，可以实现了，那么如何修改EXE文件的图标呢？？
[/Quote]

过分了啊

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

[嗷嗷叫的老马]

有分啊?

那我再来抢~~~~~~

[嗷嗷叫的老马]

改EXE图标,搜索了一下,有现成的....如下:

Option Explicit

Private 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 Long

Private 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 Type

Private Type ICONDIR
    idReserved As Integer
    idType As Integer
    idCount As Integer
    'idEntries As ICONDIRENTRY
End Type

Private 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 Type

Private 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

来吧~~~我不会嫌分多的~~~:)

[cc850107]

[Quote=引用 6 楼 Modest 的回复:]
引用 5 楼 cc850107 的回复:
谢谢，可以实现了，那么如何修改EXE文件的图标呢？？


过分了啊

修改EXE图标要修改PE文件滴，豆子貌似有现成源码。
[/Quote]

不过分，嘿嘿，我会加分的。有源码贴下阿，谢谢

[cc850107]

加了一百分，这两个问题我会分开给分的，顶者有分。再开贴太麻烦了，

[嗷嗷叫的老马]

http://topic.csdn.net/u/20080513/09/70f5e934-3504-40d1-a4b1-538480faf9c1.html

2楼我的回复

[嗷嗷叫的老马]

咦,2楼那个就是了....匿

[迈克揉索芙特]

靠 被老马抢先了 bsing

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

[cc850107]

先谢了，我测试下。

[cc850107]

测试成功！结贴。

[嗷嗷叫的老马]

我靠,还果然让那小子抢了45分........强盗哇~~~~~~~~~~~~~~~~~~~~~~~~

[迈克揉索芙特]

[Quote=引用 20 楼 myjian 的回复:]
我靠,还果然让那小子抢了45分........强盗哇~~~~~~~~~~~~~~~~~~~~~~~~
[/Quote]

我抢分 我自豪 哇咔咔