如何读取及修改文件的资源

Question

如何读取及修改文件的资源，请给出完整代码及解析。

Answer 1

修改没有试过，只用过loadlibrary

Answer 2

zyl910有读写改换图标的代码。

Answer 3

Option ExplicitPrivate Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As LongEnd Type
Private Type ICONDIR
    idReserved As Integer
    idType As Integer
    idCount As Integer
    ' idEntries() as ICONDIRENTRY array follows.End Type
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 LongEnd Type'bitmapinfoheader icheader;
'rgbquad iccolors[];
'byte icxor[]; '4字节对齐
'byte icand[]; '4字节对齐Private Type BitMapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End TypePrivate Type RGBQuad
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End TypePrivate Declare Function ImageList_ReplaceIcon Lib "comctl32.dll" (ByVal himl As Long, ByVal I As Long, ByVal hIcon As Long) As LongPrivate Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Type BITMAPINFO
    bmiHeader As BitMapInfoHeader
    bmiColors As RGBQuad
End TypePrivate Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQuad) As Long'Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0
Private Const DIB_PAL_COLORS = 1Private Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hDC As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal x As Long, ByVal y As Long, ByVal W As Long, ByVal H As Long, ByVal StateFlags As Long) As Long
Private Const DST_BITMAP As Long = &H4
Private Const DSS_NORMAL As Long = &H0Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
'Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As LongPrivate Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private IcoS() As Long
Private IcoB() As Long
Private IcoCount As LongPrivate Sub LoadIco()
    Dim rc As Long
    Dim I As Long
    
    rc = ExtractIconEx(CDlgOpen.FileName, 0, ByVal 0, ByVal 0&, -1)
    
    If rc <= 0 Then
        MsgBox "没有发现图标！", vbCritical, "错误"
        Exit Sub
    End If
    
    FreeIco
    LV1.ListItems.Clear
    IcoCount = ILLVB.ListImages.Count
    For I = IcoCount + 1 To rc
        ILLVB.ListImages.Add , , Me.Icon
        ILLVS.ListImages.Add , , Me.Icon
    Next I
    
    IcoCount = rc
    ReDim IcoS(0 To IcoCount - 1)
    ReDim IcoB(0 To IcoCount - 1)
    
    If IcoCount > 10 Then Me.MousePointer = vbHourglass
    
    rc = ExtractIconEx(CDlgOpen.FileName, 0, IcoB(0), IcoS(0), IcoCount)
    
    Dim hILLVB As Long, hILLVS As Long
    
    
    hILLVB = ILLVB.hImageList
    hILLVS = ILLVS.hImageList
    
    For I = 0 To IcoCount - 1
        ImageList_ReplaceIcon hILLVB, I, IcoB(I)
        ImageList_ReplaceIcon hILLVS, I, IcoS(I)
        LV1.ListItems.Add , , I, I + 1, I + 1
    Next I
    
    If IcoCount > 10 Then Me.MousePointer = vbDefault
    
End Sub

Answer 4

Private Sub FreeIco()
    Dim I As Long
    
    For I = 0 To IcoCount - 1
        DestroyIcon IcoS(I)
        DestroyIcon IcoB(I)
    Next I
    IcoCount = 0
    
End SubPublic Function ReWrite(FileName As String) As Boolean
    Dim hFile As Long
    
    hFile = FreeFile
    On Error Resume Next
    Open FileName For Output As #hFile
    If Err.Number Then Exit Function
    On Error GoTo 0
    Close hFile
    
    ReWrite = True
    
