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

Text File | 1993-07-15 | 17KB | 590 lines

VERSION 2.00
Begin Form Form1
   BorderStyle     =   1  'Fixed Single
   Caption         =   "FONEWORD"
   ClientHeight    =   6630
   ClientLeft      =   2535
   ClientTop       =   3240
   ClientWidth     =   7275
   ForeColor       =   &H00000000&
   Height          =   7155
   Left            =   2475
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6630
   ScaleWidth      =   7275
   Top             =   2775
   Width           =   7395
   Begin CommandButton CommandAbout
      Caption         =   "&About"
      Height          =   495
      HelpContextID   =   5
      Left            =   6180
      TabIndex        =   20
      Top             =   120
      Width           =   975
   End
   Begin SSCommand ClipBtnOnly
      Font3D          =   3  'Inset w/light shading
      ForeColor       =   &H00000000&
      Height          =   615
      HelpContextID   =   6
      Left            =   6480
      Picture         =   FONEWORD.FRX:0000
      TabIndex        =   10
      Top             =   960
      Width           =   615
   End
   Begin SSCommand ClipBtnReal
      Font3D          =   3  'Inset w/light shading
      ForeColor       =   &H00000000&
      Height          =   615
      HelpContextID   =   6
      Left            =   4080
      Picture         =   FONEWORD.FRX:083A
      TabIndex        =   7
      Top             =   960
      Width           =   615
   End
   Begin SSCommand ClipBtnAll
      Font3D          =   3  'Inset w/light shading
      ForeColor       =   &H00000000&
      Height          =   615
      HelpContextID   =   6
      Left            =   1680
      Picture         =   FONEWORD.FRX:1074
      TabIndex        =   3
      Top             =   960
      Width           =   615
   End
   Begin CommandButton CommandAll
      BackColor       =   &H00000080&
      Caption         =   "&All words"
      Height          =   615
      HelpContextID   =   1
      Left            =   360
      TabIndex        =   2
      Top             =   960
      Width           =   1335
   End
   Begin CommandButton CommandReal
      Caption         =   "&Real words"
      Height          =   615
      HelpContextID   =   2
      Left            =   2760
      TabIndex        =   6
      Top             =   960
      Width           =   1335
   End
   Begin CommandButton CommandOnly
      BackColor       =   &H00FF0000&
      Caption         =   "&Only words"
      Height          =   615
      HelpContextID   =   3
      Left            =   5160
      TabIndex        =   9
      Top             =   960
      Width           =   1335
   End
   Begin CommandButton CommandBreak
      Caption         =   "&Break"
      Height          =   495
      HelpContextID   =   4
      Left            =   4020
      TabIndex        =   12
      Top             =   120
      Width           =   975
   End
   Begin CommandButton CommandHelp
      Caption         =   "&Help"
      Default         =   -1  'True
      Height          =   495
      HelpContextID   =   5
      Left            =   5100
      TabIndex        =   13
      Top             =   120
      Width           =   975
   End
   Begin ListBox ListAll
      DragIcon        =   FONEWORD.FRX:18AE
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   4530
      HelpContextID   =   7
      Left            =   360
      MultiSelect     =   2  'Extended
      TabIndex        =   5
      Top             =   1620
      Width           =   1935
   End
   Begin ListBox ListReal
      DragIcon        =   FONEWORD.FRX:1BB0
      DragMode        =   1  'Automatic
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   4530
      HelpContextID   =   7
      Left            =   2760
      MultiSelect     =   2  'Extended
      TabIndex        =   8
      Top             =   1620
      Width           =   1935
   End
   Begin ListBox ListOnly
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   4530
      HelpContextID   =   7
      Left            =   5160
      MultiSelect     =   2  'Extended
      TabIndex        =   11
      Top             =   1620
      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            =   2340
      TabIndex        =   19
      Top             =   900
      Visible         =   0   'False
      Width           =   195
   End
   Begin Gauge GaugeAll
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H0000FF00&
      Height          =   5595
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   120
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   14
      TabStop         =   0   'False
      Top             =   900
      Width           =   135
   End
   Begin Gauge GaugeReal
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H000000FF&
      Height          =   5595
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   2520
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   15
      TabStop         =   0   'False
      Top             =   900
      Width           =   135
   End
   Begin Gauge GaugeOnly
      Autosize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00FF0000&
      Height          =   5595
      HelpContextID   =   8
      InnerBottom     =   2
      InnerLeft       =   1
      InnerRight      =   2
      InnerTop        =   2
      Left            =   4920
      Max             =   100
      NeedleWidth     =   1
      Style           =   1  'Vertical Bar
      TabIndex        =   16
      TabStop         =   0   'False
      Top             =   900
      Width           =   135
   End
   Begin MaskEdBox PhoneEdit
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   15
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   495
      HelpContextID   =   10
      Left            =   2100
      Mask            =   "###-####"
      MaxLength       =   8
      PromptChar      =   "_"
      TabIndex        =   1
      Top             =   120
      Width           =   1635
   End
   Begin Line Line1
      X1              =   0
      X2              =   7260
      Y1              =   720
      Y2              =   720
   End
   Begin Label LabelOnly
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   5160
      TabIndex        =   4
      Top             =   6180
      Width           =   1935
   End
   Begin Label LabelReal
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   2760
      TabIndex        =   17
      Top             =   6180
      Width           =   1935
   End
   Begin Label LabelAll
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   360
      TabIndex        =   18
      Top             =   6180
      Width           =   1935
   End
   Begin Label LabelPhone
      Caption         =   "Enter Phone Number:"
      Height          =   315
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   1875
   End
   Begin Shape ShapeOnly
      BackColor       =   &H00FF0000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H00FF0000&
      FillStyle       =   0  'Solid
      Height          =   5595
      Left            =   5100
      Top             =   900
      Width           =   2055
   End
   Begin Shape ShapeReal
      BackColor       =   &H000000FF&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H000000FF&
      FillStyle       =   0  'Solid
      Height          =   5595
      Left            =   2700
      Top             =   900
      Width           =   2055
   End
   Begin Shape ShapeAll
      BackColor       =   &H0000FF00&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      FillColor       =   &H0000FF00&
      FillStyle       =   0  'Solid
      Height          =   5595
      Left            =   300
      Top             =   900
      Width           =   2055
   End
