home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Programmer'…arterly (Limited Edition) / Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso / code / ch26code / listings / 26lst10.txt < prev    next >
Text File  |  1995-08-01  |  9KB  |  193 lines
  1. '**************************************************************
  2. ' COMMON.BAS - This module contains declarations and
  3. '              proceedures that are need by more than one
  4. '              form or class in this project. It also includes
  5. '              the required starting point for the project by
  6. '              declaring a public Sub Main().
  7. '**************************************************************
  8. Option Explicit
  9. '**************************************************************
  10. ' API calls that are only used by this module don't need to
  11. ' be public.
  12. '**************************************************************
  13. #If Win32 Then
  14. Private Declare Function SetWindowPos Lib "user32" (ByVal _
  15.     hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x _
  16.     As Long, ByVal y As Long, ByVal cx As Long, ByVal cy _
  17.     As Long, ByVal wFlags As Long) As Long
  18. Private Declare Function GetWindowsDirectory Lib "kernel32" _
  19.     Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
  20.     ByVal nSize As Long) As Long
  21. Public Declare Function GetVersion Lib "kernel32" () As Long
  22. Public Declare Function SendMessage Lib "user32" Alias _
  23.     "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
  24.     ByVal wParam As Long, lParam As Any) As Long
  25. Public Declare Function PostMessage Lib "user32" Alias _
  26.     "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
  27.     ByVal wParam As Long, lParam As Any) As Long
  28. #Else
  29. Private Declare Function SetWindowPos Lib "User" (ByVal hwnd%, _
  30.     ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, _
  31.     ByVal FLAGS%) As Integer
  32. Private Declare Function GetWindowsDirectory Lib "Kernel" _
  33.     (ByVal retStr$, ByVal bufferLen%) As Integer
  34. '**************************************************************
  35. ' API calls used by other modules, forms, or classes, should
  36. ' be exposed via Public.
  37. '**************************************************************
  38. Public Declare Function GetVersion Lib "Kernel" () As Long
  39. Public Declare Function SendMessage Lib "User" (ByVal hwnd As _
  40.     Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
  41.     lParam As Any) As Long
  42. Public Declare Function PostMessage Lib "User" (ByVal hwnd As _
  43.     Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
  44.     lParam As Any) As Long
  45. #End If
  46. '**************************************************************
  47. ' This boolean keeps track of the way the about box should
  48. ' be displayed.
  49. '**************************************************************
  50. Public bSplashScreen As Boolean
  51. '**************************************************************
  52. ' This proceedure will set or restore a window to the topmost
  53. ' postion above all open windows.
  54. '**************************************************************
  55. #If Win32 Then
  56. Public Sub AlwaysOnTop(ByVal hwnd&, ResetWindow As Boolean)
  57. #Else
  58. Public Sub AlwaysOnTop(ByVal hwnd%, ResetWindow As Boolean)
  59. #End If
  60. Const HWND_TOPMOST = -1
  61. Const HWND_NOTOPMOST = -2
  62. Const SWP_NOMOVE = 2
  63. Const SWP_NOSIZE = 1
  64. Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
  65. Dim success%
  66.     
  67.     On Error GoTo AlwaysOnTop_Err
  68.  
  69.     If ResetWindow Then
  70.         success = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, _
  71.                   0, 0, FLAGS)
  72.     Else
  73.         success = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, _
  74.                   0, FLAGS)
  75.     End If
  76.     
  77.     Exit Sub
  78.  
  79. AlwaysOnTop_Err:
  80.     ErrHandler Err, "AlwaysOnTop" & str$(ResetWindow)
  81.     Exit Sub
  82. End Sub
  83. '**************************************************************
  84. ' This is a generic error handler which will display a message,
  85. ' close any open files, and restore the pointer and Err.
  86. '**************************************************************
  87. Public Sub ErrHandler(ErrType%, FromWhere$)
  88.     '**********************************************************
  89.     ' We wouldn't be here if there wasn't an error, so be sure
  90.     ' to turn error handling off.
  91.     '**********************************************************
  92.     On Error Resume Next
  93.     '**********************************************************
  94.     ' ErrType = 32755 is Cancel button was selected
  95.     ' ErrType = 3197 Then Data has changed when 2 users
  96.     ' accessing one record
  97.     '**********************************************************
  98.     If ErrType = 32755 Or ErrType = 3197 Then Exit Sub
  99.     '**********************************************************
  100.     ' This statement prevents a error message if this function
  101.     ' was accidentally called.
  102.     '**********************************************************
  103.     If ErrType <> 0 Then
  104.         '******************************************************
  105.         ' Set Err so we can get Error
  106.         '******************************************************
  107.         Err = ErrType
  108.         '******************************************************
  109.         ' Restore the mouse, and display a descriptive message
  110.         '******************************************************
  111.         Screen.MousePointer = vbDefault
  112.         MsgBox "An error of type" & str(Err) & " occured in " _
  113.                & FromWhere & ".", vbExclamation, Error
  114.         '******************************************************
  115.         ' Restore Err, and close any open files to prevent
  116.         ' corrupting files.
  117.         '******************************************************
  118.         Err = 0
  119.         Close
  120.     End If
  121. End Sub
  122. '**************************************************************
  123. ' Uses the Dir command to see if a file exists. Resume Next is
  124. ' required in case FileName contains an invalid path
  125. '**************************************************************
  126. Public Function FileExists(FileName$) As Boolean
  127.     On Error Resume Next
  128.     FileExists = IIf(Dir(FileName) <> "", True, False)
  129. End Function
  130. '**************************************************************
  131. ' Returns the path to the Windows directory with or without
  132. ' a trailing backslash.
  133. '**************************************************************
  134. Public Function GetWinDir(WithSlash As Boolean) As String
  135. Dim lpBuffer$, res%, GetWin$
  136.     '**********************************************************
  137.     ' Turn on error handling
  138.     '**********************************************************
  139.     On Error GoTo GetWinDir_Err
  140.     '**********************************************************
  141.     ' Initalize a buffer that is large enough to hold the
  142.     ' result, otherwise you'll get a GPF.
  143.     '**********************************************************
  144.     lpBuffer = Space$(2048)
  145.     '**********************************************************
  146.     ' Call the function, and strip the null terminator using
  147.     ' the return value.
  148.     '**********************************************************
  149.     res = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
  150.     GetWin = LCase$(Left$(lpBuffer, res))
  151.     '**********************************************************
  152.     ' Add or Remove the slash depending on what was returned,
  153.     ' and the value of WithSlash.
  154.     '**********************************************************
  155.     If Right$(GetWin, 1) <> "\" And WithSlash Then
  156.         GetWinDir = GetWin & "\"
  157.     ElseIf Right$(GetWin, 1) = "\" And Not WithSlash Then
  158.         GetWinDir = Left$(GetWin, Len(GetWin) - 1)
  159.     Else
  160.         GetWinDir = GetWin
  161.     End If
  162.     '**********************************************************
  163.     ' Don't forget to exit, otherwise you'll fall into the
  164.     ' error handler.
  165.     '**********************************************************
  166.     Exit Function
  167. '**************************************************************
  168. ' If error, call the error handler, and tell it where the
  169. ' error occured. This is useful for distributed apps.
  170. '**************************************************************
  171. GetWinDir_Err:
  172.     ErrHandler Err, "GetWinDir"
  173.     Exit Function
  174. End Function
  175. '**************************************************************
  176. ' All projects must have an entry point (either a startup form
  177. ' or Sub Main()). This one just initalizes our variables.
  178. '**************************************************************
  179. Sub Main()
  180.     '**********************************************************
  181.     ' If this program is started manually, then show the
  182.     ' about box.
  183.     '**********************************************************
  184.     If App.StartMode = vbSModeStandalone Then
  185.         Dim thisApp As New Application
  186.         thisApp.ShowAboutBox False, App:="Martinsen's Software", _
  187.             AppCompany:="Martinsen's Software", VerNum:="1.00.01", _
  188.             User:="John Doe", Company:="XYZ Incorporated", _
  189.             AboutMsg:="This OLE object was started manually.", _
  190.             RegNum:="Registration Number: 12345"
  191.     End If
  192. End Sub
  193.