INI 文件读写！

山中老人

INI 文件 作为标准的配置文本文件，很多时候都需要用到。
比如：要在本地保存一些环境变量。

下面是一个完全使用VBA写的INI文件操作类模块：

第一部分：

Option Explicit
Private Const ClassName_ As String = "M_IniFile", ClassVer_ As String = "0.01", ClassInfo_ As String = "Ini文件操作 类" '#类基本常量
Public Name As String '类 实例名
Public ErrVisible As Boolean '是否显示 ERR提示，默认=显示

'--专用变量--
Public PathFile As String 'INI文件
Public IniDic As Scripting.Dictionary 'INI文件内容 词典
Public IsChange As Boolean '词典内容被修改过（Set_Item）

'--专用变量--End

'类 基本属性
Public Property Get ClassName() As String '类型名
    ClassName = ClassName_
End Property

Public Property Get ClassVer() As String '类版本
    ClassVer = ClassVer_
End Property

Public Property Get ClassInfo() As String '类注释
    ClassInfo = ClassInfo_
End Property

'类初始化
Private Sub Class_Initialize()
    Set Me.IniDic = New Scripting.Dictionary
    Me.IniDic.CompareMode = TextCompare
    Me.IsChange = False
End Sub
'类结束
Private Sub Class_Terminate()

End Sub

'通用错误提示。ErrObj =错误对象, SubName=过程名，Visible=是否显示提示，Txt=附加提示内容；返回=提示文本
Private Function ErrMsBox(ErrObj As ErrObject, SubName As String, Optional Txt As String = "", Optional Visible As Boolean = True) As String
    ErrMsBox = "位置：" & ClassName_ & "/" & Me.Name & "/" & SubName
    ErrMsBox = ErrMsBox & Chr(13) & "说明：" & Txt
    ErrMsBox = ErrMsBox & Chr(13) & "ERR：" & ErrObj.Description
    If Me.ErrVisible And Visible Then Call MsgBox(ErrMsBox, vbExclamation, SubName & "错误")
End Function

'--读写项目--
Public Function Set_Item(Section As String, Key As String, Value As String) As Boolean
    'Section=节点名称
    'Key=键
    'Value=值
    Set_Item = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "Set_Item"
    SubTxt = "设置项目:[" & Section & "]" & Key

    Me.IsChange = True '修改标记
    '获取节点
    Dim SectionD As Scripting.Dictionary
    If Me.IniDic.Exists(Section) Then
        Set SectionD = Me.IniDic(Section)
    Else
        Set SectionD = ADD_Section(Section, Nothing)
    End If
    '获取项目词典
    Dim KeySD As Scripting.Dictionary, ItemD As Scripting.Dictionary
    Set KeySD = SectionD("KeySD")
    '获取项目
    If KeySD.Exists(Key) Then
        Set ItemD = KeySD(Key)
    Else
        Set ItemD = New Scripting.Dictionary '新建项目
        ItemD.CompareMode = TextCompare
        Set ItemD("NotesD") = New Scripting.Dictionary
        KeySD.Add Key, ItemD
    End If
    '写入项目
    ItemD("Key") = Key
    ItemD("Value") = Value

    Set_Item = True
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Public Function Get_Item(Section As String, Key As String) As String
    'Section=节点名称
    'Key=键
    Get_Item = ""
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "Get_Item"
    SubTxt = "读取项目:[" & Section & "]" & Key

    '获取节点
    Dim SectionD As Scripting.Dictionary
    If Me.IniDic.Exists(Section) Then
        Set SectionD = Me.IniDic(Section)
    Else
        Exit Function
    End If
    '获取项目词典
    Dim KeySD As Scripting.Dictionary, ItemD As Scripting.Dictionary
    Set KeySD = SectionD("KeySD")
    '获取项目
    If KeySD.Exists(Key) Then
        Set ItemD = KeySD(Key)
    Else
        Exit Function
    End If
    Get_Item = ItemD("Value")
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