End
Option Explicit
Dim A(50 To 57, 0 To 2)
Dim MyDB As database
Dim MySet As DynaSet
Dim MinWord, Continue%

Declare Function sndPlaySound% Lib "MMSystem" (ByVal lpszSoundName$, ByVal wFlags%)
Const SND_ASYNC = 1
Const SND_NODEFAULT = 2

Sub AllCombos (ByVal S$, ByVal N%)
  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 ClipBtnAll_Click ()
  ToClip ListAll
End Sub

Sub ClipBtnOnly_Click ()
  ToClip ListOnly
End Sub

Sub ClipBtnReal_Click ()
  ToClip ListReal
End Sub

Sub Command1_Click ()
  ' uh?
End Sub

Sub CommandAbout_Click ()
  Form2.Show
End Sub

Sub CommandAll_Click ()
  Dim N%, Success%
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  Continue = True
  GaugeAll.Max = 1
  ListAll.Clear
  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%
  ListCover.Visible = True
  ListAll.Visible = False
  Form1.MousePointer = 11
  AllCombos PhoneEdit.ClipText, 1
  Form1.MousePointer = 0
  ListAll.Visible = True
  ListCover.Visible = False
  LabelAll.Caption = ListAll.ListCount + " Items"
  Success = sndPlaySound("DING.WAV", SND_ASYNC + SND_NODEFAULT)
End Sub

Sub CommandBreak_Click ()
  Continue = False
End Sub

Sub CommandHelp_Click ()
  Dim Success%
  Success% = Shell("WINHELP.EXE " + App.HelpFile, 1)
End Sub

Sub CommandOnly_Click ()
  Dim N%, Success%
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  Continue = True
  GaugeOnly.Max = Len(PhoneEdit.ClipText)
  ListOnly.Clear
  GaugeOnly.Value = 0
  Form1.MousePointer = 11
  OnlyRealWords PhoneEdit.ClipText, ""
  Form1.MousePointer = 0
  LabelOnly.Caption = ListOnly.ListCount + " Items"
  Success = sndPlaySound("DING.WAV", SND_ASYNC + SND_NODEFAULT)
