Visual Basic Programmer'…arterly (Limited Edition)/Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso/code/ch26code/app.cls

Text File | 1995-08-01 | 18KB | 362 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Application"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
'**************************************************************
' APP.CLS - This is the application class which is exposed
'           to other OLE Automation clients. It provides some
'           handy routines that aren't included in VB, and it
'           is a good demonstration on how to write a OLE server
'           that can be used with other Office apps.
'**************************************************************
Option Explicit
'**************************************************************
' Hidden API Functions for private use only
'**************************************************************
#If Win32 Then
Private Declare Function GetPrivateProfileInt Lib "kernel32" _
    Alias "GetPrivateProfileIntA" (ByVal lpApplicationName$, _
    ByVal lpKeyName As String, ByVal nDefault As Long, ByVal _
    lpFileName As String) As Long

Private Declare Function GetPrivateProfileString Lib "kernel32" _
    Alias "GetPrivateProfileStringA" (ByVal lpApplicationName$, _
    lpKeyName As Any, ByVal lpDefault As String, ByVal _
    lpReturnedString As String, ByVal nSize As Long, ByVal _
    lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib _
    "kernel32" Alias "WritePrivateProfileStringA" (ByVal _
    lpApplicationName As String, lpKeyName As Any, lpString _
    As Any, ByVal lplFileName As String) As Long

Private Declare Function GetShortPathName Lib "kernel32" Alias _
    "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal _
    lpszShortPath As String, ByVal cchBuffer As Long) As Long
#Else
Private Declare Function GetPrivateProfileInt Lib "Kernel" _
        (ByVal lpApplicationName As String, ByVal lpKeyName _
        As String, ByVal nDefault As Integer, ByVal lpFileName _
        As String) As Integer

Private Declare Function GetPrivateProfileString Lib "Kernel" _
        (ByVal lpAppName As Any, ByVal lpKeyName As Any, _
        ByVal lpDefault As String, ByVal lpReturnedString _
        As String, ByVal nSize As Integer, ByVal lpFileName _
        As String) As Integer

Private Declare Function WritePrivateProfileString% Lib "Kernel" _
        (ByVal lpAppName As Any, ByVal lpKeyName As Any, ByVal _
        lpString As Any, ByVal lpFileName As String)
#End If
'**************************************************************
' Hidden variable for this class
'**************************************************************
Private thisAbout As New About
'**************************************************************
' Description: This proceedure displays an about box
'
' Arguments:
' AsSplash  (Boolean)- Display as splash screen?
' App       (String) - The name of your application
' AppCompany(String) - The name of your company
' VerNum    (String) - The version number of your app
' User      (String) - The name of the registered user
' Company   (String) - The User's company name
' RegNum    (String) - The User's registration number
' AboutMsg  (String) - Your about box message that goes
'                      between the 2 black lines
' IconProg  (String) - The filename (without a extension)
'                      of the running app that contains
'                      the icon you would like to use.
'                      The default is Progman
'                      (for Program Manager)
'
' IconIdx   (Long)   - The 1 based index of the icon
'                      stored in IconProg. The default
'                      is 1
'**************************************************************
Public Sub ShowAboutBox(AsSplash As Boolean, _
                        Optional App, _
                        Optional AppCompany, _
                        Optional VerNum, _
                        Optional User, _
                        Optional Company, _
                        Optional RegNum, _
                        Optional AboutMsg)

    '**********************************************************
    ' You should only set the properties if the argument was
    ' provided. Otherwise, just let the default values appear.
    '**********************************************************
    If Not IsMissing(App) Then thisAbout.AppName = App
    If Not IsMissing(AppCompany) Then _
                        thisAbout.AppCompanyName = AppCompany
    If Not IsMissing(VerNum) Then thisAbout.VersionNumber = VerNum
    If Not IsMissing(User) Then thisAbout.UserName = User
    If Not IsMissing(Company) Then thisAbout.CompanyName = Company
    If Not IsMissing(RegNum) Then thisAbout.Registration = RegNum
    If Not IsMissing(AboutMsg) Then thisAbout.Message = AboutMsg
    '**********************************************************
    ' Show it using the About object
    '**********************************************************
    thisAbout.ShowAbout AsSplash
End Sub
'**************************************************************
' Returns a reference to an About object so that its properties
' may be accessed individually.
'**************************************************************
Public Property Get CreateAbout() As Object
Attribute CreateAbout.VB_Description = "Returns an About object, so that you may access the class directly."
    Set CreateAbout = thisAbout
