assoutil.frm

很不错的vb源码

Dim mStage As Integer
Dim mStopFlag As Boolean
Dim mresult
Private Const ERROR_SUCCESS = 0&



Private Sub Form_Load()
     ' Configure ListView control.
    lvwAsso.ListItems.Clear
    lvwAsso.ColumnHeaders.Clear
    lvwAsso.ColumnHeaders.Add , , "Ext", 1000
    lvwAsso.ColumnHeaders.Add , , "Title Ref", (3000)
    lvwAsso.ColumnHeaders.Add , , "Association", (Me.Width - 4200)
    lvwAsso.LabelEdit = lvwManual
    lvwAsso.FullRowSelect = True
    lvwAsso.HideSelection = False
    lvwAsso.HideColumnHeaders = False
    lvwAsso.View = lvwReport
    cmdDelete.Enabled = False
    lblProgress.Visible = False
End Sub




Private Sub mnuHelpHelp_Click()
    Dim Msg As String
    Msg = "General" & vbCrLf
    Msg = Msg & "Unless you know what you are doing, refrain from meddling the registry.  To" & vbCrLf
    Msg = Msg & "run Add/Delete, it is advisable to back up System.dat and User.dat first." & vbCrLf & vbCrLf
    Msg = Msg & "List" & vbCrLf
    Msg = Msg & "Display all file extensions in machine which have a file association, their" & vbCrLf
    Msg = Msg & "program title references and their associated executable files." & vbCrLf & vbCrLf
    Msg = Msg & "Add" & vbCrLf
    Msg = Msg & "Add a new file extension associating with an executable file." & vbCrLf & vbCrLf
    Msg = Msg & "Delete" & vbCrLf
    Msg = Msg & "Remove a file extension entry, and if the Title Ref is entered, remove" & vbCrLf
    Msg = Msg & "the Title Ref entry (and its subkeys of DefaultIcon and Shell) from the" & vbCrLf
    Msg = Msg & "alias of location HKEY_CLASSES_ROOT." & vbCrLf & vbCrLf
    Msg = Msg & "Icon in System Tray" & vbCrLf
    Msg = Msg & "Toggle the program icon appearing in the System Tray (If the icon is there," & vbCrLf
    Msg = Msg & "a minimized form becomes invisible, but you may click the icon to restore it)." & vbCrLf
    MsgBox Msg
End Sub



Private Sub cmdList_Click()
    Dim mlistitem As ListItem
    Dim colSubKeys As Collection
    Dim arrAsso() As String
    Dim mkey As Long
    Dim mBuffer As String * 256
    Dim mBufSize As Long
    Dim mClassBuffer As String
    Dim mClassBufSize As Long
    Dim typLastWriteTime As FILETIME
    Dim SubKeyName As String
    Dim SubKeyValue As String
    Dim mValType As Long
    Dim mIndex As Integer
    Dim mKeyRef As String
    Dim mCtn As Integer
    Dim mHasOne As Boolean
    Dim mPercent As Integer
    Dim tmp As String, mChr As String
    Dim i As Integer, j As Integer
    
    Set colSubKeys = New Collection
    
    If RegOpenKeyEx(MainKey, SubKey, 0&, KEY_ALL_ACCESS, mkey) <> 0& Then
        Exit Sub
    End If

    lvwAsso.Visible = True
    lblProgress.Visible = True
    DoEvents
    Screen.MousePointer = vbHourglass
    SetButtomsAndMenus (False)
    mStopFlag = False
    
       ' Enumerate the Subkey's colSubKeys
    mIndex = 0
    Do
        mClassBuffer = ""
        mClassBufSize = 0
        mBufSize = 256
        SubKeyName = Space$(mBufSize)
        mresult = RegEnumKeyEx(mkey, mIndex, SubKeyName, mBufSize, 0, mClassBuffer, _
                mClassBufSize, typLastWriteTime)
        If mresult <> 0& Then
             Exit Do
        End If
        SubKeyName = Left$(SubKeyName, InStr(SubKeyName, Chr$(0)) - 1)
        If Left$(SubKeyName, 1) = "." Then
             colSubKeys.Add SubKeyName
        End If
        mIndex = mIndex + 1
    Loop
        
    lvwAsso.ListItems.Clear
       ' Recursively get information on the keys.
    For i = 1 To colSubKeys.Count
        ListEntryValues0 MainKey, SubKey & "\" & colSubKeys(i)
    Next i
    RegCloseKey mkey
    
    mCtn = lvwAsso.ListItems.Count
    lblProgress.Visible = False
    If mCtn = 0 Then
         SetButtomsAndMenus (True)
         Screen.MousePointer = vbDefault
         MsgBox "No file association found"
         Exit Sub
    End If
    
       ' Fill commands in Listview.
       ' We start from 1 as ListItems is 1-based
    For i = 1 To mCtn
         mKeyRef = lvwAsso.ListItems(i).SubItems(1)
         mLVIndex = i
         DoEnumSubKeys MainKey, SubKey & "\" & mKeyRef & "\" & ShellSubKey
    Next i
    
       ' Check and delete those items without a command, if any
    ReDim arrAsso(mCtn - 1, 2)
    mHasOne = False
    For i = 1 To mCtn
         If Len(Trim(lvwAsso.ListItems(i).SubItems(2))) > 0 Then
              arrAsso(i - 1, 0) = lvwAsso.ListItems(i).Text
              arrAsso(i - 1, 1) = lvwAsso.ListItems(i).SubItems(1)
              arrAsso(i - 1, 2) = lvwAsso.ListItems(i).SubItems(2)
         Else
              mHasOne = True
         End If
    Next i
    If mHasOne Then
         lvwAsso.ListItems.Clear
         For i = 0 To UBound(arrAsso)
             If Len(Trim(arrAsso(i, 2))) > 0 Then
                   Set mlistitem = lvwAsso.ListItems.Add(, , Text:=arrAsso(i, 0))
                   mlistitem.SubItems(1) = arrAsso(i, 1)
                   mlistitem.SubItems(2) = arrAsso(i, 2)
             End If
         Next i
    End If
    mCtn = lvwAsso.ListItems.Count
    
    SetButtomsAndMenus (True)
    lblProgress.Visible = False
    Screen.MousePointer = vbDefault
    If mCtn > 0 Then
         MsgBox "Listing completed.  Total  " & CStr(mCtn)
           ' Let hightlight visible
         If Not Me.WindowState = 1 Then
              lvwAsso.SetFocus
         End If
    Else
         MsgBox "No file association found"
    End If
