access2010 access2007 Win32API レジストリ その2

Option Compare Database
Option Explicit
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Const HKEY_CURRENT_USER = &H80000001
 
Private Const ERROR_SUCCESS = 0
 
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_DWORD = 4 '32-bit number
 
Private Const REG_OPTION_NON_VOLATILE = 0
 
Private Const KEY_ALL_ACCESS = &HF003F
Private Const KEY_SET_VALUE = &H2
 
#If VBA7 Then
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As LongPtr
    bInheritHandle As Long
End Type
 
Private Const strTrustedLocations = "Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\"

Private Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" _
                                Alias "RegCreateKeyExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpSubKey As String, _
                                ByVal Reserved As Long, _
                                ByVal lpClass As String, _
                                ByVal dwOptions As Long, _
                                ByVal samDesired As Long, _
                                lpSecurityAttributes As SECURITY_ATTRIBUTES, _
                                phkResult As LongPtr, _
                                lpdwDisposition As Long _
                                ) As Long
  
Private Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" _
                                Alias "RegSetValueExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpValueName As String, _
                                ByVal Reserved As Long, _
                                ByVal dwType As Long, _
                                lpData As Any, _
                                ByVal cbData As Long _
                                ) As Long
 
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
                                ByVal hKey As LongPtr _
                                ) As Long

Private Declare PtrSafe Function CoCreateGuid Lib "OLE32.DLL" ( _
                                pGuid As GUID _
                                ) As Long
#Else
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Const strTrustedLocations = "Software\Microsoft\Office\12.0\Access\Security\Trusted Locations\"

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, _
                                lpSecurityAttributes As SECURITY_ATTRIBUTES, _
                                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
 
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
                                ByVal hKey As Long _
                                ) As Long

Private Declare Function CoCreateGuid Lib "OLE32.DLL" ( _
                                pGuid As GUID _
                                ) As Long
#End If

Public Function GetNewGUID() As String
    Dim udtGUID As GUID
    If (CoCreateGuid(udtGUID) = 0) Then
        GetNewGUID = "{" & _
        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & "-" & _
        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & "-" & _
        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & "-" & _
        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & "-" & _
        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7)) & "}"
    End If
End Function

Sub setTrustedLocations()
#If VBA7 Then
    Dim hNewKey As LongPtr
#Else
    Dim hNewKey As Long
#End If
    Dim lngrtn As Long, strSubKey As String
    Dim SA As SECURITY_ATTRIBUTES, rtnDisp As Long
    Dim strValue As String, lngValue As Long
    
    strSubKey = strTrustedLocations & GetNewGUID
    
    lngrtn = RegCreateKeyEx(HKEY_CURRENT_USER, _
                            strSubKey, _
                            0, _
                            vbNullString, _
                            REG_OPTION_NON_VOLATILE, _
                            KEY_ALL_ACCESS, _
                            SA, _
                            hNewKey, _
                            rtnDisp)
    If lngrtn = ERROR_SUCCESS Then
        strValue = CurrentProject.Path & "\"
        RegSetValueEx hNewKey, _
                      "Path", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
        strValue = CurrentProject.Name & "の自炊レジストリ"
        RegSetValueEx hNewKey, _
                      "Description", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
        strValue = Format(Now, "yyyy/mm/dd hh:nn")
        RegSetValueEx hNewKey, _
                      "Date", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
'        lngValue = 1
'        RegSetValueEx hNewKey, _
'                      "AllowSubfolders", _
'                      0, _
'                      REG_DWORD, _
'                      lngValue, _
'                      Len(lngValue)
    End If
    RegCloseKey hNewKey
End Sub