home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast.iso
/
pcmag
/
vol12n18.zip
/
FONSRC.ZIP
/
FONEWORD.TXT
< prev
next >
Wrap
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