assoutil.frm

很不错的vb源码

    txtFileExt.SetFocus
End Sub



Private Sub cmdCancel_Click()
    lvwAsso.Visible = True
    SetButtomsAndMenus (True)
End Sub



Private Sub cmdProceed_Click()
    If fraAsso.Caption = "Add" Then
         ProceedAddition
    ElseIf fraAsso.Caption = "Delete" Then
         ProceedDeletion
    Else
         Exit Sub
    End If
       ' Not until cancel is clicked, don't go back to main screen yet
       ' If task completed successfully, cmdList_Click will be called
       ' and at the end of it, lvwAsso etc will be visible/enabled again.
    'lvwAsso.Visible = True
    'SetButtomsAndMenus (True)
End Sub



Private Sub cmdDialogFileSpec_Click()
     On Error GoTo errhandler
     Dim gcdg As Object
     Set gcdg = CommonDialog1
     gcdg.Filter = "(*.exe)|*.exe|(*.com)|*.com|(*.*)|*.*|"
     gcdg.FilterIndex = 1
     gcdg.DefaultExt = "exe"
     gcdg.Flags = cdlOFNFileMustExist
     gcdg.FileName = ""
     gcdg.CancelError = True
     gcdg.ShowOpen
     If gcdg.FileName = "" Then
         Exit Sub
     End If
     txtExecutableFileSpec.Text = gcdg.FileName
     Exit Sub
    
errhandler:
     If Err <> 32755 Then
         ErrMsgProc "cmdDialogFileSpec_Click"
     End If
End Sub



Private Sub ProceedAddition()
    Dim mKeyHandle As Long
    Dim mkey As Long
    Dim mTitleRef As String
    Dim mFileExt As String
    Dim mExeFileSpec As String
    Dim DispBuffer As Long
    Dim typSA As SecurityAttributes
    typSA.lpSecurityDescriptor = KEY_ALL_ACCESS
    mKeyHandle = HKEY_CLASSES_ROOT
    
    If Left(Trim(txtFileExt.Text), 1) <> "." Then
         mFileExt = "." & Trim(txtFileExt.Text)
    Else
         mFileExt = Trim(txtFileExt.Text)
    End If
    
    mTitleRef = Trim(txtTitleRef.Text)
    mExeFileSpec = Trim(txtExecutableFileSpec.Text)
    If Len(mFileExt) = 1 Then
         MsgBox "No file extension entered yet"
         Exit Sub
    ElseIf mTitleRef = "" Then
         MsgBox "No titel ref entered yet"
         Exit Sub
    ElseIf mExeFileSpec = "" Then
         MsgBox "No association file spec entered yet"
         Exit Sub
    End If
       ' Test existence of association file
    If IsFileThere(mExeFileSpec) = False Then
         MsgBox mExeFileSpec & " not found"
         Exit Sub
    End If
       ' Test existence of subkey(s)
    mresult = RegOpenKeyEx(mKeyHandle, mFileExt, 0, KEY_READ, mkey)
    If mresult = 0 Then
         MsgBox mFileExt & " already in registry"
         Exit Sub
    End If
    RegCloseKey mkey
    mresult = RegOpenKeyEx(mKeyHandle, mTitleRef, 0, KEY_READ, mkey)
    If mresult = 0 Then
         If MsgBox("Title Ref already in existence in the registery." & vbCrLf & _
             "Proceed still?", vbYesNo + vbQuestion) <> vbYes Then
              Exit Sub
         End If
    End If

    If RegCreateKeyEx(mKeyHandle, mFileExt, 0, "", _
        OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSA, mkey, DispBuffer) <> 0 Then
         MsgBox "Unable to create " & mFileExt
         Exit Sub
    End If
    RegCloseKey mkey
         ' Set value to "Default", and value being the title ref.
    If SetRegEntry(mKeyHandle, mFileExt, "", mTitleRef) = False Then
         MsgBox "Unable to set value of " & mTitleRef & " to " & mFileExt
         Exit Sub
    End If
    RegCloseKey mkey
      
    If RegCreateKeyEx(mKeyHandle, mTitleRef, 0, "", _
        OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSA, mkey, DispBuffer) <> 0 Then
         MsgBox "Unable to create " & mTitleRef
         Exit Sub
    End If
       ' We don't have to have a value in mTitleRef
    RegCloseKey mkey
    
    If RegCreateKeyEx(mKeyHandle, mTitleRef & "\shell\open\command", 0, "", _
        OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSA, mkey, DispBuffer) <> 0 Then
         MsgBox "Unable to create " & mTitleRef & "\shell\open\command"
         Exit Sub
    End If
    RegCloseKey mkey
    If SetRegEntry(mKeyHandle, mTitleRef & "\shell\open\command", "", _
             mExeFileSpec & " %1") = False Then
         MsgBox "Unable to set value to " & mTitleRef & "\shell\open\command"
         Exit Sub
    End If
    RegCloseKey mkey

    If RegCreateKeyEx(mKeyHandle, mTitleRef & "\DefaultIcon", 0, "", _
        OPTION_NON_VOLATILE, KEY_ALL_ACCESS, typSA, mkey, DispBuffer) <> 0 Then
         MsgBox "Unable create " & mTitleRef & "\DefaultIcon"
         Exit Sub
    End If
    RegCloseKey mkey
    If SetRegEntry(mKeyHandle, "", mTitleRef & "\DefaultIcon", _
            mExeFileSpec & ",1") = False Then
         MsgBox "Unable to set value to " & mTitleRef & "\DefaultIcon"
         Exit Sub
    End If
    RegCloseKey mkey
    
    If cbxUpdateList.Value = 1 Then
         MsgBox "Addition of subkey to registry completed." & vbCrLf & vbCrLf & _
                "Will proceed to update the list in a moment."
         cmdList_Click
    Else
         MsgBox "Addition of subkey to registry completed."
    End If
    Exit Sub
    