End FunctionPublic Function SaveIco(ByVal hIcon As Long, FileName As String) As Boolean
    Dim hFile As Long
    
    If ReWrite(FileName) = False Then Exit Function
    
    hFile = FreeFile
    On Error Resume Next
    Open FileName For Binary As #hFile
    If Err.Number Then Exit Function
    On Error GoTo 0
    
    Dim II As ICONINFO
    Dim BM As BITMAP
    Dim ID As ICONDIR
    Dim IDE As ICONDIRENTRY
    Dim BMIH As BitMapInfoHeader
    Dim BMI As BITMAPINFO
    Dim LineWidth As Long
    Dim MapBit() As Byte
    Dim TCB(0 To 1) As RGBQuad
    
    Call GetIconInfo(hIcon, II)
    Call GetObject(II.hbmColor, Len(BM), BM)
    'MsgBox BM.bmWidth & " * " & BM.bmHeight & " * " & BM.bmBitsPixel & "位色"
    
    ID.idReserved = 0
    ID.idType = 1
    ID.idCount = 1
    Put hFile, , ID
    
    With IDE
        .bWidth = BM.bmWidth
        .bHeight = BM.bmHeight
        .bColorCount = &HFF
        .wBitCount = 24
        .wPlanes = 1
        .dwBytesInRes = Len(BMIH)
        .dwBytesInRes = .dwBytesInRes + ((BM.bmWidth * 3 + 3) And &H7FFFFFFC) * BM.bmHeight
        .dwBytesInRes = .dwBytesInRes + (((BM.bmWidth + 7) \ 8 + 3) And &H7FFFFFFC) * BM.bmHeight
        .dwImageOffset = Len(ID) + Len(IDE)
    End With
    Put hFile, , IDE
    
    
    Dim TemphDC As Long
    Dim hDIB As Long
    Dim MapPtr As Long
    Dim OldMap As Long
    Dim TempLng As Long
    Dim I As Long
    
    BMI.bmiHeader.biSize = Len(BMI.bmiHeader)
    BMI.bmiHeader.biWidth = BM.bmWidth
    BMI.bmiHeader.biHeight = BM.bmHeight
    BMI.bmiHeader.biBitCount = 24
    BMI.bmiHeader.biPlanes = 1
    LineWidth = (BM.bmWidth * 3 + 3) And &H7FFFFFFC
    BMI.bmiHeader.biSizeImage = LineWidth * BM.bmHeight
    
    BMIH = BMI.bmiHeader
    BMIH.biHeight = BMIH.biHeight * 2
    Put hFile, , BMIH
    
    TemphDC = CreateCompatibleDC(0)
    hDIB = CreateDIBSection(TemphDC, BMI, DIB_RGB_COLORS, MapPtr, 0, 0)
    'Debug.Print hDIB
    OldMap = SelectObject(TemphDC, hDIB)
    
    DrawState TemphDC, 0, 0, II.hbmColor, 0, 0, 0, 0, 0, DST_BITMAP Or DSS_NORMAL
    'BitBlt Me.hDC, 0, 0, BM.bmWidth, BM.bmHeight, TemphDC, 0, 0, vbSrcCopy
    
    ReDim MapBit(1 To BMI.bmiHeader.biSizeImage)
    CopyMemory MapBit(1), ByVal MapPtr, BMI.bmiHeader.biSizeImage
    'Debug.Print GetDIBits(TemphDC, II.hbmColor, 0, BM.bmHeight, MapBit(1), BMI, DIB_RGB_COLORS)
    Put hFile, , MapBit
    
    
    'Call SelectObject(TemphDC, II.hbmMask)
    BMI.bmiHeader.biBitCount = 1
    LineWidth = ((BM.bmWidth + 31) \ 8) And &H7FFFFFFC
    BMI.bmiHeader.biSizeImage = LineWidth * BM.bmHeight
    Call SelectObject(TemphDC, OldMap)
    hDIB = CreateDIBSection(TemphDC, BMI, DIB_PAL_COLORS, MapPtr, 0, 0)
    OldMap = SelectObject(TemphDC, hDIB)
    TCB(1).rgbRed = &HFF
    TCB(1).rgbGreen = &HFF
    TCB(1).rgbBlue = &HFF
    SetDIBColorTable TemphDC, 0, 2, TCB(0)
    DrawState TemphDC, 0, 0, II.hbmMask, 0, 0, 0, 0, 0, DST_BITMAP Or DSS_NORMAL
    ReDim MapBit(1 To BMI.bmiHeader.biSizeImage)
    CopyMemory MapBit(1), ByVal MapPtr, BMI.bmiHeader.biSizeImage
    'Call GetDIBits(TemphDC, II.hbmMask, 0, BM.bmHeight, MapBit(1), BMI, DIB_RGB_COLORS)
    Put hFile, , MapBit
    
    
    Call SelectObject(TemphDC, OldMap)
    DeleteObject hDIB
    Call DeleteDC(TemphDC)
    
    '由ICONINFO结构载入的位图必须由应用程序删去
    DeleteObject II.hbmMask
    DeleteObject II.hbmColor
    
    Close hFile
    
    SaveIco = True
    
End FunctionPrivate Sub Form_Load()
    CDlgOpen.CancelError = True
    CDlgOpen.Filter = "所有支持的文件(*.exe;*.dll;*.ocx)|*.exe;*.dll;*.ocx|可执行文件(*.exe)|*.exe|动态连接库(*.dll)|*.dll|控件(*.ocx)|*.ocx|所有文件(*.*)|*.*"
    CDlgOpen.FilterIndex = 1
    CDlgOpen.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
    
    CDlgSave.CancelError = True
    CDlgSave.Filter = "图标文件(*.ico)|*.ico"
    CDlgSave.FilterIndex = 1
    CDlgSave.Flags = cdlOFNHideReadOnly
    
    ILLVB.ImageWidth = 32
    ILLVB.ImageHeight = 32
    ILLVS.ImageWidth = 16
    ILLVS.ImageHeight = 16
    ILLVB.ListImages.Add , , Me.Icon
    ILLVS.ListImages.Add , , Me.Icon
    Set LV1.Icons = ILLVB
    Set LV1.SmallIcons = ILLVS
    
End SubPrivate Sub Form_Resize()
    LV1.Move 0, TB1.Height, Me.ScaleWidth, Me.ScaleHeight - TB1.Height
    
End SubPrivate Sub Form_Unload(Cancel As Integer)
    FreeIco
    
End SubPrivate Sub TB1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
    Case "Open"
        On Error Resume Next
        CDlgOpen.ShowOpen
        If Err.Number Then Exit Sub
        On Error GoTo 0
        LoadIco
        
    Case "Save"
        If LV1.ListItems.Count = 0 Then Exit Sub
        
        On Error Resume Next
        CDlgSave.ShowSave
        If Err.Number Then Exit Sub
        On Error GoTo 0
        If SaveIco(IIf(LV1.View = lvwIcon, IcoB(LV1.SelectedItem.Text), IcoS(LV1.SelectedItem.Text)), CDlgSave.FileName) Then
        Else
        End If
        
    Case "BigIco"
        LV1.View = lvwIcon
    Case "SmallIco"
        LV1.View = lvwList
    End Select
    
End Sub