查看: 16  |  回复: 0
  VB6 修改图标,懒得写例子,直接给.bas
楼主
发表于 2024年11月19日 17:37

新建模块 modChangeIcon.bas,代码:

'ChangeExeIcon 图标地址, 文件地址
Option Explicit
Public 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
Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Public Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Public Declare Function BeginUpdateResource Lib "kernel32" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Public 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
Public Declare Function EndUpdateResource Lib "kernel32" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetLastError Lib "kernel32" () As Long
Public Const INVALID_HANDLE_VALUE = -1
Public Const GENERIC_READ = &H80000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_BEGIN = 0
Public Const OPEN_EXISTING = 3
Public Const RT_ICON = 3&
Public Const DIFFERENCE     As Long = 11
Public Const RT_GROUP_ICON  As Long = (RT_ICON + DIFFERENCE)

Public 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

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

Public 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

Public Type GRPICONDIR
    idReserved              As Integer
    idType                  As Integer
    idCount                 As Integer
    idEntries               As GRPICONDIRENTRY
End Type

Public 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


您需要登录后才可以回帖 登录 | 立即注册
【本版规则】请勿发表违反国家法律的内容,否则会被冻结账号和删贴。
用户名: 立即注册
密码:
2020-2024 MaNongKu.com