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 >
Wrap
BASIC Source File
|
1995-08-01
|
9KB
|
194 lines
Attribute VB_Name = "Common"
'**************************************************************
' COMMON.BAS - This module contains declarations and
' proceedures that are need by more than one
' form or class in this project. It also includes
' the required starting point for the project by
' declaring a public Sub Main().
'**************************************************************
Option Explicit
'**************************************************************
' API calls that are only used by this module don't need to
' be public.
'**************************************************************
#If Win32 Then
Private Declare Function SetWindowPos Lib "user32" (ByVal _
hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x _
As Long, ByVal y As Long, ByVal cx As Long, ByVal cy _
As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Public Declare Function GetVersion Lib "kernel32" () As Long
Public Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
#Else
Private Declare Function SetWindowPos Lib "User" (ByVal hwnd%, _
ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, _
ByVal FLAGS%) As Integer
Private Declare Function GetWindowsDirectory Lib "Kernel" _
(ByVal retStr$, ByVal bufferLen%) As Integer
'**************************************************************
' API calls used by other modules, forms, or classes, should
' be exposed via Public.
'**************************************************************
Public Declare Function GetVersion Lib "Kernel" () As Long
Public Declare Function SendMessage Lib "User" (ByVal hwnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
lParam As Any) As Long
Public Declare Function PostMessage Lib "User" (ByVal hwnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
lParam As Any) As Long
#End If
'**************************************************************
' This boolean keeps track of the way the about box should
' be displayed.
'**************************************************************
Public bSplashScreen As Boolean
'**************************************************************
' This proceedure will set or restore a window to the topmost
' postion above all open windows.
'**************************************************************
#If Win32 Then
Public Sub AlwaysOnTop(ByVal hwnd&, ResetWindow As Boolean)
#Else
Public Sub AlwaysOnTop(ByVal hwnd%, ResetWindow As Boolean)
#End If
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Dim success%
On Error GoTo AlwaysOnTop_Err
If ResetWindow Then
success = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, _
0, 0, FLAGS)
Else
success = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, _
0, FLAGS)
End If
Exit Sub
AlwaysOnTop_Err:
ErrHandler Err, "AlwaysOnTop" & str$(ResetWindow)
Exit Sub
End Sub
'**************************************************************
' This is a generic error handler which will display a message,
' close any open files, and restore the pointer and Err.
'**************************************************************
Public Sub ErrHandler(ErrType%, FromWhere$)
'**********************************************************
' We wouldn't be here if there wasn't an error, so be sure
' to turn error handling off.
'**********************************************************
On Error Resume Next
'**********************************************************
' ErrType = 32755 is Cancel button was selected
' ErrType = 3197 Then Data has changed when 2 users
' accessing one record
'**********************************************************
If ErrType = 32755 Or ErrType = 3197 Then Exit Sub
'**********************************************************
' This statement prevents a error message if this function
' was accidentally called.
'**********************************************************
If ErrType <> 0 Then
'******************************************************
' Set Err so we can get Error
'******************************************************
Err = ErrType
'******************************************************
' Restore the mouse, and display a descriptive message
'******************************************************
Screen.MousePointer = vbDefault
MsgBox "An error of type" & str(Err) & " occured in " _
& FromWhere & ".", vbExclamation, Error
'******************************************************
' Restore Err, and close any open files to prevent
' corrupting files.
'******************************************************
Err = 0
Close
End If
End Sub
'**************************************************************
' Uses the Dir command to see if a file exists. Resume Next is
' required in case FileName contains an invalid path
'**************************************************************
Public Function FileExists(FileName$) As Boolean
On Error Resume Next
FileExists = IIf(Dir(FileName) <> "", True, False)
End Function
'**************************************************************
' Returns the path to the Windows directory with or without
' a trailing backslash.
'**************************************************************
Public Function GetWinDir(WithSlash As Boolean) As String
Dim lpBuffer$, res%, GetWin$
'**********************************************************
' Turn on error handling
'**********************************************************
On Error GoTo GetWinDir_Err
'**********************************************************
' Initalize a buffer that is large enough to hold the
' result, otherwise you'll get a GPF.
'**********************************************************
lpBuffer = Space$(2048)
'**********************************************************
' Call the function, and strip the null terminator using
' the return value.
'**********************************************************
res = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
GetWin = LCase$(Left$(lpBuffer, res))
'**********************************************************
' Add or Remove the slash depending on what was returned,
' and the value of WithSlash.
'**********************************************************
If Right$(GetWin, 1) <> "\" And WithSlash Then
GetWinDir = GetWin & "\"
ElseIf Right$(GetWin, 1) = "\" And Not WithSlash Then
GetWinDir = Left$(GetWin, Len(GetWin) - 1)
Else
GetWinDir = GetWin
End If
'**********************************************************
' Don't forget to exit, otherwise you'll fall into the
' error handler.
'**********************************************************
Exit Function
'**************************************************************
' If error, call the error handler, and tell it where the
' error occured. This is useful for distributed apps.
'**************************************************************
GetWinDir_Err:
ErrHandler Err, "GetWinDir"
Exit Function
End Function
'**************************************************************
' All projects must have an entry point (either a startup form
' or Sub Main()). This one just initalizes our variables.
'**************************************************************
Sub Main()
'**********************************************************
' If this program is started manually, then show the
' about box.
'**********************************************************
If App.StartMode = vbSModeStandalone Then
Dim thisApp As New Application
thisApp.ShowAboutBox False, App:="Martinsen's Software", _
AppCompany:="Martinsen's Software", VerNum:="1.00.01", _
User:="John Doe", Company:="XYZ Incorporated", _
AboutMsg:="This OLE object was started manually.", _
RegNum:="Registration Number: 12345"
End If
End Sub