frmoptions.frm

VB开发的自动更新程序

        End With
    End If
    Unload Me
End Sub

Private Sub cmdDef_Click()
    Me.shpTag(0).FillColor = &H800000
    Me.shpTag(1).FillColor = &HFF0000
    Me.shpTag(2).FillColor = 13705184
End Sub

Private Sub Form_Load()
Dim cR As New cReg
    Me.chkAssociate.Enabled = IsAdministrator
    With Setup '-------------------------------- Display current settings
        Me.chkFileNames.Value = Abs(.TestForFileNames)
        Me.shpTag(0).FillColor = .SecTagColor
        Me.shpTag(1).FillColor = .KeyTagColor
        Me.shpTag(2).FillColor = .ValTagColor
        Me.txtDefWeb.Text = .DefaultWeb
        Me.cmbDefConst.Text = .DefaultConst
    End With
    With cR '----------------------------------- Get and display association settings
        .ClassKey = HKEY_CLASSES_ROOT
        .ValueType = REG_SZ
        .SectionKey = ".rus"
        bAssocValue = IIf(Len(.Value), 1, 0)
    End With
    Me.chkAssociate.Value = bAssocValue
End Sub

Private Function WindowsVersion() As Long
'--------------------------------------------------------------
' Purpose   : Returns 1 if 95/98/ME and 2 or > for NT based OS.
'--------------------------------------------------------------
Dim osinfo   As OSVERSIONINFO
Dim retvalue As Integer
    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)
    WindowsVersion = osinfo.dwPlatformId
End Function

Private Function IsAdministrator() As Boolean
'*******************************************************************************************
'Adapted from code written by Randy Birch, http://vbnet.mvps.org
'"How to Determine if the Current User is a Member of Administrators"
'Full post is here: http://vbnet.mvps.org/index.html?code/network/isadministrator.htm
'*******************************************************************************************

 Dim hProcessID     As Long
 Dim hToken         As Long
 Dim res            As Long
 Dim cbBuff         As Long
 Dim tiLen          As Long
 Dim TG             As TOKEN_GROUPS
 Dim SIA            As SID_IDENTIFIER_AUTHORITY
 Dim lSid           As Long
 Dim cnt            As Long
 Dim sAcctName1     As String
 Dim sAcctName2     As String
 Dim cbAcctName     As Long
 Dim sDomainName    As String
 Dim cbDomainName   As Long
 Dim peUse          As Long
 
 '//See if Win9X or ME.
 '..This is the only thing I changed or added in this routine.
 If WindowsVersion = 1 Then
    IsAdministrator = True
    Exit Function
 End If
 
 tiLen = 0
 
'obtain handle to process. 0 indicates failure;
'may return -1 for current process (and is valid)
 hProcessID = GetCurrentProcess()
 
 If hProcessID <> 0 Then

   'obtain a handle to the access
   'token associated with the process
    If OpenProcessToken(hProcessID, TOKEN_READ, hToken) = 1 Then

      'retrieve specified information
      'about an access token. The first
      'call to GetTokenInformation fails
      'since the buffer size is unspecified.
      'On failure the correct buffer size
      'is returned (cbBuff), and a subsequent call
      'is made to return the data.
       res = GetTokenInformation(hToken, _
                                 TokenGroups, _
                                 TG, _
                                 tiLen, _
                                 cbBuff)
       
       If res = 0 And cbBuff > 0 Then

          tiLen = cbBuff
          res = GetTokenInformation(hToken, _
                                    TokenGroups, _
                                    TG, _
                                    tiLen, _
                                    cbBuff)
          
          If res = 1 And tiLen > 0 Then
          
            'The SID_IDENTIFIER_AUTHORITY (SIA) structure
            'represents the top-level authority of a
            'security identifier (SID). By specifying
            'we want admins (by setting the value of
            'the fifth item to SECURITY_NT_AUTHORITY),
            'and passing the relative identifiers (RID)
            'DOMAIN_ALIAS_RID_ADMINS  and
            'SECURITY_BUILTIN_DOMAIN_RID, we obtain
            'the SID for the administrators account
            'in lSid
             SIA.Value(5) = SECURITY_NT_AUTHORITY
 
             res = AllocateAndInitializeSid(SIA, 2, _
                                            SECURITY_BUILTIN_DOMAIN_RID, _
                                            DOMAIN_ALIAS_RID_ADMINS, _
                                            0, 0, 0, 0, 0, 0, _
                                            lSid)
                                            
             If res = 1 Then
             
               'Now obtain the name of the account
               'pointed to by lSid above (ie
               '"Administrators"). Note vbNullString
               'is passed as lpSystemName indicating
               'the SID is looked up on the local computer.
               '
               'Re sDomainName: On Win NT+ systems, the
               'domain name returned for most accounts in
               'the local computer's security database is
               'the computer's name as of the last start
               'of the system (backslashes excluded). If
               'the computer's name changes, the old name
               'continues to be returned as the domain
               'name until the system is restarted.
               '
               'On Win NT+ Server systems, the domain name
               'returned for most accounts in the local
               'computer's security database is the
               'name of the domain for which the server is
               'a domain controller.
               '
               'Some accounts are predefined by the system.
               'The domain name returned for these accounts
               'is BUILTIN.
               '
               'sAcctName is the value of interest in this
               'exercise.
                sAcctName1 = Space$(255)
                sDomainName = Space$(255)
                cbAcctName = 255
                cbDomainName = 255
                res = LookupAccountSid(vbNullString, _
                                       lSid, _
                                       sAcctName1, _
                                       cbAcctName, _
                                       sDomainName, _
                                       cbDomainName, _
                                       peUse)
                                       
                If res = 1 Then
                   
                  'In the call to GetTokenInformation above,
                  'the TOKEN_GROUP member was filled with
                  'the SIDs of the defined groups.
                  '
                  'Here we take each SID from the token
                  'group and retrieve the name of the account
                  'corresponding to the SID. If a SID returns
                  'the same name retrieved above, the user
                  'is a member of the admin group.
                   For cnt = 0 To TG.GroupCount - 1
                   
                      sAcctName2 = Space$(255)
                      sDomainName = Space$(255)
                      cbAcctName = 255
                      cbDomainName = 255
                      
                      res = LookupAccountSid(vbNullString, _
                                             TG.Groups(cnt).Sid, _
                                             sAcctName2, _
                                             cbAcctName, _
                                             sDomainName, _
                                             cbDomainName, _
                                             peUse)
                       
                      If sAcctName1 = sAcctName2 Then
                         IsAdministrator = True
                         Exit For
                      End If   'if sAcctName1 = sAcctName2
                      
                   Next
                   
                End If  'if res = 1 (LookupAccountSid)

                FreeSid ByVal lSid
       
             End If  'if res = 1 (AllocateAndInitializeSid)
             
             CloseHandle hToken
       
          End If  'if res = 1
       
       End If  'if res = 0  (GetTokenInformation)
    
    End If  'if OpenProcessToken
    
    CloseHandle hProcessID

 End If  'if hProcessID  (GetCurrentProcess)
 
