如何使在exe文件提取后的图标，保存后不颜色失真？

Question

如何使在exe文件提取后的图标，保存后不颜色失真？
用savepicture保存后图象失真。
谁能给我一个源码?
mail to : [email protected]

Answer 1

http://vbworld.sxnw.gov.cn/Source/index.asp?kind=graphics&page=2
 IconHunter.zip 144K 这个应用程序能提取，保存并且操作所有类型的图标文件 ( 包括 *.exe ， *.dll,*.icl,*.ico 等等 ) 
这个可行。

Answer 2

多数是用了一个API，不大好用。
VB声明 
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long 
说明 
判断一个可执行文件或DLL中是否有图标存在，并将其提取出来 
返回值 
Long，如成功，返回指向图标的句柄；如文件中不存在图标，则返回零。如果nIconIndex设为-1，就返回文件中的图标总数 
参数表 
参数 类型及说明 
hInst Long，当前应用程序的实例句柄。也可用GetWindowWord函数取得拥有一个窗体或控件的实例的句柄 
lpszExeFileName String，在其中提取图标的那个程序的全名 
nIconIndex Long，欲获取的图标的索引。如果为-1，表示取得文件中的图标总数 

Answer 3

Option ExplicitPublic Const MAXDWORD = &HFFFFFFFF
Public Const MAX_PATH = 260
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10Public Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End TypePublic Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End TypePublic Type FILE_PARAMS
   bRecurse As Boolean
   bList As Boolean
   bFound As Boolean     'not used in this demo
   sFileRoot As String
   sFileNameExt As String
   sResult As String 
   nFileCount As Long 
   nFileSize As Double 
End TypePublic Declare Function FindClose Lib "kernel32" _
  (ByVal hFindFile As Long) As Long
   
Public Declare Function FindFirstFile Lib "kernel32" _
   Alias "FindFirstFileA" _
  (ByVal lpFileName As String, _
   lpFindFileData As WIN32_FIND_DATA) As Long
   
Public Declare Function FindNextFile Lib "kernel32" _
   Alias "FindNextFileA" _
  (ByVal hFindFile As Long, _
   lpFindFileData As WIN32_FIND_DATA) As Long
   
Public Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, ByVal Ptr As Long) As Long
                        
Public Declare Function lstrlenA Lib "kernel32" _
  (ByVal Ptr As Any) As LongPublic Type VS_FIXEDFILEINFO
   dwSignature As Long
   dwStrucVersion As Long 
   dwFileVersionMS As Long 
   dwFileVersionLS As Long   
   dwProductVersionMS As Long  
   dwProductVersionLS As Long  
   dwFileFlagsMask As Long    
   dwFileFlags As Long         
   dwFileOS As Long  
   dwFileType As Long  
   dwFileSubtype As Long  
   dwFileDateMS As Long    
   dwFileDateLS As Long  
End TypePublic Declare Function GetFileVersionInfoSize Lib "version.dll" _
   Alias "GetFileVersionInfoSizeA" _
  (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As LongPublic Declare Function GetFileVersionInfo Lib "version.dll" _
   Alias "GetFileVersionInfoA" _
  (ByVal lptstrFilename As String, _
   ByVal dwHandle As Long, _
   ByVal dwLen As Long, _
   lpData As Any) As Long
   
Public Declare Function VerQueryValue Lib "version.dll" _
   Alias "VerQueryValueA" _
  (pBlock As Any, _
   ByVal lpSubBlock As String, _
   lplpBuffer As Any, nVerSize As Long) As LongPublic Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)
Private Function GetPointerToString(lpString As Long, nBytes As Long) As String   Dim Buffer As String
   
   If nBytes Then
      Buffer = Space$(nBytes)
      CopyMemory ByVal Buffer, ByVal lpString, nBytes
      GetPointerToString = Buffer
   End If
   
End Function
Private Function GetStrFromPtrA(ByVal lpszA As Long) As String   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
   
