Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast.iso/pcmag/vol12n18.zip/FONSRC.ZIP/FONEWORD.TXT

Text File | 1993-07-27 | 22KB | 716 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "FONEWORD"
   ClientHeight    =   5370
   ClientLeft      =   60
   ClientTop       =   870
   ClientWidth     =   7275
   ForeColor       =   &H00000000&
   Height          =   6300
   Icon            =   FONEWORD.FRX:0000
   Left            =   0
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5370
   ScaleWidth      =   7275
   Top             =   0
   Width           =   7395
   Begin PushButton PushStop
      Height          =   615
      HelpContextID   =   4
      Left            =   6420
      TabIndex        =   14
      Top             =   120
      Width           =   615
   End
   Begin PushButton PushOnly
      Height          =   615
      HelpContextID   =   6
      Left            =   1680
      TabIndex        =   3
      Top             =   1020
      Width           =   615
   End
   Begin PushButton PushReal
      Height          =   615
      HelpContextID   =   6
      Left            =   4080
      TabIndex        =   7
      Top             =   1020
      Width           =   615
   End
   Begin PushButton PushAll
      Height          =   615
      HelpContextID   =   6
      Left            =   6480
      PictureDown     =   FONEWORD.FRX:0302
      PictureUp       =   FONEWORD.FRX:0754
      TabIndex        =   11
      Top             =   1020
      Width           =   615
   End
   Begin CommandButton CommandAll
      BackColor       =   &H00000080&
      Caption         =   "&All words"
      Height          =   615
      HelpContextID   =   1
      Left            =   5160
      TabIndex        =   10
      Top             =   1020
      Width           =   1335
   End
   Begin CommandButton CommandReal
      Caption         =   "&Real words"
      Height          =   615
      HelpContextID   =   2
      Left            =   2760
      TabIndex        =   6
      Top             =   1020
      Width           =   1335
   End
   Begin CommandButton CommandOnly
      BackColor       =   &H00FF0000&
      Caption         =   "&Only words"
      Height          =   615
      HelpContextID   =   3
      Left            =   360
      TabIndex        =   2
      Top             =   1020
      Width           =   1335
   End
   Begin ListBox ListAll
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   3180
      HelpContextID   =   7
      Left            =   5160
      MultiSelect     =   2  'Extended
      TabIndex        =   12
      Top             =   1680
      Width           =   1935
   End
   Begin ListBox ListReal
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   3180
      HelpContextID   =   7
      Left            =   2760
      MultiSelect     =   2  'Extended
      TabIndex        =   8
      Top             =   1680
      Width           =   1935
   End
   Begin ListBox ListOnly
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   3180
      HelpContextID   =   7
      Left            =   360
      MultiSelect     =   2  'Extended
      TabIndex        =   4
      Top             =   1680
      Width           =   1935
   End
   Begin ListBox ListCover
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   60
      TabIndex        =   18
      Top             =   60
      Visible         =   0   'False
      Width           =   195
   End
   Begin Gauge GaugeAll
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H0000FF00&
      Height          =   4275
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   4920
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   13
      Top             =   960
      Width           =   135
   End
   Begin Gauge GaugeReal
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H000000FF&
      Height          =   4275
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   2520
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   9
      Top             =   960
      Width           =   135
   End
   Begin Gauge GaugeOnly
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00FF0000&
      Height          =   4275
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   120
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   5
      Top             =   960
      Width           =   135
   End
   Begin MaskEdBox PhoneEdit
      BackColor       =   &H00FFFFFF&
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   18
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   555
      HelpContextID   =   10
      Left            =   2700
      Mask            =   "###-####"
      MaxLength       =   8
      PromptChar      =   "_"
      TabIndex        =   1
      Top             =   120
      Width           =   2055
   End
   Begin Image ImageStopDn
      Height          =   615
      Left            =   5400
      Picture         =   FONEWORD.FRX:0BA6
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin Image ImageDiStopDn
      Height          =   615
      Left            =   5220
      Picture         =   FONEWORD.FRX:0FF8
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin Image ImageDiStopUp
      Height          =   615
      Left            =   5040
      Picture         =   FONEWORD.FRX:144A
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin Image ImageStopUp
      Height          =   615
      Left            =   4860
      Picture         =   FONEWORD.FRX:189C
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin Line Line1
      X1              =   0
      X2              =   7260
      Y1              =   840
      Y2              =   840
   End
   Begin Label LabelOnly
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   360
      TabIndex        =   15
      Top             =   4920
      Width           =   1935
   End
   Begin Label LabelReal
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   2760
      TabIndex        =   16
      Top             =   4920
      Width           =   1935
   End
   Begin Label LabelAll
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   5160
      TabIndex        =   17
      Top             =   4920
      Width           =   1935
   End
   Begin Label LabelPhone
      Alignment       =   1  'Right Justify
      Caption         =   "Enter Phone Number:"
      Height          =   315
      Left            =   240
      TabIndex        =   0
      Top             =   360
      Width           =   2295
   End
   Begin Shape ShapeOnly
      BackColor       =   &H00FF0000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H00FF0000&
      FillStyle       =   0  'Solid
      Height          =   4275
      Left            =   300
      Top             =   960
      Width           =   2055
   End
   Begin Shape ShapeReal
      BackColor       =   &H000000FF&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H000000FF&
      FillStyle       =   0  'Solid
      Height          =   4275
      Left            =   2700
      Top             =   960
      Width           =   2055
   End
   Begin Shape ShapeAll
      BackColor       =   &H0000FF00&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H0000FF00&
      FillStyle       =   0  'Solid
      Height          =   4275
      Left            =   5100
      Top             =   960
      Width           =   2055
   End
   Begin Menu MainMenu
      Caption         =   "&File"
      HelpContextID   =   11
      Index           =   1
      Begin Menu FileMenu
         Caption         =   "E&xit"
         HelpContextID   =   11
         Index           =   1
      End
   End
   Begin Menu MainMenu
      Caption         =   "&Help"
      HelpContextID   =   5
      Index           =   2
      Begin Menu HelpMenu
         Caption         =   "&Contents"
         HelpContextID   =   5
         Index           =   101
      End
      Begin Menu HelpMenu
         Caption         =   "&Search for Help On..."
         HelpContextID   =   5
         Index           =   102
      End
      Begin Menu HelpMenu
         Caption         =   "&How to Use Help"
         HelpContextID   =   5
         Index           =   103
      End
      Begin Menu HelpMenu
         Caption         =   "-"
         HelpContextID   =   5
         Index           =   104
      End
      Begin Menu HelpMenu
         Caption         =   "&About FoneWord..."
         HelpContextID   =   5
         Index           =   105
      End
   End