End Sub

Sub CommandReal_Click ()
  Dim Success%
  If Len(PhoneEdit.ClipText) = 0 Then Exit Sub
  If Len(PhoneEdit.ClipText) < MinWord Then
    MsgBox "You must enter at least " + MinWord + " digits", 0, "FoneWord Message"
    Exit Sub
  End If
  Continue = True
  ListReal.Clear
  Form1.MousePointer = 11
  FindRealWords
  Form1.MousePointer = 0
  LabelReal.Caption = ListReal.ListCount + " items"
  Success = sndPlaySound("DING.WAV", SND_ASYNC + SND_NODEFAULT)
End Sub

Function Decode$ (ByVal S$, ByVal Code%)
  Dim N%, TempS$
  If (Len(S) = 1) And InStr("01", S) Then
    Decode = S
  Else
    TempS = ""
    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 FindRealWords ()
  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.Max = GaugeReal.Max - 1
  GaugeReal.Value = 0
  For Num = MinWord To vLen
    For Start = 1 To (vLen + 1 - Num)
      DoEvents
      If Not Continue Then Exit Sub
      SPart = Mid$(PhoneEdit.ClipText, Start, Num)
      Char = "@"
      SDecode = NextMatch(SPart, Char)
      Do While SDecode <> ""
        DoEvents
        If Not Continue Then Exit Sub
        S = ""
        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)
        'S = PhoneEdit.ClipText
        'Mid(S, Start, Num) = SDecode
        ListReal.AddItem S
        SDecode = NextMatch(SPart, Char)
      Loop
      GaugeReal.Value = GaugeReal.Value + 1
    Next Start
  Next Num
End Sub

Sub Form_Load ()
  Dim X%, Y%
  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%
  MinWord = 2
  Set MyDB = OpenDatabase("D:\UTIL\FONE", True, True, "Paradox;")
  Set MySet = MyDB.CreateDynaset("FONENUMS")
  ListCover.Move ListAll.Left, ListAll.Top, ListAll.Width, ListAll.Height
  ListCover.AddItem "One"
  ListCover.AddItem "Moment"
  ListCover.AddItem "Please..."
  GaugeAll.Min = 0
  GaugeReal.Min = 0
  GaugeOnly.Min = 0
End Sub

Function NextMatch$ (ByVal S$, C$)
  Dim Criteria$, Code%
  NextMatch = ""
  If (Len(S) = 1) And (C = "@") And InStr("01", S) Then
    NextMatch = S$
  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
  End If
  C$ = Chr$(Asc(C$) + 1)
End Function

Sub OnlyRealWords (ByVal S$, ByVal SAcc$)
  Dim N%, SPart$, SDecode$
  Dim Char As String * 1
  If Not Continue Then Exit Sub
  For N = 1 To Len(S)
    DoEvents
    If Not Continue Then Exit Sub
    SPart$ = Mid$(S, 1, N)
    Char = "@"
    SDecode = NextMatch(SPart, Char)
    Do While SDecode <> ""
      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
    GaugeOnly.Value = GaugeOnly.Value + 1
  Next N
End Sub

Sub PhoneEdit_Change ()
  ListAll.Clear
  ListReal.Clear
  ListOnly.Clear
  'NO ListCover.Clear
  LabelAll.Caption = ""
  LabelReal.Caption = ""
  LabelOnly.Caption = ""
  GaugeAll.Value = 0
  GaugeReal.Value = 0
  GaugeOnly.Value = 0
End Sub

Sub PictureAll_Click ()
  ToClip ListAll
End Sub

Sub PictureOnly_Click ()
  ToClip ListOnly
End Sub

Sub PictureReal_Click ()
  ToClip ListReal
End Sub

Sub ToClip (L As ListBox)
  Dim N%, Text$
  Text$ = ""
  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 Text$ = "" Then
    MsgBox "No items are selected", 0
  Else
    Clipboard.Clear
    Clipboard.SetText Text$
  End If
End Sub