25 Years of Programming
An open source source for C, C++, OWL, BASIC, MDB, XLS, DOT, and more...

Home Projects Up Sitemap Search Blog Forum+Chat About Us Privacy Terms of Use Feedback FAQ Images Services Ads Donate Humor

Language translation
by Google is available
when JavaScript enabled.
Google Translate
is an alternative.

Microsoft Word 2003 Visual Basic Macros from AI.DOT

This is the macro code from my AI.DOT template, used by the RECORDS.MDB project for processing records into the database. It is presented here for examination. If you download the project, the code is already in the template.

Most, but not all, of this code is just about the same as the Microsoft Word 6.0 WordBasic version, but this version is less readable because Visual Basic apparently imports WordBasic code into itself by prepending "WordBasic." to every statement!

Some of the macros refer to disk files by absolute locations, so they require modification before being run.

AppendToTracksTable

Attribute VB_Name = "AppendToTracksTable"

Public Sub MAIN()
Dim ThisMaxID$
Dim sql$
Dim Chan1
Dim MyData$
Dim LastID
Dim Chan2
Dim NewID
Dim a$
Rem AppendToTracksTable, assigned to EXPORT button, 6/03/02
Rem (c)Copyright 2000,2002 by Steven Whitney
Rem automatically exports contents of tabledata to records.mdb tracks table,
Rem 1 row at a time to avoid confirmation dialog in msaccess.

'11/2/04:  Keep all this this code in case I figure out how to do it the old
'way.  But for now, it just transfers the tracks into a separate MSWord .DOC,
'from which you can cut and paste it into Tracks in one operation. I've
'remmed out all the old code.

On Error GoTo -1: On Error GoTo 0
WordBasic.DDETerminateAll

If Not WordBasic.Call("Fns.OpenRECORDSDatabase") Then GoTo bye

ActiveDocument.FollowHyperlink ("C:\Documents and Settings\Owner\My Documents\My Databases (MISC)\RECORDSTRANSFERTABLE.DOC")
AppActivate "RECORDS.DOC - Microsoft Word", False

Rem warn user if this MaxID is already in MDB.  Will be useful if I start
'pre-scanning records that I listen to, out of the mass-scanning sequence.
WordBasic.WW7_EditGoTo Destination:="MaxID": WordBasic.LineDown
ThisMaxID$ = WordBasic.[LTrim$](WordBasic.[RTrim$](Str(WordBasic.Val(WordBasic.[GetBookmark$]("\cell")))))
If WordBasic.Val(ThisMaxID$) = 0 Then
    WordBasic.MsgBox "MaxID must not be empty.  Revise and try again.", "Field Error", 48
    GoTo bye
End If
sql$ = "SELECT DISTINCTROW Count(*) AS CountOfMaxID FROM Tracks WHERE ((Tracks.MaxID=" + ThisMaxID$ + "));"
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
If Chan1 = 0 Then WordBasic.MsgBox "Chan1 failed": GoTo bye
MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
WordBasic.DDETerminate Chan1
Rem MsgBox sql$
Rem MsgBox Str$(Val(MyData$)) : Goto bye

If WordBasic.Val(MyData$) > 0 Then If WordBasic.MsgBox("The MaxID of this record is already in RECORDS.MDB.  Post the new entries anyway? (Normal=No)", "Duplicate Entry Warning", 292) <> -1 Then GoTo bye

Rem get the counter value of the last record to verify each pasteappend
'sql$ = "SELECT DISTINCTROW TOP 1 Tracks.ID FROM Tracks ORDER BY Tracks.ID DESC;"
'Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
'If Chan1 = 0 Then WordBasic.MsgBox "Chan1 failed": GoTo bye
'MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
'LastID = WordBasic.Val(MyData$): ' ID IS THE FIRST FIELD

Rem to watch, activate it *before* the transfer, apparently done by idleaction. if enabled, you see it from msaccess; if disabled, from msword.
Rem MicrosoftAccess

'OLD method, kept as a block
'WordBasic.WW7_EditGoTo Destination:="t1": WordBasic.WW7_EditGoTo Destination:="\Cell"
'WordBasic.LineDown
'While WordBasic.SelInfo(12) = -1        'while selection is within the table
'    WordBasic.TableSelectRow
'    WordBasic.EditCut
'    DDEExecute Channel:=Chan1, Command:="[PasteAppendTracks]"
'    Rem a new channel to get the latest info. chan1 just returns the same as before.
'    Chan2 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
'    MyData$ = WordBasic.[DDERequest$](Chan2, "NextRow")
'    WordBasic.DDETerminate Chan2
'    NewID = WordBasic.Val(MyData$)
'    If NewID = LastID Then
'        a$ = Str(LastID) + " " + Str(NewID) + ": "
'        WordBasic.MsgBox a$ + "Immediately paste somewhere, resolve the problem and retry the transfer.", "MSAccess paste failed.", 48
'        GoTo a1
'    End If
'    LastID = NewID
'Wend

'11/2/04: NEW method.
AppActivate "RECORDS.DOC - Microsoft Word", False
WordBasic.WW7_EditGoTo Destination:="t1": WordBasic.WW7_EditGoTo Destination:="\Cell"
WordBasic.LineDown
While WordBasic.SelInfo(12) = -1        'while selection is within the table
    'just 1 line at a time; couldn't figure out how to do whole table at once.
    WordBasic.TableSelectRow
    WordBasic.EditCut
    AppActivate "RECORDSTRANSFERTABLE.DOC - Microsoft Word", False
    WordBasic.EndOfDocument
    WordBasic.EditPaste
    AppActivate "RECORDS.DOC - Microsoft Word", False
Wend
AppActivate "RECORDSTRANSFERTABLE.DOC - Microsoft Word", False
ActiveDocument.Save

a1:
'WordBasic.DDETerminate Chan1
Rem do some cleanup:
AppActivate "RECORDS.DOC - Microsoft Word", False
WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\section"
Rem just make sure remaining data is all garbage before you export!
WordBasic.WW6_EditClear

bye:
WordBasic.ViewZoom ZoomPercent:="100%"

End Sub

BreakDocIntoSections

Attribute VB_Name = "BreakDocIntoSections"