End
Option Explicit
' A is an array of three letter values for each
' ASCII value from 50 ("2") to 57 ("9")
Dim A(50 To 57, 0 To 2)
Dim MyDB As database
Dim MySet As DynaSet
Dim Continue%
Const MinWord = 2
Const NullStr = ""

Declare Function WinHelpByNum% Lib "User" Alias "WinHelp" (ByVal hWnd%, ByVal lpHelpFile$, ByVal wCommand%, ByVal dwData&)
Declare Function WinHelp% Lib "User" (ByVal hWnd%, ByVal lpHelpFile$, ByVal wCommand%, ByVal dwData$)
Const HELP_CONTENTS = 3
Const HELP_HELPONHELP = 4
Const HELP_PARTIALKEY = &H105

Declare Sub MessageBeep Lib "User" (ByVal wType%)

Sub After (Lis As ListBox, Lab As Label)
  PushStop.PictureUp = ImageDiStopUp.Picture
  PushStop.PictureDown = ImageDiStopDn.Picture
  Form1.MousePointer = 0
  Lab.Caption = Lis.ListCount + " Items"
  MessageBeep (0)
End Sub

Sub AllCombos (ByVal S$, ByVal N%)
  ' Called when button CommandAll is clicked
  '
  ' Recursive function.  Replaces the Nth digit of S with
  ' each of the three possible letters, then calls itself
  ' to handle the N+1th digit for each.  When it passes
  ' the LAST digit, it records the completed combination
  ' by adding it to a list box.
  '
  Dim Ch%
  DoEvents
  If Not Continue Then Exit Sub
  If N > Len(S) Then
    ListAll.AddItem S
    GaugeAll.Value = ListAll.ListCount
  Else
    Ch = Asc(Mid$(S, N, 1))
    If (Ch >= 50) And (Ch <= 57) Then
      Mid$(S, N, 1) = A(Ch, 0)
      AllCombos S, N + 1
      Mid$(S, N, 1) = A(Ch, 1)
      AllCombos S, N + 1
      Mid$(S, N, 1) = A(Ch, 2)
      AllCombos S, N + 1
    Else
      AllCombos S, N + 1
    End If
  End If