End Property
'**************************************************************
' Unload via the About object
'**************************************************************
Public Sub UnloadSplash()
Attribute UnloadSplash.VB_Description = "Unloads the splash screen"
    thisAbout.HideSplash
End Sub
'**************************************************************
' This method is just a wrapper for the global function which
' the about object needs too. This demonstrates how you can
' expose non-class objects.
'**************************************************************
' NOTE: You may be wondering why I didn't just put the code
'       in here, and require other modules to just call this
'       one. The reason is that this is a class. If another
'       module wants to use a class method, then they must
'       create an object which consumes a great deal of
'       memory. This method exposes our object, but it also
'       leaves it available to all forms by putting it into
'       a module. This duplication is actually an optimization.
'**************************************************************
#If Win32 Then
Public Sub AlwaysOnTop(ByVal hwnd&, ResetWindow As Boolean)
#Else
Public Sub AlwaysOnTop(ByVal hwnd%, ResetWindow As Boolean)
Attribute AlwaysOnTop.VB_Description = "Sets or removes the topmost setting from a given window."
#End If
    Common.AlwaysOnTop hwnd, ResetWindow
End Sub
'**************************************************************
' This method is a wrapper for Common.FileExists.
'**************************************************************
Public Function FileExists(FileName$) As Boolean
Attribute FileExists.VB_Description = "Checks to see if a file exists"
    FileExists = Common.FileExists(FileName)
End Function
'**************************************************************
' This method is a wrapper for Common.GetWinDir.
'**************************************************************
Public Function GetWinDir(WithSlash As Boolean) As String
Attribute GetWinDir.VB_Description = "Returns the path to the Windows directory."
    GetWinDir = Common.GetWinDir(WithSlash)
End Function
#If Win32 Then
'**************************************************************
' This function converts a long file name into a DOS compatible
' short file name.
'**************************************************************
Private Function GetShortName(LongFileName As String) As String
Dim strFileName As String
    strFileName = Space(2048)
    GetShortName = Left(strFileName, GetShortPathName _
        (LongFileName, strFileName, Len(strFileName)))
