.net 1999 December/netCD65.iso/pc/Software/VirtualA/32bit/vasetup.exe/%MYDIR%/Hmibase.ebs

Text File | 1999-10-06 | 39.6 KB | 1,262 lines

'T:HMIBASE.EBS for CompuServe
' VA 4.52 release

Declare Function ParseString(args As String, delim As String) As String
Declare Function FileName$(fullpath As String)
Declare Function FileUrl(fn As String) As String
Declare Function MakeDateString(s As HMITIMESTAMP) As String
Declare Sub AddToMsgFile(SourceFileName as String)
Declare Function QueueFile(service As String, sfilename As String, queueflags As Long) As Boolean
Declare Sub LoadAddonLibraries
Declare Function MyDate$
Declare Function StartMessageDownload(id As String, forum As String, sections As String) As Integer
Declare Sub SearchMessages(searchtype As Integer, searchstring As String, bodies As Boolean, rootsonly As Boolean)
Declare Sub ReportSuccess(msg As String)
Declare Function ForumName(ByVal forum As String) As String
Declare Function FullErrorMessage() As String
Declare Sub FetchMail(id As String)
Declare Sub SetupOptions(id As String)
Declare Sub RecordBulletins(forum As String, getnews As Boolean, _
                            getothers As Boolean, getuserlog As Boolean)
Declare Function HMIGotoForum(ByVal forum As String) As Boolean
Declare Sub RecordSectionInformation(forum As String)
Declare Sub HMIGetWhatsNew(id As String, forum As String)

'T:iFlags for CompuServe (constant)
Const IM_SPECIAL = 128        ' My special msg format
Const IM_DELETE = 2048        ' Delete scratchpad file afterwards?

Const fRECEIPT = 1            'CIS mail receipt
Const fPRIVATE = 2            'CIS private forum message
Const fNOFORMAT = 4            'CIS unformatted message

Const DAP_DC_HAVE_MAIL% = &H0001          ' mail waiting
Const DAP_DC_ACCOUNT_ATTENTION% = &H0004  ' account needs attention

Const DAP_AL_VOLATILE = &H02

Const DAP_AP_SESSION_ONLY = &H01
Const DAP_AP_VOLATILE = &H02
Const DAP_AP_HAVE_HEADER% = &H04
Const DAP_AP_HAVE_TRAILER% = &H08
Const DAP_AP_HAVE_NEXT% = &H10
Const DAP_AP_EX_HAVE_TITLE% = &H0100

Const HMI_DATA_SIZE% = 1024

Const FAP_DELETABLE% = &H1
Const FAP_OWNER% = &H2
Const FAP_MSG_IS_PRIVATE% = &H4
Const FAP_READ_BY_RECIPIENT% = &H8
Const FAP_MSG_HELD% = &H10
Const FAP_MSG_FORWARDED% = &H20
Const FAP_HAS_BEEN_DELETED% = &H80

Const FAP_FILE_DELETABLE% = &H1
Const FAP_FILE_NON_PUBLIC% = &H2
Const FAP_FILE_MARKED_FOR_DELETION% = &H4
Const FAP_FILE_HAS_FEE% = &H8

Const FAP_NOT_A_MEMBER% = &H8

Const HMI_STATE_FIRST% = 0
Const HMI_STATE_NEXT% = HMI_STATE_FIRST + 1

' enum EMPCONTENTTYPES:
Const EMP_TEXT% = 0                                  ' Ascii Text Object
Const EMP_BINARY% = EMP_TEXT + 1                  ' 8-bit data
Const EMP_GIF% = EMP_BINARY + 1                      ' Graphic Interchange Format
Const EMP_BINARY_FILE% = EMP_GIF + 1              ' Contents_Name contains filename
Const EMP_TEXT_FILE% = EMP_BINARY_FILE + 1          ' Text file
Const EMP_TEXT_OBJECT% = EMP_TEXT_FILE + 1        ' TextObject message
Const EMP_JPEG% = EMP_TEXT_OBJECT + 1

Const DAP_MP_HAVE_HEADER%  = 1
Const DAP_MP_HAVE_TRAILER% = 2
Const DAP_MP_HAVE_NEXT%    = 4
Const DAP_MP_BLOB_MENU%    = 8
Const DAP_MP_SESSION_ONLY% = 16
Const DAP_MP_VOLATILE%     = 32
Const DAP_MP_ATTRIBUTES%   = 64
Const DAP_MP_EXTENSION%    = 128

Public DownloadDir As String    'where downloads go
Public WorkingPath As String    'added to speed up Fetch stuff online
Public WhereAmI As String        'name of last forum/page etc
Public Sysop As Boolean            'are we a sysop?
Public InAscii As Boolean

Public FAPconfig As FAPCONFIG

Public currentCAP As Integer
Public SectionMsgIds(32) As Integer, SectionLibIds(32) As Integer
Public szMsgSection() As FAPSECTIONENTRY, szLibSection() As FAPSECTIONENTRY
Public nummessages As Integer
Public CurrentForum As String
Public MailName As String      'My name for mail purposes
Public PersonalAddress As String      'My PA

Dim LastDownMessages As String
Dim capturefilename As String
Dim messagefilename As String
Dim sectionvector As Long
Dim sct As FAPSECTIONS
Dim DAPconfig As DAPCONFIG

Const Months$ = "JanFebMarAprMayJunJulAugSepOctNovDec"

Dim captureStack As Integer
Dim captureForum As String

Function rj(i As Integer) As String
    rj = Right$(Str$(i + 100), 2)
End Function

Function MakeDateString(s As HMITIMESTAMP) As String
    On Error Resume Next
    If s.cMonth > 0 Then
        MakeDateString = rj(s.cDay) + "-" + Mid$(Months$,3 * (s.cMonth-1) + 1, 3) _
                         + "-" + LTrim$(Str$(1970 + s.cYear)) + " " + _
                         rj(s.cHour) + ":" + rj(s.cMinutes) + ":" + _
                         rj(s.cSeconds)
    Else
        MakeDateString = ""
    End If