End Sub

Sub Before (Lis As ListBox, Lab As Label)
  Continue = True
  Lis.Clear
  Lab.Caption = NullStr
  Form1.MousePointer = 11
  PushStop.PictureUp = ImageStopUp.Picture
  PushStop.PictureDown = ImageStopDn.Picture
End Sub

Sub CommandAll_Click ()
  Dim N%
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  GaugeAll.Max = 1
  ' Set the max value for the gauge to the number
  ' of possible combinations, which is 3 to the nth
  ' power, where n is the number of digits in the
  ' input string that are NOT "1" or "0"
  For N = 1 To Len(PhoneEdit.ClipText)
    Select Case Mid$(PhoneEdit.ClipText, N, 1)
      Case "0"
      Case "1"
      Case Else
        GaugeAll.Max = GaugeAll.Max * 3
    End Select
  Next N
  ' Cover the list box with a blank list box and fill
  ' the list while not visible - that makes it fill
  ' up MUCH faster
  ListCover.Visible = True
  ListAll.Visible = False
  Before ListAll, LabelAll
  AllCombos PhoneEdit.ClipText, 1
  ListAll.Visible = True
  ListCover.Visible = False
  After ListAll, LabelAll
End Sub

Sub CommandOnly_Click ()
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  GaugeOnly.Max = Len(PhoneEdit.ClipText) + 1
  GaugeOnly.Value = 0
  Before ListOnly, LabelOnly
  OnlyRealWords PhoneEdit.ClipText, NullStr
  After ListOnly, LabelOnly
End Sub

Sub CommandReal_Click ()
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  If Len(PhoneEdit.ClipText) < MinWord Then
    MsgBox "You must enter at least " + Str$(MinWord) + " digits", 0, "FoneWord Message"
    Exit Sub
  End If
  Before ListReal, LabelReal
  FindRealWords
  After ListReal, LabelReal
End Sub

Function Decode$ (ByVal S$, ByVal Code%)
  ' This function receives a string of digits from 2 to 9
  ' and an integer that tells how to decode those digits
  ' into a real word.  It repeatedly divides the code by
  ' 3 and uses the remainder as an index into the A array,
  ' selecting the first, second, or third letter associated
  ' with the current digit.
  Dim N%, TempS$
  If (Len(S) = 1) And InStr("01", S) Then
    Decode = S
  Else
    TempS = NullStr
    For N = 1 To Len(S)
      TempS = TempS + A(Asc(Mid$(S, N, 1)), Code Mod 3)
      Code = Code \ 3
    Next N
    Decode = TempS
  End If
End Function

Sub FileMenu_Click (Index As Integer)
  ' Handles the Exit choice from the File menu
  If Index = 1 Then End
End Sub

