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