图标提取器.frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   2295
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   2295
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.HScrollBar HScroll1 
      Height          =   240
      Left            =   668
      TabIndex        =   5
      Top             =   1170
      Width           =   3345
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   645
      Left            =   1950
      ScaleHeight     =   585
      ScaleWidth      =   720
      TabIndex        =   4
      Top             =   315
      Width           =   780
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   180
      Top             =   1710
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command3 
      Caption         =   "退出"
      Height          =   285
      Left            =   3600
      TabIndex        =   3
      Top             =   1845
      Width           =   780
   End
   Begin VB.CommandButton Command2 
      Caption         =   "保存"
      Height          =   285
      Left            =   2587
      TabIndex        =   2
      Top             =   1845
      Width           =   780
   End
   Begin VB.CommandButton Command1 
      Caption         =   "浏览"
      Height          =   285
      Left            =   1575
      TabIndex        =   1
      Top             =   1845
      Width           =   780
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   195
      Left            =   1710
      TabIndex        =   0
      Top             =   1485
      Width           =   2760
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Type ICONINFO
        fIcon As Long
        xHotspot As Long
        yHotspot As Long
        hbmMask As Long
        hbmColor As Long
End Type
Private Type TypeIcon
    cbSize As Long
    picType As PictureTypeConstants
    hIcon As Long
End Type
Private Type CLSID
    ID(16) As Byte
End Type
Dim IconSS As Long
Dim fName As String
Dim MyIcon As Long
Private Sub Command1_Click()
    CommonDialog1.FileName = ""
    CommonDialog1.Filter = "二进制文件|*.exe;*.dll;*.ocx"
    CommonDialog1.ShowOpen
    If CommonDialog1.FileName = "" Then Exit Sub
    fName = CommonDialog1.FileName
    Lis fName
End Sub

Private Sub Command2_Click()
    With CommonDialog1
        .FileName = ""
        .Filter = "图标文件(*.ico)|*.ico"
        .ShowSave
    End With
    If CommonDialog1.FileName = "" Then Exit Sub
    SavePicture Picture1.Picture, CommonDialog1.FileName
End Sub

Private Sub Command3_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Me.Caption = App.Title & App.Major & "." & App.Minor & "." & App.Revision
    Command2.Enabled = False
End Sub
Private Sub Lis(fName As String)
    IconSS = ExtractIcon(App.hInstance, fName, -1)
    Label1.Caption = CommonDialog1.FileTitle & " 中包含 " & Trim(Str(IconSS)) & " 个图标"
    If IconSS < 1 Then
        Command2.Enabled = False
        Exit Sub
    Else
        Command2.Enabled = True
        With HScroll1
            If IconSS = 1 Then
                .Min = 1
                .Max = 1
                .Value = 1
            Else
                .Min = 1
                .Max = IconSS
                .Value = 1
            End If
        End With
        FenLi fName, 0
    End If
End Sub
Private Sub FenLi(allFname As String, Va As Long)
    On Error Resume Next
    Dim Y As Long
    Dim oopp As IPictureDisp
    Dim dddd As ICONINFO
    MyIcon = ExtractIcon(App.hInstance, allFname, Va)
    'GetIconInfo MyIcon, dddd
    'Y = CreateIconIndirect(dddd)
    Set oopp = IconToPicture(MyIcon)
    Picture1.Picture = oopp
End Sub

Private Sub HScroll1_Change()
    FenLi fName, HScroll1.Value - 1
End Sub
Private Function IconToPicture(hIcon As Long)
    Dim ID As CLSID
    Dim hR As Long
    Dim Nicon As TypeIcon
    Dim Lp As Object
    With Nicon
        .cbSize = Len(Nicon)
        .picType = vbPicTypeIcon
        .hIcon = hIcon
    End With
    With ID
        .ID(8) = 192
        .ID(15) = 70
    End With
    hR = OleCreatePictureIndirect(Nicon, ID, 1, Lp)
    DestroyIcon hIcon
    If hR = 0 Then
        Set IconToPicture = Lp
    Else
    End If
    
End Function