End Function

Function TimeZone(s As EMPTIMEZONE) As String
    TimeZone = ""

    ' CIS Doesn't seem to fill in the variable
    'Dim pm As String
    '
    'On Error Resume Next
    'If s.cDirection=0 Then pm = "+" Else pm = "-"
    'TimeZone = " " & pm & rj(s.cHours) & rj(s.cMinutes)
End Function

Function GetFileType(i As Integer) As String
    Select Case i
        Case 0
            GetFileType = "Unknown"
        Case 1
            GetFileType = "Text"
        Case 2
            GetFileType = "Binary"
        Case 3
            GetFileType = "Image"
        Case 4
            GetFileType = "RLE"
        Case 5
            GetFileType = "NAPLPS"
        Case 6
            GetFileType = "GIF"
        Case 7
            GetFileType = "JPEG"
        Case 8
            GetFileType = "ETO"
        Case 9
            GetFileType = "HTML"
        Case 10
            GetFileType = "PNG"
    End Select
End Function

Function CompareTimes(d1 As HMITIMESTAMP, d2 As HMITIMESTAMP) As Integer
    If d1.cYear < d2.cYear Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cYear > d2.cYear Then
        CompareTimes = 1
        Exit Function
    End If
    If d1.cMonth < d2.cMonth Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cMonth > d2.cMonth Then
        CompareTimes = 1
        Exit Function
    End If
    If d1.cDay < d2.cDay Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cDay > d2.cDay Then
        CompareTimes = 1
        Exit Function
    End If
    If d1.cHour < d2.cHour Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cHour > d2.cHour Then
        CompareTimes = 1
        Exit Function
    End If
    If d1.cMinutes < d2.cMinutes Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cMinutes > d2.cMinutes Then
        CompareTimes = 1
        Exit Function
    End If
    If d1.cSeconds < d2.cSeconds Then
        CompareTimes = -1
        Exit Function
    End If
    If d1.cSeconds > d2.cSeconds Then
        CompareTimes = 1
        Exit Function
    End If
    CompareTimes = 0
End Function

Function CompareDates(d1 As HMIDATE, d2 As HMIDATE) As Integer
    If d1.cYear < d2.cYear Then
        CompareDates = -1
        Exit Function
    End If
    If d1.cYear > d2.cYear Then
        CompareDates = 1
        Exit Function
    End If
    If d1.cMonth < d2.cMonth Then
        CompareDates = -1
        Exit Function
    End If
    If d1.cMonth > d2.cMonth Then
        CompareDates = 1
        Exit Function
    End If
    If d1.cDay < d2.cDay Then
        CompareDates = -1
        Exit Function
    End If
    If d1.cDay > d2.cDay Then
        CompareDates = 1
        Exit Function
    End If
    CompareDates = 0
End Function

Sub CaptureLine(textline As String)
    CaptureText textline + Basic.Eoln$
End Sub

Sub CaptureLines(textline As String)
    Dim p As Integer, q As Integer, e As Integer

    p = 1
    Do
        q = Instr(p, textline, Chr$(10))
        If q = 0 Then
            e = Len(textline) + 1
            CaptureText Mid$(textline, p, e - p)
        Else
            e = q
            If q > p Then
                If Mid$(textline, q - 1, 1) = Chr$(13) Then
                    e = e - 1
                End If
            End If
            CaptureLine Mid$(textline, p, e - p)
        End If
        p = q + 1
    Loop While q > 0
End Sub

Sub StartCapturing(pseudoforum As String, title As String, formatted As Boolean)
    captureStack = captureStack + 1
    If captureStack <= 1 Then
        captureStack = 1
        capturefilename = UniqueFilename$()
        Capture CAPTURE_ON, capturefilename
        captureForum = pseudoforum
    Else
        CaptureText Basic.Eoln$ + "!end" + Basic.Eoln$
    End If
    If formatted Then
        CaptureText Basic.Eoln$+"#pragma ciscontrol=yes;deleteexisting=no"+Basic.Eoln$
    Else
        CaptureText Basic.Eoln$+"#pragma ciscontrol=no;deleteexisting=no"+Basic.Eoln$
    End If
    CaptureText Basic.Eoln$ + "!start " + captureForum + " " + title + Basic.Eoln$
End Sub

Sub FinishCapturing
    Dim i As Integer

    captureStack = captureStack - 1
    CaptureText Basic.Eoln$+"!end"+Basic.Eoln$
    If captureStack <= 0 Then
        captureStack = 0
        Capture CAPTURE_OFF
        ' Add to import queue
        i = QueueFile(Session.Service, capturefilename, IM_SPECIAL Or IM_DELETE)
    End If
End Sub

Function CheckCache(pagetype As String, npage As String, pversion As Long) _
        As String
    Dim newpage As String
    Dim tmp As String

    tmp = ReadIni$(pagetype, npage, Session.ServicePath+"cache.ini")
    newpage = ParseString(tmp, " Version# ")
    If newpage > "" And pversion = Val(tmp) Then
        CheckCache = newpage
    Else
        CheckCache = ""
    End If
End Function

Sub UpdateCache(pagetype As String, npage As String, pversion As Long, _
        newpage As String)
    WriteIni pagetype, npage, newpage & " Version# " & pversion, _
            Session.ServicePath+"cache.ini"
End Sub

Sub RecordTerminalOutput()
    On Error Goto RecordTerminal_error

    HMIResume

    Exit Sub

RecordTerminal_error:
    CaptureLine "Error:" & FullErrorMessage
End Sub