Public Sub MAIN()
Rem BreakDocIntoSections, 3/15/02
Rem a utility sub that only needs to be called once per doc, & shouldn't be called by pgm.
Rem before running, edit it here to specify the search string, the UNIQUE text that indicates a break between database records.  (It can't exist in the text for any other purpose.)
Rem It turns each instance of the indicator text into a true section break.
WordBasic.StartOfDocument
WordBasic.EditFind Find:="-----^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
While WordBasic.EditFindFound()
    WordBasic.WW6_EditClear
    WordBasic.InsertBreak Type:=3
    WordBasic.EditFind
Wend
End Sub

ChangeFirstSpaceToColon

Attribute VB_Name = "ChangeFirstSpaceToColon"

Public Sub MAIN()
Dim c
Rem ChangeFirstSpaceToColon
Rem 3/27/02
Rem change [composer composition] to [composer:composition] in all lines in selection
If Len(WordBasic.[Selection$]()) = 1 Then
    WordBasic.WW7_EditGoTo Destination:="\Para"
    WordBasic.EditReplace Find:=" ", Replace:=":", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceOne:=1, Format:=0, Wrap:=0
    GoTo bye
End If
WordBasic.CopyBookmark "\StartOfSel", "StartPoint"
WordBasic.CopyBookmark "\EndOfSel", "EndPoint"
WordBasic.WW7_EditGoTo Destination:="\Para"
c = WordBasic.CmpBookmarks("\EndOfSel", "EndPoint")
While (c = 2) Or (c = 0)
    WordBasic.EditReplace Find:="(>)( )", Replace:="\1:", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceOne:=1, Format:=0, Wrap:=0
    WordBasic.ParaDown: WordBasic.WW7_EditGoTo Destination:="\Para"
    c = WordBasic.CmpBookmarks("\EndOfSel", "EndPoint")
Wend
WordBasic.WW7_EditGoTo Destination:="StartPoint"
WordBasic.EditBookmark Name:="EndPoint", SortBy:=1, Delete:=1
WordBasic.EditBookmark Name:="StartPoint", SortBy:=1, Delete:=1
bye:
End Sub

DeSpaceWholeLines

Attribute VB_Name = "DeSpaceWholeLines"

Public Sub MAIN()
Dim a$
Rem DeSpaceWholeLines
Rem this search string locates this p r o b l e m, and other errors.
a$ = "( )([!ABCDEFGIai\-&/:0-9,.•])( )"
WordBasic.EditFind Find:=a$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, Format:=0, Wrap:=0
While WordBasic.EditFindFound()
    WordBasic.WW7_EditGoTo Destination:="\Para"
    If WordBasic.MsgBox("De-space this whole line?", "Please verify", 36) = -1 Then WordBasic.Call "RemoveAllSpaces"
    WordBasic.EndOfLine
    WordBasic.EditFind Find:=a$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, Format:=0, Wrap:=0
Wend
End Sub

DoAllAutoFilldowns

Attribute VB_Name = "DoAllAutoFilldowns"

Public Sub MAIN()
Dim i
Rem DoAllAutoFilldowns, assigned to FILLDOWNS button, 4/14/02
Rem fills down repeating entries in the DataTable.
Rem do this as last step before export.
Rem This new version is generalizable to other uses besides RECORDS, but it isn't as smart.
Rem BEFORE running it, you must anticipate what it will do and pre-arrange the table entries if needed.  (This usually isn't necessary.)
Rem It can make mistakes, which you may have to undo.

Rem this seems to affect accuracy: if table is wider than screen, macro gets confused
WordBasic.ViewZoom ZoomPercent:="40%"
WordBasic.WW7_EditGoTo Destination:="t1": WordBasic.WW7_EditGoTo Destination:="\table"
WordBasic.WW7_EditGoTo Destination:="\Cell":     ' if sel has > 1 cell, this selects only the first
If WordBasic.SelInfo(15) < 3 Then GoTo bye: ' Table only has 1 data row
WordBasic.LineDown: ' autofill starts 1 line below heading row
i = WordBasic.Call("Fns.TableFillDownBlanksAll")

Rem some special checks
WordBasic.WW7_EditGoTo Destination:="MaxID": WordBasic.LineDown
If WordBasic.Call("Fns.CellIsEmpty") Then
    WordBasic.ViewZoom ZoomPercent:="100%"
    WordBasic.MsgBox "MaxID must not be empty.  Revise and try again.", "Field Error", 48
    GoTo bye
End If
WordBasic.WW7_EditGoTo Destination:="RPM": WordBasic.LineDown
If WordBasic.Call("Fns.CellIsEmpty") Then
    WordBasic.ViewZoom ZoomPercent:="100%"
    WordBasic.MsgBox "RPM must not be empty.  Revise and try again.", "Field Error", 48
    GoTo bye
End If

bye:
WordBasic.WW7_EditGoTo Destination:="t1": WordBasic.WW7_EditGoTo Destination:="\table"
WordBasic.WW7_EditGoTo Destination:="\Cell":     ' if sel has > 1 cell, this selects only the first
WordBasic.LineDown
WordBasic.ViewZoom ZoomPercent:="60%"

End Sub

Fns

Attribute VB_Name = "Fns"

Public Sub MAIN()
Attribute MAIN.VB_Description = "Central storage loc for functions used by other routines."
Attribute MAIN.VB_ProcData.VB_Invoke_Func = "TemplateProject.Fns.MAIN"
Rem Fns (functions), (c)Copyright 2000,2002 by Steven Whitney   3/28/02
Rem this macro itself does nothing.  it only holds functions for other macros.
'a function is a subroutine that returns a value. all others can simply be
'independent macros.
End Sub
Rem ----------------------------------------------------------------------------
Private Function CopySelOrLine$()
Rem if there is a selection, copy it, else copy the whole line.  On exit, it leaves the selection in place and selected, but possibly modified.
CopySelOrLine$ = ""
If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.WW7_EditGoTo Destination:="\Para":   ' takes paramark
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo CSOLbye: ' there's nothing except paramark
Rem compress all selection's whitespace (incl paramarks) to a single space.
WordBasic.EditReplace Find:="^p", Replace:=" ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^w", Replace:=" ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
Rem strip any (rare) nonprinting chars and strip both ends
CopySelOrLine$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[Selection$]())))
CSOLbye:
End Function
Rem ----------------------------------------------------------------------------
Private Function TransferToDataTable(BkmarkName$)
Dim a$
Dim i
Rem MOVES the selected text to the data table, at the named bookmark.
Rem if there is no selection, use the entire line containing the cursor.
a$ = CopySelOrLine$
Rem cut out what we copied, and set a temporary bookmark to this location.
WordBasic.EditCut
WordBasic.EditBookmark Name:="temp", SortBy:=1, Add:=1
WordBasic.WW7_EditGoTo Destination:=BkmarkName$
i = DownToFirstEmptyCell
Rem if it failed, paste the original (but modified) selection back where it was.
If Not i Then WordBasic.WW7_EditGoTo Destination:="temp"
WordBasic.Insert a$
WordBasic.WW7_EditGoTo Destination:="temp"
TransferToDataTable = i
End Function
Rem ----------------------------------------------------------------------------
Private Function TextToDataTable(text_$, BkmarkName$)
Dim i
Rem inserts text$ into the data table, at the named bookmark.
WordBasic.EditBookmark Name:="TTDTtemp", SortBy:=1, Add:=1
WordBasic.WW7_EditGoTo Destination:=BkmarkName$
i = DownToFirstEmptyCell
Rem if it failed, paste the text at TTDTtemp for debugging review.
If Not i Then WordBasic.WW7_EditGoTo Destination:="TTDTtemp"
WordBasic.Insert text_$
WordBasic.WW7_EditGoTo Destination:="TTDTtemp"
WordBasic.EditBookmark Name:="TTDTtemp", SortBy:=1, Delete:=1
TextToDataTable = i
End Function
Rem ----------------------------------------------------------------------------
Private Function CellText$()
Dim a$
CellText$ = ""
If WordBasic.SelInfo(12) = -1 Then
    a$ = WordBasic.[GetBookmark$]("\cell")
    CellText$ = WordBasic.[Left$](a$, Len(a$) - 2)
End If
End Function
Rem ----------------------------------------------------------------------------
Private Function CellIsEmpty()
Rem returns true if a cell is empty, false if it has text. (if not in a table, it detects a blank line). it leaves cursor at start of line(cell)
WordBasic.StartOfLine
CellIsEmpty = Not WordBasic.EndOfLine()
WordBasic.StartOfLine
End Function
Rem ----------------------------------------------------------------------------
Private Function DownToFirstEmptyCell()
Rem positions cursor in first empty cell below the last filled cell in the column. returns true if it succeeds, false if there was no empty cell. it leaves cursor at start of the cell if it succeeds, else at end of table.
Rem with more tests for running off start or end of table, this could become a normal macro, that wouldn't have to return a value because it would always succeed, unless not in a table to begin with.
DownToFirstEmptyCell = 0
WordBasic.SelType 1:                         'deselect & position at start of selection
If WordBasic.SelInfo(12) <> -1 Then GoTo DTFECbye:  'if not in a table, do nothing
DownToFirstEmptyCell = -1:           'now success is the default
WordBasic.EndOfColumn
If Not CellIsEmpty Then             'table is filled up, so add a row
    WordBasic.EditBookmark Name:="tempbottom", SortBy:=1, Add:=1
    While WordBasic.SelInfo(12) = -1: WordBasic.LineDown: Wend      'down to first line below the table
    WordBasic.StartOfLine                               'append a row to the table
    WordBasic.TableInsertRow NumRows:="1"
    WordBasic.WW7_EditGoTo Destination:="tempbottom"    'go back where you were
    WordBasic.EditBookmark Name:="tempbottom", SortBy:=1, Delete:=1
    WordBasic.EndOfColumn                           'now go to the new last cell in column
End If
While CellIsEmpty               'go up until you find first FILLED cell
    If Not WordBasic.LineUp() Then      'top line is empty: error! should never happen
        WordBasic.EndOfColumn
        DownToFirstEmptyCell = 0
        GoTo DTFECbye
    End If
Wend
WordBasic.LineDown                      'return to the last empty cell
DTFECbye:
End Function
Rem ----------------------------------------------------------------------------
Private Function TableFillDownBlanks()
Rem 3/12/02
Rem starting from current cell, copies the contents of each cell with text into all blank cells below it.  each cell with existing text changes the fill value to that text.
TableFillDownBlanks = 0
If WordBasic.SelInfo(12) <> -1 Then GoTo bye1:  ' if not in a table, do nothing
WordBasic.EditBookmark Name:="TFDBtemp", SortBy:=1, Add:=1
WordBasic.WW7_EditGoTo Destination:="\Cell":     ' if sel has > 1 cell, this selects only the first
WordBasic.EditCopy: ' copy cell whether it has text or not
While WordBasic.SelInfo(12) = -1
    If CellIsEmpty Then
        WordBasic.EditPaste
    Else
        WordBasic.WW7_EditGoTo Destination:="\Cell":     ' must select it all
        WordBasic.EditCopy
    End If
    WordBasic.LineDown
Wend
WordBasic.WW7_EditGoTo Destination:="TFDBtemp"
WordBasic.EditBookmark Name:="TFDBtemp", SortBy:=1, Delete:=1
TableFillDownBlanks = -1
bye1:
End Function
Rem ----------------------------------------------------------------------------
Private Function TableFillDownBlanksAll()
Dim i
Dim oldcol
Dim newcol
Rem 3/13/02
Rem calls TableFillDownBlanks for all columns from current cell to right side of table. To exclude top or left side headers, place cursor below and to the right of them before calling.
TableFillDownBlanksAll = 0
If WordBasic.SelInfo(12) <> -1 Then GoTo bye2:  ' if not in a table, do nothing
WordBasic.EditBookmark Name:="TFDBRtemp", SortBy:=1, Add:=1:       ' save absolute start loc
WordBasic.WW7_EditGoTo Destination:="\Cell":     ' if sel has > 1 cell, this selects only the first
Rem if in last row, it's a success, but do nothing
If WordBasic.SelInfo(13) = WordBasic.SelInfo(15) Then GoTo L1
While 1
    i = TableFillDownBlanks: ' this leaves cursor at original top of column
    oldcol = WordBasic.SelInfo(16): WordBasic.NextCell: newcol = WordBasic.SelInfo(16)
    If newcol <= oldcol Then GoTo L1
Wend
L1:
TableFillDownBlanksAll = -1
bye2:
If WordBasic.ExistingBookmark("TFDBRtemp") Then
    WordBasic.WW7_EditGoTo Destination:="TFDBRtemp"
    WordBasic.EditBookmark Name:="TFDBRtemp", SortBy:=1, Delete:=1
End If
End Function
Rem ----------------------------------------------------------------------------
Private Function OpenDatabase_(fullpath$)
Rem fullpath$ MUST be the full path name of the MDB file.
OpenDatabase_ = -1: ' success is default