errhandler:
    MsgBox "Addition of subkey to registry failed"
End Sub



Private Function GetRegEntry(ByVal inMainKey As Long, ByVal inSubKey As String, ByVal inEntry As String) As String
    Dim mkey As Long
    Dim mBuffer As String * 255
    Dim mBufSize As Long
    mresult = RegOpenKeyEx(inMainKey, inSubKey, 0, KEY_READ, mkey)
    If mresult = 0 Then
          mBufSize = Len(mBuffer)
          mresult = RegQueryValueEx(mkey, inEntry, 0, REG_SZ, mBuffer, mBufSize)
          If mresult = 0 Then
                If mBuffer <> "" Then
                     GetRegEntry = Mid$(mBuffer, 1, mBufSize)
                End If
                RegCloseKey mkey
          Else                    ' Value may be simply not exist, not an error
                GetRegEntry = ""
          End If
    Else
          MsgBox "Unable to open " & inSubKey
          GetRegEntry = ""
    End If
End Function



Private Function SetRegEntry(ByVal inMainKey As Long, ByVal inSubKey As String, ByVal inEntry As String, ByVal inValue As String) As Boolean
    Dim mkey As Long
    mresult = RegOpenKeyEx(inMainKey, inSubKey, 0, KEY_WRITE, mkey)
    If mresult <> 0 Then
         SetRegEntry = False
         Exit Function
    End If
        ' Here we set value as REG_SZ type, you may set it to other type, e.g.
        ' if the type is REG_DWORD: mresult = RegSetValueExLong(mKey, inEntry,
        ' 0, REG_DWORD, inValue, 4)
    mresult = RegSetValueExString(mkey, inEntry, 0, REG_SZ, inValue, Len(inValue))
    If mresult <> 0 Then
         MsgBox "Unable to set value of " & inValue & " to subkey " & inEntry
    End If
    RegCloseKey mkey
    SetRegEntry = (mresult = 0)
End Function



Private Sub ProceedDeletion()
    Dim mKeyHandle As Long
    Dim mkey1 As Long, mKey2 As Long
    Dim mTitleRef As String
    Dim mFileExt As String
    Dim i
    
    If Left(Trim(txtFileExt.Text), 1) <> "." Then
         mFileExt = "." & Trim(txtFileExt.Text)
    Else
         mFileExt = Trim(txtFileExt.Text)
    End If
    
    If Len(mFileExt) = 1 Then
         MsgBox "No file extension entered yet"
         Exit Sub
    End If
    mTitleRef = Trim(txtTitleRef.Text)
    If mTitleRef = "" Then
         If MsgBox("File ext: " & lvwAsso.SelectedItem & vbCrLf & _
             "Sure to delete ext, but not title ref?", vbYesNo + vbQuestion) <> vbYes Then
              Exit Sub
         End If
    Else
         If MsgBox("File ext: " & lvwAsso.SelectedItem & vbCrLf & _
             "Sure to delete ext and title ref?", vbYesNo + vbQuestion) <> vbYes Then
              Exit Sub
         End If
    End If
    mKeyHandle = HKEY_CLASSES_ROOT
    mresult = RegOpenKeyEx(mKeyHandle, mFileExt, 0, KEY_READ, mkey1)
    If mresult <> 0 Then
         MsgBox "Unable to open subkey " & mFileExt & ".  Pleaser re-check your entry"
         Exit Sub
    ElseIf mTitleRef <> "" Then
         mresult = RegOpenKeyEx(mKeyHandle, mTitleRef, 0, KEY_READ, mKey2)
         If mresult <> 0 Then
              MsgBox "Unable to open subkey " & mTitleRef & ".  Please re-check your entry"
              Exit Sub
         End If
    End If
    RegCloseKey mkey1
    RegCloseKey mKey2
         
    If DoDeleteRegKey(mKeyHandle, mFileExt) Then
         If DoDeleteRegKey(mKeyHandle, mTitleRef) Then
             If cbxUpdateList.Value = 1 Then
                  MsgBox "Association deleted from registry for " & mFileExt & vbCrLf & vbCrLf & _
                      "Will proceed to update the list in a moment."
                  cmdList_Click
             Else
                  MsgBox "Association deleted from registry for " & mFileExt
             End If
         Else
             MsgBox "Failed to complete deletion of association of " & mFileExt
         End If
    Else
         MsgBox "Failed to complete deletion of association of " & mFileExt
    End If
      'Notify shell to refresh the hooked icons, if involved any.
    SHChangeNotify ICON_ASSOCCHANGED, ICON_IDLIST, 0, 0