End Function
#End If
'**************************************************************
' This method extracts the filename (with extension) from a
' fully qualified path. If path = "c:\autoexec.bat", then
' this method returns "autoexec.bat".
'**************************************************************
' NOTE: This method is not used by any modules or forms in this
' project, so its code belongs here.
'**************************************************************
'***************************************************************
' WARNING: This function modifies Path, so ByVal is required.
'***************************************************************
Public Function ExtractFileName(ByVal Path As String) As String
Attribute ExtractFileName.VB_Description = "Extracts the filename from fully qualified path."
Dim res%
    '***********************************************************
    ' One of the few uses for GoTo is as an error handler,and
    ' this is a great example of how to use them.
    '***********************************************************
    On Error GoTo ExtractFileName_Err
    '***********************************************************
    ' Since a filename (with extension) in DOS can only be
    ' a maximum of 13 chars (8 + 1 + 3), get rid of the rest.
    '***********************************************************
    #If Win32 Then ' Convert LFN's to SFN's
        Path = GetShortName(Path)
    #End If
    If Len(Path) > 13 Then Path = Right(Path, 13)
    res = InStr(Path, "\")
    '***********************************************************
    ' Get rid of the rest of the garbage by looking for slashes.
    '***********************************************************
    Do While res <> 0
        Path = Mid$(Path, res + 1, Len(Path))
        res = InStr(Path, "\")
    Loop
    '***********************************************************
    ' Return the result, and exit the function to prevent
    ' executing the error handler.
    '***********************************************************
    ExtractFileName = Path
    Exit Function
'***************************************************************
' Our error handler calls an external module's generic error
' handler, and exits to prevent further damage.
'***************************************************************
ExtractFileName_Err:
    ErrHandler Err, "ExtractFileName"
    Exit Function
End Function
'**************************************************************
' Calls the API to read an INI file, and return the results.
' A large buffer is used so that this function can be used
' in any app without causing a GPF.
'***************************************************************
' NOTE: ByVal is used, so you can pass control values such
'       as Text1.Text without surrounding it in parenthesis.
'**************************************************************
Public Function GetINI(ByVal Section$, ByVal Key$, ByVal _
                       Default$, ByVal FileName$) As String
Dim res&, retVal$
    retVal = Space$(32400)
    res = GetPrivateProfileString(Section, Key, Default, _
                            retVal, Len(retVal), FileName)
    GetINI = Left$(retVal, res)
End Function
'**************************************************************
' Same as above, but it returns an integer.
'**************************************************************
Public Function GetINIInt(ByVal Section$, ByVal Key$, ByVal _
                        Default%, ByVal FileName$) As Integer
    GetINIInt = GetPrivateProfileInt(Section, Key, Default, FileName)
End Function
'**************************************************************
' This function is useful with SendMessage and GetVersion
' so you can get the low order word.
'**************************************************************
Public Function GetLoWord(ByVal DWORD&) As Long
    GetLoWord = DWORD And &HFFFF&
End Function
'**************************************************************
' Same as above, but returns the high order word.
'**************************************************************
Public Function GetHiWord(ByVal DWORD As Long) As Long
Attribute GetHiWord.VB_Description = "Returns the high order word from a DWORD."
    GetHiWord = DWORD \ &H10000
End Function
#If Win16 Then
'**************************************************************
' This function is EXTREMELY useful under Win16 for making
' a DWORD which is sometimes required by SendMessage's lParam
' argument.
'**************************************************************
Public Function MakelParam(LoWord%, HiWord%) As Long
Attribute MakelParam.VB_Description = "Takes 2 integers and converts them to a DWORD."
    MakelParam = CLng(HiWord) * &H1000& Or LoWord
End Function
#End If
'**************************************************************
' This method returns the Windows version as a variant so you
' can use it as text, or as a number.
'**************************************************************
Public Function WindowsVersion() As Variant
Attribute WindowsVersion.VB_Description = "Returns the version of Windows that is currently running."
Dim WinVer As Long
    WinVer = GetLoWord(GetVersion())
    WindowsVersion = Format((WinVer Mod 256) + ((WinVer \ 256) _
                            / 100), "Fixed")
End Function
'**************************************************************
' This methods accepts alphanumeric settings to write to an
' INI file. In addition, you can delete a section or key by,
' passing the special "_DELETE_" string.
'**************************************************************
Public Sub WriteINI(ByVal Section$, ByVal Key$, ByVal Setting _
                    As Variant, ByVal FileName$)
Attribute WriteINI.VB_Description = "Writes an entry to an INI file. Use _DELETE_ in Key or Setting to delete Sections or Keys."
    '**********************************************************
    ' If key is set to _DELETE_, then delete the section
    '**********************************************************
    If Key = "_DELETE_" Then
        WritePrivateProfileString Section, 0&, 0&, FileName
    '**********************************************************
    ' If setting is set to _DELETE_, then delete the key
    '**********************************************************
    ElseIf Setting = "_DELETE_" Then
        WritePrivateProfileString Section, Key, 0&, FileName
    '**********************************************************
    ' Otherwise, convert the setting to a string and write it
    ' to the INI file.
    '**********************************************************
    Else
        WritePrivateProfileString Section, Key, CStr(Setting), _
                                  FileName
    End If
End Sub
#If Win32 Then
'**************************************************************
' This method demonstrates how you can expose API calls. Since
' you can't use As Any with functions, SendMessage requires
' type-safe versions.
'**************************************************************
Public Function SendMessageAsLong(hwnd As Long, wMsg As _
            Integer, wParam As Long, lParam As Long) As Long
    SendMessageAsLong = Common.SendMessage(hwnd, wMsg, wParam, _
                                          lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function SendMessageAsStr(hwnd As Long, wMsg As _
          Integer, wParam As Long, lParam As String) As Long
    SendMessageAsStr = Common.SendMessage(hwnd, wMsg, wParam, _
    lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function PostMessage(ByVal hwnd As Long, ByVal wMsg _
   As Integer, ByVal wParam As Long, lParam As Long) As Long
    PostMessage = Common.PostMessage(ByVal hwnd, wMsg, wParam, _
                                    lParam)
End Function
#Else
'**************************************************************
' This method demonstrates how you can expose API calls. Since
' you can't use As Any with functions, SendMessage requires
' type-safe versions.
'**************************************************************
Public Function SendMessageAsLong(hwnd As Integer, wMsg As _
            Integer, wParam As Integer, lParam As Long) As Long
    SendMessageAsLong = Common.SendMessage(hwnd, wMsg, wParam, _
                                          lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function SendMessageAsStr(hwnd As Integer, wMsg As _
          Integer, wParam As Integer, lParam As String) As Long
Attribute SendMessageAsStr.VB_Description = "An exposed wrapper for the SendMessage API call. Use this function as described in the SDK."
    SendMessageAsStr = Common.SendMessage(hwnd, wMsg, wParam, _
    lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function PostMessage(ByVal hwnd As Integer, ByVal wMsg _
   As Integer, ByVal wParam As Integer, lParam As Long) As Long
    PostMessage = Common.PostMessage(ByVal hwnd, wMsg, wParam, _
                                    lParam)
End Function
#End If