PC World Komputer 1997 November/Pcwk1197.iso/LOTUS/Eng-ins/COMPNENT/LTSSL30.LSS

Text File | 1996-04-16 | 23KB | 808 lines

'--------------------------------------------------------------------------
'
'    File:         LTSSL30.LSS
'    Module:    Sample Function Libraries - Windows 3.1 interfaces
'    Created:    07/12/94
'
'    Copyright (c) 1994-95 Lotus Development Corporation
'
'    Description: This file contains the following sample
'        LotusScript Windows Functions:
'
'        GetTempDirectory
'        GetWinDirectory
'        WindowsHelp
'        GetProfInteger
'        GetProfString
'        WriteProfInteger
'        WriteProfString
'
'        AppClose
'        AppGetAppCount
'        AppGetAppNames
'        AppGetHWnd
'        AppGetWindowPos
'        AppHide
'        AppShow
'        AppIsRunning
'        AppIsVisible
'        AppMaximize
'        AppMinimize
'        AppMove
'        AppRestore
'        AppSize
'        AppSendMessage
'
'        FormatDate
'        DateDiff
'        Pause
'        ProperCase
'        Repeat
'        Str_Word
'        Log10
'
'    Disclaimer:
'        The sample LotusScript functions are provided
'        as code examples that provide useful functionality
'        to LotusScript programmers.  lotus makes no promise
'        or guarantee with respect to the use of these
'        functions.  Users can use the library at their own risk.
'
'--------------------------------------------------------------------------

option declare
option compare nocase

'--------------------------------------------------------------------------
' Windows functions/constants
'
' Culled from windows.h, rather than including the whole huge file.
'--------------------------------------------------------------------------

'------------------------------------------
' WinHelp
'------------------------------------------

public Const HELP_CONTENTS        = &H3    ' Display index.
public Const HELP_FORCEFILE    = &H9 ' Ensure that correct file is displayed.
public Const HELP_HELPONHELP    = &H4    ' Display "Using Help"
public Const HELP_QUIT            = &H2 ' Help no longer needed.

'------------------------------------------
' GetWindow
'------------------------------------------

public Const GW_HWNDFIRST        = 0
public Const GW_HWNDLAST        = 1
public Const GW_HWNDNEXT        = 2
public Const GW_HWNDPREV        = 3
public Const GW_OWNER            = 4
public Const GW_CHILD            = 5

'------------------------------------------
' GetWindowRect
'------------------------------------------

Type RECT
    left As Integer
    top As Integer
    right As Integer
    bottom As Integer
End Type

'------------------------------------------
' ShowWindow
'------------------------------------------

public Const SW_HIDE                 = 0
public Const SW_NORMAL                 = 1
public Const SW_MAXIMIZE             = 3
public Const SW_SHOW                 = 5
public Const SW_MINIMIZE             = 6
public Const SW_RESTORE             = 9

'------------------------------------------
' SetWindowPos
'------------------------------------------

public Const SWP_NOSIZE         = &H1
public Const SWP_NOMOVE         = &H2
public Const SWP_NOZORDER         = &H4

'--------------------------------------------------------------------------
' External Function Declarations
'
' Rather than include a monster header file with every Windows function
' in it, we just take what we need.
'--------------------------------------------------------------------------

Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function GetProfileInt Lib "Kernel" (ByVal lpSection As String, ByVal lpEntry As String, ByVal nDefault As Integer) As Integer
Declare Function GetProfileString Lib "Kernel" (ByVal lpSection As String, ByVal lpEntry As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpSection As String, ByVal lpEntry As String, ByVal nDefault As Integer, ByVal lpFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WriteProfileString Lib "Kernel" (ByVal lpSection As String, ByVal lpEntry As String, ByVal lpNewString As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpSection as String, ByVal lpEntry As String, ByVal lpNewString As String, ByVal lpFileName As String ) As Integer
Declare Function WinHelp Lib "User" (ByVal hWnd As Integer, ByVal lpHelpFile As String, ByVal wCommand As Integer, dwData As Any) As Integer
Declare Function GetWindow Lib "User" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
Declare Function GetDesktopWindow Lib "User" () As Integer
Declare Function GetWindowText Lib "User" (ByVal hWnd As Integer, ByVal lpString As String, ByVal aint As Integer) As Integer
Declare Function GetNextWindow Lib "User" (ByVal hWnd As Integer, ByVal wFlag As Integer) As Integer
Declare Function IsWindowVisible Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lpRect As RECT)
Declare Function ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer
Declare Function SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer


