VB 更改注册表键权限

原创 2007年10月03日 12:35:00

VERSION 5.00
Begin VB.Form frmMain
   BorderStyle     =   0  'None
   ClientHeight    =   885
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   885
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'Private Const FOLDER_PATH = "MACHINE/SYSTEM/CurrentControlSet/Enum/ACPI_HAL"
Private Const SYNCHRONIZE As Long = &H100000
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const STANDARD_RIGHTS_WRITE = &H20000
Private Const STANDARD_RIGHTS_EXECUTE = &H20000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = (KEY_READ)
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
'Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const ERROR_SUCCESS = 0&
'Private Const READ_CONTROL = &H20000
'Private Const KEY_QUERY_VALUE = &H1
'Private Const KEY_SET_VALUE = &H2
'Private Const KEY_CREATE_SUB_KEY = &H4
'Private Const KEY_ENUMERATE_SUB_KEYS = &H8
'Private Const KEY_NOTIFY = &H10
'Private Const KEY_CREATE_LINK = &H20
'Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL + KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL) And (Not SYNCHRONIZE))

Private Const DACL_SECURITY_INFORMATION = 4&
Private Const SET_ACCESS = 2&
Private Const SUB_CONTAINERS_AND_OBJECTS_INHERIT = &H3

Private Enum SE_OBJECT_TYPE
    SE_UNKNOWN_OBJECT_TYPE = 0&
    SE_FILE_OBJECT = 1&
    SE_SERVICE = 2&
    SE_PRINTER = 3&
    SE_REGISTRY_KEY = 4&
    SE_LMSHARE = 5&
    SE_KERNEL_OBJECT = 6&
    SE_WINDOW_OBJECT = 7&
End Enum

'
Private Type TRUSTEE
    pMultipleTrustee As Long
    MultipleTrusteeOperation As Long
    TrusteeForm As Long
    TrusteeType As Long
    ptstrName As String
End Type


Private Type EXPLICIT_ACCESS
    grfAccessPermissions As Long
    grfAccessMode As Long
    grfInheritance As Long
    pTRUSTEE As TRUSTEE
End Type


Private Declare Sub BuildExplicitAccessWithName Lib "advapi32.dll" Alias _
    "BuildExplicitAccessWithNameA" _
    (ea As Any, _
    ByVal TrusteeName As String, _
    ByVal AccessPermissions As Long, _
    ByVal AccessMode As Integer, _
    ByVal Inheritance As Long)
   
Private Declare Function SetEntriesInAcl Lib "advapi32.dll" Alias _
    "SetEntriesInAclA" _
    (ByVal CountofExplicitEntries As Long, _
    ea As Any, _
    ByVal OldAcl As Long, _
    NewAcl As Long) As Long

Private Declare Function GetNamedSecurityInfo Lib "advapi32.dll" Alias _
    "GetNamedSecurityInfoA" _
    (ByVal ObjName As String, _
    ByVal SE_OBJECT_TYPE As Long, _
    ByVal SecInfo As Long, _
    ByVal pSid As Long, _
    ByVal pSidGroup As Long, _
    pDacl As Long, _
    ByVal pSacl As Long, _
    pSecurityDescriptor As Long) As Long
   
Private Declare Function SetNamedSecurityInfo Lib "advapi32.dll" Alias _
    "SetNamedSecurityInfoA" _
    (ByVal ObjName As String, _
    ByVal SE_OBJECT As Long, _
    ByVal SecInfo As Long, _
    ByVal pSid As Long, _
    ByVal pSidGroup As Long, _
    ByVal pDacl As Long, _
    ByVal pSacl As Long) As Long

Private Declare Function LocalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
Private commandLine As String