'--读取INI文件
Public Function IniRead(Optional PathFile As String = "") As Boolean
    IniRead = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "IniRead"
    SubTxt = "读取INI文件:" & Me.PathFile

    If Trim(PathFile) = "" Then PathFile = Me.PathFile
    If Trim(PathFile) = "" Then GoTo err1

    Dim fso As New Scripting.FileSystemObject
    If Not fso.FileExists(Me.PathFile) Then GoTo err1 '文件不存在
    Set fso = Nothing
    Me.PathFile = PathFile
    '清空词典
    Set Me.IniDic = New Scripting.Dictionary
    Me.IniDic.CompareMode = TextCompare
    Me.IsChange = False '取消修改标记

    IniRead = Me.ADD_IniRead(PathFile)
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Public Function ADD_IniRead(PathFile As String) As Boolean
    ADD_IniRead = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "ADD_IniRead"
    SubTxt = "追加读取INI文件:" & PathFile

    Dim fso As New Scripting.FileSystemObject, TF As Scripting.TextStream
    If Trim(PathFile) = "" Then GoTo err1
    If Not fso.FileExists(PathFile) Then GoTo err1 '文件不存在
    Set TF = fso.OpenTextFile(PathFile, ForReading, False, TristateMixed)   '打开文件

    Dim i As Long, Txt As String, Txt2 As String, Section As String
    Dim e As Long, Key As String, Value As String

    Dim NotesD As New Scripting.Dictionary '注释词典
    '遍历文件
    Do Until TF.AtEndOfStream
        i = TF.Line
        Txt = TF.ReadLine
        Txt2 = Trim(Txt)
        If Left(Txt2, 1) = ";" Or Txt2 = "" Then '注释、空行
            NotesD.Add i, Txt
        ElseIf Left(Txt2, 1) = "[" And Right(Txt2, 1) = "]" Then '节标题
            Section = Mid(Txt2, 2, Len(Txt2) - 2)
            Call ADD_Section(Section, NotesD)
            Set NotesD = New Scripting.Dictionary '新注释 词典
        ElseIf InStr(1, Txt2, "=") > 0 Then '项目
            e = InStr(1, Txt2, "=")
            Key = Left(Txt2, e - 1)
            Value = Mid(Txt2, e + 1)
            Call ADD_Item(Section, Key, Value, NotesD)
            Set NotesD = New Scripting.Dictionary '新注释 词典
        Else '注释、空行
            NotesD.Add i, Txt
        End If
    Loop
    TF.Close '关闭文件
    Set TF = Nothing
    Set fso = Nothing

    ADD_IniRead = True
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Private Function ADD_Section(Section As String, Optional NotesD As Scripting.Dictionary = Nothing) As Scripting.Dictionary
    'Section=节点名称
    'NotesD=注释
    Set ADD_Section = Nothing
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "ADD_Section"
    SubTxt = "添加节点:" & Section

    '获取节点
    Dim SectionD As Scripting.Dictionary
    Dim NotesD1 As Scripting.Dictionary, KeySD1 As Scripting.Dictionary
    If Me.IniDic.Exists(Section) Then
        Set SectionD = Me.IniDic(Section)
        Set NotesD1 = SectionD("NotesD")
        Set KeySD1 = SectionD("KeySD")
    Else '新建节点
        Set SectionD = New Scripting.Dictionary
        SectionD.CompareMode = TextCompare
        Set NotesD1 = New Scripting.Dictionary
        Set KeySD1 = New Scripting.Dictionary
        KeySD1.CompareMode = TextCompare
        SectionD.Add "NotesD", NotesD1
        SectionD.Add "KeySD", KeySD1
        Me.IniDic.Add Section, SectionD
    End If

    Dim i As Long, Line As Long, Value As String
    If Not NotesD Is Nothing Then '添加注释
        For i = 0 To NotesD.Count - 1
            Line = NotesD.Keys(i)
            Value = NotesD.Items(i)
            NotesD1(Line) = Value
        Next
    End If

    Set ADD_Section = SectionD
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Private Function ADD_Item(Section As String, Key As String, Value As String, Optional NotesD As Scripting.Dictionary = Nothing) As Scripting.Dictionary
    'Section=节点名称
    'NotesD=注释
    Set ADD_Item = Nothing
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "ADD_Item"
    SubTxt = "添加项目:" & Section

    '获取节点
    Dim SectionD As Scripting.Dictionary
    If Me.IniDic.Exists(Section) Then
        Set SectionD = Me.IniDic(Section)
    Else
        Set SectionD = ADD_Section(Section, Nothing)
    End If
    '获取项目词典
    Dim KeySD As Scripting.Dictionary, ItemD As Scripting.Dictionary
    Set KeySD = SectionD("KeySD")
    '获取项目
    If KeySD.Exists(Key) Then
        Set ItemD = KeySD(Key)
    Else
        Set ItemD = New Scripting.Dictionary
        ItemD.CompareMode = TextCompare
        KeySD.Add Key, ItemD
    End If
    '写入项目
    If NotesD Is Nothing Then
        Set ItemD("NotesD") = New Scripting.Dictionary
    Else
        Set ItemD("NotesD") = NotesD
    End If
    ItemD("Key") = Key
    ItemD("Value") = Value

    Set ADD_Item = ItemD
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

山中老人

第二部分：