End Sub



Private Sub DoEnumSubKeys(ByVal inMainKey As Long, ByVal inSubKey As String)
    Dim mkey As Long
    Dim colSubKeys As Collection
    Dim colSubKeyValues As Collection
    
    Dim mBuffer As String * 256
    Dim mBufSize As Long
    Dim mClassBuffer As String * 256
    Dim mClassBufSize As Long
    Dim typLastWriteTime As FILETIME
    
    Dim SubKeyName As String
    Dim SubKeyValue As String
    Dim mValType As Long
    Dim mIndex As Integer
    Dim i As Integer
    Dim tmp As String, mChr As String
    
    Dim Ok As Boolean
    
    Set colSubKeys = New Collection
    
    If RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey) <> 0& Then
        mStopFlag = True
        Exit Sub
    End If

    tmp = ""
    For i = Len(inSubKey) To 1 Step -1
        mChr = Mid(inSubKey, i, 1)
        If mChr = "\" Then
            Exit For
        End If
        tmp = mChr & tmp
    Next i
    
    ListEntryValues1 inMainKey, inSubKey
    
       ' Enumerate the Subkey's colSubKeys
    mIndex = 0
    Do
        mClassBuffer = ""
        mClassBufSize = 0
        mBufSize = 256
        SubKeyName = Space$(mBufSize)
        mresult = RegEnumKeyEx(mkey, mIndex, SubKeyName, mBufSize, 0, mClassBuffer, _
                mClassBufSize, typLastWriteTime)
        If mresult <> 0& Then
             Exit Do
        End If
        SubKeyName = Left$(SubKeyName, InStr(SubKeyName, Chr$(0)) - 1)
        If Len(Trim(SubKeyName)) > 0 Then
             colSubKeys.Add SubKeyName
        End If
        mIndex = mIndex + 1
    Loop
    RegCloseKey mkey
        
       ' Recursively get information on the keys.
    For i = 1 To colSubKeys.Count
        If mStopFlag Then
             Exit Sub
        End If
        DoEnumSubKeys inMainKey, inSubKey & "\" & colSubKeys(i)
    Next i
End Sub




Private Sub ListEntryValues0(ByVal inMainKey As Long, ByVal inSubKey As String)
    Dim mkey
    Dim mEntry As String
    Dim mEntryLength As Long
    Dim mDataType As Long
    Dim arrDataByte(1 To 1024) As Byte
    Dim mDataByteLength As Long
    Dim mDataByteValue As String
    Dim i As Integer
    Dim mIndex As Integer
    Dim NetSubKey As String, mChr As String
    Dim mlistitem As ListItem
    
    mresult = RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey)
    If mresult <> 0 Then
        Exit Sub
    End If
    
    NetSubKey = ""
    For i = Len(inSubKey) To 1 Step -1
        mChr = Mid(inSubKey, i, 1)
        If mChr = "\" Then
            Exit For
        End If
        NetSubKey = mChr & NetSubKey
    Next i
    mIndex = 0
    Do
        mEntryLength = 1024
        mDataByteLength = 1024
        mEntry = Space$(mEntryLength)
        mresult = RegEnumValue(mkey, mIndex, mEntry, mEntryLength, 0, _
           mDataType, arrDataByte(1), mDataByteLength)
        If mresult <> 0 Then                  ' No more
            Exit Do
        End If

        mEntry = Left$(mEntry, mEntryLength)
          ' Note if value is "(No value set)" then the following
          ' will not be displayed, i.e. as if no entry exists.
        If mEntry = "" And mDataByteLength > 0 Then            ' (Default)
             If mDataType = REG_SZ Then
                  mDataByteValue = ""
                  For i = 1 To mDataByteLength - 1
                        mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
                  Next i
                  If Trim(mDataByteValue) <> "" Then
                        Set mlistitem = lvwAsso.ListItems.Add(, , Text:=NetSubKey)
                        mlistitem.SubItems(1) = mDataByteValue
                  End If
             End If
             Exit Do
        End If
        mIndex = mIndex + 1
    Loop
    RegCloseKey mkey