ActiveDocument.FollowHyperlink (fullpath$)
AppActivate "RECORDS.DOC - Microsoft Word", False

End Function
Rem ----------------------------------------------------------------------------
Private Function OpenRECORDSDatabase()
Rem this old fn is for temporary convenience because many macros call it.
OpenRECORDSDatabase = OpenDatabase_("C:\Documents and Settings\Owner\My Documents\My Databases (MISC)\RECORDS.MDB")
End Function
Rem ----------------------------------------------------------------------------
Private Function StartWTalk()
Dim wordWin$
StartWTalk = 0          'failure is default
Rem must start mdb first.  if wtalk does it, this macro doesn't work properly.
If Not OpenDatabase_("C:\AI\TALK\WTALK.MDB") Then GoTo bye4
wordWin$ = "Microsoft Word - " + WordBasic.[WindowName$]()
If Not WordBasic.AppIsRunning("WTalk") Then
    WordBasic.Shell "C:\AI\TALK\WTALK.EXE"
    WordBasic.AppActivate wordWin$, 1       'immediately return to word
End If
StartWTalk = -1     'everything is ok
bye4:
End Function
Rem ----------------------------------------------------------------------------
Private Function DDEField$(Source$, Index_)
Dim a$
Dim tab2
Dim i
Dim tab1
Rem given a TAB-delimited DDERequest$ row, returns the data for an individual field.
Rem The Index of the first field is 1, not 0.
DDEField$ = ""
a$ = Source$ 'local copy
If Len(a$) Then
    If WordBasic.[Right$](a$, 1) <> Chr(9) Then a$ = a$ + Chr(9)
    tab2 = 0
    For i = 1 To Index_
        tab1 = tab2 + 1
        tab2 = InStr(tab1, a$, Chr(9))
    Next i
    If tab2 > tab1 Then DDEField$ = Mid(a$, tab1, tab2 - tab1)
End If
End Function
Rem ----------------------------------------------------------------------------
Private Sub CreateDataTableFromMDB(FullPathMDB$, TableName$)
Dim Chan1
Dim FieldCount
Dim Row$
Dim i
Dim a$
Rem given the database name and table name, this sets up the data transfer table into
Rem which you transfer data from the text and from which you export it to the database.
Rem each database field gets its own column.  Use this to reconstruct a damaged table.
If Not OpenDatabase_(FullPathMDB$) Then GoTo bye10
Chan1 = WordBasic.DDEInitiate("MSAccess", FullPathMDB$ + ";TABLE " + TableName$)
If Chan1 = 0 Then GoTo bye10
FieldCount = WordBasic.Val(WordBasic.[DDERequest$](Chan1, "FieldCount"))
Row$ = WordBasic.[DDERequest$](Chan1, "FieldNames")
WordBasic.DDETerminate Chan1
Rem blank line at top is because it's hard to insert one after the table is in place.
WordBasic.StartOfDocument: WordBasic.InsertPara: WordBasic.Insert Row$: WordBasic.WW7_EditGoTo Destination:="\Para"
WordBasic.TextToTable ConvertFrom:="1", NumColumns:=FieldCount, NumRows:="1", InitialColWidth:="Auto", Format:="0", Apply:="167"
WordBasic.TableColumnWidth ColumnWidth:="", SpaceBetweenCols:="0.15" + Chr(34), AutoFit:=1, RulerStyle:="0"
WordBasic.WW7_EditGoTo Destination:="\cell"
For i = 1 To FieldCount
    WordBasic.StartOfLine
    a$ = DDEField$(Row$, i)
    WordBasic.EditBookmark Name:=a$, SortBy:=1, Add:=1
    If i <> FieldCount Then WordBasic.NextCell
Next i
WordBasic.StartOfDocument
WordBasic.MsgBox "You probably want to use Ctrl+Shift+Drag Border, which adjusts only the 1 column.", "To Revise Column Widths"
bye10:
End Sub
Rem ----------------------------------------------------------------------------

InsertCommas

Attribute VB_Name = "InsertCommas"

Public Sub MAIN()
Rem InsertCommas
WordBasic.WW7_EditGoTo Destination:="\para"
If Len(WordBasic.[Selection$]()) > 1 Then WordBasic.EditReplace Find:=" ", Replace:=", ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
End Sub

MoveARecordToDocTop

Attribute VB_Name = "MoveARecordToDocTop"

Public Sub MAIN()
Dim tofind$
Rem MoveARecordToDocTop
Rem 5/24/02
WordBasic.StartOfDocument
tofind$ = WordBasic.[InputBox$]("Record number to find (its MaxID):", "Find and Move To Doc Top")
If WordBasic.Val(tofind$) = 0 Then GoTo bye
WordBasic.EditFind Find:=tofind$, Direction:=0, MatchCase:=0, WholeWord:=1, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
If WordBasic.EditFindFound() Then
    WordBasic.WW7_EditGoTo Destination:="\section"
    WordBasic.EditCut
    WordBasic.WW7_EditGoTo Destination:="s2"
    WordBasic.EditPaste
    WordBasic.StartOfDocument
End If
bye:
End Sub

MoveSectionToBottom

Attribute VB_Name = "MoveSectionToBottom"

Public Sub MAIN()
Rem MoveSectionToBottom
Rem moves the current ONE section (only) to bottom of records list,
Rem as lowest priority for getting into records.mdb.
Rem (you should ensure end of document already has a trailing section break.)
Rem 9/28/02

If WordBasic.SelInfo(2) < 2 Then GoTo bye
WordBasic.WW7_EditGoTo Destination:="\section"
WordBasic.EditCut
WordBasic.EditBookmark Name:="MSTTTemp", SortBy:=0, Add:=1
WordBasic.EndOfDocument
WordBasic.EditPaste
WordBasic.WW7_EditGoTo Destination:="MSTTTemp"
WordBasic.EditBookmark Name:="MSTTTemp", SortBy:=0, Delete:=1

bye:
End Sub

MoveSectionToTop

Attribute VB_Name = "MoveSectionToTop"

Public Sub MAIN()
Rem MoveSectionToTop
Rem moves the current ONE section (only) to top of records list
Rem 9/28/02

If WordBasic.SelInfo(2) < 3 Then GoTo bye       'must be at or beyond section 3
WordBasic.WW7_EditGoTo Destination:="\section"
WordBasic.EditCut
WordBasic.EditBookmark Name:="MSTTTemp", SortBy:=0, Add:=1
WordBasic.WW7_EditGoTo Destination:="s2"
WordBasic.EditPaste
WordBasic.WW7_EditGoTo Destination:="MSTTTemp"
WordBasic.EditBookmark Name:="MSTTTemp", SortBy:=0, Delete:=1

bye:
End Sub

PasteComments

Attribute VB_Name = "PasteComments"

Public Sub MAIN()
Dim i
Rem PasteComments, assigned to COMMENTS button, 3/24/02
i = WordBasic.Call("Fns.TransferToDataTable", "Comments")
End Sub

PasteComposer

Attribute VB_Name = "PasteComposer"

Public Sub MAIN()
Dim i
Rem PasteComposer, assigned to COMPOSER button, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Composer")
End Sub

PasteComposition

Attribute VB_Name = "PasteComposition"

Public Sub MAIN()
Dim i
Rem PasteComposition, assigned to COMPOSITION button, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Composition")
End Sub

PasteCompositionX2

Attribute VB_Name = "PasteCompositionX2"

Public Sub MAIN()
Dim i
Rem PasteComposition, can be assigned to CX2 button when desired, 3/24/02
Rem handy for 45's and 78's, BUT ALWAYS DO THIS LAST
REM 12/26/05 I don't remember what this was for or why it was "handy".
i = WordBasic.Call("Fns.TransferToDataTable", "Composition")
i = WordBasic.Call("Fns.TransferToDataTable", "Composition")
WordBasic.Call "DoAllAutoFilldowns"
End Sub

PasteConductor

Attribute VB_Name = "PasteConductor"

Public Sub MAIN()
Dim i
Rem PasteConductor, assigned to CONDUCTOR button, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Conductor")
End Sub

PasteMaxID

Attribute VB_Name = "PasteMaxID"

Public Sub MAIN()
Dim i
Rem PasteMaxID, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "MaxID")
End Sub

PasteMemo

Attribute VB_Name = "PasteMemo"

Public Sub MAIN()
Dim i
Rem PasteMemo, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Memo")
End Sub

PasteOrchestra

Attribute VB_Name = "PasteOrchestra"

Public Sub MAIN()
Dim i
Rem PasteOrchestra, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Orchestra")
End Sub

PasteRCID

Attribute VB_Name = "PasteRCID"

Public Sub MAIN()
Dim i
Rem PasteRCID, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "RCID")
End Sub

PasteRPM

Attribute VB_Name = "PasteRPM"

Public Sub MAIN()
Dim i
Rem PasteRPM, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "RPM")
End Sub

PasteSoloist

Attribute VB_Name = "PasteSoloist"

Public Sub MAIN()
Dim i
Rem PasteSoloist, 3/10/02
Rem format the line as you want it before calling, with multiple soloists on same line, if appropriate.
i = WordBasic.Call("Fns.TransferToDataTable", "Soloists")
End Sub

PasteTitle

Attribute VB_Name = "PasteTitle"

Public Sub MAIN()
Dim i
Rem PasteTitle, assigned to TITLE button, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Title")
End Sub

PasteYear

Attribute VB_Name = "PasteYear"

Public Sub MAIN()
Dim i
Rem PasteYear, 3/10/02
i = WordBasic.Call("Fns.TransferToDataTable", "Year")
End Sub