'--------------------------------------------------------------------------
'
' Implementation
'
'--------------------------------------------------------------------------

Public Function GetWinDirectory() as String

'--------------------------------------------------------------------------
' GetWinDirectory
'
' Returns the Directory in which Windows is installed.
'--------------------------------------------------------------------------

    Dim sBuffer as String * 256: sBuffer = string( 256, " " )

    GetWindowsDirectory sBuffer, 256

    GetWinDirectory = sBuffer

End Function


Public Function GetTempDirectory() as String

'--------------------------------------------------------------------------
' GetTempDirectory
'
' The temporary directory "TEMP" set in the environment variables.
' If this fails, it looks for "TMP".  If neither one is found, it returns
' an empty string.
'--------------------------------------------------------------------------

    Dim sTempBuffer as String

    sTempBuffer = Environ$( "TEMP" )

    If sTempBuffer = "" then
        sTempBuffer = Environ$ ( "TMP" )
    End If

    GetTempDirectory = sTempBuffer

End Function


Public Function WindowsHelp(HelpFile as String, HelpType as Integer ) as Long

'--------------------------------------------------------------------------
' WindowsHelp
'
' Brings up Windows Help with a given help file and context flags.
'--------------------------------------------------------------------------

   WindowsHelp = WinHelp(0, HelpFile, HelpType, 0 )

End Function


Public Function GetProfInteger(Section as String, Entry as String, Filename as String, DefaultValue as Integer) as Long

'--------------------------------------------------------------------------
' GetProfInteger
'
' Finds a value of the specified entry in the specified file.  If
' the entry is not found, the return value is set to zero.
'--------------------------------------------------------------------------

    Dim retval as Integer

    If filename = "" then
        retval = GetProfileInt(Section, Entry, DefaultValue)
    Else
        retval = GetPrivateProfileInt(Section, Entry, DefaultValue, Filename)
    End If

    GetProfInteger = retval

End Function


Public Function GetProfString(Section as String, Entry as String, Filename as String, DString as String) as String

'--------------------------------------------------------------------------
' GetProfString
'
' This function returns a profile string from the specified ini file.
' If the filename passed is "", then the string will be searched for
' in the WIN.INI file
'--------------------------------------------------------------------------

    Dim retstr as String*256
    Dim retval as Integer

    If filename = "" then
        retval = GetProfileString(Section, Entry, DString, retstr, 256)
   Else
        retval = GetPrivateProfileString(Section, Entry, DString, retstr, 256,Filename)
    End If

    GetProfString = Left$(retstr, retval)

End Function


Public Function WriteProfInteger(Section as String, Entry as String, Filename as String, NewValue as Integer) as Long

'--------------------------------------------------------------------------
' WriteProfInteger
'--------------------------------------------------------------------------

    Dim Strval as String
    Dim Errval as Integer
    Dim CurrChar as String

    Strval = CSTR(NewValue)

    If filename = "" then
        Errval = WriteProfileString(Section, Entry, Strval)
    Else
        Errval = WritePrivateProfileString(Section, Entry, Strval, Filename)
    End if

    WriteProfInteger = Errval

End Function


Public Function WriteProfString(Section as String, Entry as String, Filename as String, NewString as String ) as Long

'--------------------------------------------------------------------------
' WriteProfString
'--------------------------------------------------------------------------

    Dim Errval as Integer

    If filename = "" then
        Errval = WriteProfileString(Section, Entry, NewString)
    Else
        Errval = WritePrivateProfileString(Section, Entry, NewString, Filename)
    End If

    WriteProfString = Errval

End Function

public function AppClose(AppName as String) as Long