Private Sub Form_Load()
'    MsgBox SetRegKeySecurity("CURRENT_USER/Software/Microsoft/Protected Storage System Provider/S-1-5-21-2459544509-2615247588-1385470033-500")
'    End
'    SetRegKeySecurity "MACHINE/SYSTEM/CurrentControlSet/Enum/usb"
'    End
    Me.Hide
    Dim splitArr() As String
    commandLine = Command
    If commandLine = "" Then Unload Me: End

    If InStr(commandLine, "/") Then
        splitArr = Split(commandLine, "/")
        If UBound(splitArr) >= 1 Then
            If LCase(Trim(splitArr(1))) = "r" Then
                RestoreRegSecurity Trim(splitArr(2))
            Else
                If LCase(Trim(splitArr(1))) = "u" Then
                    SetRegKeySecurity Trim(splitArr(2))
                Else
                   
                    SetRegKeySecurity Trim(splitArr(1))
                End If
            End If
        End If
    ElseIf InStr(commandLine, "-") Then
        splitArr = Split(commandLine, "-")
        If UBound(splitArr) >= 1 Then
            If LCase(Trim(splitArr(1))) = "r" Then
                RestoreRegSecurity Trim(splitArr(2))
            Else
                If LCase(Trim(splitArr(1))) = "u" Then
                    SetRegKeySecurity Trim(splitArr(2))
                Else
                    SetRegKeySecurity Trim(splitArr(1))
                End If
            End If
        End If
    End If
    Unload Me: End
End Sub

Private Function SetRegKeySecurity(ByVal RegPath As String) As Boolean
    Dim result As Long
    Dim pSecDesc As Long
    Dim ea As EXPLICIT_ACCESS
    Dim pNewDACL As Long
    Dim pOldDACL As Long
    result = GetNamedSecurityInfo(RegPath, SE_REGISTRY_KEY, DACL_SECURITY_INFORMATION, 0&, 0&, pOldDACL, 0&, pSecDesc)

    If result = ERROR_SUCCESS Then
        Call BuildExplicitAccessWithName(ea, "EVERYONE", KEY_ALL_ACCESS, SET_ACCESS, SUB_CONTAINERS_AND_OBJECTS_INHERIT)
        result = SetEntriesInAcl(1, ea, pOldDACL, pNewDACL)
        If result = ERROR_SUCCESS Then
            result = SetNamedSecurityInfo(RegPath, SE_REGISTRY_KEY, DACL_SECURITY_INFORMATION, 0&, 0&, pNewDACL, 0&)
            If result = ERROR_SUCCESS Then

            Else
                SetRegKeySecurity = False
                Exit Function
            End If
           
            LocalFree pNewDACL
        Else
            SetRegKeySecurity = False
            Exit Function
        End If
       
        LocalFree pSecDesc
        SetRegKeySecurity = True
        If commandLine <> "" Then
            If InStr(LCase(commandLine), "-u") Or InStr(LCase(commandLine), "/u") Then
                Dim fn As Integer
                fn = FreeFile
                Open "_temp.txt" For Output As #fn
                Print #fn, pOldDACL
                Close #fn
            End If
        End If
    Else
        SetRegKeySecurity = False
        Exit Function
    End If
'    MsgBox SetNamedSecurityInfo(RegPath, SE_REGISTRY_KEY, DACL_SECURITY_INFORMATION, 0&, 0&, pOldDACL, 0&)
End Function

Private Function GetDacl() As Long
    Dim strDacl As String, fn As Integer
    On Error Resume Next
    If Dir(App.Path & "/_temp.txt", 1 Or 2 Or 4) <> "" Then
        fn = FreeFile
        Open App.Path & "/_temp.txt" For Input As #fn
        Line Input #fn, strDacl
        Close #fn
        strDacl = Trim(strDacl)
        If strDacl <> "" And IsNumeric(strDacl) Then
            GetDacl = CLng(strDacl)
        Else
            GetDacl = 0
        End If
    Else
        GetDacl = 0
        Exit Function
    End If
    If GetAttr(App.Path & "/_temp.txt") And vbReadOnly Then
        SetAttr App.Path & "/_temp.txt", 0
    End If
    Kill App.Path & "/_temp.txt"