ProcessOneRecord

Attribute VB_Name = "ProcessOneRecord"

Public Sub MAIN()
Dim i
Dim s$
Dim t$
Dim a$
Dim q$
Dim SQLCount
Dim ChunkSize
Dim startpos
Dim Chan1
Dim ComposersIndex
Dim CompositionsIndex
Dim Loc_
Dim Length
Dim Row$
Dim MinLoc
Dim Match$
Dim Source$
Dim dummy
Dim Discard$
Dim UsePatternMatch
Dim result
Dim colon
Dim stillgood
Dim GotOne
Rem ProcessOneRecord, assigned to the START button, 6/4/02
Rem (c)Copyright 2000,2002 by Steven Whitney
Rem this is the starting point for processing a record.  before calling it, you should
Rem clean up spelling, etc.  also try to anticipate what the pgm will do automatically,
Rem and do any manual pre-processing that will prevent anticipated errors.

Rem setup, reset, restore startup things (zoom, etc.)
On Error GoTo -1: On Error GoTo 0
WordBasic.DDETerminateAll
WordBasic.ViewZoom ZoomPercent:="100%"

ActiveDocument.FollowHyperlink ("C:\Documents and Settings\Owner\My Documents\My Databases (MISC)\Records.mdb")
AppActivate "RECORDS.DOC - Microsoft Word", False

Rem 7/13/2004 started converting this; only got to here.

Rem the record to process is always in Section 2 of the doc.
WordBasic.WW7_EditGoTo Destination:="s2"  'this puts cursor on the first line.
Rem maxid is always the first data line; extract it before any case changes, etc.
i = WordBasic.Call("Fns.TransferToDataTable", "MaxID")

WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\Section"
Rem Auto-SpellCheck is a hindrance, but if you hit a spelling error, you should
Rem SpellCheck at least several pages into the doc.
Rem ToolsSpellSelection
WordBasic.FormatChangeCase Type:=2:   ' title case is reliable if it starts all upper or lower
WordBasic.FormatChangeCase Type:=3:   ' change block to title case

Rem push the section end down a line, away from any text we might cut
WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\Section"
WordBasic.WW7_EditGoTo Destination:="\EndOfSel": WordBasic.CharLeft: WordBasic.InsertPara

Rem ----- START OF UNION QUERY MUTI-SEARCH SECTION
WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\section"
WordBasic.EditCopy: ' preserve original text
s$ = WordBasic.Call("Fns.CopySelOrLine$"): ' this removes paramarks, compresses, trims, and cleans
WordBasic.WW6_EditClear: ' delete the modified selection
WordBasic.EditPaste: ' restore the original text.
Rem ScreenRefresh
Rem strip all quotes, which would confuse SQL parser at the InStr() call.
t$ = ""
For i = 1 To Len(s$)
    a$ = Mid(s$, i, 1)
    If a$ <> Chr(34) Then t$ = t$ + a$
Next i
s$ = t$: ' s$ is stripped for searching
t$ = Chr(34) + s$ + Chr(34): ' t$ is in quotes for the SQL
ReDim Composers__$(10): ReDim Compositions__$(10) 'must do here in case section is skipped
If Len(s$) < 5 Then GoTo ENDUNIONQUERY: ' nothing left worth searching for

Rem This all-fields-at-once union query searches the database for all records
Rem whose text is found in the selection.  Returns matches in the order found.
Rem If multiple matches start at the same loc, returns the longest. The advantage of this method is that
'the search order of the fields isn't fixed.
Rem You must build the query string here (not use a built-in)
Rem so you can provide the t$ text.
q$ = "SELECT DISTINCT Conductor as Match, " + Chr(34) + "Conductor" + Chr(34) + " as Source, InStr(Txt,Conductor) as Loc, Len(Conductor) as Length, " + t$ + " as Txt "
q$ = q$ + "FROM Tracks "
q$ = q$ + "WHERE ((Conductor Is Not Null) AND (InStr(" + t$ + ",Conductor)>0)) "
q$ = q$ + "UNION SELECT DISTINCT Orchestra as Match, " + Chr(34) + "Orchestra" + Chr(34) + " as Source, InStr(Txt,Orchestra) as Loc, Len(Orchestra) as Length, " + t$ + " as Txt "
q$ = q$ + "FROM Tracks "
q$ = q$ + "WHERE ((Orchestra Is Not Null) AND (InStr(" + t$ + ",Orchestra)>0)) "
q$ = q$ + "UNION SELECT DISTINCT Soloists as Match, " + Chr(34) + "Soloists" + Chr(34) + " as Source, InStr(Txt,Soloists) as Loc, Len(Soloists) as Length, " + t$ + " as Txt "
q$ = q$ + "FROM Tracks "
q$ = q$ + "WHERE ((Soloists Is Not Null) AND (InStr(" + t$ + ",Soloists)>0)) "
q$ = q$ + "UNION SELECT DISTINCT Composer as Match, " + Chr(34) + "Composer" + Chr(34) + " as Source, InStr(Txt,Composer) as Loc, Len(Composer) as Length, " + t$ + " as Txt "
q$ = q$ + "FROM Tracks "
q$ = q$ + "WHERE ((Composer Is Not Null) AND (InStr(" + t$ + ",Composer)>0)) "
q$ = q$ + "UNION SELECT DISTINCT Composition as Match, " + Chr(34) + "Composition" + Chr(34) + " as Source, InStr(Txt,Composition) as Loc, Len(Composition) as Length, " + t$ + " as Txt "
q$ = q$ + "FROM Tracks "
q$ = q$ + "WHERE ((Composition Is Not Null) AND (InStr(" + t$ + ",Composition)>0)) "
q$ = q$ + "ORDER BY Loc, Length DESC; "

Rem Open "c:\database\records\error.log" For Append As #1 : Print #1, q$ : print #1," " : Close #1

Rem cut q$ into pieces < 256 chars each, into successive SQL$() elements
SQLCount = 80
ReDim SQL__$(SQLCount): ' holds the cut-up pieces of the SQL string
ChunkSize = 255: ' initial size is the maximum allowable

Rem START OF CHUNKING LOOP
StartDDETry:
On Error GoTo -1: On Error GoTo 0
i = 0: startpos = 1
While startpos <= Len(q$)
    SQL__$(i) = Mid(q$, startpos, ChunkSize): ' copy the first ChunkSize chars
    startpos = startpos + ChunkSize
    i = i + 1
Wend
Rem Send the SQL query and process result
On Error GoTo -1: On Error GoTo DDEDone:  ' a connect failure is unrecoverable
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL ")
On Error GoTo -1: On Error GoTo HandleChunkingError
i = 0
While Len(SQL__$(i))
    WordBasic.DDEPoke Chan1, "SQLTEXT", SQL__$(i)
    i = i + 1
Wend
GoTo BeyondChunkingError: ' if we got here, all DDEPokes succeeded

Rem ERROR HANDLER: CLOSE CHAN1, RESIZE THE CHUNKS, AND TRY AGAIN.
Rem q$ can be cut up in a way that confuses the SQL parser.
Rem cut it up into different size chunks and try again.
HandleChunkingError:
On Error GoTo -1: On Error GoTo 0
Open "c:\Documents and Settings\Owner\My Documents\My Databases (MISC)\error.log" For Append As 1: Print #1, "This " + Str(ChunkSize) + "-length DDEPoke failed: [" + SQL__$(i) + "]": Close 1
ChunkSize = ChunkSize - 7
If ChunkSize <= 100 Then GoTo DDEDone: ' abandon DDE and finish the best you can
WordBasic.DDETerminate Chan1
ReDim SQL__$(SQLCount)
GoTo StartDDETry

BeyondChunkingError:
On Error GoTo -1: On Error GoTo 0
q$ = "": t$ = "":  ' because we're through with them
ReDim SQL__$(1): ' conserves string space?

