inifile.cls

VB6.0编写的医院影像系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "IniFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
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
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
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
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

Public FileName As String               '对应INI文件
Private Const INI_SPLIT As String = ","

Public Function GetBoolean(strSection As String, strKey As String, Optional Default As Boolean = False) As Boolean
    
    '--------------------------
    '读取INI文件中的布尔值
    '--------------------------
    
    Dim strTemp As String * 256
    Dim strBool As String
    Call GetPrivateProfileString(strSection, strKey, Default, strTemp, Len(strTemp), FileName)
    strBool = Left(strTemp, InStr(strTemp, vbNullChar) - 1)
    GetBoolean = Not (Val(strBool) = 0)
    
End Function

Public Function PutBoolean(strSection As String, strKey As String, strValue As Boolean)
    
    '--------------------
    '写INI中的布尔值
    '--------------------
    
    Dim strV As String
    If strValue Then
        strV = "1"
    Else
        strV = "0"
    End If
    Call WritePrivateProfileString(strSection, strKey, strV, FileName)
    
End Function

Public Function GetString(strSection As String, strKey As String, Optional Default = vbNullString)
    
    '-------------------
    '读取INI文件中的值
    '-------------------
    
    Dim strTemp As String * 256
    Call GetPrivateProfileString(strSection, strKey, Default, strTemp, Len(strTemp), FileName)
    GetString = Left(strTemp, InStr(strTemp, vbNullChar) - 1)
    
End Function

Public Function PutString(strSection As String, strKey As String, strValue)
    
    '-------------
    '写INI值
    '-------------
    
    Dim strV As String
    strV = Format(strValue)
    Call WritePrivateProfileString(strSection, strKey, strV, FileName)
    
End Function


Public Function ReadOptionForm(frm As Form)
    
    '-----------------------
    '写Option窗体的选项
    '-----------------------
    
    Dim ctl As Control
    Dim strTag As String
    Dim A() As String
    Dim Value
    
    For Each ctl In frm.Controls
        Select Case TypeName(ctl)
            Case "CheckBox", "TextBox", "ComboBox", "UpDownTextBox", "PictureBox", "ImageCombo"
                strTag = Trim(ctl.Tag)
                If strTag <> vbNullString Then
                    A = Split(strTag, INI_SPLIT)
                    Value = Me.GetString(A(0), A(1), A(2))
                    Select Case TypeName(ctl)
                        Case "CheckBox"
                            ctl.Value = Abs(Value)
                        
                        Case "TextBox"
                            ctl.Text = Value
                        
                        Case "ComboBox"
                            ctl.Text = Value
                              
                        Case "UpDownTextBox"
                            ctl.Value = Value
                        
                        Case "ImageCombo"
                            ctl.Text = Value
                        
                        Case "PictureBox"
                            ctl.BackColor = Value
                        
                    End Select
                End If
            Case Else
        End Select
    Next ctl

End Function

Public Function WriteOptionForm(frm As Form)
    
    '-----------------------------------
    '将Option窗体的选项写回INI文件
    '-----------------------------------
    
    Dim ctl As Control
    Dim strTag As String
    Dim A() As String
    Dim Value
    
    For Each ctl In frm.Controls
        Select Case TypeName(ctl)
            Case "CheckBox", "TextBox", "ComboBox", "UpDownTextBox", "PictureBox", "ImageCombo"
                strTag = Trim(ctl.Tag)
                If strTag <> vbNullString Then
                    A = Split(strTag, INI_SPLIT)
                    
                    Select Case TypeName(ctl)
                        Case "CheckBox"
                            Me.PutString A(0), A(1), ctl.Value
                        
                        Case "TextBox"
                            Me.PutString A(0), A(1), ctl.Text
                        
                        Case "ComboBox"
                            Me.PutString A(0), A(1), ctl.Text
                        
                        Case "UpDownTextBox"
                            Me.PutString A(0), A(1), ctl.Value
                         
                        Case "PictureBox"   '当为Picture时,缺省为其背景色
                            Me.PutString A(0), A(1), ctl.BackColor
                            
                        Case "ImageCombo"
                            Me.PutString A(0), A(1), ctl.Text
                            
                    End Select
                End If
            Case Else
        End Select
    Next ctl

End Function

Public Function SaveFormPlace(frm As Form)
    
    '-----------------
    '保存窗体的位置
    '-----------------
    
    With frm
        Me.PutString "LastRun", .Name & "_Left", .Left
        Me.PutString "LastRun", .Name & "_Top", .Top
        Me.PutString "LastRun", .Name & "_Width", .width
        Me.PutString "LastRun", .Name & "_Height", .height
    End With
    
End Function

Public Function LoadFormPlace(frm As Form)
    
    '------------------------------
    '读取并设置窗体的初始位置
    '------------------------------
    
    If Me.GetString("LastRun", frm.Name & "_Width", vbNullString) = vbNullString Then Exit Function
    
    With frm
        .Move Me.GetString("LastRun", .Name & "_Left"), Me.GetString("LastRun", .Name & "_Top"), Me.GetString("LastRun", .Name & "_Width"), Me.GetString("LastRun", .Name & "_Height")
    End With
    
End Function

Public Function GetSection(strSection As String, Optional Default = vbNullString) As String
    
    '--------------------------------
    '读取并判断某个Section是否存在
    '--------------------------------
    Dim ReturnH As Long
    Dim ReturnS As String * 32767
    ReturnH = GetPrivateProfileSection(strSection, ReturnS, 32767, FileName)
    GetSection = Trim(Mid(ReturnS, 1, ReturnH))
    
End Function


Public Function GetPercent(strSection As String, strKey As String, Optional Default = vbNullString) As Single
    
    '--------------------------
    '读取INI文件中的百分比值
    '--------------------------
    
    Dim strTemp As String * 256
    Dim G As String
    Call GetPrivateProfileString(strSection, strKey, Default, strTemp, Len(strTemp), FileName)
    G = Left(strTemp, InStr(strTemp, vbNullChar) - 1)

    If Right(G, 1) = "%" Then
        GetPercent = Val(Left(G, Len(G) - 1)) / 100
    Else
        GetPercent = Val(G)
    End If
    
End Function

Public Function GetSectionNames() As String

    '-----------------------------
    '返回Ini文件的所有Sections集合
    '-----------------------------

    Dim cFSO As New FileSystemObject
    Dim cTS As TextStream
    Dim str As String, strResult As String
    Dim iEnd As Integer


    Set cTS = cFSO.OpenTextFile(FileName)
    strResult = vbNullString
    With cTS
        Do While Not .AtEndOfStream
            str = Trim(.ReadLine)
            If Left(str, 1) = "[" Then      '第一个字符为"["，则说明是节的开始
                iEnd = InStr(1, str, "]")
                If iEnd > 0 Then
                    strResult = strResult & Mid(str, 2, iEnd - 2) & Chr(0)
                End If
            End If
        Loop
    End With

    Set cFSO = Nothing
    cTS.Close
    Set cTS = Nothing

    If Right(strResult, 1) = Chr(0) Then strResult = Left(strResult, Len(strResult) - 1)
    GetSectionNames = strResult

End Function