End Function

Private Sub CreateAssociation(ByVal bAdd As Byte)
'---------------------------------------------------------------------------------------
' Purpose   : Creates file extension associations and refreshes system icons
'---------------------------------------------------------------------------------------
On Error Resume Next
Dim cR As cReg
    Screen.MousePointer = 11
    Set cR = New cReg
    With cR
        .ClassKey = HKEY_CLASSES_ROOT
        .ValueType = REG_SZ
        If bAdd Then
            .SectionKey = ".rus"
            .Value = "ReViveLiveUpdateScript"
            .CreateKey
            .SectionKey = "ReViveLiveUpdateScript"
            .Value = "ReVive LiveUpdate Script File"
            .CreateKey
            .SectionKey = "ReViveLiveUpdateScript\DefaultIcon"
            .Value = App.path & "\" & App.EXEName & ".exe,1"
            .CreateKey
            .SectionKey = "ReViveLiveUpdateScript\shell\open\command"
            .Value = Chr(34) & App.path & "\" & App.EXEName & ".exe" & Chr(34) & " %1"
            .CreateKey
        Else
            .SectionKey = ".rus"
            .DeleteKey
            .SectionKey = "ReViveLiveUpdateScript\DefaultIcon"
            .DeleteKey
            .SectionKey = "ReViveLiveUpdateScript\shell\open\command"
            .DeleteKey
            .SectionKey = "ReViveLiveUpdateScript\shell\open"
            .DeleteKey
            .SectionKey = "ReViveLiveUpdateScript\shell"
            .DeleteKey
            .SectionKey = "ReViveLiveUpdateScript"
            .DeleteKey
        End If
    End With
    Call RefreshSystemIcons
    Set cR = Nothing
    Screen.MousePointer = 0
End Sub

Private Sub lblTag_Click(Index As Integer)
On Error GoTo Errs
    With frmMain.cd
        .ShowColor
        Me.shpTag(Index).FillColor = .Color
    End With
Errs:
    If Err Then Exit Sub
End Sub

Private Sub lblTag_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
On Error Resume Next
    SetCursor LoadCursor(0, IDC_HAND)
End Sub

Private Sub RefreshSystemIcons()
On Error Resume Next
Dim WSH                         As Object
Dim CurIconSize                 As String
Dim cR                          As New cReg
Dim Result                      As Long
Const HWND_BROADCAST            As Long = &HFFFF&
Const WM_SETTINGCHANGE          As Long = &H1A
Const SPI_SETNONCLIENTMETRICS   As Long = 42
Const SMTO_ABORTIFHUNG          As Long = &H2
Const REG_ICONSIZE_KEY          As String = "HKCU\Control Panel\Desktop\WindowMetrics\Shell Icon Size"
    
    '//Get current icon size
    With cR
        .ClassKey = HKEY_CURRENT_USER
        .SectionKey = "Control Panel\Desktop\WindowMetrics"
        .ValueKey = "Shell Icon Size"
        CurIconSize = .Value
    End With
    '//If no default size, assume 32.
    If CurIconSize = "" Then CurIconSize = 32
    '//Change the icon size to 1 pixel less.
    With cR
        .ClassKey = HKEY_CURRENT_USER
        .SectionKey = "Control Panel\Desktop\WindowMetrics"
        .ValueKey = "Shell Icon Size"
        .ValueType = REG_SZ
        .Value = CurIconSize - 1
    End With
    '//Broadcast change to all running apps
    Call SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS, 0&, SMTO_ABORTIFHUNG, 10000&, Result)
    '//Restore the original icon size.
    With cR
        .ClassKey = HKEY_CURRENT_USER
        .SectionKey = "Control Panel\Desktop\WindowMetrics"
        .ValueKey = "Shell Icon Size"
        .ValueType = REG_SZ
        .Value = CurIconSize
    End With
    '//Broadcast change to all running apps
    Call SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS, 0&, SMTO_ABORTIFHUNG, 10000&, Result)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmOptions = Nothing
End Sub