ComposersIndex = 0: CompositionsIndex = 0
Loc_ = 1: Length = 0
On Error GoTo -1: On Error GoTo DDEDone:  ' we're expecting an End Of Data error eventually
LOOP2:
    Row$ = WordBasic.[DDERequest$](Chan1, "NextRow")
    Rem the minimum starting point within s$ for a match to be used.  the query returns
    Rem all distinct matches found, longest first.  If we use the first match, we must
    Rem discard all the shorter matches whose loc falls WITHIN the text we just cut.
    Rem We also discard some matches (Composer, Composition).  Since they were perfectly
    Rem valid (we just didn't use them), we likewise want to discard any smaller matches
    Rem (regardless of their Source$) that occurred within them.  So any Loc we just
    Rem retrieved that is < MinLoc is in a section of text that, one way or another,
    Rem has already been processed. Loc and MinLoc must be relative to s$; there's no
    Rem telling where its corresponding loc is in the doc text, since we're constantly
    Rem cutting text out of it.
    MinLoc = Loc_ + Length      'start loc of the previous match + its length
    Match$ = WordBasic.Call("Fns.DDEField$", Row$, 1)
    Source$ = WordBasic.Call("Fns.DDEField$", Row$, 2)
    Loc_ = WordBasic.Val(WordBasic.Call("Fns.DDEField$", Row$, 3))
    Length = WordBasic.Val(WordBasic.Call("Fns.DDEField$", Row$, 4))

    If Loc_ < MinLoc Then GoTo DDELoopEnd
    Rem these only get added to arrays for later Tab1C, Tab2C tests.
    If Source$ = "Composer" Then
        Composers__$(ComposersIndex) = Match$: ComposersIndex = ComposersIndex + 1
        GoTo DDELoopEnd
    End If
    If Source$ = "Composition" Then
        Compositions__$(CompositionsIndex) = Match$: CompositionsIndex = CompositionsIndex + 1
        GoTo DDELoopEnd
    End If

    WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\Section"
    WordBasic.EditFind Find:=Match$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    If WordBasic.EditFindFound() Then
        dummy = WordBasic.Call("Fns.TransferToDataTable", Source$)
        If ParaIsAllGarbage Then WordBasic.WW7_EditGoTo Destination:="\Para": WordBasic.WW6_EditClear
Rem         ScreenRefresh
    End If
DDELoopEnd:
GoTo LOOP2

DDEDone:
WordBasic.DDETerminate Chan1
On Error GoTo -1: On Error GoTo 0
Rem ScreenRefresh
Rem ScreenUpdating 1
Rem ----- END OF UNION QUERY MUTI-SEARCH SECTION
ENDUNIONQUERY:

Rem pattern-match search for any remaining patterns that you know belong to particular
Rem fields.
Rem the table contains mostly RCID entries and RPM indicators,
Rem but can handle entries for any field.  This section is AFTER the union
Rem query so it can replace the old find-by-context-flag searches.  If a known
Rem conductor, for example, wasn't found, this can locate one using a pattern match search.
Rem You can even use this for temporary entries that you find repeatedly
Rem in a series of records.  Just delete the MDB entry when you no longer need it.
Rem Case is always significant when PatternMatch is used.
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;QUERY PatternMatchStringsByLength")
Rem ScreenUpdating 0
On Error GoTo -1: On Error GoTo LABEL1 'will get End Of Data error eventually
LOOP1:  'attempt to avoid while-wend missmatch problems
    Row$ = WordBasic.[DDERequest$](Chan1, "NextRow")
    Match$ = WordBasic.Call("Fns.DDEField$", Row$, 1)
    Source$ = WordBasic.Call("Fns.DDEField$", Row$, 2)
    Discard$ = WordBasic.Call("Fns.DDEField$", Row$, 3)
    If WordBasic.Val(WordBasic.Call("Fns.DDEField$", Row$, 4)) = 0 Then UsePatternMatch = 0 Else UsePatternMatch = 1
Rem     ShowVars
    WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\section"
    WordBasic.EditFind Find:=Match$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=UsePatternMatch, SoundsLike:=0, Format:=0, Wrap:=0
    While WordBasic.EditFindFound() 'loop will find multiple occurrences of the search string
        Rem if a discard string is specified, find it, cut it out, AND ask user if correct.
        Rem if it's not, put everything back as it was, and continue.
        i = -1:  ' temp flag whether TransferToDataTable is allowed this time.
        If Len(Discard$) Then
            WordBasic.EditBookmark Name:="pmtemp", SortBy:=1, Add:=1
            Rem #error it might be ok to use pattern matching for the discard string
            WordBasic.EditFind Find:=Discard$, Direction:=0, MatchCase:=1, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
            If WordBasic.EditFindFound() Then WordBasic.WW6_EditClear
            WordBasic.WW7_EditGoTo Destination:="pmtemp"  'reselect the originally-found data
            Rem the union query left behind all the flags, which now get found here.
            Rem So test length to determine whether selection is likely meaningful.
            If Len(WordBasic.[Selection$]()) > 5 Then
                Rem I've considered always verifying, but that would also verify RCIDs.
                Rem I've also considered a table field Verify, but don't do yet;
                Rem generally, if pgm makes a mistake here, you see it in the text
                Rem that it leaves behind.
                If WordBasic.MsgBox("Transfer this " + Source$ + "?", "Please verify", 36) <> -1 Then
                    Rem if you leave the flag cut out, it's easier because it won't
                    Rem be found again.  if you put it back in, you must cause the While                        rem EditFindFound() to abort, which is complicated.
                    Rem EditUndo'put back the context flag we cut out
                    i = 0 'prevent TransferToDataTable below
                End If
            Else
                Rem if sel is short enough, don't even bother asking.
                Rem but some text that SHOULD be transferred is always short, so test
                If Discard$ <> "rpm" Then i = 0
            End If
            WordBasic.EditBookmark Name:="pmtemp", SortBy:=1, Delete:=1
        End If
        If i Then result = WordBasic.Call("Fns.TransferToDataTable", Source$)
        If ParaIsAllGarbage Then WordBasic.WW7_EditGoTo Destination:="\Para": WordBasic.WW6_EditClear
Rem         ScreenRefresh
        WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\section"
        WordBasic.EditFind Find:=Match$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, Format:=0, Wrap:=0
    Wend
GoTo LOOP1
LABEL1:
WordBasic.DDETerminate Chan1
Rem ScreenRefresh

WordBasic.ScreenUpdating 0 'I'm usually reviewing the text, so prevent screen disruption.
Rem there should be an easier way to do this
WordBasic.WW7_EditGoTo Destination:="RPM"
If WordBasic.SelInfo(15) = 1 Then       'only 1 row in table
    result = WordBasic.Call("Fns.TextToDataTable", "33", "RPM")
Else
    WordBasic.WW7_EditGoTo Destination:="\cell": WordBasic.LineDown
    If WordBasic.Call("Fns.CellIsEmpty") Then result = WordBasic.Call("Fns.TextToDataTable", "33", "RPM")
End If
Rem put a 0 in the Kp column
WordBasic.WW7_EditGoTo Destination:="Kp"
If WordBasic.SelInfo(15) = 1 Then       'only 1 row in table
    result = WordBasic.Call("Fns.TextToDataTable", "0", "Kp")
Else
    WordBasic.WW7_EditGoTo Destination:="\cell": WordBasic.LineDown
    If WordBasic.Call("Fns.CellIsEmpty") Then result = WordBasic.Call("Fns.TextToDataTable", "0", "Kp")
End If
Rem put a 0 in the HD column
WordBasic.WW7_EditGoTo Destination:="HD"
If WordBasic.SelInfo(15) = 1 Then       'only 1 row in table
    result = WordBasic.Call("Fns.TextToDataTable", "0", "HD")
Else
    WordBasic.WW7_EditGoTo Destination:="\cell": WordBasic.LineDown
    If WordBasic.Call("Fns.CellIsEmpty") Then result = WordBasic.Call("Fns.TextToDataTable", "0", "HD")
End If
WordBasic.ScreenUpdating 1

Rem process all consecutive Tab2c-format lines
WordBasic.WW7_EditGoTo Destination:="s2"
LOOP3:
    WordBasic.WW7_EditGoTo Destination:="\Para"
    s$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[Selection$]()))): ' get the source
    Rem s$ MUST contain exactly one ":", and there must be something AFTER the colon
    colon = InStr(s$, ":")
    If colon = 0 Then GoTo StartTAB1CTests
    If Len(s$) = colon Then GoTo StartTAB1CTests
    If InStr(Mid(s$, colon + 1), ":") <> 0 Then GoTo StartTAB1CTests
    i = 0: stillgood = 0
    While Len(Composers__$(i)) > 0      ' must START w/composer name
        If InStr(s$, Composers__$(i)) = 1 Then stillgood = -1
        i = i + 1
    Wend
    If stillgood = 0 Then GoTo StartTAB1CTests
    Rem existing compositions in MDB are often quite specific.
    Rem to succeed, an entire MDB composition must be found within selection.
    i = 0: GotOne = 0
    While (Len(Compositions__$(i)) > 0) And (GotOne = 0)
        Rem composition must start AFTER the colon
        If InStr(s$, Compositions__$(i)) > colon Then
            WordBasic.StartOfLine
            WordBasic.Call "Tableize2Columns"
            GotOne = -1
        Else
            i = i + 1
        End If
    Wend
    If GotOne = 0 Then GoTo StartTAB1CTests: 'else it keeps trying the same failed line
    WordBasic.StartOfLine
GoTo LOOP3

StartTAB1CTests:
Rem if current line is only a composer name, select all following lines that are
Rem compositions.  User can extend the selection if necessary.
WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\Para"
s$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[Selection$]()))): ' get the source
If Len(s$) <= 2 Then WordBasic.StartOfLine: GoTo endtab1cproc
s$ = WordBasic.[Left$](s$, Len(s$) - 1): ' strip paramark
i = 0: stillgood = 0
While Len(Composers__$(i)) > 0      ' must START w/composer name
    If s$ = Composers__$(i) Then stillgood = -1
    i = i + 1
Wend
If stillgood Then
    WordBasic.ParaDown: ' down 1 line to prospective composition list start
    WordBasic.SetStartOfBookmark "\Para", "BeginPara": ' start building a "selection"
    WordBasic.SetStartOfBookmark "\Para", "EndPara": ' it starts as zero-length
    WordBasic.WW7_EditGoTo Destination:="\Para"
    i = 0
    While Len(Compositions__$(i)) > 0
        If InStr(WordBasic.[Selection$](), Compositions__$(i)) Then
            WordBasic.ParaDown
            WordBasic.SetStartOfBookmark "\Para", "EndPara"
            WordBasic.WW7_EditGoTo Destination:="\Para"
        End If
        i = i + 1
    Wend
    If WordBasic.CmpBookmarks("BeginPara", "EndPara") = 2 Then
        WordBasic.WW7_EditGoTo Destination:="BeginPara"
        WordBasic.ExtendSelection
        WordBasic.WW7_EditGoTo Destination:="EndPara"
        WordBasic.Cancel
    End If
    WordBasic.EditBookmark Name:="BeginPara", SortBy:=0, Delete:=1
    WordBasic.EditBookmark Name:="EndPara", SortBy:=0, Delete:=1
End If
endtab1cproc:

