DP Tool Club 26/CD_ASCQ_26_1295.iso/vrac/holcal.zip/HOLLINK.BAS

BASIC Source File | 1995-08-06 | 9KB | 209 lines

' HolLink.Bas - Subroutine to Link to the Holiday Calendar
' 95/02/19 Copyright 1995, Larry Rebich, The Bridge, Inc.

    Option Explicit
    DefInt A-Z

    Declare Function HCL_GetPrivateProfileString Lib "Kernel" Alias "GetPrivateProfileString" (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 HCL_GetWindowsDirectory Lib "Kernel" Alias "GetWindowsDirectory" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer

' Global Constants and Variables used by the LinkCalendar subroutine
    Global Const HC_HolidayCalendarExe = "HolCal.Exe"
    Const HolidayCalendarIniFile = "HolCal.Ini"

' Local Constants
    Const HolidayCalendarNoExe = "HolCal"
    Const HolidayCalendarFormName = "FormCalendarV3"
    Const HolidayCalendar = "Holiday Calendar"
    Const HolidayCalendarEnd = "@ End the Holiday Calendar @"
    Const HolidayCalendarActivate = "+ Activate the Holiday Calendar +"
    Const HolidayCalendarMinimize = "- Minimize the Holiday Calendar -"

' Link Constants
    Const NONE = 0           ' 0 - None
    Const LINK_AUTOMATIC = 1 ' 1 - Automatic (controls only)
    Const LINK_MANUAL = 2    ' 2 - Manual (controls only)

' Holiday Calendar Action Constants, use in your application
    Global Const HCL_LINKIFSTARTED = &H0    'link of already running
    Global Const HCL_FORCESTART = &H2       'force a shell if Calendar not already running
    Global Const HCL_CLOSECALENDAR = &H4    'send closing message, if started
    Global Const HCL_MINIMIZE = &H8         'send to icon state, if started

Function HCL_Delay (Secs As Single)
    Dim EndTime As Double
'convert seconds to percent of day and add to current day/time
    EndTime = Now + (Secs / 86400#)
    While Now < EndTime     'delay for a while
    Wend
End Function

Private Function HCL_GetCalendarPathFromIni (TheIniFile As String) As String
    Dim a As String         'work string
    Dim b As String         'work string
    Dim hp As String        'holiday path
    Dim ap As String        'app path
    Dim wp As String        'win dir
    wp = HCL_GetWinDir()    'get win dir
    ap = App.Path           'app path, try here if not in WinDir
    If Right$(ap, 1) <> "\" Then ap = ap & "\"
    a = wp & TheIniFile
    If Dir$(a) = "" Then            'is there one
        a = ap & TheIniFile         'look in this one
    End If

    If Dir$(a) <> "" Then
        Dim OK As Integer
        Dim Value As Variant
        OK = HCL_IniGetPrivate("Files", "Application Path", Value, a)
        If OK Then
            hp = Value
            If Right$(hp, 1) <> "\" Then hp = hp & "\"
        Else
            hp = ap     'try this one, however link will fail if it is not there
        End If
    Else
        a = Dir$(ap & HC_HolidayCalendarExe)
        If a <> "" Then
            hp = ap
        Else
            Dim Msg As String
            Msg = "The " & HolidayCalendar & " initialization file could not be "
            Msg = Msg & "found in " & LCase$(Left$(wp, Len(wp) - 1))
            Msg = Msg & " or " & LCase$(Left$(ap, Len(ap) - 1)) & ""
            Msg = Msg & " and " & HC_HolidayCalendarExe & " is not in " & LCase$(Left$(ap, Len(ap) - 1))
            Msg = Msg & "." & Chr$(13) & Chr$(13)
            Msg = Msg & "Please run " & HC_HolidayCalendarExe & " then try this again."
            MsgBox Msg, 16, "Could not find " & TheIniFile & " or " & HC_HolidayCalendarExe
            End
        End If
    End If
    HCL_GetCalendarPathFromIni = hp
End Function

Private Function HCL_GetWinDir () As String
    Dim Temp As String          'get the windows directory
    Dim nSize, ValidLength
    Dim lpBuffer As String
    nSize = 150                 'buffer size
    lpBuffer$ = Space$(nSize)   'load buffer with spaces
    ValidLength = HCL_GetWindowsDirectory(lpBuffer$, nSize) 'get it
    Temp = Trim$(Left$(lpBuffer$, ValidLength)) 'into temp
    If Right$(Temp, 1) <> "\" Then Temp = Temp & "\"
    HCL_GetWinDir = Temp
End Function

Private Function HCL_IniGetPrivate (AppName As String, Key As String, Value As Variant, IniFile As String) As Integer
    Dim Buf As Integer, Num As Integer
    Dim SValue As String    'loaded into here
    Buf = 64
    SValue = Space$(Buf)
    Num = HCL_GetPrivateProfileString(AppName, Key, "", SValue, Buf, IniFile)
    If Num > 0 Then     'OK?
        Value = Trim$(Mid$(SValue, 1, Num))
        HCL_IniGetPrivate = True
    Else
        Value = ""          'return nothing
    End If
End Function

Function HCL_LinkToCalendar (TheBoxDate As Control, TheLabelStatus As Control, TheLabelMessage As Control, TheAction As Integer) As Integer
' Call this Function to initiate a DDE link with the Holiday Calendar
'
'       TheBoxDate              'Date passed in this text box
'       TheLabelStatus          'Status from the Holiday Calendar
'       TheLabelMessage         'Message from this subroutine
'       TheAction               'Action to be taken
'
' Returns True if function was performed.
'
' A Sample:
'   Rtn = HC_LinkToCalendar(Text1, Label1, Label2, HCL_FORCESTART)

    Static WeStartedIt As Integer   'save this, only terminate the calendar if we started it
    Dim a As String, b As String, x As Integer
    Dim h As String                 'link topic, easier to work with
    h = HolidayCalendarNoExe & "|" & HolidayCalendarFormName                'link topic
    ' minimize
    If Hex(TheAction And HCL_MINIMIZE) = Hex(HCL_MINIMIZE) Then
        TheLabelStatus.Caption = HolidayCalendarMinimize    'yes
        On Error Resume Next
        TheLabelStatus.LinkPoke     'send the cancel command
        x = HCL_Delay(.3)           'pause a bit
        HCL_LinkToCalendar = True   'say it was completed
        Exit Function                   'bye
    End If
    ' close
    If Hex(TheAction And HCL_CLOSECALENDAR) = Hex(HCL_CLOSECALENDAR) Then   'does user want to terminate it
        If WeStartedIt Then         'did we start it
            TheLabelStatus.Caption = HolidayCalendarEnd     'yes
            On Error Resume Next
            TheLabelStatus.LinkPoke     'send the cancel command
            x = HCL_Delay(.3)           'pause a bit
            HCL_LinkToCalendar = True   'say it was completed
        End If
        Exit Function                   'bye
    End If
    On Error GoTo TryShell              'in case linkage fails
    TheLabelMessage.Caption = "Establish DDE Link"
TryAgain:
    TheBoxDate.LinkMode = NONE          'reset if any
    TheBoxDate.LinkTopic = h            'topic
    TheBoxDate.LinkTimeout = 10 * 30    'thirty seconds should be enough
    TheBoxDate.LinkItem = "TextLinkCalendar"    'link to this box
    TheBoxDate.LinkMode = LINK_MANUAL           'first time
    TheLabelMessage.Caption = "Link Date Field" 'message to user
    TheLabelMessage.Refresh                     'make it visible
    DoEvents
    'set up status link
    TheLabelStatus.LinkMode = NONE      'reset if any
    TheLabelStatus.LinkTopic = h        'link the status box
    TheLabelStatus.LinkTimeout = TheBoxDate.LinkTimeout
    TheLabelStatus.LinkItem = "TextLinkStatus"
    TheLabelStatus.LinkMode = LINK_AUTOMATIC        'updates are automatic
    TheLabelMessage.Caption = "Link Status Field"   'tell user
    On Error GoTo TryShell
    TheBoxDate.LinkPoke                             'force it to source
    TheBoxDate.LinkMode = LINK_AUTOMATIC            'date box is now automatic
    TheLabelMessage.Caption = "Link Established"    'tell user
    TheLabelStatus.Caption = HolidayCalendarActivate'Starting
    On Error Resume Next
    AppActivate TheBoxDate.Text
    TheLabelStatus.LinkPoke                         'send the start command
    x = HCL_Delay(.2)                               'pause a bit
    DoEvents
    HCL_LinkToCalendar = True           'completed
    Exit Function                       'bye

TryShell:
    If Hex(TheAction And HCL_FORCESTART) = Hex(HCL_FORCESTART) Then 'caller does not want to force shell
    Else
        Exit Function
    End If
    x = Err                         'save for later
    a = HCL_GetCalendarPathFromIni(HolidayCalendarIniFile)  'get calendar path
    a = a & HC_HolidayCalendarExe   'is it there?
    b = Trim$(Dir$(a))              'use Dir$ function to test
    If b = "" Then                  'is it there
        x = 0                       'if not there then set error msg to zero
    End If
    If x = 282 Or x = 293 Then      'error was no link
        TheLabelMessage.Caption = "Shell to " & LCase$(a)
        TheLabelStatus.Caption = ""
        x = Shell(a, 1)             'try to load it
        WeStartedIt = True          'will not get here if shell fails
        DoEvents
        On Error GoTo LinkFailed    'reset error goto
        Resume TryAgain             'try again
    Else
        MsgBox "Could not start file: " & a, 48, Str$(Err) & " - " & Error$
        Resume ExitThis             'problem and bye
    End If
LinkFailed:                         'could not link after attempting shell
    TheLabelMessage.Caption = "Link Failed - " & Error$
    MsgBox "Link Failed", 48, Str$(Err) & " - " & Error$
    Resume ExitThis
ExitThis:
End Function