'--------------------------------------------------------------------------
' AppClose
'
' Close a particular application
'--------------------------------------------------------------------------

    on error goto handleit

    ActivateApp AppName
    SendKeys "%{F4}", TRUE
    AppClose = TRUE
    exit function

    handleit:
        AppClose = FALSE

end function


public function AppGetAppCount() as Long

'--------------------------------------------------------------------------
' AppGetAppCount
'
' Return number of running Windows applications
'--------------------------------------------------------------------------

    dim hWnd as Long
    dim namebuf as string*80
    dim textlen as Integer

    AppGetAppCount = 0
    hWnd = GetWindow(GetDesktopWindow(),GW_CHILD)

    do while hWnd <> 0

        textlen = GetWindowText(hWnd,namebuf,80)
        if textlen <> 0 then
            AppGetAppCount = AppGetAppCount + 1
        end if

        hWnd = GetNextWindow( hWnd, GW_HWNDNEXT )

    loop

end function


public function AppGetAppNames(AppList() as String, AppCount as Integer) as Integer

'--------------------------------------------------------------------------
' AppGetAppNames
'
' Fill an array with the names of the currently running applications.
'--------------------------------------------------------------------------

    dim hWnd as Long
    dim namebuf as String*80 ': namebuf = string(80," ")
    dim i as Integer : i = 0
    dim textlen as Integer

    redim AppList(AppCount)

    hWnd = GetWindow(GetDesktopWindow(),GW_CHILD)

    do while hWnd <> 0

        textlen = GetWindowText(hWnd,namebuf,80)

        if textlen <> 0 then
            AppList(i) = left$(namebuf,textlen) : i = i + 1
            if  i = AppCount then
                exit do
            end if
        end if

        hWnd = GetNextWindow( hWnd, GW_HWNDNEXT )

    loop

    AppGetAppNames = i

end function


public function AppGetHWnd(AppName as String) as Long

'--------------------------------------------------------------------------
' AppGetHWnd
'
' Returns HWnd for a given window title
'--------------------------------------------------------------------------

    dim hWnd as Long
    dim namebuf as String*80 ': namebuf = string(80," ")
    dim textlen as Integer

    AppGetHWnd = 0

    hWnd = GetWindow(GetDesktopWindow(), GW_CHILD)

    if hWnd = 0 then
        AppGetHWnd = 0
        exit function
    end if

    do while hWnd <> 0

        textlen = GetWindowText(hWnd,namebuf,80)
        if textlen <> 0 then
            if AppName = left$(namebuf,textlen) then
                AppGetHWnd = hWnd
                exit do
            end if
        end if

        hWnd = GetNextWindow( hWnd, GW_HWNDNEXT )

    loop

end function


public function AppGetWindowPos(AppName as String, x as Integer, y as Integer, w as Integer, h as Integer) as Long

'--------------------------------------------------------------------------
' AppGetWindowPos
'
' Get the coordinates and size of a window
'--------------------------------------------------------------------------

    dim hWnd as Long
    dim namebuf as string*80
    dim r as RECT

    hWnd = AppGetHWnd(AppName)

    if hWnd = 0 then
        AppGetWindowPos = FALSE
        exit function
    end if

    ' Window is valid, get rectange coordinates and compute width/height...

    call GetWindowRect(hWnd, r)

    x = r.left
    y = r.right
    w = r.right - r.left
    h = r.bottom - r.top
    AppGetWindowPos = TRUE

end function


function SetWindowState(AppName as String, NewState as Integer) as Long

'--------------------------------------------------------------------------
' SetWindowState (Private function)
'
' Set the state of a named window
'--------------------------------------------------------------------------

    dim hWnd as Long

    hWnd = AppGetHWnd(AppName)

    if hWnd = 0 then
        SetWindowState = FALSE
        exit function
    end if

    if ShowWindow(hWnd, NewState) = 0 then
        SetWindowState = TRUE  ' Previously visible
    else
        SetWindowState = FALSE ' Previously hidden
    end if

end function



public function AppHide(AppName as String) as Long

'--------------------------------------------------------------------------
' AppHide
'
' Hides a window
'--------------------------------------------------------------------------

    AppHide = SetWindowState(AppName, SW_HIDE)

end function


