home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / code / system / winini / winini.bas next >
Encoding:
BASIC Source File  |  1994-04-11  |  6.2 KB  |  178 lines
  1. 'Functions for dealing with INI files
  2.  
  3. Option Compare Database   'Use database order for string comparisons
  4. Option Explicit : DefInt A-Z
  5.  
  6. Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal Section As String, ByVal Entry As String, ByVal Default As Integer, ByVal FileName As String) As Integer
  7. Declare Function PAWSOFFGetPrivateProfileString Lib "Kernel" Alias "GetPrivateProfileString" (ByVal Section As String, ByVal Entry As Any, ByVal Default As String, ByVal Buffer As String, ByVal BufSize As Integer, ByVal FileName As String) As Integer
  8. Declare Function PAWSOFFWritePrivateProfileString Lib "Kernel" Alias "WritePrivateProfileString" (ByVal Section As Any, ByVal Entry As Any, ByVal Value As Any, ByVal FileName As String) As Integer
  9.  
  10. Declare Function GetProfileInt Lib "Kernel" (ByVal Section As String, ByVal Entry As String, ByVal Default As Integer) As Integer
  11. Declare Function PAWSOFFGetProfileString Lib "Kernel" Alias "GetProfileString" (ByVal Section As String, ByVal Entry As Any, ByVal Default As String, ByVal Buffer As String, ByVal BufSize As Integer) As Integer
  12. Declare Function PAWSOFFWriteProfileString Lib "Kernel" Alias "WriteProfileString" (ByVal Section As Any, ByVal Entry As Any, ByVal Value As Any) As Integer
  13.  
  14. Const BufSz = 1024
  15. Const BufSzAll = 4096
  16.  
  17. 'A slightly more bulletproof string-to-number function
  18. Function Dec (ByVal s As String) As Double
  19.     Dim temp As String
  20.     Dim i As Integer
  21.     Dim c As String
  22.     Dim DecimalPt As String
  23.     Dim DPUsed As Integer
  24.     Dim NDigits As Integer
  25.  
  26.     DecimalPt = GetProfileString("intl", "sDecimal", ".")
  27.     DPUsed = False
  28.     NDigits = 0
  29.  
  30.     For i = 1 To Len(s)
  31.         c = Mid$(s, i, 1)
  32.         Select Case (Asc(c))
  33.         Case Asc("0") To Asc("9")
  34.             temp = temp & c: NDigits = NDigits + 1
  35.         Case Asc(DecimalPt)
  36.             If (Not DPUsed) Then temp = temp & DecimalPt: DPUsed = True
  37.         'Case Else
  38.         '    If (temp <> "") Then Exit For
  39.         End Select
  40.     Next i
  41.  
  42.     If (NDigits > 0) Then Dec = CDbl(temp) Else Dec = 0
  43. End Function
  44.  
  45. 'The most recently read profile file is cached in memory. This flushes the cache.
  46. Sub FlushPrivateProfile (ByVal FileName As String)
  47.     Dim R As Integer
  48.     R = PAWSOFFWritePrivateProfileString(0&, 0&, 0&, FileName)
  49. End Sub
  50.  
  51. 'WIN.INI is cached in memory. This flushes the cache.
  52. Sub FlushProfile ()
  53.     Dim R As Integer
  54.     R = PAWSOFFWriteProfileString(0&, 0&, 0&)
  55. End Sub
  56.  
  57. 'Like the API call but allows the use of VB's Null in place of a C-style NULL
  58. Function GetPrivateProfileString (ByVal Section As String, ByVal Entry As Variant, ByVal Default As String, ByVal FileName As String) As String
  59.     Dim Buffer As String
  60.     Dim R As Integer
  61.  
  62.     If (IsNull(Entry)) Then
  63.         'Get names of all entries in the named section
  64.         Buffer = String$(BufSzAll, 0)
  65.         R = PAWSOFFGetPrivateProfileString(Section, 0&, Default, Buffer, BufSzAll, FileName)
  66.     Else
  67.         'Get the value of the named entry
  68.         Buffer = String$(BufSz, 0)
  69.         R = PAWSOFFGetPrivateProfileString(Section, CStr(Entry), Default, Buffer, BufSz, FileName)
  70.     End If
  71.     GetPrivateProfileString = Left$(Buffer, R)
  72. End Function
  73.  
  74. 'Like the API call but allows the use of VB's Null in place of a C-style NULL
  75. Function GetProfileString (ByVal Section As String, ByVal Entry As Variant, ByVal Default As String) As String
  76.     Dim Buffer As String
  77.     Dim R As Integer
  78.  
  79.     If (IsNull(Entry)) Then
  80.         'Get names of all entries in the named section
  81.         Buffer = String$(BufSzAll, 0)
  82.         R = PAWSOFFGetProfileString(Section, 0&, Default, Buffer, BufSzAll)
  83.     Else
  84.         'Get the value of the named entry
  85.         Buffer = String$(BufSz, 0)
  86.         R = PAWSOFFGetProfileString(Section, CStr(Entry), Default, Buffer, BufSz)
  87.     End If
  88.     GetProfileString = Left$(Buffer, R)
  89. End Function
  90.  
  91. 'Retrieve an entry from a multi-entry string
  92. Function StrEntry (ByVal s As String, ByVal Which As Integer) As String
  93.     If (Which < 1) Then StrEntry = "": Exit Function
  94.     
  95.     Dim Pos As Long
  96.     Dim Curr As Integer
  97.     Curr = 1
  98.     Pos = 1
  99.  
  100.     'Pos = starting character of entry #Curr
  101.     Do Until (Curr = Which)
  102.         Pos = InStr(Pos, s, Chr$(0))
  103.         If (Pos = 0) Then
  104.             StrEntry = ""
  105.             Exit Function
  106.         End If
  107.         Pos = Pos + 1
  108.         Curr = Curr + 1
  109.     Loop
  110.     'Pos = starting character of entry #Which
  111.  
  112.     'Find end of this line
  113.     Dim LineEnd
  114.     LineEnd = InStr(Pos, s, Chr$(0))
  115.     If (LineEnd = 0) Then
  116.  
  117.         StrEntry = Right$(s, Len(s) - Pos + 1)
  118.     Else
  119.         StrEntry = Mid$(s, Pos, LineEnd - Pos)
  120.     End If
  121. End Function
  122.  
  123. 'Find the number of NUL separated entries in a string
  124. Function StrNEntries (ByVal s As String) As Integer
  125.     Dim NNuls As Integer
  126.     Dim Pos As Integer
  127.  
  128.     Pos = 1
  129.     NNuls = 1
  130.     Do While (True)
  131.         Pos = InStr(Pos, s, Chr$(0))
  132.         If (Pos = 0) Then
  133.             StrNEntries = NNuls
  134.             Exit Function
  135.         Else
  136.             Pos = Pos + 1
  137.             NNuls = NNuls + 1
  138.         End If
  139.     Loop
  140. End Function
  141.  
  142. 'Like the API call but allows the use of VB's Null in place of a C-style NULL
  143. Sub WritePrivateProfile (ByVal Section As String, ByVal Entry As Variant, ByVal Value As Variant, ByVal FileName As String)
  144.     Dim R As Integer
  145.  
  146.     If (IsNull(Entry)) Then
  147.         'Delete named section
  148.         R = PAWSOFFWritePrivateProfileString(Section, 0&, 0&, FileName)
  149.     ElseIf (IsNull(Value)) Then
  150.         'Delete named entry within the section
  151.  
  152.         R = PAWSOFFWritePrivateProfileString(Section, CStr(Entry), 0&, FileName)
  153.     Else
  154.         'Insert or replace the entry
  155.         R = PAWSOFFWritePrivateProfileString(Section, CStr(Entry), CStr(Value), FileName)
  156.     End If
  157.     
  158.     If (R = 0) Then Err = 32767
  159. End Sub
  160.  
  161. 'Like the API call but allows the use of VB's Null in place of a C-style NULL
  162. Sub WriteProfile (ByVal Section As String, ByVal Entry As Variant, ByVal Value As Variant)
  163.     Dim R As Integer
  164.  
  165.     If (IsNull(Entry)) Then
  166.         'Delete named section
  167.         R = PAWSOFFWriteProfileString(Section, 0&, 0&)
  168.     ElseIf (IsNull(Value)) Then
  169.         'Delete named entry within the section
  170.         R = PAWSOFFWriteProfileString(Section, CStr(Entry), 0&)
  171.     Else
  172.         'Insert or replace the entry
  173.         R = PAWSOFFWriteProfileString(Section, CStr(Entry), CStr(Value))
  174.     End If
  175.     
  176.     If (R = 0) Then Err = 32767
  177. End Sub
  178.