Rem ----- Some special situation experiments, normally disabled
Rem EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
Rem EditReplace .Find = "Gilbert & Sullivan^p", .Replace = "Gilbert & Sullivan:", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
Rem EditGoTo .Destination = "\Line"
Rem LineDown
Rem EditGoTo .Destination = "\Line"
Rem Tableize2Columns
Rem DoAllAutoFilldowns
Rem -----

PORbye:
If Len(WordBasic.[Selection$]()) = 1 Then
    WordBasic.WW7_EditGoTo Destination:="s2": WordBasic.WW7_EditGoTo Destination:="\section"
    WordBasic.SelType 1             'just a signal that the macro is done
End If
End Sub
Rem ----------------------------------------------------------------------------
Private Function ParaIsAllGarbage()
Dim s$
Dim i
Dim a
ParaIsAllGarbage = -1
Rem prevents deleting a section break line.
WordBasic.WW7_EditGoTo Destination:="\para"
WordBasic.EditFind Find:="^b", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
If WordBasic.EditFindFound() Then ParaIsAllGarbage = 0: GoTo PIAGbye
s$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[GetBookmark$]("\Para"))))
For i = 1 To Len(s$)
    a = Asc(Mid(s$, i, 1))
    If ((a >= 48) And (a <= 57)) Then ParaIsAllGarbage = 0: i = 32767
    If ((a >= 65) And (a <= 90)) Then ParaIsAllGarbage = 0: i = 32767
    If ((a >= 97) And (a <= 122)) Then ParaIsAllGarbage = 0: i = 32767
Next i
PIAGbye:
End Function
Rem ----------------------------------------------------------------------------

RemoveAllSpaces

Attribute VB_Name = "RemoveAllSpaces"

Public Sub MAIN()
Rem RemoveAllSpaces
If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.WW7_EditGoTo Destination:="\para"
WordBasic.EditReplace Find:=" ", Replace:="", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
End Sub

Tableize1Column

Attribute VB_Name = "Tableize1Column"

Public Sub MAIN()
Dim a$
Rem Tableize1Column, assigned to TAB1C button, 3/17/02
Rem (c)Copyright 2000,2002 by Steven Whitney
Rem at time of call, selection must be ON, or CONTAIN, 1 or more lines of compositions, which follow a (not selected) composer's name.

WordBasic.EditBookmark Name:="temp", SortBy:=1, Add:=1
If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.WW7_EditGoTo Destination:="\Para"

Rem whitespace-strip all the lines (compositions) in user selection,
WordBasic.EditReplace Find:="^w^p", Replace:="^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^p^w", Replace:="^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0

Rem put the compositions into column 2 of a 2-column table.
WordBasic.Call "TabIn": ' my macro
WordBasic.TextToTable ConvertFrom:="1", NumColumns:="2", NumRows:="10", InitialColWidth:="4" + Chr(34), Format:="0", Apply:="167"

WordBasic.TableSelectTable
WordBasic.EditBookmark Name:="temptable", SortBy:=0, Add:=1
Rem go up one line to get composer
WordBasic.LineUp 1
WordBasic.EndOfLine: WordBasic.StartOfLine 1
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo bye: ' avoid processing entire document
Rem compress all its whitespace to a single space, then trim both ends
WordBasic.EditReplace Find:="^w", Replace:=" ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
a$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[Selection$]())))
WordBasic.StartOfLine: WordBasic.EndOfLine 1:  ' now select whole line including pmark, to cut it
WordBasic.EditCut
WordBasic.WW7_EditGoTo Destination:="temptable"         'avoids ambiguity
WordBasic.EditBookmark Name:="temptable", SortBy:=0, Delete:=1
WordBasic.StartOfLine
WordBasic.Insert a$
WordBasic.StartOfLine: WordBasic.EndOfLine 1                    'select the whole cell
If WordBasic.EndOfColumn(1) Then WordBasic.Call "TableFillDown"

Rem cut out table, and set a temporary bookmark to this location
Rem if macro aborts, you can paste the original selection back to review it.
WordBasic.TableSelectTable
WordBasic.EditCut
WordBasic.EditBookmark Name:="temp", SortBy:=1, Add:=1
WordBasic.WW7_EditGoTo Destination:="Composer"
If Not WordBasic.Call("Fns.DownToFirstEmptyCell") Then WordBasic.WW7_EditGoTo Destination:="temp"
WordBasic.EditPaste

bye:
WordBasic.WW7_EditGoTo Destination:="temp"

End Sub

Tableize2Columns

Attribute VB_Name = "Tableize2Columns"

Public Sub MAIN()
Rem Tableize2Columns, assigned to TAB2C button, 3/17/02
Rem (c)Copyright 2000,2002 by Steven Whitney
Rem at time of call, rows must be in [composer:composition] format, and selected.
Rem converts the rows to a 2-column table, then cuts the table and move the cells to the data transfer table.
Rem this is a bit risky. if you make a mistake, you can make a mess of the tables.

WordBasic.EditBookmark Name:="temp", SortBy:=1, Add:=1
If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.WW7_EditGoTo Destination:="\Para"
Rem prepare (whitespace-strip) all the lines (compositions) in user selection,
WordBasic.EditReplace Find:="^w^p", Replace:="^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^p^w", Replace:="^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:=":^w", Replace:=":", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^w:", Replace:=":", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:=":", Replace:="^t", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0

Rem NumRows argument doesn't matter.
WordBasic.TextToTable ConvertFrom:="1", NumColumns:="2", NumRows:="10", InitialColWidth:="4" + Chr(34), Format:="0", Apply:="167"
WordBasic.TableSelectTable
WordBasic.EditCut
WordBasic.EditBookmark Name:="temp", SortBy:=1, Add:=1
WordBasic.WW7_EditGoTo Destination:="Composer"
Rem if it fails, paste the original selection back where it was.
If Not WordBasic.Call("Fns.DownToFirstEmptyCell") Then WordBasic.WW7_EditGoTo Destination:="temp"
WordBasic.EditPaste

bye:
WordBasic.WW7_EditGoTo Destination:="temp"
End Sub

End of the code actually used by the automated routines.

Everything below this point is legacy code, some of which demonstrates
methods that might no longer be used in the project.

Archive

Attribute VB_Name = "Archive"

Public Sub MAIN()
Rem 3/18/02
Rem this macro holds old unused code, for archival purposes.
End Sub
Rem ----------------------------------------------------------------------------
Private Sub AddCompositionFlag()
Dim tofind$
Dim LOOKUP$
Dim Chan1
Dim MyData$
Rem 12/01/00, 3/18/02
Rem copy user-selected text, and add it to the compositionflags table in .mdb if an entry for that word or phrase doesn't already exist.
Rem saved for (SQL) reference only; no longer used, and has some deficiencies.
Rem to use, it should be implemented as a fn with tables and fields as args.

If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.SelectCurWord
WordBasic.FormatChangeCase Type:=3      'change selection to title case

Rem compress all its whitespace (incl paramarks) to a single space, then trim both ends
WordBasic.EditReplace Find:="^p", Replace:=" ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^w", Replace:=" ", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0
tofind$ = WordBasic.[RTrim$](WordBasic.[LTrim$](WordBasic.[CleanString$](WordBasic.[Selection$]())))
WordBasic.EditCut
WordBasic.EditPaste
If Not WordBasic.Call("Fns.OpenRECORDSDatabase") Then GoTo bye

Rem this is the sql to find if an entry already exists.
LOOKUP$ = "SELECT DISTINCTROW CompositionFlags.Phrase FROM CompositionFlags WHERE ((CompositionFlags.Phrase = " + Chr(34) + tofind$ + Chr(34) + "))"
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL " + LOOKUP$ + ";")
MyData$ = WordBasic.[DDERequest$](Chan1, "Data")
If Len(MyData$) = 0 Then
    Rem these are the steps from the old macro PasteAppendCompositionFlag.
    Rem although cumbersome, this is preferable to a sep macro for each purpose.
    Rem however, note that this erroneously pastes the cut selection (which is on the clipboard) instead of the trimmed and cleaned string!
    WordBasic.DDEExecute Chan1, "[OpenTable CompositionFlags,0,1]": ' open table
    WordBasic.DDEExecute Chan1, "[DoMenuItem 11, 1, 6]": ' Edit|PasteAppend
    WordBasic.DDEExecute Chan1, "[DoMenuItem 11, 0, 3]": ' File|SaveRecord
End If
WordBasic.DDETerminate Chan1

bye:
End Sub
Rem ----------------------------------------------------------------------------
Private Function SelIsAComposer()
Dim Chan1
Dim MyData$
Rem RETURNS TRUE IF CURRENT SELECTION CONTAINS A KNOWN COMPOSER'S NAME.
Rem IT MAYBE SHOULD TEST FOR EXACT EQUALITY, AFTER STRIPPING, ETC.
SelIsAComposer = 0
Rem REQUIRE A BLOCK SELECTION TO AVOID SEARCHING WHOLE FILE.
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo bye5
If Not OpenRECORDSDatabase Then GoTo bye5
On Error GoTo -1: On Error GoTo DDEDone
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;QUERY ComposersByLength")
While 1                                     ' while Err <> 503?
    MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
    WordBasic.EditFind Find:=MyData$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    If WordBasic.EditFindFound() Then
        SelIsAComposer = -1
        GoTo DDEDone
    End If
