Option Explicit
' =========================================================
' Class: cIniFile
' Author: Steve McMahon
' Date : 21 Feb 1997
'
' A nice class wrapper around the INIFile functions
' Allows searching,deletion,modification and addition
' of Keys or Values.
'
' Updated 10 May 1998 for VB5.
' * Added EnumerateAllSections method
' * Added Load and Save form position methods
' =========================================================
Private m_sPath As String '路徑文件名
Private m_sKey As String '鍵
Private m_sSection As String '小節(jié)
Private m_sDefault As String '默認值
Private m_lLastReturnCode As Long '返回值
' Profile String functions:
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 GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Property Get LastReturnCode() As Long '返回值
LastReturnCode = m_lLastReturnCode
End Property
Property Get Success() As Boolean '成功
Success = (m_lLastReturnCode <> 0)
End Property
'=======================================
Property Let Default(sDefault As String) '默認
m_sDefault = sDefault
End Property
Property Get Default() As String
Default = m_sDefault
End Property
'======================================
Property Let Path(sPath As String) '路徑
m_sPath = sPath
End Property
Property Get Path() As String '路徑
Path = m_sPath
End Property
Property Get AppPath() As String '路徑
AppPath = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
End Property
Property Let Key(sKey As String)
m_sKey = sKey
End Property
Property Get Key() As String
Key = m_sKey
End Property
'=======================================
Property Let Section(sSection As String) '小節(jié)
m_sSection = sSection
End Property
Property Get Section() As String '小節(jié)
Section = m_sSection
End Property
'=======================================
Property Get Value() As String '值
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(255)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Value = Trim(Replace(sBuf, Chr(0), ""))
Else
Value = ""
End If
End Property
Property Let Value(sValue As String) '值
Dim iPos As Integer
' Strip chr$(0):
iPos = InStr(sValue, Chr$(0))
Do While iPos <> 0
sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))
iPos = InStr(sValue, Chr$(0))
Loop
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue, m_sPath)
End Property
'=========================================
Public Sub DeleteKey() '刪除鍵
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&, m_sPath)
End Sub
Public Sub DeleteSection() '刪除小節(jié)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)
End Sub
Public Function ReadStr(mKey As String, Optional mSection As String, Optional mDefault As String) As String
Dim S As String
If mSection <> "" Then
Section = mSection
End If
Key = mKey
S = Value
S = IIf(Len(Trim(S)) = 0, mDefault, S)
ReadStr = S
End Function
Public Sub WriteValue(mKey As String, mValue As String, Optional mSection As String)
If mSection <> "" Then
Section = mSection
End If
Key = mKey
Value = mValue
End Sub
Property Get INISection() As String 'Ini小節(jié)
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
INISection = Left$(sBuf, iRetCode)
Else
INISection = ""
End If
End Property
Property Let INISection(sSection As String) 'Ini小節(jié)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection, m_sPath)
End Property
Property Get Sections() As String '小節(jié)
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(0&, 0&, m_sDefault, sBuf, iSize, m_sPath)
'Debug.Print sBuf
If (iSize > 0) Then
Sections = Left$(sBuf, iRetCode)
Else
Sections = ""
End If
End Property
'----------------------------------
'枚舉小節(jié)，返回兩個參數(shù)
'sKey --鍵字符串?dāng)?shù)組，1開始
'iCount --鍵總數(shù)
Public Sub EnumerateCurrentSection(ByRef sKey() As String, ByRef iCount As Long)
Dim sSection As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sKey
sSection = INISection
If (Len(sSection) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sSection, Chr$(0))
Do While iNextPos <> 0
sCur = Mid$(sSection, iPos, (iNextPos - iPos))
If (sCur <> Chr$(0)) Then
iCount = iCount + 1
ReDim Preserve sKey(1 To iCount) As String
'Debug.Print sSection
sKey(iCount) = Mid$(sSection, iPos, (iNextPos - iPos))
iPos = iNextPos + 1
iNextPos = InStr(iPos, sSection, Chr$(0))
End If
Loop
End If
End Sub
'' ==========================================================
' 開發(fā)人員：夜的影子
' 編寫時間：2007-1-20
' 過程名稱：EnumerateAllSections
' 參數(shù)說明：sSections : 小節(jié)字符串?dāng)?shù)組，1開始
' iCount : 小節(jié)總數(shù)
' 功能說明：枚舉所有小節(jié)，返回兩個參數(shù)
'' ==========================================================
Public Sub EnumerateAllSections(ByRef sSections() As String, ByRef iCount As Long)
Dim sIniFile As String
Dim iPos As Long
Dim iNextPos As Long
Dim sCur As String
iCount = 0
Erase sSections
sIniFile = Sections
'Debug.Print Sections
If (Len(sIniFile) > 0) Then
iPos = 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Do While iNextPos <> 0
If (iNextPos <> iPos) Then
sCur = Mid$(sIniFile, iPos, (iNextPos - iPos))
iCount = iCount + 1
ReDim Preserve sSections(1 To iCount) As String
sSections(iCount) = sCur
End If
iPos = iNextPos + 1
iNextPos = InStr(iPos, sIniFile, Chr$(0))
Loop
End If
End Sub
'保存窗體數(shù)據(jù)
Public Sub SaveFormPosition(ByRef frmThis As Object)
Dim sSaveKey As String
Dim sSaveDefault As String
On Error GoTo SaveError
sSaveKey = Key
If Not (frmThis.WindowState = vbMinimized) Then '如果窗體沒有最小化
Key = "Maximised" '鍵,最大化
Value = (frmThis.WindowState = vbMaximized) * -1 '值,最大化的值
If (frmThis.WindowState <> vbMaximized) Then '如果沒有最大化
Key = "Left" '鍵
Value = frmThis.Left '值
Key = "Top"
Value = frmThis.Top
Key = "Width"
Value = frmThis.Width
Key = "Height"
Value = frmThis.Height
End If
End If
Key = sSaveKey
Exit Sub
SaveError: '錯誤處理
Key = sSaveKey
m_lLastReturnCode = 0
Exit Sub
End Sub
'-----------------------------------------
'載入窗體參數(shù)
Public Sub LoadFormPosition(ByRef frmThis As Object, Optional ByRef lMinWidth = 3000, Optional ByRef lMinHeight = 3000)
Dim sSaveKey As String
Dim sSaveDefault As String
Dim lLeft As Long
Dim lTOp As Long
Dim lWidth As Long
Dim lHeight As Long
On Error GoTo LoadError
sSaveKey = Key
sSaveDefault = Default
Default = "FAIL"
Key = "Left"
lLeft = CLngDefault(Value, frmThis.Left)
Key = "Top"
lTOp = CLngDefault(Value, frmThis.Top)
Key = "Width"
lWidth = CLngDefault(Value, frmThis.Width)
If (lWidth < lMinWidth) Then lWidth = lMinWidth
Key = "Height"
lHeight = CLngDefault(Value, frmThis.Height)
If (lHeight < lMinHeight) Then lHeight = lMinHeight
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lLeft = Screen.Width - 4 * Screen.TwipsPerPixelX - lWidth
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lWidth = Screen.Width - lLeft - 4 * Screen.TwipsPerPixelX
End If
End If
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lTOp = Screen.Height - 4 * Screen.TwipsPerPixelY - lHeight
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lHeight = Screen.Height - lTOp - 4 * Screen.TwipsPerPixelY
End If
End If
If (lWidth >= lMinWidth) And (lHeight >= lMinHeight) Then
frmThis.Move lLeft, lTOp, lWidth, lHeight
End If
Key = "Maximised"
If (CLngDefault(Value, 0) <> 0) Then
frmThis.WindowState = vbMaximized
End If
Key = sSaveKey
Default = sSaveDefault
Exit Sub
LoadError:
Key = sSaveKey
Default = sSaveDefault
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Function CLngDefault(ByVal sString As String, Optional ByVal lDefault As Long = 0) As Long
Dim lR As Long
On Error Resume Next
lR = CLng(sString)
If (Err.Number <> 0) Then
CLngDefault = lDefault
Else
CLngDefault = lR
End If
End Function
Private Sub Class_Initialize()
m_sSection = "Main"
End Sub