Sub CaptureTerminalOutput(page As String)
    StartCapturing "Actions/Information", "Terminal output when going to " + page, False
    page = ""
    RecordTerminalOutput
    FinishCapturing
End Sub

Sub CaptureMenuOptions(page As String)
    Dim menupage As DAPMENUPAGE
    Dim selections() As DAPSELECTION
    Dim p As Integer

    On Error Resume Next
    StartCapturing "Actions/Information CompuServe", Basic.Eoln$+"Menu found when going to " + page, False
    page = ""
    HMIGetMenu menupage, selections
    page = menupage.lpName

    If menupage.cOptions And DAP_MP_BLOB_MENU Then
        CaptureLines selections(0).lpItem
    Else
        For p = 0 To Ubound(selections)
            CaptureLine selections(p).lpItem + " " + Str(selections(p).nSvcClass)
        Next
    End If
    FinishCapturing
End Sub

Function DoHMIGotoPage(ByVal forum As String, ByVal menuoption As Integer, ByVal expectedCAP As Integer, Quiet As Boolean)
    Dim reqforum As String

    reqforum = forum
    SetHighMessageNumber
    ResetForum
    InAscii = False

    While forum > ""
        currentCAP = HMIGoToPage(forum, menuoption)
        If currentCAP = expectedCAP Then
            DoHMIGotoPage = True
            Exit Function
        End If
        If Quiet then
            DoHMIGotoPage = False
            Exit Function
        End If
        Select Case currentCAP
            Case DAP_ERROR
                LogResult "Go:"+forum+":HMI error"
                forum = ""
            Case DAP_TERMINAL
                CaptureTerminalOutput forum
                forum = ""
            Case DAP_MENU
                CaptureMenuOptions forum
                forum = ""
            Case DAP_ARTICLE
                CaptureArticleText "Actions/Articles"
                forum = ""
            Case DAP_ALERT
                CaptureAlert reqforum, forum
            Case DAP_FILE
                LogResult "Go:"+forum+":this page is a file for download"
                forum = ""
            Case CAP_EMAIL
                LogResult "Go:"+forum+":this page is an Electronic Mail page"
                forum = ""
            Case CAP_FORUM
                LogResult "Go:"+forum+":this page is a Forum"
                forum = ""
            Case CAP_ENS
                LogResult "Go:"+forum+":this page is an Electronic News page"
                forum = ""
            Case Else
                LogResult "Go:"+forum+":this page is an unexpected type (" + Trim$(Str$(currentCAP)) + ")"
                forum = ""
        End Select
    Wend
    DoHMIGotoPage = False
End Function

Function DoHMIFollowMenus(ByVal forum As String, optionlist As String, ByVal expectedDAP As Integer)
    Dim p As Integer
    Dim i As Integer
    Dim newDAP As Integer
    Dim menupage As DAPMENUPAGE
    Dim selections() As DAPSELECTION

    DoHMIFollowMenus = False
    newDAP = DAP_MENU
    While optionlist > ""
        i = Val(ParseString(optionlist, ";"))
        If i <= 0 Then i = -1
        If optionlist = "" Then newDAP = expectedDAP
        If Not DoHMIGotoPage(forum, i, newDAP, False) Then Exit Function
        If currentCAP = DAP_MENU Then
            HMIGetMenu menupage, selections
            forum = menupage.lpName
        End If
    Wend
    DoHMIFollowMenus = True
End Function


'T:Main - CIS (subroutine) (CompuServe) (CompuServe)
'Entry point. Does a complete blink
Sub HMIMain
    Dim redials As Integer, ok As Integer, i As Boolean

    Comms.AutoDownload = PROT_QUICKB

    MailName = ReadIni$("Service "+Session.Service, "Mail Name", Session.IniFilename)
    PersonalAddress = ReadIni$("Service "+Session.Service, "Personal Address", Session.IniFilename)
    If MailName = "" Then MailName = "Not known"

    ' Dial
    If Comms.Dial("")=0 Then
        LogResult "Error whilst attempting to dial modem"
        Exit Sub
    End If

    ' Display connection info
    HMIGetDAPConfig DAPconfig
    Terminal.Print "Connected to node: "+DAPconfig.lpNodeID+Basic.Eoln$
    LogResult "Connected to node: "+DAPconfig.lpNodeID

    ' Check account attention flag
    If (DAPconfig.wAlerts And DAP_DC_ACCOUNT_ATTENTION%)<>0 Then
        Terminal.Print Basic.Eoln$+"Your account needs attention.  Please contact CompuServe"+Basic.Eoln$
        LogResult "Your account needs attention.  Please contact CompuServe"
        Comms.Bitmask = True ' CIS messes up if we don't do this
        On Error Resume Next
        i = DoHMIGoToPage("admhmi", -1, CAP_DISPLAY, False)
        On Error Goto 0
    End If

    ' Check to see if we need to set options
    If ReadIni$("Service "+Session.Service, "Set Options", Session.IniFilename)<>"YES" Then
        SetupOptions ""
        Script
        SetHighMessageNumber
        Comms.HangUp
        Exit Sub
    End If

    If Instr(Command$, "manual") Then
        On Error Resume Next
        ManualTerminal
    Else
        Terminal.Status "Logged in successfully"

        ' Do the REPLY.EBS script
        Script

        ' Added this to process fetch file at end
        QueFetches

        ' Set hmn on exit
        SetHighMessageNumber
        If Session.StayOnline Then
            Comms.Send "go cis:top\r"
            On Error Resume Next
            ManualTerminal
        End If
    End If

    Comms.Hangup
End Sub

Function ReverseInStr(search As String, find As String) As Integer
    Dim i As Integer, lasti As Integer

    i = 0
    Do
        lasti = i
        i = InStr(lasti+1, search, find)
        If i>0 Then tmp = Mid$(search, i+1)
    Loop Until i=0

    ReverseInStr = lasti