Wend
DDEDone:
WordBasic.DDETerminate Chan1
On Error GoTo -1: On Error GoTo 0
bye5:
End Function
Rem ----------------------------------------------------------------------------
Private Function SelIsAComposition()
Dim Chan1
Dim MyData$
Rem RETURNS TRUE IF CURRENT SELECTION CONTAINS A KNOWN COMPOSITION TYPE.
Rem IT MAYBE SHOULD TEST FOR EXACT EQUALITY, AFTER STRIPPING, ETC.
SelIsAComposition = 0
Rem REQUIRE A BLOCK SELECTION TO AVOID SEARCHING WHOLE FILE.
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo bye6
Rem EXCLUDE COMMON MISTAKES ("SYMPHONY ORCHESTRA",)
WordBasic.EditFind Find:="orchestra", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
If WordBasic.EditFindFound() Then GoTo bye6
If Not OpenRECORDSDatabase Then GoTo bye6
On Error GoTo -1: On Error GoTo DDEDone
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;TABLE CompositionFlags")
While 1                                     ' while Err <> 503?
    MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
    WordBasic.EditFind Find:=MyData$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    If WordBasic.EditFindFound() Then
        SelIsAComposition = -1
        GoTo DDEDone
    End If
Wend
DDEDone:
WordBasic.DDETerminate Chan1
On Error GoTo -1: On Error GoTo 0
bye6:
End Function

Rem ----------------------------------------------------------------------------
Private Function FindAndTransferFieldData(fieldname$, concatenate): ' 3/14/02
Rem uses an SQL query to find within CurrentBlock all text that matches existing database records for the given field, and transfers each found to the DataTable table.
Rem if concatenate is 0, multiple entries are posted to separate cells; if nonzero, multiple entries are concatenated into 1 long  one, and then posted, once, to a single cell.
Rem Concatenate was added for soloists: usually all appear in all tracks on the record.
Rem fieldname$ MUST BE:
Rem 1) the name of the field to query in the MDB file, AND
Rem 2) the name of the DataTable bookmark where matching text is transferred.
Rem to generalize this fn further, the database name and table name should be fn args.
Rem this was taken directly from FindAndPasteConductors, and seems to work the same.
Rem it will work differently from the old FindAndPasteOrchestras because it will process ALL that are found, not just the first one.
Rem It CAN extract them in a different order from how they appear in the source block, so multiples may not match up with the proper compositions.
 Dim Count_
 Dim Cat$
 Dim f$
 Dim s$
 Dim t$
 Dim i
 Dim a$
 Dim q$
 Dim startpos
 Dim Chan1
 Dim MyData$
 Dim tab_
 Dim result

Count_ = 0
Cat$ = "": ' when Concatenating the field data, you build it in this.
Rem for records.doc, the selection must be CurrentBlock on entry, but this fn uses its own name for it from here on.
WordBasic.EditBookmark Name:="FATFDtemp", SortBy:=1, Add:=1
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo bye8
If Not AI.AI.Fns.OpenDatabase("C:\DATABASE\RECORDS\RECORDS.MDB") Then GoTo bye8
f$ = fieldname$: ' keep these synonymous thruout fn; f$ is shorter, but less clear

Rem ----- copy the selection block for the query to search
Rem THIS METHOD IS RISKY BECAUSE IT ASSUMES CLIPBOARD WILL REMAIN UNTOUCHED UNTIL IT PASTES
WordBasic.EditCopy: ' save the original text because it will be altered
Rem OriginalText$ = Selection$() :rem a better save method?
s$ = CopySelOrLine$: ' this removes paramarks, compresses, and strips
WordBasic.WW6_EditClear: ' delete the modified selection
WordBasic.EditPaste: ' restore the original text.
t$ = ""
For i = 1 To Len(s$): ' strip all quotes, which would confuse SQL parser at InStr() call
    a$ = Mid(s$, i, 1)
    If a$ <> Chr(34) Then t$ = t$ + a$
Next i
s$ = t$
t$ = "": ' in case there's a string space limit

Rem -----Construct the SQL QUERY
Rem SQL 1, lets MSAccess do the keyword search of the selected text.
Rem complicated. could still turn up bugs, but appears to work well, and is very fast.
Rem MSAccess does all the comparisons, calculations, and sorting, and returns only
Rem the end result.
Rem It sorts by the order entries appear in the provided source text, then by descending
Rem length, so if 2 entries start at the SAME loc, the longest is returned first.
q$ = "SELECT DISTINCT Tracks." + f$ + ", InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]) AS Expr1, Len([" + f$ + "]) AS Expr2"
q$ = q$ + " FROM Tracks"
q$ = q$ + " WHERE ((Tracks." + f$ + " Is Not Null) AND ((InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]))>0))"
q$ = q$ + " ORDER BY InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]), Len([" + f$ + "]) DESC;"
Rem Open "d:\temp\a.txt" For Append As #1 : Print #1, q$ : Close #1

Rem -----
Rem cut q$ into pieces < 256 chars each, into successive SQL$() elements
ReDim SQL__$(20): ' holds the cut-up pieces of the SQL string
i = 0
startpos = 1
While startpos <= Len(q$)
    SQL__$(i) = Mid(q$, startpos, 200): ' copy the first 200 chars
    startpos = startpos + 200
    i = i + 1
Wend
q$ = ""
Rem ----- Send the SQL query and process result
On Error GoTo -1: On Error GoTo DDEDone
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL ")
i = 0
While Len(SQL__$(i))
    WordBasic.DDEPoke Chan1, "SQLTEXT", SQL__$(i)
    i = i + 1
Wend
Rem this loop cuts and pastes ALL that are found.
While 1
    MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
    tab_ = InStr(MyData$, Chr(9))
    MyData$ = Mid(MyData$, 1, tab_ - 1)
    WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
    WordBasic.EditFind Find:=MyData$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    If WordBasic.EditFindFound() Then
        Count_ = Count_ + 1
        If concatenate Then
            If Len(Cat$) Then Cat$ = Cat$ + "; "
            Cat$ = Cat$ + MyData$: ' note this uses MyData$ from MDB, not the selection
            WordBasic.EditCut: ' because we're not using AI.Fns.TransferToDataTable, which cuts
        Else
            result = AI.Fns.AI.Fns.TransferToDataTable__(fieldname$): ' MOVES selected text to DataTable
        End If
    End If
Wend
DDEDone:
WordBasic.DDETerminate Chan1
If concatenate Then If Len(Cat$) Then result = AI.Fns.TextToDataTable__(Cat$, fieldname$)
On Error GoTo -1: On Error GoTo 0
If Count_ > 0 Then GoTo bye8:    ' if we got 1 or more, we're done

Rem ----- DDE search failed, so try searching for context flags
Rem the exact method is specific to the data being sought.  each possible fieldname$ needs its own section.  The method is useful in this application, but try to find better, more general methods, or better generalize this one.

If fieldname$ <> "Conductor" Then GoTo EndConductor
Rem ----- This section is special processing for "Conductor"
Rem Conductor does not support concatenating.

ReDim LeadingFlags__$(5)
LeadingFlags__$(0) = "conducted by "

ReDim TrailingFlags__$(5)
TrailingFlags__$(0) = ", conductor"
TrailingFlags__$(1) = " conductor"
TrailingFlags__$(2) = " conducting"

Rem putting TrailingFlags search first is intentional
For i = 0 To 5
    If Len(TrailingFlags__$(i)) = 0 Then GoTo FATFD1
    WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
    WordBasic.EditFind Find:=TrailingFlags__$(i), Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    While WordBasic.EditFindFound()
        a$ = WordBasic.[Selection$]()   'save the flag's text, but not to clipboard
        WordBasic.WW6_EditClear         'remove the flag
        WordBasic.WordLeft 2, 1     'and select previous 2 words
        If WordBasic.MsgBox("Cut and paste this " + fieldname$ + "?", "Is this the Right One?", 36) = -1 Then
            Count_ = Count_ + 1
            result = AI.Fns.AI.Fns.TransferToDataTable__(fieldname$): ' MOVES text to DataTable
        Else
            Rem if you reject it, restore the flag and quit because even if you find more,
            Rem they probably won't be in the right order when you're done.
            WordBasic.CharRight
            WordBasic.Insert a$
            GoTo FATFD1
        End If
        WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
        WordBasic.EditFind
    Wend
Next i
FATFD1:
If Count_ > 0 Then GoTo bye8
For i = 0 To 5
    If Len(LeadingFlags__$(i)) = 0 Then GoTo FATFD2
    WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
    WordBasic.EditFind Find:=LeadingFlags__$(i), Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
    While WordBasic.EditFindFound()
        a$ = WordBasic.[Selection$]()   'save the flag's text, but not to clipboard
        WordBasic.WW6_EditClear         'remove the flag
        WordBasic.WordRight 2, 1        'and select next 2 words
        If WordBasic.MsgBox("Cut and paste this " + fieldname$ + "?", "Is this the Right One?", 36) = -1 Then
            Count_ = Count_ + 1
            result = AI.Fns.TransferToDataTable__(fieldname$): ' MOVES text to DataTable
        Else
            Rem if you reject it, restore the flag and quit because even if you find more,
            Rem they probably won't be in the right order when you're done.
            WordBasic.CharLeft
            WordBasic.Insert a$
            GoTo FATFD2
        End If
        WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
        WordBasic.EditFind
    Wend
Next i
FATFD2:
GoTo bye8
Rem ----- End of special processing for "Conductor"
EndConductor:

