'两个函数 , 先在一个模快中定义API函数 ike
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal LpKeyName As Any, ByVal lsString As Any, ByVal lplFilename As String) As Long
'如果是读INT值可以用字符串转化,所以没有另外定义函数
'Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPriviteProfileIntA" (ByVal lpApplicationname As String, ByVal LpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal LpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'定义读与写INI文件的函数
'****读INI文件****
'文件名 lpFileName 如果不存在会自己创建,如果只有文件名,默认在Windows\system目录下
'[lpAppName]
'lpKeyName=取回的设置值
'lpDefault 当键值不存在时的默认值
Public Function ReadINI(lpFileName As String, lpAppName As String, LpKeyName As String) As String
Dim Temp As String * 20
Dim lpDefault As String
lpDefault = ""
If GetPrivateProfileString(lpAppName, LpKeyName, lpDefault, Temp, Len(Temp), lpFileName) <= 0 Then
ReadINI = ""
Else
ReadINI = MyTrim(Temp) 'MyTrim函数见下
End If
End Function
'****写INI文件****
'[lpAppName]
'lpKeyName=lpString
Public Function WriteINI(lpFileName As String, lpAppName As String, LpKeyName As String, lpString As String) As Boolean
If WritePrivateProfileString(lpAppName, LpKeyName, lpString, lpFileName) = 0 Then
WriteINI = False
Else
WriteINI = True
End If
End Function
'包含三个函数,分别取Rtrim,Ltrim,Trim
'可以去字符串中如ASC码为0,10,13,32的字符
Public Function MyRtrim(Tmpstr As String)
Dim i, s As Integer
i = Len(Tmpstr)
If i = 0 Then
MyRtrim = ""
Exit Function
End If
s = Asc(Right(Tmpstr, 1))
While (s = 0 Or s = 13 Or s = 10 Or s = 32) And i > 0
i = i - 1
Tmpstr = Left(Tmpstr, i)
If Len(Tmpstr) = 0 Then
MyRtrim = ""
Exit Function
End If
s = Asc(Right(Tmpstr, 1))
Wend
MyRtrim = Tmpstr
End Function
Public Function MyLtrim(Tmpstr As String)
Dim i, s As Integer
i = Len(Tmpstr)
If i = 0 Then
MyLtrim = ""
Exit Function
End If
s = Asc(Left(Tmpstr, 1))
While (s = 0 Or s = 13 Or s = 10 Or s = 32) And i > 0
i = i - 1
Tmpstr = Right(Tmpstr, i)
If Len(Tmpstr) = 0 Then
MyLtrim = Tmpstr
Exit Function
End If
s = Asc(Left(Tmpstr, 1))
Wend
MyLtrim = Tmpstr
End Function
Public Function MyTrim(Tmpstr As String)
Tmpstr = MyLtrim(Tmpstr)
Tmpstr = MyRtrim(Tmpstr)
MyTrim = Tmpstr
我在用的一段:
Option Explicit
Public 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 Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Public 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
Public Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Public Cnn As New ADODB.Connection
Public DBName As String
Public ServerName As String
Public SysUser As String
Public DBPassword As String 'Password
Public DBUserID As String 'UserName
Public AppPath As String
Public Const BTNS = "00000000000000101"
Public Const BTNSEDIT = "11111011110000101"
Public Const SYSNAME = "美容专家连锁店管理系统"
Public Function GetServerName() As String
Dim Buffer As String * 255
Dim x As Integer
x = GetPrivateProfileString("CnnServer", "Server", "(Not Found)", Buffer, 255, AppPath & "\Setup.ini")
If Left(Buffer, x) = "(Not Found)" Then
MsgBox "你的服务器没有找到,请修改你有Setup.INI文件的Server", vbInformation
Exit Function
Else
GetServerName = Left(Buffer, x)
End If
End Function
Public Function GetDatabase() As String
Dim Buffer As String * 255
Dim x As Integer
x = GetPrivateProfileString("CnnServer", "Database", "(Not Found)", Buffer, 255, AppPath & "\Setup.ini")
If Left(Buffer, x) = "(Not Found)" Then
MsgBox "你的服务器没有找到,请修改你有Setup.INI文件的Server", vbInformation
Exit Function
Else
GetDatabase = Left(Buffer, x)
End If
End Function
Public Function GetUserID() As String
Dim Buffer As String * 255
Dim x As Integer
x = GetPrivateProfileString("CnnServer", "UserID", "(Not Found)", Buffer, 255, AppPath & "\Setup.ini")
If Left(Buffer, x) = "(Not Found)" Then
MsgBox "你的服务器没有找到,请修改你有Setup.INI文件的Server", vbInformation
Exit Function
Else
GetUserID = Left(Buffer, x)
End If
End Function
Public Function GetDBPassword() As String
Dim Buffer As String * 255
Dim x As Integer
x = GetPrivateProfileString("CnnServer", "Password", "(Not Found)", Buffer, 255, AppPath & "\Setup.ini")
If Left(Buffer, x) = "(Not Found)" Then
MsgBox "你的服务器没有找到,请修改你有Setup.INI文件的Server", vbInformation
Exit Function
Else
GetDBPassword = Left(Buffer, x)
End If
End Function
Sub Form1_Load()
……
Forml.Height=GetIniN(“窗体1”,“高度”,6000)
Form1.Width=GetIniN(“窗体1”,“高度”,4500)
EndSub
……
Sub Form1_Unload()
……
SetIniN“窗体1”,“高度”,Me.Height
SetIniN“窗体1,”宽度“,Me.Width
……
End Sub
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
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 Sub Form_Load()
Dim Ret As String, NC As Long
'Write the setting to the file (c:\test.ini) under
' Project1 -> Keyname
WritePrivateProfileString App.Title, "KeyName", "This is the value", "c:\test.ini"
'Create a buffer
Ret = String(255, 0)
'Retrieve the string
NC = GetPrivateProfileString(App.Title, "KeyName", "Default", Ret, 255, "C:\test.ini")
'NC is the number of characters copied to the buffer
If NC <> 0 Then Ret = Left$(Ret, NC)
'Show our string
MsgBox Ret
'Delete the file
Kill "c:\test.ini"
End Sub
虽然进入win95之後,一般读写ini文件被读写Registry所取代,但我们还是可以透过
win31的传统方式读写ini文件,以存程式目前的相关设定,而於下一次程式执行时再
读回来。目前建议使用GetSetting SaveSetting的方式存於Registry中,不用目前
的方式。 储存程式的设定
'请於form中放3个TextBox,一个CommandBox
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
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 Sub Command1_Click()
Dim success As Long
success = WritePrivateProfileString("MyApp", "text1", Text1.Text, "c:\aa.ini")
'叁数一 Section Name
'叁数二 於.ini中的项目
'叁数三 项目的内容
'叁数四 .ini文件的名称
success = WritePrivateProfileString("MyApp", "text2", Text2.Text, "c:\aa.ini")
success = WritePrivateProfileString("MyApp2", "text3", Text3.Text, "c:\aa.ini")
End Sub
Private Sub Form_load()
Dim ret As Long
Dim buff As String
buff = String(255, 0)
ret = GetPrivateProfileString("Myapp", "text1", "text1", buff, 256, "c:\aa.ini")
'若.ini MyApp中无text1,则采用叁数三的值
Text1.Text = buff
buff = String(255, 0)
ret = GetPrivateProfileString("Myapp", "text2", "text2", buff, 256, "c:\aa.ini")
Text2.Text = buff
buff = String(255, 0)
ret = GetPrivateProfileString("Myapp2", "text3", "text3", buff, 256, "c:\aa.ini")
Text3.Text = buff
End Sub