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