'--写入INI文件
Public Function IniWrite(Optional PathFile As String = "", Optional Sort As Boolean = True) As Boolean
    IniWrite = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "IniWrite"
    SubTxt = "写入INI文件:" & Me.PathFile
   
    Dim fso As New Scripting.FileSystemObject, TF As Scripting.TextStream
    If Trim(PathFile) = "" Then PathFile = Me.PathFile
    If Trim(PathFile) = "" Then GoTo err1
    Set TF = fso.CreateTextFile(PathFile, True)  '新建文件
    If TF Is Nothing Then GoTo err1
   
    Dim Dic As Scripting.Dictionary
    If Sort Then
        Set Dic = DicSort(Me.IniDic) '排序
    Else
        Set Dic = Me.IniDic
    End If
   
    Dim SectionD As Scripting.Dictionary '节点
    Dim NotesD As Scripting.Dictionary  '注释
    Dim KeySD As Scripting.Dictionary '项目词典
    Dim i As Long, Section As String
    For i = 0 To Dic.Count - 1
        Section = Dic.Keys(i)
        Set SectionD = Dic.Items(i)
        '写注释
        If SectionD.Exists("NotesD") Then '
            Set NotesD = SectionD("NotesD")
            Call Write_NotesD(TF, NotesD)
        End If
        '写节点名
        TF.WriteLine "[" & Section & "]"
        '写项目词典
        If SectionD.Exists("KeySD") Then '
            Set KeySD = SectionD("KeySD")
            Call Write_KeySD(TF, KeySD)
        End If
    Next
   
    TF.Close '关闭文件
    Set TF = Nothing
    Set fso = Nothing
   
    Me.IsChange = False '取消修改标记
    IniWrite = True
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Private Function Write_NotesD(TF As Scripting.TextStream, NotesD As Scripting.Dictionary) As Boolean
    'NotesD=注释
    Write_NotesD = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "Write_NotesD"
    SubTxt = "写注释词典"
   
    If TF Is Nothing Then GoTo err1
    If NotesD Is Nothing Then Exit Function
   
    Dim i As Long
    For i = 0 To NotesD.Count - 1
        TF.WriteLine NotesD.Items(i)
    Next
    Write_NotesD = True
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Private Function Write_KeySD(TF As Scripting.TextStream, KeySD As Scripting.Dictionary) As Boolean
    'KeySD=项目词典
    Write_KeySD = False
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "Write_KeySD"
    SubTxt = "写项目词典"
   
    If TF Is Nothing Then GoTo err1
    If KeySD Is Nothing Then Exit Function
   
    Dim i As Long, ItemD As Scripting.Dictionary, NotesD As Scripting.Dictionary, Txt As String
    For i = 0 To KeySD.Count - 1
        Set ItemD = KeySD.Items(i)
        '写注释
        If ItemD.Exists("NotesD") Then '
            Set NotesD = ItemD("NotesD")
            Call Write_NotesD(TF, NotesD)
        End If
        Txt = ItemD("Key") & "=" & ItemD("Value")
        TF.WriteLine Txt
    Next
    Write_KeySD = True
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

'--支持函数--
Private Function DicSort(Dic As Scripting.Dictionary, Optional KeySort As Boolean = True, Optional DESC As Boolean = False) As Scripting.Dictionary
    'KeySort=True 按Key排序；KeySort=False 按Item排序
    'DESC=True 从大到小排序；DESC=False 从小到大排序
    Set DicSort = Nothing
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "DicSort"
    SubTxt = "词典按Key排序" '
   
    '参数处理
    If Dic Is Nothing Then Exit Function
    Dim Dic0 As Scripting.Dictionary
    Set Dic0 = DicCopy(Dic)
    If Dic0.Count <= 0 Then
        Set DicSort = Dic0
        Exit Function
    End If
    '排序
    Dim i As Long, Index As Long
    Dim Dic1 As New Scripting.Dictionary
    Do While Dic0.Count > 0
        '取Index
        Index = 0
        For i = 1 To Dic0.Count - 1 '遍历
            If DESC Then '从大到小排序
                If KeySort Then
                    If Dic0.Keys(Index) < Dic0.Keys(i) Then Index = i '取大Key
                Else
                    If Dic0.Item(Index) < Dic0.Item(i) Then Index = i '取大Item
                End If
            Else '从小到大排序
                If KeySort Then
                    If Dic0.Keys(Index) > Dic0.Keys(i) Then Index = i '取小Key
                Else
                    If Dic0.Item(Index) > Dic0.Item(i) Then Index = i '取小Item
                End If
            End If
        Next
        '转移词典 项目
        Dic1.Add Dic0.Keys(Index), Dic0.Items(Index)
        Call Dic0.Remove(Dic0.Keys(Index))
    Loop
    Set DicSort = Dic1
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

Private Function DicCopy(Dic As Scripting.Dictionary) As Scripting.Dictionary
    Set DicCopy = Nothing
    On Error GoTo err1
    Dim SubName As String, SubTxt As String
    SubName = "DicCopy"
    SubTxt = "复制词典"
   
    If Dic Is Nothing Then Exit Function
    Dim OutDic As New Scripting.Dictionary
    OutDic.CompareMode = Dic.CompareMode
    Dim i As Long, Obj As Object
    For i = 0 To Dic.Count - 1
        OutDic.Add Dic.Keys(i), Dic.Items(i)
    Next
    Set DicCopy = OutDic
    Exit Function
err1:
    Call ErrMsBox(Err, SubName, SubTxt & " 失败!")
End Function

hksxwg

非常好，只是需要学习，能再附一个实例使用就更好了。

jinhaitiao16

谢谢楼主分享！！！！！

蜡笔老新0730

厉害，厉害！

游乐缘

感谢分享，留名学习