免费申请网站永久域名设计网站模板

当你给一家公司做技术支持的时候，需求各种各样的，其中今天遇到就是要修改某个程序的图标，代码实现如下。

'// q1016058890  群 214016721
'//注    意：这个方法貌似只对有些EXE文件有效，这不是万能的方法，此方法只能做为参考所用
'//
'//函数说明：修改EXE图标
'//参    数：IconFile 图标文件 ExeFile 被修改的EXE文件
'//返 回 值： 成功为True，否则False
'//
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

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 Function

Private Sub Command1_Click() '调用方法
    Dim a As Boolean
    a = ChangeExeIcon("c:/1.ico", "c:/1.exe")
    If a = True Then
        MsgBox "成功"
    Else
        MsgBox "失败"
    End If
End Sub