End Function

' Is it a special gateway address that allows space?
Function GatewayAddress(pto As String) As Boolean
    Dim i As Integer, j As Integer

    i = InStr(pto, ":")
    j = InStr(pto, " ")
    If i=0 Or j=0 Then
        GatewayAddress = False
    ElseIf i<j Then
        GatewayAddress = True
    Else
        GatewayAddress = False
    End If
End Function

' Parse the To: line and extract the realname and the email address
Sub AnalyseName(pto As String, realname As String, email As String)
    Dim buf As String, p As Integer

    ' NOTE: Must be able to split the following types of addresses.
    ' "Peter Clapham 100142,2244"
    ' "Peter Clapham [100142,2244]"
    ' "Peter Clapham [petec]"
    ' "Peter Clapham [ASHMOUNT] 100142,2244"
    ' "Peter Clapham [ASHMOUNT] [petec]"
    ' "Peter Clapham [ASHMOUNT] [100142,2244]"
    ' "[100142,2244]"
    ' "100142,2244"
    ' "petec"
    ' "Matthias Daum [CCMAIL:Wibble Wibble]"
    ' "CCMAIL:Wibble Wibble"

    ' Init vars
    buf = Trim$(pto)
    realname = ""
    email = ""

    ' If last char is a ']' then the start of the email address is the
    ' preceeding '['
    If Right$(buf,1)="]" Then
        p = ReverseInStr(buf, "[")
    Else
        If Right$(buf,1)=">" Then
            p = ReverseInStr(buf, "<")
        Else
            If GatewayAddress(buf) Then
                p = 1
            Else
                p = ReverseInStr(buf, " ")
            End If
        End If
    End If
    If p>0 Then
        email = Mid$(buf, p+1)
        If p>0 Then
            realname = Left$(buf, p-1)
        Else
            realname = ""
        End If
    Else
        email = buf
    End If
    ReplaceAllInString email, "[", ""
    ReplaceAllInString email, "]", ""
    ReplaceAllInString email, ">", ""
    ReplaceAllInString email, "<", ""

    ' Trim off whitespace and quotes on the realname
    realname = Trim$(realname)
    If Left$(realname,1)=Chr$(34) Then realname = Mid$(realname, 2, Len(realname)-2)
    email = Trim$(email)

    ' Remove any 'internet:' or 'mime:' prefix
    If UCase$(Left$(email, 9))="INTERNET:" Then email = Mid$(email, 10)
    If UCase$(Left$(email, 5))="MIME:" Then email = Mid$(email, 6)

    ' Trim off unneeded '@compuserve.com' and convert . -> ,
    p = InStr(email, "@compuserve.com", 1)
    If p>0 Then
        email = Left$(email, p-1)
        ReplaceAllInString email, ".", ","
    End If

    ' @web.compuserve.com -> CSINET:
    If InStr(email, "@web.compuserve.com", 1)>0 And _
       UCase$(Left$(email, 7))<>"CSINET:" Then
        email = "CSINET:"+email
    End If

    ' Check to see if it's a gateway, if it isn't and contains a '@' then
    ' then it must be an internet address
    If InStr(email, ":")=0 And InStr(email, " ")=0 And _
       InStr(email, "@")<>0 Then
        email = "internet:"+email
    End If
End Sub

'Read an entire message from a file into a string
'If noformat = 0, add @b where appropriate
'If noformat = 1, add @l to say "send as shown" instead
'If noformat = 2, don't change the data at all
Function ReadMessageFile(filename As String, noformat As Integer) As String
    Dim inpline As String, body As String, badded As Boolean
    Dim quoted As Boolean

    ' Collect message text ready to send to CIS
    On Error Goto ReadMessageFile_error
    Open filename For Input Access Read Shared As #1
    If noformat = 1 Then body = "@l" + Chr$(10)
    While Not Eof(1)
        Line Input #1, inpline
        If noformat < 2 Then ReplaceAllInString inpline, "@", "@@"
        If noformat = 0 Then
            inpline = RTrim$(inpline)
            If Left$(inpline,1)=">" Then
                If body<>"" Then body = body + "@b" + Chr$(10)
                quoted = True
            ElseIf quoted Then
                body = body + "@b" + Chr$(10)
                quoted = False
            ElseIf inpline="" Or inpline<=" ~" Then
                If Not badded Then
                    body = body + "@b" + Chr$(10)
                    badded = True
                End If
            Else
                If Right$(body, 1)>" " Then
                    body = body + " "
                End If
            End If
            If inpline > "" Then badded = False
        End If
        If body="" Or body="@l"+Chr$(10) Then
            body = body + inpline
        Else
            If noformat = 0 And inpline<>"" Then
                body = body + inpline
            Else
                body = body + Chr$(10) + inpline
            End If
        End If
    Wend
ReadMessageFile_error:
    On Error Goto 0
    Close #1
    ReadMessageFile = body + Chr$(10)
End Function

'T:GetForumList (subroutine) (CompuServe)
Sub GetForumList(id As String, filename As String)
    Dim s As String, page As String, i As Integer, count As Long
    Dim filepage As DAPFILEPAGE

    If Not DoHMIFollowMenus("cis:index", "2", DAP_FILE) Then
        LogResult "Unable to refresh forum list."
        Exit Sub
    End If

    Terminal.Print "Collecting forum list.  Please wait..." + Basic.Eoln$
    page = "CIS:IND-41"

    HMIGetFile filepage

    ' Open forum list file to write to
    On Error Goto GetForumList_error
    DeleteFile filename
    Open filename For Binary Access Write Shared As #1

    count = 0
    Terminal.TransferStatus False, "Forum list", count, filepage.dwSize
    s = DAPReceiveFile(HMI_STATE_FIRST%, page, i)
    Do While i>0 And s<>""
        Put #1, , s
        count = count + i
        Terminal.TransferStatus False, "Forum list", count, filepage.dwSize
        s = DAPReceiveFile(HMI_STATE_NEXT%, page, i)
    Loop
    Close #1
    Terminal.TransferStatus

    ReportSuccess id & " : Collected new forum list"
    Exit Sub

GetForumList_error:
    Close #1
    Terminal.TransferStatus
    LogResult "Error : " + FullErrorMessage()
    LogResult id & " : Failed to collect forum list"
    Exit Sub
End Sub

'T:Announcements (subroutine) (CompuServe)
Sub Announcements(id As String, forum As String)
    If Not HMIGotoForum(forum) Then
        LogResult id + " : Failed : Unable to collect announcements from "+forum
        Exit Sub
    End If

    Terminal.Print "Collecting forum Announcements"+Basic.Eoln$
    RecordBulletins forum, False, True, False
    RecordSectionInformation forum

    If id<>"" Then ReportSuccess id & " : Announcements collected from " & forum & " "
End Sub

'T:Newsflash (subroutine) (CompuServe)
Sub Newsflash(id As String, forum As String)
    If Not HMIGotoForum(forum) Then
        LogResult id + " : Failed : Unable to collect newsflash from "+forum
        Exit Sub
    End If

    Terminal.Print "Collecting forum Newsflash"+Basic.Eoln$
    RecordBulletins forum, True, False, False
    If id<>"" Then ReportSuccess id & " : Newsflash collected from " & forum & " "
End Sub

Function ParseSectionList(ByVal sect As String, ByVal validsects As Long, _
                          ByRef count As Integer) As Long
    Dim s As String, l As Integer, h As Integer, sl As Long, xsl As Long

    count = 0
    sect = LTrim(sect)
    ReplaceAllInString sect, ",", " "    ' handle comma as separator
    If sect = "*" Or StrComp(sect, "ALL", 1)=0 Then
        ParseSectionList = validsects
        For l = 0 To 24
            sl = 2^l
            If (validsects And sl)=sl Then count = count + 1
        Next
        Exit Function
    End If
    s = ParseString(sect, " ")      'Numbers are separated by spaces
    While s > ""
        l = Instr(s, "-")           'Allowed to use range - e.g. 3-6
        If l > 0 Then               'We have a range
            h = Val(Mid$(s, l + 1)) 'High value of range
            For l = Val(s) To h     'From low to high value
                sl = sl Or (2 ^ l)  'Set appropriate bits
            Next
        Else
            If UCase$(s)<>"Y" Then
                l = Val(s)              'Value
                sl = sl Or (2 ^ l)      'Set appropriate bit
            End If
        End If
        s = ParseString(sect, " ")  'Numbers are separated by spaces
    Wend
    xsl = sl And validsects
    ParseSectionList = xsl
    For l = 0 To 24
        If (xsl And 2^l)=2^l Then count = count + 1
    Next
End Function

Function ParseSectionList1(ByVal sect As String, ByVal validsects As Long, _
                          ByRef count As Integer, ByRef mask as Long) As Long
    Dim s As String, l As Integer, h As Integer, sl As Long, xsl As Long
    Dim removeflag As Integer

    count = 0
    sect = LTrim(sect)
    ReplaceAllInString sect, ",", " "    ' handle comma as separator
    If sect = "*" Or StrComp(sect, "ALL", 1)=0 Then
        ParseSectionList1 = validsects
        For l = 0 To 24
            sl = 2^l
            If (validsects And sl)=sl Then count = count + 1
        Next
    mask=0
        Exit Function
    End If
    If sect = "-*" Or StrComp(sect, "-ALL", 1)=0 Then
        ParseSectionList1 = 0
    mask = validsects
        Exit Function
    End If
    s = ParseString(sect, " ")      'Numbers are separated by spaces
    While s > ""
    removeflag = 0
    if left(s,1) = "-" then
        removeflag = 1
        s = Right$(s,len(s)-1)
    End If
        l = Instr(s, "-")           'Allowed to use range - e.g. 3-6
        If l > 0 Then               'We have a range
            h = Val(Mid$(s, l + 1)) 'High value of range
            For l = Val(s) To h     'From low to high value
        if removeflag then
            mask = mask or (2 ^ l)
        else
                     sl = sl Or (2 ^ l)  'Set appropriate bits
        End If
            Next
        ElseIf UCase$(s)<>"Y" Then
                l = Val(s)              'Value
        If removeflag then
            mask = mask Or (2 ^ l)
        else
                    sl = sl Or (2 ^ l)      'Set appropriate bit
        End If
        End If
        s = ParseString(sect, " ")  'Numbers are separated by spaces
    Wend
    xsl = sl And validsects
    ParseSectionList1 = xsl
    For l = 0 To 24
        If (xsl And 2^l)=2^l Then count = count + 1
    Next
End Function



Sub SaveMessage(hdr As FAPMSGHEADER, body As String)
    Dim section As String, n As String, l As Integer, tail As String
    Dim f As String, FromLine As String, ToLine As String

    ' Valid message?
    If hdr.lpOriginatorId="" And hdr.lpRecipientName="" Then Exit Sub

    ' Check to see if it's a fake reply
    If Mid$(hdr.lpSubject, 1, 1)="#" And hdr.dwParentMsg=0 Then
        tail = ""
        For l = 1 To Len(hdr.lpSubject)
            If InStr("1234567890", Mid$(hdr.lpSubject, l, 1)) Then
                tail = tail + Mid$(hdr.lpSubject, l, 1)
            End If
            If Mid$(hdr.lpSubject, l, 1)="-"  And tail<>"" Then
                hdr.dwParentMsg = Val(tail)
                hdr.lpSubject = Mid$(hdr.lpSubject, l+1, Len(hdr.lpSubject)-l)
                l = Len(hdr.lpSubject)
            End If
        Next
        tail = ""
    End If

    ' Flags
    f = ""
    If (hdr.cFlags And FAP_READ_BY_RECIPIENT%)<>0 Then
        f = f + "Read-By-Recipient: Yes" & Chr$(10)
    Else
        f = f + "Read-By-Recipient: No" & Chr$(10)
    End If
    If hdr.dwThreadId <> 0 Then
        f = f + "Thread-Id: " & LTrim$(Str$(hdr.dwThreadId)) & Chr$(10)
    End If
    If (hdr.cFlags And FAP_MSG_IS_PRIVATE%)<>0 Then
        f = f + "-- PRIVATE MESSAGE --" & Chr$(10)
    End If
    If (hdr.cFlags And FAP_MSG_HELD%)<>0 Then
        f = f + "-- HOLD MESSAGE --" & Chr$(10)
    End If
    If hdr.lpOriginatorId<>"" Then
        FromLine = hdr.lpOriginatorName & " [" & hdr.lpOriginatorId & "]"
    Else
        FromLine = hdr.lpOriginatorName
    End If
    If hdr.lpRecipientId<>"" Then
        ToLine = hdr.lpRecipientName & " [" & hdr.lpRecipientId & "]"
    Else
        ToLine = hdr.lpRecipientName
    End If

    l = Len(hdr.lpSubject)+Len(f)+Len(FromLine)+Len(ToLine)+Len(body)+24
    If hdr.wNumReplies > 0 Then
        If hdr.wNumReplies > 1 Then
            tail = "There are " & hdr.wNumReplies & " Replies" & Chr$(10)
        Else
            tail = "There is 1 Reply" & Chr$(10)
        End If
    End If
    l = l - ItemCount(body, Chr$(13)) ' Don't count both CR+LF
    If tail > "" Then
        l = l + Len(tail)
    End If
    CaptureLine ""
    If SectionMsgIds(hdr.cSectionId) >= 0 Then
        section = szMsgSection(SectionMsgIds(hdr.cSectionId)).lpTitle
    Else
        section = "Unknown"
    End If
    If body="*** Header Only ***" & Chr$(10) Then
        n = "*header*"
        body = body + Chr$(10) + "[Double-click here to mark the message for collection]"
        l = l + 55
    Else
        n = hdr.lpOriginatorName
        ReplaceAllInString n, " ", "_"
    End If
    ReplaceAllInString hdr.lpOriginatorName, ";", " "
    ReplaceAllInString hdr.lpRecipientName, ";", " "
    nummessages = nummessages + 1
    Terminal.CaptureStatus nummessages
    CaptureLine "=========="
    CaptureText CurrentForum & "/S" & hdr.cSectionId & "_" & section & " #"
    CaptureText hdr.dwMsgNo & ", from " & n & ", " & l & " chars, "
    CaptureLine MakeDateString(hdr.tsDate)
    If hdr.dwParentMsg Then CaptureLine "Comment to " & hdr.dwParentMsg & "."
    CaptureLine "----------"
    CaptureLine "Subject: " & hdr.lpSubject
    CaptureLine "From: " & FromLine
    CaptureLine "To: " & ToLine
    If f<>"" Then CaptureText f
    CaptureLine ""
    CaptureText body
    CaptureLine ""
    If tail > "" Then
        CaptureLine tail
    End If
    CaptureLine ""
End Sub

Sub WriteLibraryMessage(forum As String, filedesc As FAPFILEDESCRIPTION, downloaded As String)
    Dim l As Long, sectname As String, from As String, hdr As String
    Dim d0 As String, d1 As String, d2 As String, flags As String
    Dim fn As String, sectno As Integer

    from = filedesc.lpUserName
    fn = filedesc.lpFilename
    ReplaceAllInString from, " ", "_"
    ReplaceAllInString fn, " ", "_"
    d0 = MakeDateString(filedesc.tsSubmitted)
    d1 = MakeDateString(filedesc.tsLastAccess)
    d2 = MakeDateString(filedesc.tsReleaseDate)
    If d0="" Then d0 = MyDate$

    ' RFC 822 type header
    hdr = "Subject: " & filedesc.lpTitle & Chr$(10) & _
          "From: " & filedesc.lpUserName & " [" & filedesc.lpUserID & "]" & Chr$(10) & _
          "Date-Submitted: " & d0 & Chr$(10)
    If d1<>"" Then hdr = hdr & "Date-Last-Access: " & d1 & Chr$(10)
    If d2<>"" Then hdr = hdr & "Date-Released: " & d2 & Chr$(10)
    hdr = hdr & "Filename: " & filedesc.lpFilename & Chr$(10) & _
          "File-Type: " & GetFileType(filedesc.nFileType) & Chr$(10) & _
          "File-Size: " & filedesc.dwFileSize & Chr$(10) & _
          "Access-Count: " & filedesc.dwAccessCount & Chr$(10) & _
          "Catalog-No: " & filedesc.dwCatalogNo & Chr$(10) & _
          "Keywords: " & filedesc.lpKeys & Chr$(10)
    If filedesc.lpSysOpComment <> "" Then
        hdr = hdr & "SysOp-Comment: " & filedesc.lpSysOpComment & Chr$(10)
    End If

    sectno = filedesc.cLibSectionNo
    If SectionLibIds(sectno) >= 0 Then
        sectname = szLibSection(SectionLibIds(sectno)).lpTitle
    Else
        sectname = "Unknown"
    End If

    ' For new uploads
    If filedesc.cOptions And FAP_FILE_DELETABLE Then flags = flags + ",Deletable"
    If filedesc.cOptions And FAP_FILE_NON_PUBLIC Then flags = flags + ",Not public"
    If filedesc.cOptions And FAP_FILE_MARKED_FOR_DELETION Then flags = flags + ",Marked for deletion"
    If filedesc.cOptions And FAP_FILE_HAS_FEE Then flags = flags + ",Chargeable"
    If flags > "" Then hdr = hdr & "Flags: " & Mid$(flags, 2) & Chr$(10)
    If filedesc.cOptions And FAP_FILE_MARKED_FOR_DELETION Then
        hdr = hdr & Chr$(10) & "*New Erase*" & Chr$(10)
        sectname = sectname + "_[Sysop]"
    ElseIf filedesc.cOptions And FAP_FILE_NON_PUBLIC Then
        hdr = hdr & Chr$(10) & "*New Upload*" & Chr$(10)
        sectname = sectname + "_[Sysop]"
    End If

    l = 2+Len(hdr+filedesc.lpAbstract)-ItemCount(filedesc.lpAbstract, Chr$(13))

    ' Downloaded to...
    If downloaded<>"" Then
        l = l+Len("[]Downloaded to "+FileUrl(downloaded))+1
    End If

    ' CIX header
    CaptureLine "=========="
    CaptureText forum & "/L" & sectno & "_" & sectname
    CaptureText " #" & LTrim(Str(filedesc.dwCatalogNo))
    CaptureLine ", from " & fn & ", " & l & " chars, " & d0
    CaptureLine "----------"
    CaptureLines hdr
    CaptureLines Chr$(10)+filedesc.lpAbstract+Chr$(10)+Chr$(10)
    If downloaded<>"" Then
        CaptureLine "[Downloaded to "+FileUrl(downloaded)+"]"+Chr$(10)
    End If
End Sub

Sub RecordAlert(alert As DAPALERTPAGE)
    Dim nextpage As String

    On Error Resume Next
    CaptureLine alert.lpHeader
    CaptureLines alert.lpBody
    CaptureLine alert.lpTrailer
End Sub

Sub CaptureAlert(forum As String, page As String)
    Dim alert As DAPALERTPAGE
    Dim nextpage As String

    On Error Resume Next
    HMIGetAlert alert
    If (alert.cOptions And DAP_AL_VOLATILE) = 0 Then
        nextpage = CheckCache("Alerts", nextpage, 0)
        If nextpage > "" Then
            page = nextpage
            Exit Sub
        End If
        UpdateCache "Alerts", page, 0, alert.lpNextPage
    End If
    page = alert.lpNextPage
    If StrComp(Mid$(forum, 1, 4), "CIS:", 1)=0 Then
        StartCapturing Mid$(forum, 5)+"/Alerts", "Alert recieved going to " + page, False
    Else
        StartCapturing forum+"/Alerts", "Alert recieved going to " + page, False
    End If
    RecordAlert alert
    FinishCapturing
End Sub

Sub RecordArticleText(article As DAPARTICLEPAGE)
    Dim textbuf As String
    Dim state As Integer
    Dim i As Integer

    'On Error Resume Next
    'If article.wExtendedOptions And DAP_AP_EX_HAVE_TITLE Then CaptureLine article.lpTitle
    'If article.cOptions And DAP_AP_HAVE_HEADER Then CaptureLine article.lpHeader
    i = 1
    state = HMI_STATE_FIRST%
    Do While DAPArticleRead(state, article.lpName, i, HMI_DATA_SIZE, textbuf)
        i = i + Len(textbuf)
        CaptureLines textbuf
        If textbuf = "" Then Exit Do
        state = HMI_STATE_NEXT%
    Loop
    If article.cOptions And DAP_AP_HAVE_TRAILER Then CaptureLine article.lpTrailer
End Sub

Sub CaptureArticleText(folder As String)
    Dim article As DAPARTICLEPAGE
    Dim nextpage As String

    'On Error Resume Next
    HMIGetArticle article
    If (article.cOptions And (DAP_AP_SESSION_ONLY Or DAP_AP_VOLATILE)) = 0 Then
        nextpage = CheckCache("Articles", article.lpName, article.pvVersion)
        If nextpage > "" Then Exit Sub
        UpdateCache "Articles", article.lpName, article.pvVersion, article.lpNextPage
    End If
    StartCapturing folder, "CompuServe", False
    RecordArticleText article
    FinishCapturing
End Sub

Sub RecordBulletins(forum As String, getnews As Boolean, _
                    getothers As Boolean, getuserlog As Boolean)
    Dim bulletins As FAPBULLETINCONFIG
    Dim entry() as FAPBULLETINENTRY
    Dim i As Integer
    Dim textbuf As String

    ' We must be a member
    If FAPconfig.wAlerts And FAP_NOT_A_MEMBER% Then
        Exit Sub
    End If

    FAPGetBulletinConfig bulletins, entry()
    For i = 0 To UBound(entry)
        ' Are we interested in this one ?
        If ((getnews And (entry(i).lpTitle="Newsflash" Or _
                          entry(i).lpTitle="News Flash" Or _
                          entry(i).lpTitle="Aktuelles")) Or _
            (getuserlog And entry(i).lpTitle="User Log") Or _
            (getothers And entry(i).lpTitle<>"News Flash" And _
                           entry(i).lpTitle<>"Newsflash" And _
                           entry(i).lpTitle<>"Aktuelles" And _
                           entry(i).lpTitle<>"User Log")) Then
            If entry(i).lpTitle="Newsflash" Or _
               entry(i).lpTitle="News Flash" Or _
               entry(i).lpTitle="Aktuelles" Then
                StartCapturing forum+"/Newsflash", "CompuServe", True
            Else
                If entry(i).lpTitle="User Log" Then
                    StartCapturing forum+"/Sysop_Logs", "User_Log", True
                Else
                    StartCapturing forum+"/Announcements", "CompuServe", True
                End If
            End If
            CaptureLine entry(i).lpTitle
            textbuf = FAPBulletinRead(HMI_STATE_FIRST%, entry(i).nId, 1, HMI_DATA_SIZE)
            While textbuf > ""
                CaptureLines textbuf
                textbuf = FAPBulletinRead(HMI_STATE_NEXT%, entry(i).nId, 1, HMI_DATA_SIZE)
            Wend
            FinishCapturing
        End If
    Next
End Sub

'T:DeleteMessage (subroutine) (CompuServe)
Sub DeleteMessage(id As String, forum As String, dummy As String, number As String)
    If Not HMIGotoForum(forum) Then
        LogResult id + " : Failed : Unable to delete messages in " + forum
        Exit Sub
    End If

    Terminal.Print "Deleting message #" + number + Basic.Eoln$

    ' Delete the message
    On Error Goto DeleteMessage_error
    If FAPDeleteMsg_(number)<>0 Then
        ReportSuccess id & " : Deleted message #" & number & " from " & forum
    End If
    Exit Sub
DeleteMessage_error:
    ReportSuccess id & " : Unable to delete message #" & number & " from " & forum
End Sub

'T:GetMailType (function) (CompuServe)
Function GetMailType(i As Integer) As String
    Select Case i
        Case EMP_TEXT%
            GetMailType = "Ascii"
        Case EMP_BINARY%
            GetMailType = "Binary"
        Case EMP_GIF%
            GetMailType = "GIF"
        Case EMP_BINARY_FILE%
            GetMailType = "Binary file"
        Case EMP_TEXT_FILE%
            GetMailType = "Text file"
        Case EMP_TEXT_OBJECT%
            GetMailType = "Text object"
        Case EMP_JPEG%
            GetMailType = "JPEG"
        Case Else
            GetMailType = "Unknown type - " & Str(i)
    End Select
End Function

Function Plural(l As Long) As String
    If l = 1 Then Plural = "" Else Plural = "s"
End Function

'T:WhichWhatsNew (subroutine) (CompuServe)
Sub WhichWhatsNew(id As String, which As String)
    Dim menupage As DAPMENUPAGE, blobmenu As String, pageno As Integer
    Dim selections() As DAPSELECTION, page As String, ListIni As String
    Dim menuline As String, tmp As String, menunum As Integer, folder As String

    ListIni = Session.ServicePath+"userlist.ini"

    ' Go to the What's New main menu (lists UK, French, German etc)
    If Not DoHMIGoToPage("EWN-5", -1, DAP_MENU, False) Then Exit Sub

    ' Pickup the current page name
    HMIGetMenu menupage, selections
    page = menupage.lpName

    ' Display blob menu in the terminal
    menunum = 0
    pageno = 0
    folder = "Whats_New/Unknown_News"
    blobmenu = selections(0).lpItem
    Do While blobmenu > ""
        menunum = menunum + 1
        menuline = ParseString(blobmenu, Chr(10))
        ReplaceAllInString menuline, " What's New", ""
        ReplaceAllInString menuline, " Whats New", ""
        menuline = menuline + " What's New"
        If InStr(menuline, which, 1)>0 Then
            pageno = menunum
            folder = Mid$(menuline, 4) + "_News"
            ReplaceAllInString folder, " What's New", ""
            ReplaceAllInString folder, " Whats New", ""
            ReplaceAllInString folder, " ", "_"
            ReplaceAllInString folder, "/", "_"
            folder = "Whats_New/" + folder
        End If

        ' Update userlist.ini with latest list
        WriteIni "Which Whats New:", menunum, Mid$(menuline, 4), ListIni
    Loop
    WriteIni "Which Whats New:", menunum+1, "All What's New", ListIni
    WriteIni "Which Whats New:", menunum+2, "", ListIni

    ' Recurse to collect them all?
    If which="All What's New" Then
        blobmenu = selections(0).lpItem
        Do While blobmenu > ""
            menuline = ParseString(blobmenu, Chr(10))
            WhichWhatsNew "", menuline
        Loop

        ReportSuccess id & " : " & which & " collected"
        Exit Sub
    End If

    ' Invalid choice!
    If pageno=0 Then
        ReportSuccess id & " : " & which & " not collected - no such What's New"
        Exit Sub
    End If

    ' Go to the specific What's New
    If Not DoHMIGotoPage(page, pageno, DAP_MENU, False) Then Exit Sub
    Terminal.Print "Collecting " & which & "..." & Basic.Eoln$ & Basic.Eoln$

    ' Pickup list of specific What's New menu articles
    HMIGetMenu menupage, selections
    page = menupage.lpName

    Do
        ' Display blob menu in the terminal
        blobmenu = selections(0).lpItem
        Do While blobmenu > ""
            menuline = LTrim$(ParseString(blobmenu, Chr(10)))
            Terminal.Print menuline & Basic.Eoln$

            tmp = menuline
            menunum = Val(ParseString(tmp, " "))
            If menunum>0 Then
                ' Get the article
                If DoHMIGotoPage(page, menunum, DAP_ARTICLE, True) Then
                    CaptureArticleText folder
                End If
            End If
        Loop

        ' Next menu?
        If menupage.cOptions And DAP_MP_HAVE_NEXT% Then
            ' Go to the specific What's New
            page = menupage.lpNextPage
            If Not DoHMIGotoPage(page, -1, DAP_MENU, False) Then Exit Sub

            ' Pickup list of specific What's New menu articles
            HMIGetMenu menupage, selections
            page = menupage.lpName
        End If
    Loop While menupage.cOptions And DAP_MP_HAVE_NEXT%
    Terminal.Print Basic.Eoln$

    ' It worked!
    If id<>"" Then
        ReportSuccess id & " : " & which & " collected"
        SetLastUpdated which
    End If
End Sub