End Function
Public Function GetFileDescription(sSourceFile As String) As String   Dim FI As VS_FIXEDFILEINFO
   Dim sBuffer() As Byte
   Dim nBufferSize As Long
   Dim lpBuffer As Long
   Dim nVerSize As Long
   Dim nUnused As Long
   Dim tmpVer As String
   Dim sBlock As String
   
   If sSourceFile > "" Then
      nBufferSize = GetFileVersionInfoSize(sSourceFile, nUnused)
      
      ReDim sBuffer(nBufferSize)
      
      If nBufferSize > 0 Then
         Call GetFileVersionInfo(sSourceFile, 0&, nBufferSize, sBuffer(0))
         Call VerQueryValue(sBuffer(0), "\", lpBuffer, nVerSize)
         Call CopyMemory(FI, ByVal lpBuffer, Len(FI))
   
         If VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", lpBuffer, nVerSize) Then
            
            If nVerSize Then
               tmpVer = GetPointerToString(lpBuffer, nVerSize)
               tmpVer = Right("0" & Hex(Asc(Mid(tmpVer, 2, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 1, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 4, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 3, 1))), 2)
               sBlock = "\StringFileInfo\" & tmpVer & "\FileDescription"
               
               If VerQueryValue(sBuffer(0), sBlock, lpBuffer, nVerSize) Then
               
                  If nVerSize Then
                  
                     GetFileDescription = GetStrFromPtrA(lpBuffer)                  End If 
               End If  
            End If 
         End If 
      End If
   End If End Function

Answer 4

' Form Code
Option Explicit
Private Const vbDot As Long= 46
Private twipsX As Long
Private twipsY As LongPrivate Declare Function DrawIcon Lib "user32" _
  (ByVal hdc As Long, _
   ByVal x As Long, _
   ByVal Y As Long, _
   ByVal hIcon As Long) As LongPrivate Declare Function ExtractIcon Lib "shell32" _
   Alias "ExtractIconA" _
  (ByVal hInst As Long, _
   ByVal lpszExeFileName As String, _
   ByVal nIconIndex As Long) As Long
   
Private Declare Function DestroyIcon Lib "user32" _
  (ByVal hIcon As Long) As Long
Private Sub Form_Load()   With Combo1
      .AddItem "*.*"
      .AddItem "*.exe"
      .AddItem "*.dll"
      .AddItem "*.ocx"
      .AddItem "*.ico"
      .ListIndex = 1
   End With
   
   twipsX = Screen.TwipsPerPixelX
   twipsY = Screen.TwipsPerPixelY
   
   With ListView1
      .ColumnHeaders.Add , , "File"
      .ColumnHeaders.Add , , "Icons"
      .ColumnHeaders.Add , , "File Type"
      .ColumnHeaders.Add , , "Full Filename"
      .View = lvwReport
      .FullRowSelect = True  'VB6 only
      .HideSelection = False 'VB6 only
   End With
      
   Text1.Text = LCase$(Environ$("WINDIR") & "\system32")   
   
End Sub
Private Sub Command1_Click()   Dim FP As FILE_PARAMS
    
   ListView1.ListItems.Clear
   
   With FP
      .sFileRoot = Text1.Text
      .sFileNameExt = Combo1.Text
      .bRecurse = Check1.Value = 1
      .bList = True
   End With
   
   Screen.MousePointer = vbHourglass
   Call SearchForFiles(FP)
   Screen.MousePointer = vbDefault
   
End Sub
Private Sub GetFileInformation(FP As FILE_PARAMS)   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
   Dim itmx As ListItem
   Dim nIconCount As Long
   
   Dim lv As Control
   Set lv = ListView1
      
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & FP.sFileNameExt
   
   hFile = FindFirstFile(sPath, WFD)
   
   If hFile <> INVALID_HANDLE_VALUE Then      Do
      
         sTmp = TrimNull(WFD.cFileName)
         If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
            = FILE_ATTRIBUTE_DIRECTORY Then            nIconCount = GetFileIconCount(sRoot & sTmp)            If FP.bList And nIconCount > 0 Then
               Set itmx = lv.ListItems.Add(, , LCase$(sTmp))
               
               itmx.SubItems(1) = nIconCount
               itmx.SubItems(2) = GetFileDescription(sRoot & sTmp)
               itmx.SubItems(3) = LCase$(sRoot & sTmp)
               
            End If
         
         End If
         
      Loop While FindNextFile(hFile, WFD)
      
      hFile = FindClose(hFile)
   
   End IfEnd Sub
Public Function TrimNull(startstr As String) As String   Dim pos As Integer
   
   pos = InStr(startstr, Chr$(0))
   
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
  
   TrimNull = startstr
  
End Function
Private Function QualifyPath(sPath As String) As String   If Right$(sPath, 1) <> "\" Then
         QualifyPath = sPath & "\"
   Else: QualifyPath = sPath
   End If
      
End Function
Private Sub SearchForFiles(FP As FILE_PARAMS)   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
      
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & "*.*"   hFile = FindFirstFile(sPath, WFD)
   
   If hFile <> INVALID_HANDLE_VALUE Then
   
      Call GetFileInformation(FP)      Do
      
         If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then            If FP.bRecurse Then
            
               sTmp = TrimNull(WFD.cFileName)               If Asc(sTmp) <> vbDot Then
              
                  FP.sFileRoot = sRoot & sTmp
                  Call SearchForFiles(FP)
                  
               End If
               
            End If
            
         End If
         
      Loop While FindNextFile(hFile, WFD)
      
      hFile = FindClose(hFile)
   
   End If
   
End Sub
Private Sub GetFileIcons(sIconFile As String)   Dim thisRow As Long
   Dim thisCol As Long
   Dim numIcons As Long
   Dim numRowsNeeded As Long
   Dim rowX As Long
   Dim colX As Long
   Dim cnt As Long
   Dim hIcon As Long
   Const maxPerRow As Long = 10
   
   Picture1.Cls   numIcons = GetFileIconCount(sIconFile)   If numIcons > 0 Then
      numRowsNeeded = numIcons \ maxPerRow      If numRowsNeeded = 0 Then numRowsNeeded = 1      If numRowsNeeded Mod numIcons Then
         numRowsNeeded = numRowsNeeded + 1
      End If      With Picture1
      
         .Left = 0
         .Top = 0
         .Height = (numRowsNeeded * 66) * twipsX
         .Width = Picture2.Width * twipsY
    
         For thisRow = 0 To numRowsNeeded - 1
            For thisCol = 0 To maxPerRow - 1
           
              'this calcs the position within
              'the pixbox to draw the icon
               rowX = (thisCol * 48)
               colX = (thisRow * 60) + 8
            
               If thisCol = 0 Then rowX = rowX + 8
            
                 'get the icon in position
                 'specified by cnt
                  hIcon = ExtractIcon(0&, sIconFile, cnt)
            
                  If hIcon Then
                 
                    'draw the icon
                     Call DrawIcon(Picture1.hdc, rowX, colX, hIcon)
                     .ForeColor = vbBlue
                     .CurrentX = rowX + 2
                     .CurrentY = colX + 33
                  
                    'can't use a With statement against
                    'a Print method!
                     Picture1.Print cnt
                  
                    'we don't need that icon any
                    'longer, so toast it
                     Call DestroyIcon(hIcon)
               
                  End If  'If hIcon
               
               cnt = cnt + 1
            
            Next  'For thisCol
         Next  'For thisRow
      
      End With  'With Picture1
      
   End If  'If numIcons   VScroll1.Min = 0
   VScroll1.Value = 0
   VScroll1.Enabled = True
   
   If numRowsNeeded > 5 Then
      VScroll1.Max = numRowsNeeded + (75)
      VScroll1.Enabled = True
   Else:
      VScroll1.Max = numRowsNeeded
      VScroll1.Enabled = False
   End IfEnd Sub
Private Function GetFileIconCount(sIconFile As String) As Long   GetFileIconCount = ExtractIcon(0&, sIconFile, -1)End Function
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)   ListView1.SortKey = ColumnHeader.index - 1
   ListView1.SortOrder = Abs(Not ListView1.SortOrder = 1)
   ListView1.Sorted = True
   
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)   Call GetFileIcons(Item.SubItems(3))End Sub
Private Sub VScroll1_Change()   Picture1.Top = (VScroll1.Value / 100) * (Picture2.ScaleHeight - Picture1.Height)End Sub
Private Sub VScroll1_Scroll()   Picture1.Top = (VScroll1.Value / 100) * (Picture2.ScaleHeight - Picture1.Height)End Sub
完全抄袭，我没用过。你自己看看吧！