• Home
 · 
• Windows API Call/Explanation
 · 
• 'Registry Manipulation 'Enable/Disable RegEdit 'Set Application Limit 'Granting of License (criteri

'Registry Manipulation 'Enable/Disable RegEdit 'Set Application Limit 'Granting of License (criteri

'Registry Manipulation 'Enable/Disable RegEdit 'Set Application Limit 'Granting of License (criteria based on you) 'Autorun Program, etc.

Rate 'Registry Manipulation 'Enable/Disable RegEdit 'Set Application Limit 'Granting of License (criteri

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Private Sub Command1_Click()
    Dim cls_reg As New clsReg
    With cls_reg
        cls_reg.AppName = Trim(Text2)
        MsgBox .WillRunAtStartup
    End With
End Sub

Private Sub Command2_Click()
    Dim cls_reg As New clsReg
    With cls_reg
        .AppName = Trim(Text2)
        .RunAtStartUp = False
        .SetRunAtStartup
    End With
End Sub

Private Sub Command3_Click()
    Dim cls_reg As New clsReg, intnu%
    
    'License Granted
    cls_reg.ShareWareLimit 2, Trim(Text2)
    
End Sub

Private Sub Command4_Click()
    Dim cls_reg As New clsReg
    With cls_reg
        .AppName = Trim(Text2)
        .AppPath = Trim(Text3)
        .RunAtStartUp = True
        .SetRunAtStartup
    End With
End Sub

Private Sub Command5_Click()
    Dim cls_reg As New clsReg, intnu%
    
    'Set Shareware Limit
    cls_reg.ShareWareLimit 1, Trim(Text2), Val(Text1), intnu%
    
    'Application #2 should verify the Limit
End Sub

Private Sub Command6_Click()
Static i%
Dim cls_reg As New clsReg

If i% = 0 Then
    cls_reg.DisableRegEdit True
    i% = 1
Else
    cls_reg.DisableRegEdit False
    i% = 0
End If
    
End Sub


'-------------------------clsReg

Private Const READ_CONTROL = &H20000
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const SYNCHRONIZE = &H100000
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))

Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Private Const ERROR_SUCCESS = 0&
Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_SZ = 1

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long        ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
'-------------------------

Private app_name As String, _
        app_path As String, _
        rn_startup As Boolean, _
        errnum As Long

Public Property Let AppName(strValue As String)
    app_name = strValue
End Property

Public Property Get AppName() As String
    AppName = app_name
End Property

Public Property Let AppPath(strValue$)
    app_path = strValue$
End Property

Public Property Get AppPath() As String
    AppPath = app_path
End Property

Public Property Get RunAtStartUp() As Boolean
    RunAtStartUp = rn_startup
End Property

Public Property Let RunAtStartUp(blnValue As Boolean)
    rn_startup = blnValue
End Property

Public Property Get ErrCode() As Long
    ErrCode = errnum
End Property

Public Sub SetRunAtStartup()
Dim hKey As Long
Dim key_value As String
Dim status As Long

    On Error GoTo SetStartupError
    
    If RegCreateKeyEx(HKEY_CURRENT_USER, _
        "Software\Microsoft\Windows\CurrentVersion\Run", _
        ByVal 0&, ByVal 0&, ByVal 0&, _
        KEY_WRITE, ByVal 0&, hKey, _
        ByVal 0&) <> ERROR_SUCCESS Then
        errnum = Err.Number
    End If
    
    If RunAtStartUp Then
        key_value = AppPath & "\" & AppName & ".exe" & vbNullChar
        status = RegSetValueEx(hKey, AppName, 0, REG_SZ, ByVal key_value, Len(key_value))
        If status <> ERROR_SUCCESS Then
            errnum = Err.Number
        End If
    Else
        RegDeleteValue hKey, AppName
    End If
    
    RegCloseKey hKey
    Exit Sub

SetStartupError:
    
    errnum = Err.Number
    
End Sub

Public Function WillRunAtStartup() As Boolean
Dim hKey As Long
Dim value_type As Long

    If RegOpenKeyEx(HKEY_CURRENT_USER, _
        "Software\Microsoft\Windows\CurrentVersion\Run", _
        0, KEY_READ, hKey) = ERROR_SUCCESS Then
        
        WillRunAtStartup = (RegQueryValueEx(hKey, AppName, ByVal 0&, value_type, ByVal 0&, ByVal 0&) = ERROR_SUCCESS)
        RegCloseKey hKey
    Else
        WillRunAtStartup = False
    End If
    
End Function

Public Sub DisableRegEdit(blnValue As Boolean)
On Error Resume Next
    Dim wsobj As Object, strKey$
    Set wsobj = CreateObject("wscript.shell")
    strKey$ = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
    If blnValue Then
        wsobj.regwrite strKey$, 1, "REG_DWORD"
    Else
        wsobj.regdelete strKey$
    End If
    Set wsobj = Nothing
End Sub

Public Function ShareWareLimit(lngOperation As Long, strAppName As String, Optional intDaysLimit% = 0, Optional ByRef intDaysUsed% = 0) As Long
On Error Resume Next
    
    'KEY_CURRENT_USER\Software\VB and VBA Program
    Select Case lngOperation
        Case 1 'Set Shareware Limit
            SaveSetting strAppName, "Startup", "Counter", 1
            SaveSetting strAppName, "Startup", "Limit", intDaysLimit%
            SaveSetting strAppName, "Startup", "Started", Format(Date, "mm dd yyyy")
            SaveSetting strAppName, "Startup", "Last Used", Format(Date, "mm dd yyyy")
            DeleteSetting strAppName, "Startup", "License"
            intDaysUsed% = 1
            'Set
            ShareWareLimit = -1
        Case 2 'Licensed to Use
            SaveSetting strAppName, "Startup", "License", "1"
            DeleteSetting strAppName, "Startup", "Counter"
            DeleteSetting strAppName, "Startup", "Limit"
            DeleteSetting strAppName, "Startup", "Started"
            DeleteSetting strAppName, "Startup", "Last Used"
            ShareWareLimit = 4
    End Select

End Function