Rem special processing for other fieldname$'s go here
Rem ORCHESTRA:
Rem editfind forward "orchestra", extendselection, editfind reverse "the", or
Rem editfind forward "orchestra", extendselection, startofline, editfind "the"
Rem (don't go beyond start/end of para!)

Rem -----
bye8:
WordBasic.WW7_EditGoTo Destination:="FATFDtemp"
WordBasic.EditBookmark Name:="FATFDtemp", SortBy:=1, Delete:=1
FindAndTransferFieldData = Count_
End Function
Rem ----------------------------------------------------------------------------
Private Function FieldDataFoundInSel$(fieldname$)
Dim f$
Dim s$
Dim t$
Dim i
Dim a$
Dim q$
Dim startpos
Dim Chan1
Dim MyData$
Dim tab_
Rem #error should be FieldDataFoundInText$(source$,fieldname$), and not modify selection.
Rem fieldname$ is the name of the field to query in the MDB file.
Rem searches the given field in the database for records whose text is found in the current selection.  Returns the earliest match found.  If multiple matches start at the same loc, returns the longest.
Rem example 1: if result matches original sel exactly, the line contains ONLY a composer.
Rem example 2: if sel contains composer match at the start, take a Mid$() of the original sel that cuts off the matching text, then search the rest for a ":".
Rem If found, cut that off, and search what remains for a composition.  If found, original sel was a Tab2C format line.

FieldDataFoundInSel$ = ""

WordBasic.EditBookmark Name:="SHFDtemp", SortBy:=1, Add:=1
If Len(WordBasic.[Selection$]()) <= 1 Then WordBasic.WW7_EditGoTo Destination:="\Para"
If Len(WordBasic.[Selection$]()) <= 1 Then GoTo bye9: ' nothing to search for
If Not AI.Fns.OpenDatabase___("C:\DATABASE\RECORDS\RECORDS.MDB") Then GoTo bye9
f$ = fieldname$: ' keep these synonymous thruout fn; f$ is shorter, but less clear

Rem ----- copy the selection block for the query to search
Rem THIS METHOD IS RISKY BECAUSE IT ASSUMES CLIPBOARD WILL REMAIN UNTOUCHED UNTIL IT PASTES
Rem save the original text because it will be altered, incl. paramarks removed.
WordBasic.EditCopy
Rem OriginalText$ = Selection$() :rem a better save method?
s$ = CopySelOrLine$: ' this removes paramarks, compresses, and strips
WordBasic.WW6_EditClear: ' delete the modified selection
WordBasic.EditPaste: ' restore the original text.
Rem strip all quotes, which would confuse SQL parser at the InStr() call.
Rem In some cases, (e.g. "Emperor"), this may cause the query to fail to identify a match that otherwise would be found.
t$ = ""
For i = 1 To Len(s$)
    a$ = Mid(s$, i, 1)
    If a$ <> Chr(34) Then t$ = t$ + a$
Next i
s$ = t$
t$ = "": ' in case there's a string space limit

Rem -----Construct the SQL QUERY
Rem It sorts by the order entries appear in the provided source text, then by descending
Rem length, so if 2 entries start at the SAME loc, the longest is returned first.
q$ = "SELECT DISTINCT TOP 1 Tracks." + f$ + ", InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]) AS Expr1, Len([" + f$ + "]) AS Expr2"
q$ = q$ + " FROM Tracks"
q$ = q$ + " WHERE ((Tracks." + f$ + " Is Not Null) AND ((InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]))>0))"
q$ = q$ + " ORDER BY InStr(" + Chr(34) + s$ + Chr(34) + ",[" + f$ + "]), Len([" + f$ + "]) DESC;"
Rem Open "d:\temp\a.txt" For Append As #1 : Print #1, q$ : Close #1 : REM for debugging

Rem -----
Rem cut q$ into pieces < 256 chars each, into successive SQL$() elements
ReDim SQL__$(20): ' holds the cut-up pieces of the SQL string
i = 0
startpos = 1
While startpos <= Len(q$)
    SQL__$(i) = Mid(q$, startpos, 200): ' copy the first 200 chars
    startpos = startpos + 200
    i = i + 1
Wend
q$ = ""
Rem ----- Send the SQL query and process result
On Error GoTo -1: On Error GoTo DDEDone
Chan1 = WordBasic.DDEInitiate("MSAccess", "RECORDS;SQL ")
i = 0
While Len(SQL__$(i))
    WordBasic.DDEPoke Chan1, "SQLTEXT", SQL__$(i)
    i = i + 1
Wend
MyData$ = WordBasic.[DDERequest$](Chan1, "NextRow")
tab_ = InStr(MyData$, Chr(9))
MyData$ = Mid(MyData$, 1, tab_ - 1)
WordBasic.WW7_EditGoTo Destination:="SHFDtemp"
WordBasic.EditFind Find:=MyData$, Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
If WordBasic.EditFindFound() Then FieldDataFoundInSel$ = WordBasic.[Selection$]()
DDEDone:
WordBasic.DDETerminate Chan1
On Error GoTo -1: On Error GoTo 0

bye9:
WordBasic.WW7_EditGoTo Destination:="SHFDtemp"
WordBasic.EditBookmark Name:="SHFDtemp", SortBy:=1, Delete:=1
End Function

Rem ----------------------------------------------------------------------------

misc

Attribute VB_Name = "misc"

Public Sub MAIN()
Rem misc
Rem 11/21/00
Rem THIS IS AN ARCHIVE FOR MISC COMMANDS I USED DURING EDITING records.doc.
Rem IT IS FOR REFERENCE ONLY, NOT TO BE RUN.

Exit Sub

Rem THIS IS A TINY DOT THAT OFTEN SEPARATES COMPOSITIONS OR SOLOISTS
Rem IT IS CHR$(183) OR ^0183
WordBasic.EditReplace Find:="•", Replace:="^p", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=0

WordBasic.EditReplace Find:="(Op)([0-9]@>)", Replace:="Op. \2", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceOne:=1, Format:=0, Wrap:=2

WordBasic.EditReplace Find:="(<Cal)([0-9]@>)", Replace:="CAL\2", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, FindNext:=1, Format:=0, Wrap:=2

Rem this search string locates this p r o b l e m, and other errors.
Rem "( )([!ABCDEFGIai\-&0-9,.•])( )"

WordBasic.EditReplace Find:="<Cto>", Replace:="Concerto", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=2

WordBasic.EditReplace Find:="(" + Chr(34), Replace:="(", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=2
WordBasic.EditReplace Find:=Chr(34) + ")", Replace:=")", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=2

WordBasic.EditReplace Find:="[", Replace:="", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=2
WordBasic.EditReplace Find:="]", Replace:="", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=1, SoundsLike:=0, ReplaceAll:=1, Format:=0, Wrap:=2



End Sub

GetSysItems

This does have to be customized for each use. All it does is demonstrate how to
get the list of supported system topics from a DDE server application.

Attribute VB_Name = "GetSysItems"

Public Sub MAIN()
Dim Chan1
Dim a$
Dim b$
Rem GetSysItems
Rem gets list of supported topics for a server app
Rem you may need to customize for each use, depending on what you want to retrieve
Rem 1/1/01
Rem

WordBasic.DDETerminateAll

Rem MicrosoftAccess
Rem MicrosoftExcel
Rem to do:
    Rem msaccess done
    Rem excel done
    Rem winword done
Chan1 = WordBasic.DDEInitiate("winword", "System")
If Chan1 = 0 Then
    WordBasic.MsgBox "Failed to open DDE channel.", "Cannot Continue", 48
    GoTo bye
End If
a$ = WordBasic.[DDERequest$](Chan1, "sysitems")

WordBasic.EndOfDocument
WordBasic.Insert a$
WordBasic.InsertPara
Rem Goto bye

Rem create a table, then inquire about the topics (now 1 in each cell)
WordBasic.LineUp
WordBasic.StartOfLine
WordBasic.WW7_EditGoTo "\Para"
WordBasic.TextToTable ConvertFrom:="1", NumColumns:="4", NumRows:="1", InitialColWidth:="Auto", Format:="0", Apply:="167"
On Error GoTo -1: On Error GoTo done
While WordBasic.SelInfo(12) = -1 And WordBasic.NextCell() <> 0
    a$ = WordBasic.[DDERequest$](Chan1, WordBasic.[Selection$]())
    b$ = b$ + a$ + Chr(13)
Wend

done:
WordBasic.EndOfDocument
WordBasic.Insert b$
WordBasic.InsertPara
WordBasic.InsertPara
Rem DDETerminate Chan1          'WE'RE THROUGH WITH THE SYSTEM TOPIC

On Error GoTo -1: On Error GoTo 0

bye:
WordBasic.DDETerminateAll

End Sub

LaunchWTalk

Attribute VB_Name = "LaunchWTalk"

Public Sub MAIN()
Dim Chan1
Rem LaunchWTalk
Rem tests auto-launch and server use of WTalk.exe.  Works!
Rem 3/6/02

Rem HERE'S HOW YOU USE IT:
If WordBasic.Call("Fns.StartWTalk") Then
    Chan1 = WordBasic.DDEInitiate("WTALK", "System")
    WordBasic.DDEExecute Chan1, "parse this is a test."
    WordBasic.DDETerminate Chan1
    

    'VIEW THE RESULT
    Chan1 = WordBasic.DDEInitiate("MSACCESS", "WTALK")
    WordBasic.DDEExecute Chan1, "[OpenQuery ToksEditor]"
    WordBasic.DDEExecute Chan1, "[Maximize]"
    WordBasic.AppActivate "Microsoft Access - [Select Query: ToksEditor]", 1
    'gives insight into macro: you can't do this because macro runs
    'to its end even after the other app is activated.
    'DDEExecute Chan1, "[Close 1, ToksEditor]"
    WordBasic.DDETerminate Chan1
End If

bye:
WordBasic.DDETerminateAll

End Sub