public function AppShow(AppName as String) as Long

'--------------------------------------------------------------------------
' AppShow
'
' Shows a window
'--------------------------------------------------------------------------

    AppShow = SetWindowState(AppName, SW_SHOW)

end function


public function AppIsRunning(AppName as String) as Long

'--------------------------------------------------------------------------
' AppIsRunning
'
' Return whether or not an application is running
'--------------------------------------------------------------------------

    if AppGetHWnd(AppName) <> 0 then
        AppIsRunning = TRUE
    else
        AppIsRunning = FALSE
    end if

end function


public function AppIsVisible(AppName as String) as Long

'--------------------------------------------------------------------------
' AppIsVisible
'
' Return whether or not an application is visible
'--------------------------------------------------------------------------

    dim hWnd as Long

    AppIsVisible = FALSE

    hWnd = AppGetHWnd(AppName)
    if hWnd <> 0 then
        if IsWindowVisible(hWnd) then
            AppIsVisible = TRUE
        end if
    end if

end function


public function AppMaximize(AppName as String) as Long

'--------------------------------------------------------------------------
' AppMaximize
'
' Maximizes a window
'--------------------------------------------------------------------------

    AppMaximize = SetWindowState(AppName, SW_MAXIMIZE)

end function


public function AppMinimize(AppName as String) as Long

'--------------------------------------------------------------------------
' AppMinimize
'
' Minimizes a window
'--------------------------------------------------------------------------

    AppMinimize = SetWindowState(AppName, SW_MINIMIZE)

end function


public function AppRestore(AppName as String) as Long

'--------------------------------------------------------------------------
' AppRestore
'
' Restore window to previous state
'--------------------------------------------------------------------------

    AppRestore = SetWindowState(AppName, SW_RESTORE)

end function


public function AppMove(AppName as String, x as Integer, y as Integer) as Long

'--------------------------------------------------------------------------
' AppMove
'
' Move a window
'--------------------------------------------------------------------------

    dim hWnd as Long

    hWnd = AppGetHWnd(AppName)

    if hWnd = 0 then
        AppMove = FALSE
        exit function
    end if

    AppMove = SetWindowPos(hWnd, 0, x, y, 0, 0, SWP_NOSIZE+SWP_NOZORDER)

end function


public function AppSize(AppName as String, w as Integer, h as Integer) as Long

'--------------------------------------------------------------------------
' AppSize
'
' Resize a window
'--------------------------------------------------------------------------

    dim hWnd as Long

    hWnd = AppGetHWnd(AppName)

    if hWnd = 0 then
        AppSize = FALSE
        exit function
    end if

    AppSize = SetWindowPos(hWnd, 0, 0, 0, w, h, SWP_NOMOVE+SWP_NOZORDER)

end function


public function AppSendMessage(AppName as String, msg as Integer, wParam as Integer, lParam as Long) as Long

'--------------------------------------------------------------------------
' AppSendMessage
'
' Send a Windows message to a window
'--------------------------------------------------------------------------

    dim hWnd as Long

    hWnd = AppGetHWnd(AppName)

    if hWnd = 0 then
        AppSendMessage = FALSE
        exit function
    end if

    AppSendMessage = SendMessage(hWnd, msg, wParam, lParam)

end function



Public Function FormatDate(d as variant, fmt as string) as string

