Option Explicit
Option Private Module '←Functionなので、シート不可とする為に必須
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'_/
'_/ ＩＮＩファイルの操作関数 (Ver1.2)
'_/
'_/ ktINI_GetValue :１つのValueを取得
'_/ ktINI_GetValueList : Key&Valueリストを取得
'_/ ktINI_GetSecKeyList : Sectionリスト or Keyリストを取得
'_/ ktINI_ReWrite : Valueの追加/変更
'_/ ktINI_Delete :
Section or Keyの削除
'_/
'_/ ※ FileNameは【フルパス】
'_/
'_/ Ver1.0 2006/1/10
'_/ Ver1.1 2006/2/5
'_/ a) prvINI_FileCreate内で、Openステートメントに指定する
'_/ ファイル番号を #1 固定からFreeFile関数利用に変更しました。
'_/ Ver1.2 2011/7/27
'_/ a) フォルダが存在しない場合に [Open Output]による
'_/ ファイル作成が失敗するバグを修正しました。
'_/ (SHCreateDirectoryEx を利用)
'_/ b) API 宣言等を 64bit対応に修正しました。
'_/
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'==========================================
'====== ＡＰＩ宣言 =========================
'==========================================
'INIファイルの指定したセクション内のすべてのキーと値を取得
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetPrivateProfileSection Lib "kernel32" _
Alias "GetPrivateProfileSectionA" _
(ByVal lpAppName As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
Private Declare Function GetPrivateProfileSection Lib "kernel32" _
Alias "GetPrivateProfileSectionA" _
(ByVal lpAppName As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
#End If
'INIファイルの文字列を取得
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
#End If
'INIファイルの文字列を変更
#If VBA7 And Win64 Then
Private Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
#Else
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
#End If
'フォルダの作成
#If VBA7 And Win64 Then
Private Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" _
Alias "SHCreateDirectoryExA" _
(ByVal hwnd As LongPtr, ByVal pszPath As String, _
ByVal psa As LongPtr) As Long
#Else
Private Declare Function SHCreateDirectoryEx Lib "shell32" _
Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, _
ByVal psa As Long) As Long
#End If
'==============================================
'========= ＩＮＩ操作関数 ======================
'==============================================
'--- Section/Key指定で値を取得 -----------------
Public Function ktINI_GetValue _
(ByVal FileName As String, _
ByVal SectionName As String, _
ByVal KeyName As String, _
ByRef ValueString As String) As Boolean
Dim strReturnedString As String * 32767
Dim strValue As String
Dim i As Integer
Dim blnFlag As Boolean
Dim rc As Long
If (FileName = "") Or (SectionName = "") Or _
(KeyName = "") Then
ktINI_GetValue = False
Exit Function
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
ktINI_GetValue = False
Exit Function
ElseIf (Dir(FileName, vbNormal) = "") Then
'INIファイル無し
ktINI_GetValue = False
Exit Function
End If
On Error Resume Next
rc = GetPrivateProfileString _
(SectionName, KeyName, _
vbNullString, strReturnedString, _
Len(strReturnedString), FileName)
On Error GoTo 0
If (rc = 0) Then
ktINI_GetValue = False
Exit Function
End If
'返却文字列よりデータを抽出
blnFlag = False
strValue = ""
For i = 1 To Len(strReturnedString)
If Mid(strReturnedString, i, 1) = vbNullChar Then
If (blnFlag = True) Then '２文字連続のvbNullChar
Exit For
Else
strValue = strValue & Mid(strReturnedString, i, 1)
blnFlag = True '１文字目のvbNullChar
End If
Else
strValue = strValue & Mid(strReturnedString, i, 1)
blnFlag = False 'vbNullCharの後に文字が続けばFalseに戻す
End If
Next i
'終端のvbNullCharを除去
ValueString = Left(strValue, Len(strValue) - 1)
ktINI_GetValue = True
End Function
'--- Section/Key指定で値の更新(追加/変更) -----------
Public Function ktINI_ReWrite _
(ByVal FileName As String, _
ByVal SectionName As String, _
ByVal KeyName As String, _
ByVal ValueString As String) As Boolean
Dim rc As Long
If (FileName = "") Or (SectionName = "") Or _
(KeyName = "") Then
ktINI_ReWrite = False
Exit Function
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
ktINI_ReWrite = False
Exit Function
ElseIf (Dir(FileName, vbNormal) = "") Then
'INIファイルが無いので作成
rc = prvINI_FileCreate(FileName)
If (rc <> 0) Then
'フォルダ作成に失敗
ktINI_ReWrite = False
Exit Function
End If
End If
'既存キーならば更新、未登録キーならば追加
On Error Resume Next
rc = WritePrivateProfileString _
(SectionName, KeyName, ValueString, FileName)
On Error GoTo 0
If (rc = 0) Then
ktINI_ReWrite = False
Else
ktINI_ReWrite = True
End If
End Function
'--- Section/Keyを削除(Keyを省略するとSection全体を削除) ---
Public Function ktINI_Delete _
(ByVal FileName As String, _
ByVal SectionName As String, _
Optional ByVal KeyName As String = "") As Boolean
Dim rc As Long
If (FileName = "") Or (SectionName = "") Then
ktINI_Delete = False
Exit Function
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
ktINI_Delete = False
Exit Function
ElseIf (Dir(FileName, vbNormal) = "") Then
'INIファイル無し
ktINI_Delete = False
Exit Function
End If
On Error Resume Next
If (KeyName = "") Then
'Sectionの削除
rc = WritePrivateProfileString _
(SectionName, vbNullString, _
vbNullString, FileName)
Else
'Keyの削除
rc = WritePrivateProfileString _
(SectionName, KeyName, _
vbNullString, FileName)
End If
On Error GoTo 0
If (rc = 0) Then
ktINI_Delete = False
Else
ktINI_Delete = True
End If
End Function
'--- Section内の全Key/Valueを一括取得 ----------------
' KeyValueListは(キー,値)の２次元配列
Public Function ktINI_GetValueList _
(ByVal FileName As String, _
ByVal SectionName As String, _
ByRef KeyValueList() As String) As Boolean
Dim strReturnedString As String * 32767
Dim strValue As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim blnFlag As Boolean
Dim rc As Long
Dim intCount As Integer
If (FileName = "") Or (SectionName = "") Then
ktINI_GetValueList = False
Exit Function
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
ktINI_GetValueList = False
Exit Function
ElseIf (Dir(FileName, vbNormal) = "") Then
'INIファイル無し
ktINI_GetValueList = False
Exit Function
End If
'Section全体の情報を取得
On Error Resume Next
rc = GetPrivateProfileSection _
(SectionName, strReturnedString, _
Len(strReturnedString), FileName)
On Error GoTo 0
If (rc = 0) Then
ktINI_GetValueList = False
Exit Function
End If
'返却文字列よりデータを抽出
blnFlag = False
intCount = 0
strValue = ""
For i = 1 To Len(strReturnedString)
If Mid(strReturnedString, i, 1) = vbNullChar Then
If (blnFlag = True) Then '２文字連続のvbNullChar
Exit For
Else
strValue = strValue & Mid(strReturnedString, i, 1)
blnFlag = True '１文字目のvbNullChar(要素の区切り)
intCount = intCount + 1
End If
Else
strValue = strValue & Mid(strReturnedString, i, 1)
blnFlag = False 'vbNullCharの後に文字が続けばFalseに戻す
End If
Next i
strValue = Left(strValue, Len(strValue) - 1) '終端のvbNullCharを除去
If (strValue = "") Then
ktINI_GetValueList = False
Exit Function
End If
'文字列から[キー：値]の２次元配列に格納
ReDim KeyValueList(1 To intCount, 1 To 2)
j = 1
k = 1
For i = 1 To Len(strValue)
Select Case Mid(strValue, i, 1)
Case vbNullChar
j = j + 1
k = 1
Case "="
k = 2
Case Else
KeyValueList(j, k) = KeyValueList(j, k) & Mid(strValue, i, 1)
End Select
Next i
ktINI_GetValueList = True
End Function
'--- Section内の全Key or INIファイル内の全Sectionを一括取得 ----------------
' SecKeyListは(キー) or (セクション)の１次元配列
' SectionName を空文字にするとセクションの一覧
' SectionName を指定するとキーの一覧
Public Function ktINI_GetSecKeyList _
(ByVal FileName As String, _
ByVal SectionName As String, _
ByRef SecKeyList() As String) As Boolean
Dim strReturnedString As String * 32767
Dim strSecKey As String
Dim i As Integer
Dim j As Integer
Dim blnFlag As Boolean
Dim rc As Long
Dim intCount As Integer
If (FileName = "") Then
ktINI_GetSecKeyList = False
Exit Function
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
ktINI_GetSecKeyList = False
Exit Function
ElseIf (Dir(FileName, vbNormal) = "") Then
'INIファイル無し
ktINI_GetSecKeyList = False
Exit Function
End If
On Error Resume Next
If (SectionName = "") Then
'INIファイル内のSection情報を取得
rc = GetPrivateProfileString _
(vbNullString, vbNullString, _
vbNullString, strReturnedString, _
Len(strReturnedString), FileName)
Else
'Section内のKey情報を取得
rc = GetPrivateProfileString _
(SectionName, vbNullString, _
vbNullString, strReturnedString, _
Len(strReturnedString), FileName)
End If
On Error GoTo 0
If (rc = 0) Then
ktINI_GetSecKeyList = False
Exit Function
End If
'返却文字列よりデータを抽出
blnFlag = False
intCount = 0
strSecKey = ""
For i = 1 To Len(strReturnedString)
If Mid(strReturnedString, i, 1) = vbNullChar Then
If (blnFlag = True) Then '２文字連続のvbNullChar
Exit For
Else
strSecKey = strSecKey & Mid(strReturnedString, i, 1)
blnFlag = True '１文字目のvbNullChar(要素の区切り)
intCount = intCount + 1
End If
Else
strSecKey = strSecKey & Mid(strReturnedString, i, 1)
blnFlag = False 'vbNullCharの後に文字が続けばFalseに戻す
End If
Next i
strSecKey = Left(strSecKey, Len(strSecKey) - 1) '終端のvbNullCharを除去
If (strSecKey = "") Then
ktINI_GetSecKeyList = False
Exit Function
End If
'文字列から[キー] or [セクション]の１次元配列に格納
ReDim SecKeyList(1 To intCount)
j = 1
For i = 1 To Len(strSecKey)
Select Case Mid(strSecKey, i, 1)
Case vbNullChar
j = j + 1
Case Else
SecKeyList(j) = SecKeyList(j) & Mid(strSecKey, i, 1)
End Select
Next i
ktINI_GetSecKeyList = True
End Function
'--- INIファイルの作成 ------------------------------
Private Function prvINI_FileCreate(ByVal FileName As String) As Long
'0:OK, 1:既存ファイルなのでSkip, -1:Error
Dim intFileNum As Integer
Dim j As Integer
Dim strPath As String
Dim rc As Long
#If VBA7 And Win64 Then
Const hwnd0 As LongPtr = 0
Const psa0 As LongPtr = 0
#Else
Const hwnd0 As Long = 0
Const psa0 As Long = 0
#End If
'[FileName]はフルパス
If (FileName = "") Then
prvINI_FileCreate = -1
ElseIf (LCase(Right(FileName, 4)) <> ".ini") Or _
(InStr(FileName, "\") = 0) Then
'識別子ＮＧ,フルパス無し
prvINI_FileCreate = -1
Else
strPath = Left(FileName, InStrRev(FileName, "\") - 1)
If (Dir(strPath, vbDirectory) = "") Then
'指定フォルダが無いので作成
On Error Resume Next
rc = SHCreateDirectoryEx(hwnd0, strPath, psa0)
On Error GoTo 0
If (rc <> 0) Then
prvINI_FileCreate = -1
Exit Function
End If
End If
If (Dir(FileName, vbNormal) = "") Then
'指定ファイルが無いので作成
On Error Resume Next
intFileNum = FreeFile
Open FileName For Output As #intFileNum
Close #intFileNum
On Error GoTo 0
prvINI_FileCreate = 0 'OK
Else
prvINI_FileCreate = 1 '既存ファイル
End If
End If
End Function
|