End Function

Private Function RestoreRegSecurity(ByVal RegPath As String) ', ByVal dacl As Long)
    Dim dacl As Long
    dacl = GetDacl
    If dacl Then
        SetNamedSecurityInfo RegPath, SE_REGISTRY_KEY, DACL_SECURITY_INFORMATION, 0&, 0&, dacl, 0&
        LocalFree dacl
    End If
End Function

 

VB修改注册表

以前找到一个修改注册表的模块。 功能很全,不知道是谁写的。 有时候,由于Window权限设置,从开始运行那里不能启动注册表,那么用这个就可以修改注册表了。VB代码:Option Explicit ...
  • frost_007
  • frost_007
  • 2016年05月05日 16:42
  • 179

普通用户如何修改电源管理方案

今天在微软新闻组里看到一个帖子,网友提这么两个问题(稍作修改): 问题1  用Users组帐户登录系统,打开“电源管理”控制面板窗口,发现无法更改“电源使用方案”,比如将默认的“家用/办公桌”方案(...
  • zcry21cn
  • zcry21cn
  • 2014年01月07日 14:40
  • 1901

火狐(Firefox)浏览器解决首页捆绑的问题

360是解决不了问题的,因为360的浏览器修复主要是注册表和应用程序捆绑,而且大多是针对基于IE内核的 火狐是拥有的自己的内核和扩展机制,对于火狐主页被捆绑,症状如下: 1.打开火狐,出现...
  • prsniper
  • prsniper
  • 2016年07月30日 20:53
  • 1270

批处理:修改COM端口号

发现万能的WMI居然没有实现修改COM端口号的方法,不过用来遍历端口信息还是可以的,参考http://msdn.microsoft.com/en-us/library/aa394413(v=vs.85...
  • binhualiu1983
  • binhualiu1983
  • 2016年06月12日 14:43
  • 369

不重启IE修改代理服务器的设置

IE通过Internet选项进行代理服务器的设置相信大家很熟悉,但是有的情况下,需要有一堆代理IP进行切换,这样就显得很不方便。那我们就弄小工具实现下切换先介绍下注册表下的两个键    HKEY_CU...
  • longzhiwen888
  • longzhiwen888
  • 2015年06月19日 15:47
  • 535

深入应用看本质之-ARP协议

深入应用看本质之-ARP协议
  • feipeixuan
  • feipeixuan
  • 2014年04月26日 18:11
  • 971

VB键盘钩子源码:截取一切键盘按键

VB键盘钩子源码:截取一切键盘按键   (2011-07-15 10:52:11) 转载▼ 标签:  杂谈 分类: 我的VB ...
  • jhs2016
  • jhs2016
  • 2016年08月24日 21:50
  • 946

VB6实现自定义windows的字体对话框修改字体

昨天没有时间把给Kivi的代码发上来,今天补上,仅仅是提供给一些VB的初学者和Kivi同学,如果需要大家可以下载下来看看,VB6是个很老的工具了,不过现在本科的理科同学学还是有需要的这是一个非常简单的...
  • yctccg
  • yctccg
  • 2016年08月16日 10:39
  • 1455

AHCI模式导致系统蓝屏

windows因用AHCI模式蓝屏         windows蓝屏有许多原因,最近在用U盘做启动盘,然后修改BIOS从U盘启动。再重新进入windows系统一出现画面图标就蓝屏,进入安全模式或其他...
  • u012943448
  • u012943448
  • 2013年11月27日 21:12
  • 983

自定义windows登录认证(微软 Credential Providers 详解一《调用原理》)

windows登录认证在不同的windows版本中有不同的方式。在xp中使用gina.dll,而在win7及以上版本使用Credential Providers。在win8及以上版本也是使用Crede...
  • lwwl12
  • lwwl12
  • 2017年07月15日 10:47
  • 555
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:VB 更改注册表键权限
举报原因:
原因补充:

(最多只允许输入30个字)