'--------------------------------------------------------------------------
' FormatDate
'
' Formats date based on specified flag.
'--------------------------------------------------------------------------

    select case fmt

        case is="b":     FormatDate =    format$(d, "mmmm dd, yyyy")
        case is="B":     FormatDate =     ucase(format$(d, "mmmm dd, yyyy"))
        case is="c":     FormatDate =    format$(d, "dd mmmm yyyy")
        case is="C":    FormatDate =     ucase(format$(d, "dd mmmm yyyy"))
        case is="d":    FormatDate =    format$(d, "long date")
        case is="D":    FormatDate =    ucase(format$(d, "long date"))
        case is="e":    FormatDate =    format$(d, "mmmm dd")
        case is="E":    FormatDate =    ucase(format$(d, "mmmm dd"))
        case is="f":     FormatDate =    format$(d, "dddd dd")
        case is="F":    FormatDate =     ucase(format$(d, "dddd dd"))
        case is="g":    FormatDate =    format$(d, "mm/dd")
        case is="G":    FormatDate =    ucase(format$(d, "mm/dd"))
        case is="h":    FormatDate =    format$(d, "mm/dd/yyyy")
        case is="H":    FormatDate =    ucase(format$(d, "mm/dd/yyyy"))
        case is="i":     FormatDate =    format$(d, "dd, mmmm")
        case is="I":     FormatDate =    ucase(format$(d, "dd, mmmm"))
        case is="j":    FormatDate =    format$(d, "dd, mmmm yyyy")
        case is="J":    FormatDate =    ucase(format$(d, "dd, mmmm yyyy"))
        case is="k":    FormatDate =    format$(d, "yyyy mmmm dd")
        case is="K":    FormatDate =     ucase(format$(d, "yyyy mmmm dd"))
        case is="l":     FormatDate =    format$(d, "mmmm, dd")
        case is="L":    FormatDate =     ucase(format$(d, "mmmm, dd"))
        case else:        FormatDate =    ""
    end select

End function


Public Function DateDiff(date1 as Variant, date2 as Variant ) as Long

'--------------------------------------------------------------------------
' DateDiff
'
' Returns an integer value that represents the number of days that
' separate the dates passed to the function
'--------------------------------------------------------------------------

    Dim TempVal as Variant

    TempVal = CINT((DateValue(date1)) - (DateValue(date2)) )

    DateDiff = ABS(TempVal)

End Function


Public Sub Pause( pausetime as Integer )

'--------------------------------------------------------------------------
' Pause
'
' Suspend execution of application for specified amount of time.
'--------------------------------------------------------------------------

    Dim BeginTime as Single

    BeginTime = Timer

    Do While Timer < BeginTime + pausetime
        Yield
    loop

End Sub


Public Function ProperCase ( s as String ) as String

'----------------------------------------------------------------------------
' ProperCase
'
' Capitalizes the first character, and lowercases the rest, of a string.
'----------------------------------------------------------------------------

    Dim UpperIt as Integer : UpperIt = TRUE
    Dim newstring as string
    Dim currchar as string
    Dim i as Integer

    For i = 1 to len(s)
        currchar = mid(s,i,1)
        currchar = lcase$(currchar)
        If UpperIt then
            currchar = ucase$(currchar)
            UpperIt = FALSE
        End if
        If currchar = " " then
            UpperIt = TRUE
        End if
        newstring = newstring + currchar
    Next i

    ProperCase = newstring

End Function


Public Function Repeat(pattern as string, repcount as integer, maxlen as integer) as String

'----------------------------------------------------------------------------
' Repeat
'
' Repeat a given pattern a certain number of times, up to a maximum length.
'----------------------------------------------------------------------------

    Dim Newstring as String
   Dim i as Integer

    For i =  1 to repcount
        Newstring = Newstring + pattern
    Next i

    If maxlen <> 0 then ' in lieu of ommitted arguments...
        newstring = left$(newstring, maxlen)
    end if

    Repeat = newstring

End function


Public Function Str_Word(searchstr as String, sepstr as String, wordnum as Integer) as String

'----------------------------------------------------------------------------
' Str_Word
'
' Search for a given numbered repetition of a substring
'----------------------------------------------------------------------------

    Dim done as Integer : done = FALSE
    Dim beginpos as Integer : beginpos = 0
    Dim endpos as Integer : endpos = 0
   Dim i as Integer

    For i = 1 to wordnum
        beginpos = endpos + 1
        endpos = instr(beginpos, searchstr, sepstr)
        if endpos = 0 then
            endpos = len(searchstr) + 1
            exit for
        end if
    Next i

    Str_Word = mid$(searchstr,beginpos,endpos-beginpos)

End function


Public Function Log10( inVal as Double) as Double

'----------------------------------------------------------------------------
' Log10
'
' Calculates the logarithm for a given number for the base of 10.
'----------------------------------------------------------------------------

    Log10 = Log(inVal)/Log(10)

End function