End Sub




Private Sub ListEntryValues1(ByVal inMainKey As Long, ByVal inSubKey As String)
    Dim mkey As Long
    Dim mEntry As String
    Dim mEntryLength As Long
    Dim mDataType As Long
    Dim arrDataByte(1 To 1024) As Byte
    Dim mDataByteLength As Long
    Dim mDataByteValue As String
    Dim i As Integer
    Dim mIndex As Integer
    
    mresult = RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey)
    If mresult <> 0 Then
        Exit Sub
    End If
    
    mIndex = 0
    mEntryLength = 1024
    mDataByteLength = 1024
    mEntry = Space$(mEntryLength)
    mresult = RegEnumValue(mkey, mIndex, mEntry, mEntryLength, 0, _
          mDataType, arrDataByte(1), mDataByteLength)
    If mresult <> 0 Then                  ' No more
        Exit Sub
    End If

    mEntry = Left$(mEntry, mEntryLength)
          ' Note if value is "(No value set)" then the following
          ' will not be displayed, i.e. as if no entry exists.
    If mEntry = "" And mDataByteLength > 0 Then            ' (Default)
         If mDataType = REG_SZ Then
              mDataByteValue = ""
              For i = 1 To mDataByteLength - 1
                    mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
              Next i
              If Trim(mDataByteValue) <> "" Then
                    lvwAsso.ListItems(mLVIndex).SubItems(2) = mDataByteValue
              Else
                    lvwAsso.ListItems(mLVIndex).SubItems(2) = ""
              End If
         End If
    End If
    RegCloseKey mkey
End Sub



' Here we resize lvwAsso and picProgressContainer only
Private Sub Form_Resize()
    Dim h As Single, w As Single
       ' Avoid runtime error
    h = Me.ScaleHeight - lvwAsso.Top
    If h < 150 Then
         h = 150
    End If
    lvwAsso.Move 0, lvwAsso.Top, Me.ScaleWidth, h
    w = (lvwAsso.ColumnHeaders(1).Width + lvwAsso.ColumnHeaders(2).Width + 200)
    If Me.Width > w Then
        lvwAsso.ColumnHeaders(3).Width = (Me.Width - w)
    End If
       ' Make form invisible when minimized, if icon is in system tray
    If mnuSysTrayIcon.Checked Then
         If Me.WindowState = vbMinimized Then
              Me.Hide
         End If
    End If
End Sub



Private Sub SetButtomsAndMenus(ByVal OnOff As Boolean)
    mnuSysTray.Enabled = OnOff
    mnuHelp.Enabled = OnOff
    cmdList.Enabled = OnOff
    cmdAdd.Enabled = OnOff
    cmdDelete.Enabled = OnOff
    If cmdDelete.Enabled = True Then
         cmdDelete.Enabled = (lvwAsso.ListItems.Count > 0)
    End If
End Sub
    


Private Sub cmdExit_Click()
    mnuFileExit_Click
End Sub




Private Sub cmdAdd_Click()
    SetButtomsAndMenus (False)
    lblRemarksForTitleDelete.Visible = False
    lblExecutableFileSpec.Visible = True
    txtExecutableFileSpec.Visible = True
    cmdDialogFileSpec.Visible = True
    lvwAsso.Visible = False
    fraAsso.Caption = "Add"
    txtFileExt.SetFocus
End Sub



Private Sub cmdDelete_Click()
    lblRemarksForTitleDelete.Visible = True
    SetButtomsAndMenus (False)
    lblExecutableFileSpec.Visible = False
    txtExecutableFileSpec.Visible = False
    cmdDialogFileSpec.Visible = False
    lvwAsso.Visible = False
        
      ' Fetch these for user
    txtFileExt.Text = lvwAsso.SelectedItem
    txtTitleRef.Text = lvwAsso.SelectedItem.SubItems(1)
    fraAsso.Caption = "Delete"