Option Explicit

'ルートキー
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003

Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const SYNCHRONIZE = &H100000

'動作方法を指定する定数
Public Const KEY_CREATE_LINK = &H20         'キーオブジェクトとのリンク作成
Public Const KEY_ENUMERATE_SUB_KEYS = &H8   'サブキー列挙
Public Const KEY_QUERY_VALUE = &H1          'レジストリ値を設定
Public Const KEY_SET_VALUE = &H2            'レジストリ値を取得
Public Const KEY_CREATE_SUB_KEY = &H4       'サブキー作成
Public Const KEY_NOTIFY = &H10              'レジストリの内容変更通知を要求
Public 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))

'Registry Data Types
Public Const REG_BINARY = 3                 'バイナリデータ
Public Const REG_DWORD = 4                  '32ビット数値
Public Const REG_DWORD_LITTLE_ENDIAN = 4    '= RGE_DWORD
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_EXPAND_SZ = 2
Public Const REG_LINK = 6                   '別のサブキーへのシンボリックリンク
Public Const REG_MULTI_SZ = 7               'Chr(0)で区切られた文字列(最後尾は Chr(0)が二つ)
Public Const REG_NONE = 0                   '未定義のタイプ
Public Const REG_RESOURCE_LIST = 8
Public Const REG_SZ = 1                     '文字列

'Registry Create Type Values
Public Const REG_OPTION_NON_VOLATILE = 0

Type SECURITY_ATTRIBUTES
  nLength As Long                           '構造体のバイト数
  lpSecurityDescriptor As Long              'セキュリティデスクリプタ（Windows98 では無効）
  bInheritHandle As Long                    '1 のとき、属性を継承する
End Type

'レジストリキーハンドルを開放
Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long

'指定のキーを作成。存在する場合はキーをオープン。
Declare Function RegCreateKeyEx Lib "ADVAPI32" 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

'指定のキーを削除
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long

'指定のキーをオープン
Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long

'レジストリキーの値を設定
'（文字列）
Declare Function RegSetValueExStr Lib "ADVAPI32" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
'（数値）
Declare Function RegSetValueExLong Lib "ADVAPI32" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpData As Long, ByVal cbData As Long) As Long

Const ERROR_SUCCESS = 0&

Function Ls_SetFileType(ByVal strExtension As String, ByVal strFileType As String, ByVal strProgram As String) As Boolean
    'ファイル拡張子をプログラムに関連付ける
    '   strExtension   拡張子
    '   strFileType    ファイルタイプ名
    '   strProgram     プログラム
    '   結果           成功=True
    Dim RootKey As Long, SubKey As String, lpValName As String, strData As String
    
    If Dir$(strProgram) = "" Then Exit Function
    If Right$(strExtension, 1) = "." Then strExtension = Mid$(strExtension, 2)
    
    RootKey = HKEY_CLASSES_ROOT
    SubKey = "." & strExtension
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strExtension & "_auto_file"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = strExtension & "_auto_file"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strFileType
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = SubKey & "\DefaultIcon"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strProgram & ",0"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = strExtension & "_auto_file\shell"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    
    SubKey = SubKey & "\open"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = "\""FdOffice.exe\"" %1"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = SubKey & "\command"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = "\""" & strProgram & "\"" %1"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    RootKey = HKEY_LOCAL_MACHINE
    SubKey = "SOFTWARE\Classes\." & strExtension
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strExtension & "_auto_file"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = "SOFTWARE\Classes\" & strExtension & "_auto_file"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strFileType
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = SubKey & "\DefaultIcon"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = strProgram & ",0"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = "SOFTWARE\Classes\" & strExtension & "_auto_file\shell"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    
    SubKey = SubKey & "\open"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = "\""FdOffice.exe\"" %1"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    
    SubKey = SubKey & "\command"
    If Ls_RegCreateKeyEx(RootKey, SubKey) = False Then Exit Function
    lpValName = ""
    strData = """" & strProgram & """ %1"
    If Ls_RegSetValueEx(RootKey, SubKey, lpValName, strData, False) = False Then Exit Function
    Ls_SetFileType = True
End Function

Private Function Ls_RegCreateKeyEx(ByVal RootKey As Long, ByVal SubKey As String) As Boolean
    'レジストリに値を設定
    '   RootKey    オープンするルートキー
    '   SubKey     サブキー
    '   結果       成功=true
    Dim rc As Long
    Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
    Dim phkResult As Long, lpdwDisposition As Long
    
    rc = RegCreateKeyEx(RootKey, SubKey, 0, vbNullString, REG_OPTION_NON_VOLATILE, _
           KEY_CREATE_SUB_KEY, lpSecurityAttributes, phkResult, lpdwDisposition)
    
    Call RegCloseKey(phkResult)

    If rc <> ERROR_SUCCESS Then Exit Function
    Ls_RegCreateKeyEx = True
End Function

Private Function Ls_RegSetValueEx(ByVal RootKey As Long, ByVal SubKey As String, ByVal lpValName As String, ByVal strData As String, NumFlg As Boolean) As Boolean
    'レジストリに値を設定
    '   RootKey    オープンするルートキー
    '   SubKey     サブキー
    '   lpValName  値名
    '   strData    値
    '   NumFlg     数値データ（32ビット値）の場合True
    '   結果       成功=true
    Dim rc As Long, phkResult As Long
    Dim Reserved As Long
    Dim cbData As Long
    Dim lpData As Long
    
    'キーをオープンしてハンドル取得
    rc = RegOpenKeyEx(RootKey, SubKey, 0, KEY_SET_VALUE, phkResult)
    If rc <> ERROR_SUCCESS Then Exit Function
    
    If NumFlg Then
        '数値の場合は、変数のポインタを取得
        lpData = VarPtr(Val(strData))
        cbData = 4
        rc = RegSetValueExLong(phkResult, lpValName, Reserved, REG_DWORD, lpData, cbData)
    Else
        '文字列の場合は、文字列のバイト数 + 1
        cbData = LenB(StrConv(strData, vbFromUnicode)) + 1
        rc = RegSetValueExStr(phkResult, lpValName, Reserved, REG_SZ, strData, cbData)
    End If
    'ハンドルを開放
    Call RegCloseKey(phkResult)
    If rc <> ERROR_SUCCESS Then Exit Function
    Ls_RegSetValueEx = True
End Function