home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / vb_code1 / mdi_demo / general.bas < prev    next >
BASIC Source File  |  1994-04-07  |  4KB  |  174 lines
  1. Option Explicit
  2.  
  3. Global gDatabaseName As String
  4.  
  5. Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Integer, ByVal lpFileName As String) As Integer
  6. Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, lpKeyName As Any, lpString As Any, ByVal lplFileName As String) As Integer
  7. Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
  8.  
  9. Function CheckWindow (F1 As Form) As Integer
  10. Dim x As Integer
  11.  
  12. ' this routine makes sure than a form object actually points
  13. ' to a form that is currently loaded
  14.  
  15. CheckWindow = False
  16.  
  17. If Not (F1 Is Nothing) Then
  18.     For x = 0 To Forms.Count - 1
  19.     If F1 Is Forms(x) Then
  20.         CheckWindow = True
  21.         Exit For
  22.     End If
  23.     Next x
  24. End If
  25.  
  26. End Function
  27.  
  28. Function CurrentRecord (Data1 As Data) As Integer
  29.  
  30. If Data1.EditMode = Data_EditAdd Then
  31.     CurrentRecord = False
  32. ElseIf Data1.Recordset.EOF Or Data1.Recordset.BOF Then
  33.     CurrentRecord = False
  34. Else
  35.     CurrentRecord = True
  36. End If
  37.  
  38. End Function
  39.  
  40. Sub DataError (ErrNo, ErrorMsg)
  41.  
  42. Select Case ErrNo
  43.     Case 3197
  44.     MsgBox "This record has been edited by another user. Save record again to overwrite their changes, or choose Edit, Refresh to discard your changes.", MB_IconExclamation
  45.     Case 3200
  46.     MsgBox ErrorMsg, MB_IconStop
  47.     Case Else
  48.     MsgBox "Unable to save record. Error #" & ErrNo & " has occured: " & ErrorMsg, MB_IconStop
  49. End Select
  50.  
  51. End Sub
  52.  
  53. Sub Main ()
  54. Dim RealTitle As String
  55.  
  56. If App.PrevInstance Then
  57.     ' Activate, then restore the previous instance
  58.     RealTitle = App.Title
  59.     App.Title = "Duplicate App"
  60.     AppActivate RealTitle
  61.     SendKeys "%( R)", True
  62.     DoEvents
  63.     End
  64. End If
  65.  
  66. gDatabaseName = ReadIniString("Options", "Database")
  67.  
  68. MainMdi.Show
  69.  
  70. End Sub
  71.  
  72. Function MakeDate (d As Double) As String
  73.  
  74. If d < DateSerial(2000, 1, 1) Then
  75.     MakeDate = Format$(d, "mm/dd/yy")
  76. Else
  77.     MakeDate = Format$(d, "mm/dd/yyyy")
  78. End If
  79.  
  80. End Function
  81.  
  82. Sub NewForm (File As String, Cmd As String)
  83. Dim F1 As Form
  84.  
  85. Select Case File
  86.     Case "Titles"
  87.     Set F1 = New Titles
  88.     ' can't use show because modal form may be visible
  89.     F1.Visible = True
  90.     Case "Authors"
  91.     Set F1 = New Authors
  92.     F1.Visible = True
  93.     Case "Publishers"
  94.     Set F1 = New Publish
  95.     F1.Visible = True
  96.     Case Else
  97.     MsgBox File & " not implemented yet." '*
  98. End Select
  99.  
  100. If Not (F1 Is Nothing) And Cmd <> "" Then
  101.     F1.FormCommand = Cmd
  102. End If
  103.  
  104. End Sub
  105.  
  106. Function QuotesAround (inside As String) As String
  107. Dim x As Integer, temp As String
  108.  
  109. If InStr(inside, "'") = 0 Then
  110.     QuotesAround = "'" & inside & "'"
  111. ElseIf InStr(inside, Chr$(34)) = 0 Then
  112.     QuotesAround = Chr$(34) & inside & Chr$(34)
  113. Else
  114.     temp = ""
  115.     For x = 1 To Len(inside)
  116.     If Mid$(inside, x, 1) = Chr$(34) Then
  117.         temp = temp & Chr$(34) & Chr$(34)
  118.     Else
  119.         temp = temp & Mid$(inside, x, 1)
  120.     End If
  121.     Next x
  122.     QuotesAround = temp
  123. End If
  124.  
  125. End Function
  126.  
  127. Function ReadIniInt (Section As String, Entry As String, default As Integer) As Integer
  128. Dim INIFile As String
  129.  
  130. INIFile = App.EXEName & ".ini"
  131. ReadIniInt = GetPrivateProfileInt(Section, Entry, default, INIFile)
  132.  
  133. End Function
  134.  
  135. Function ReadIniString (Section As String, Entry As String) As String
  136. Dim INIFile  As String
  137. Dim DefaultString As String, ReturnString As String
  138. Dim StringLength As Integer, ReturnLength As Integer
  139.  
  140. INIFile = App.EXEName & ".INI"
  141. DefaultString = ""
  142. ReturnString = Space$(255)
  143. StringLength = Len(ReturnString)
  144. ReturnLength = GetPrivateProfileString(Section, ByVal Entry, DefaultString, ReturnString, StringLength, INIFile)
  145.  
  146. ReadIniString = Left$(ReturnString, ReturnLength)
  147.  
  148. End Function
  149.  
  150. Sub SendAll (message As String)
  151. Dim x As Integer
  152.  
  153. On Error Resume Next
  154.  
  155. For x = 0 To Forms.Count - 1
  156.     Forms(x).FormCommand = message
  157. Next x
  158.  
  159. End Sub
  160.  
  161. Sub WriteIni (Section As String, Entry As String, Value As String)
  162. Dim dummy As Integer
  163. Dim INIFile As String
  164.  
  165. INIFile = App.EXEName & ".INI"
  166. If Value = "" Then
  167.     dummy = WritePrivateProfileString(Section, ByVal Entry, 0&, INIFile)
  168. Else
  169.     dummy = WritePrivateProfileString(Section, ByVal Entry, ByVal Value, INIFile)
  170. End If
  171.  
  172. End Sub
  173.  
  174.