End Sub




' Delete a key
Private Function DoDeleteRegKey(ByVal inMainKey As Long, ByVal inSubKey As String) As Boolean
    On Error GoTo errhandler
    Dim One_Level_Up As String
    Dim mkey As Long
    Dim mPos As Integer

    If Right$(inSubKey, 1) = "\" Then
         inSubKey = Left$(inSubKey, Len(inSubKey) - 1)
    End If
       ' Delete the inSubkey's own subkeys first
    If DeleteSubkeys(inMainKey, inSubKey) = False Then
         GoTo errhandler
    End If
    
       ' Get the parent of inSubkey
    mPos = InStrRev(inSubKey, "\")
    If mPos = 0 Then
           ' This is a top-level key, delete it from the inMainKey.
         RegDeleteKey inMainKey, inSubKey
    Else
           ' Find the parent key within inSubKey itself.
         One_Level_Up = Left$(inSubKey, mPos - 1)
         inSubKey = Mid$(inSubKey, mPos + 1)
         mresult = RegOpenKeyEx(inMainKey, One_Level_Up, 0, KEY_ALL_ACCESS, mkey)
         If mresult = 0 Then
              RegDeleteKey mkey, inSubKey
              RegCloseKey mkey
         End If
    End If
    DoDeleteRegKey = True
    Exit Function
errhandler:
    DoDeleteRegKey = False
End Function




  ' Delete all the subkey's subkeys.
Private Function DeleteSubkeys(ByVal inMainKey As Long, ByVal inSubKey As String) As Boolean
    On Error GoTo errhandler
    Dim mkey As Long
    Dim colSubKeys As Collection
    Dim mClassBuffer As String * 255
    Dim mClassBufSize As Long
    Dim typLastWriteTime As FILETIME
    Dim mIndex As Long
    Dim mBufSize As Long
    Dim mSubKeyName As String

    mresult = RegOpenKeyEx(inMainKey, inSubKey, 0, KEY_ALL_ACCESS, mkey)
    If mresult <> 0 Then
         MsgBox "Unable to open " & inSubKey
         GoTo errhandler
    End If

    Set colSubKeys = New Collection
    mIndex = 0
    Do
         ' lpClassBuffer is a pointer to a buffer that receives the null-terminated
         ' class string of the enumerated subkey. No classes are currently defined;
         ' hence this parameter can be NULL.
         ' lpClassBufSize is a pointer to a variable that specifies the size of
         ' lpClassBuffer, including the terminating null character. When the function
         ' returns, it contains the number of characters stored in the buffer.
         ' The count returned does not include the terminating null character.
                
        mClassBuffer = ""
        mClassBufSize = 0
        mBufSize = 256
        mSubKeyName = Space$(mBufSize)
        mresult = RegEnumKeyEx(mkey, mIndex, mSubKeyName, mBufSize, 0, mClassBuffer, _
                mClassBufSize, typLastWriteTime)
    
        If mresult <> 0 Then                    ' No more
             DeleteSubkeys = True
             Exit Function
        End If
        mIndex = mIndex + 1
        mSubKeyName = Left$(mSubKeyName, InStr(mSubKeyName, Chr$(0)) - 1)
        colSubKeys.Add mSubKeyName
    Loop
    For mIndex = 1 To colSubKeys.Count
          ' Delete the subkey's colSubKeys first
        DeleteSubkeys inMainKey, inSubKey & "\" & colSubKeys(mIndex)
          ' Effect delete of the subkey itself
        RegDeleteKey mkey, colSubKeys(mIndex)
    Next mIndex

    RegCloseKey mkey
    
    DeleteSubkeys = True
    Exit Function
    
errhandler:
    DeleteSubkeys = False
End Function



Private Sub mnuFileExit_Click()
    mStopFlag = True
    Unload Me
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
     On Error Resume Next       ' Since cannot rely on value mnuSysTray.Checked here
'    If mnuSysTray.Checked = True Then
         RemoveIconFromTray
'    End If
End Sub



Private Sub mnuSysTrayIcon_Click()
    Dim c As Boolean
    Dim i As Integer
    c = mnuSysTrayIcon.Checked
    mnuSysTrayIcon.Checked = Not c
    If mnuSysTrayIcon.Checked = True Then
         If Me.WindowState = vbMinimized Then
              i = vbNormal
         Else
              i = Me.WindowState
         End If
         AddIconToTray i, Me, mnuFile, "File association utility"
    Else
         RemoveIconFromTray
    End If
End Sub