Sub FindRealWords ()
  ' Called when you press the CommandReal button.
  '
  ' Considers every substring of the phone number that's
  ' at least MinWord in length.  If it's in the database,
  ' decodes it into a word and adds the result to the list.
  ' Then it checks for other words made from the same
  ' digits.  The key values for these other words will
  ' be the same as the original number with A, B, C
  ' and so on appended in turn.
  Dim Start%, Num%, vLen%, Code%
  Dim S$, SPart$, SDecode$
  Dim Char As String * 1
  vLen = Len(PhoneEdit.ClipText)
  GaugeReal.Max = 1
  For Num = MinWord To vLen
    For Start = 1 To (vLen + 1 - Num)
      GaugeReal.Max = GaugeReal.Max + 1
    Next Start
  Next Num
  GaugeReal.Value = 0
  For Num = MinWord To vLen
    For Start = 1 To (vLen + 1 - Num)
      GaugeReal.Value = GaugeReal.Value + 1
      DoEvents
      If Not Continue Then Exit Sub
      SPart = Mid$(PhoneEdit.ClipText, Start, Num)
      Char = "@"
      SDecode = NextMatch(SPart, Char)
      Do While Len(SDecode) <> 0
        DoEvents
        If Not Continue Then Exit Sub
        S = NullStr
        If Start > 1 Then S = Mid$(PhoneEdit.ClipText, 1, Start - 1) + " "
        S = S + SDecode
        If Start + Num <= vLen Then S = S + " " + Mid$(PhoneEdit.ClipText, Start + Num)
        ListReal.AddItem S
        SDecode = NextMatch(SPart, Char)
      Loop
    Next Start
  Next Num
  GaugeReal.Value = GaugeReal.Value + 1
End Sub

Sub Form_Load ()
  SetDataAccessOption 1, App.Path + "\FONEWORD.INI"
  Dim X%, Y%
  ' Since we can't have multi-dimensional array constants,
  ' we assign values to the array A here.
  Const FoneLets$ = "ABCDEFGHIJKLMNOPRSTUVWXY"
  For X = 0 To 7
    For Y = 0 To 2
      A(X + Asc("2"), Y) = Mid(FoneLets, X * 3 + Y + 1, 1)
    Next Y
  Next X
  Set MyDB = OpenDatabase(CurDir$, True, True, "Paradox;")
  Const DB_READONLY = 4
  Set MySet = MyDB.CreateDynaset("FONENUMS", DB_READONLY)
  ListCover.Move ListAll.Left, ListAll.Top, ListAll.Width, ListAll.Height
  ListCover.AddItem "One"
  ListCover.AddItem "Moment"
  ListCover.AddItem "Please..."
  ' Some pictures are stored separately in invisible image
  ' image controls, so as to avoid either having independent
  ' BMP file or storing multiple copies of the same bitmap
  ' in the EXE.
  PushReal.PictureDown = PushAll.PictureDown
  PushReal.PictureUp = PushAll.PictureUp
  PushOnly.PictureDown = PushAll.PictureDown
  PushOnly.PictureUp = PushAll.PictureUp
  PushStop.PictureDown = ImageDiStopDn.Picture
  PushStop.PictureUp = ImageDiStopUp.Picture
End Sub

Sub HelpMenu_Click (Index As Integer)
  ' Note that WinHelp and WinHelpByNum are declared in
  ' the declarations section, to give this VB program
  ' access to the Windows API function WinHelp.
  Dim Success%
  Select Case Index
    Case 101
      Success = WinHelpByNum(Form1.hWnd, App.HelpFile, HELP_CONTENTS, 0)
    Case 102
      Success = WinHelp(Form1.hWnd, App.HelpFile, HELP_PARTIALKEY, "")
    Case 103
      Success = WinHelpByNum(Form1.hWnd, App.HelpFile, HELP_HELPONHELP, 0)
    Case 105
      Form2.Show
  End Select
End Sub

Function NextMatch$ (ByVal S$, C$)
  ' Called by FindRealWords and OnlyRealWords
  '
  ' Handles the fact that multiple decodings of the same
  ' string of digits exist.  The first is keyed with the
  ' digit string itself, and the later ones have A, B,
  ' C, and so on appended in turn.
  Dim Criteria$, Code%
  NextMatch = NullStr
  If C = "?" Then Exit Function
  If Len(S) = 1 Then
    ' deal with single-digit "words" w/o hitting database
    Select Case S
      Case "0", "1"
        NextMatch = S
      Case "2"
        NextMatch = "A"
      Case "4"
        NextMatch = "I"
      Case "^"
        NextMatch = "O"
    End Select
    C = "?"
  Else
    If C = "@" Then
      Criteria = "Foneword = '" + S + "'"
    Else
      Criteria = "Foneword = '" + S + C + "'"
    End If
    MySet.FindFirst Criteria
    If Not MySet.NoMatch Then
      Code = MySet("Code")
      NextMatch = Decode(S, Code)
    End If
    C = Chr$(Asc(C) + 1)
  End If
End Function

Sub OnlyRealWords (ByVal S$, ByVal SAcc$)
  ' Called when you press the CommandOnly button
  '
  ' Checks each prefix of the passed string to see if it's
  ' a word.  If so, adds the decoded word to the accumulator
  ' string SAcc and calls itself recursively to handle the
  ' remainder of the string.  Only of the string is entirely
  ' converted to words does it add the result to the list.
  Dim N%, SPart$, SDecode$
  Dim Char As String * 1
  If Not Continue Then Exit Sub
  For N = 1 To Len(S)
    ' Only advance the gauge for the first instance
    If Len(SAcc) = 0 Then GaugeOnly.Value = GaugeOnly.Value + 1
    DoEvents
    If Not Continue Then Exit Sub
    SPart = Mid$(S, 1, N)
    Char = "@"
    SDecode = NextMatch(SPart, Char)
    Do While Len(SDecode) <> 0
      DoEvents
      If Not Continue Then Exit Sub
      If N = Len(S) Then
        ListOnly.AddItem Mid$(SAcc + " " + SDecode, 2)
      Else
        OnlyRealWords Mid$(S, N + 1), SAcc + " " + Left$(SDecode, N)
      End If
      SDecode = NextMatch(SPart, Char)
    Loop
  Next N
  ' Only advance the gauge for the first instance
  If Len(SAcc) = 0 Then GaugeOnly.Value = GaugeOnly.Value + 1
End Sub

Sub PhoneEdit_Change ()
  ListAll.Clear
  ListReal.Clear
  ListOnly.Clear
  'DO NOT add ListCover.Clear
  LabelAll.Caption = NullStr
  LabelReal.Caption = NullStr
  LabelOnly.Caption = NullStr
  GaugeAll.Value = 0
  GaugeReal.Value = 0
  GaugeOnly.Value = 0
End Sub

Sub PushAll_Click (ButtonCaption As String)
  ToClip ListAll
End Sub

Sub PushOnly_Click (ButtonCaption As String)
  ToClip ListOnly
End Sub

Sub PushReal_Click (ButtonCaption As String)
  ToClip ListReal
End Sub

Sub PushStop_Click (ButtonCaption As String)
  ' All three lengthy functions check to see if Continue
  ' becomes FALSE, and stop if so.  Thus clicking this
  ' button interrupts the lengthy processing.
  Continue = False
End Sub

Sub ToClip (L As ListBox)
  ' Called when you press one of the clipboard buttons
  '
  ' Copies the selected items from the associated list
  ' box to the clipboard.
  Dim N%, Text$
  Text = NullStr
  If L.ListCount = 0 Then Exit Sub
  For N = 0 To L.ListCount - 1
    If L.Selected(N) Then
      Text = Text + L.List(N)
      Text = Text + Chr$(13) + Chr$(10)
    End If
  Next N
  If Len(Text) = 0 Then
    MsgBox "No items are selected", 0
  Else
    Clipboard.Clear
    Clipboard.SetText Text
  End If
End Sub