|
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 |
|
|
Microsoft Word 6.0 WordBasic Macros from AI.DOTThis is the macro code from my AI.DOT template, used by the RECORDS.MDB project for intelligently importing records into the database. It is presented here for examination. If you download the project, the code is already in the template. This code also exists in a converted VB version for MS Word 2003. Copyright (C)2000 Steven Whitney. Published under GNU GPL (General Public License) Version 2, with ABSOLUTELY NO WARRANTY. |
|
Sub MAIN
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, 1 row at a time to avoid confirmation dialog in msaccess.
On Error Goto 0
DDETerminateAll
If Not Fns.OpenRECORDSDatabase Then Goto bye
REM warn user if this MaxID is already in MDB. Will be useful if I start pre-scanning
REM records that I listen to, out of the mass-scanning sequence.
EditGoTo .Destination = "MaxID" : LineDown
ThisMaxID$ = LTrim$(RTrim$(Str$(Val(GetBookmark$("\cell")))))
If Val(ThisMaxID$) = 0 Then
MsgBox "MaxID must not be empty. Revise and try again.", "Field Error", 48
Goto bye
EndIf
sql$ = "SELECT DISTINCTROW Count(*) AS CountOfMaxID FROM Tracks WHERE ((Tracks.MaxID=" + ThisMaxID$ + "));"
Chan1 = DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
If Chan1 = 0 Then MsgBox "Chan1 failed" : Goto bye
MyData$ = DDERequest$(Chan1, "NextRow")
DDETerminate Chan1
REM MsgBox sql$
REM MsgBox Str$(Val(MyData$)) : Goto bye
If Val(MyData$) > 0 Then If 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 = DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
If Chan1 = 0 Then MsgBox "Chan1 failed" : Goto bye
MyData$ = DDERequest$(Chan1, "NextRow")
LastID = Val(MyData$) :REM 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
EditGoTo .Destination = "t1" : EditGoTo .Destination = "\Cell"
LineDown
While SelInfo(12) = - 1 'while selection is within the table
TableSelectRow
EditCut
DDEExecute Chan1, "[PasteAppendTracks]"
REM a new channel to get the latest info. chan1 just returns the same as before.
Chan2 = DDEInitiate("MSAccess", "RECORDS;SQL " + sql$)
MyData$ = DDERequest$(Chan2, "NextRow")
DDETerminate Chan2
NewID = Val(MyData$)
If NewID = LastID Then
a$ = Str$(LastID) + " " + Str$(NewID) + ": "
MsgBox a$ + "Immediately paste somewhere, resolve the problem and retry the transfer.", "MSAccess paste failed.", 48
Goto a1
EndIf
LastID = NewID
Wend
a1:
DDETerminate Chan1
REM do some cleanup:
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
REM just make sure remaining data is all garbage before you export!
EditClear
bye:
ViewZoom .ZoomPercent = "100%"
End Sub
Sub MAIN REM BreakDocIntoSections, 3/15/02 REM (c)Copyright 2002 by Steven Whitney 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. StartOfDocument EditFind .Find = "-----^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0 While EditFindFound() EditClear InsertBreak .Type = 3 EditFind Wend End Sub
Sub MAIN
REM ChangeFirstSpaceToColon
REM 3/27/02
REM (c)Copyright 2002 by Steven Whitney
REM change [composer composition] to [composer:composition] in all lines in selection
If Len(Selection$()) = 1 Then
EditGoTo .Destination = "\Para"
EditReplace .Find = " ", .Replace = ":", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceOne, .Format = 0, .Wrap = 0
Goto bye
EndIf
CopyBookmark "\StartOfSel", "StartPoint"
CopyBookmark "\EndOfSel", "EndPoint"
EditGoTo .Destination = "\Para"
c = CmpBookmarks("\EndOfSel", "EndPoint")
While (c = 2) Or (c = 0)
EditReplace .Find = "(>)( )", .Replace = "\1:", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceOne, .Format = 0, .Wrap = 0
ParaDown : EditGoTo .Destination = "\Para"
c = CmpBookmarks("\EndOfSel", "EndPoint")
Wend
EditGoTo .Destination = "StartPoint"
EditBookmark .Name = "EndPoint", .SortBy = 1, .Delete
EditBookmark .Name = "StartPoint", .SortBy = 1, .Delete
bye:
End Sub
Sub MAIN
REM DeSpaceWholeLines
REM this search string locates this p r o b l e m, and other errors.
a$ = "( )([!ABCDEFGIai\-&/:0-9,.•])( )"
EditFind .Find = a$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .Format = 0, .Wrap = 0
While EditFindFound()
EditGoTo .Destination = "\Para"
If MsgBox("De-space this whole line?", "Please verify", 36) = - 1 Then RemoveAllSpaces
EndOfLine
EditFind .Find = a$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .Format = 0, .Wrap = 0
Wend
End Sub
Sub MAIN REM DoAllAutoFilldowns, assigned to FILLDOWNS button, 4/14/02 REM (c)Copyright 2002 by Steven Whitney 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 ViewZoom .ZoomPercent = "40%" EditGoTo .Destination = "t1" : EditGoTo .Destination = "\table" EditGoTo .Destination = "\Cell" :REM if sel has > 1 cell, this selects only the first If SelInfo(15) < 3 Then Goto bye :REM Table only has 1 data row LineDown :REM autofill starts 1 line below heading row i = Fns.TableFillDownBlanksAll REM some special checks EditGoTo .Destination = "MaxID" : LineDown If Fns.CellIsEmpty Then ViewZoom .ZoomPercent = "100%" MsgBox "MaxID must not be empty. Revise and try again.", "Field Error", 48 Goto bye EndIf EditGoTo .Destination = "RPM" : LineDown If Fns.CellIsEmpty Then ViewZoom .ZoomPercent = "100%" MsgBox "RPM must not be empty. Revise and try again.", "Field Error", 48 Goto bye EndIf bye: EditGoTo .Destination = "t1" : EditGoTo .Destination = "\table" EditGoTo .Destination = "\Cell" :REM if sel has > 1 cell, this selects only the first LineDown ViewZoom .ZoomPercent = "60%" End Sub
Sub MAIN
REM Fns (functions), (c)Copyright 2000,2002 by Steven Whitney 3/28/02
REM Central storage loc for functions used by other routines.
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 ----------------------------------------------------------------------------
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(Selection$()) <= 1 Then EditGoTo .Destination = "\Para" :REM takes paramark
If Len(Selection$()) <= 1 Then Goto CSOLbye :REM there's nothing except paramark
REM compress all selection's whitespace (incl paramarks) to a single space.
EditReplace .Find = "^p", .Replace = " ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
EditReplace .Find = "^w", .Replace = " ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
REM strip any (rare) nonprinting chars and strip both ends
CopySelOrLine$ = RTrim$(LTrim$(CleanString$(Selection$())))
CSOLbye:
End Function
REM ----------------------------------------------------------------------------
Function TransferToDataTable(BkmarkName$)
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.
EditCut
EditBookmark .Name = "temp", .SortBy = 1, .Add
EditGoTo .Destination = BkmarkName$
i = DownToFirstEmptyCell
REM if it failed, paste the original (but modified) selection back where it was.
If Not i Then EditGoTo .Destination = "temp"
Insert A$
EditGoTo .Destination = "temp"
TransferToDataTable = i
End Function
REM ----------------------------------------------------------------------------
Function TextToDataTable(text$, BkmarkName$)
REM inserts text$ into the data table, at the named bookmark.
EditBookmark .Name = "TTDTtemp", .SortBy = 1, .Add
EditGoTo .Destination = BkmarkName$
i = DownToFirstEmptyCell
REM if it failed, paste the text at TTDTtemp for debugging review.
If Not i Then EditGoTo .Destination = "TTDTtemp"
Insert text$
EditGoTo .Destination = "TTDTtemp"
EditBookmark .Name = "TTDTtemp", .SortBy = 1, .Delete
TextToDataTable = i
End Function
REM ----------------------------------------------------------------------------
Function CellText$
CellText$ = ""
If SelInfo(12) = - 1 Then
a$ = GetBookmark$("\cell")
CellText$ = Left$(a$, Len(a$) - 2)
EndIf
End Function
REM ----------------------------------------------------------------------------
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)
StartOfLine
CellIsEmpty = Not EndOfLine()
StartOfLine
End Function
REM ----------------------------------------------------------------------------
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
SelType 1 :'deselect & position at start of selection
If SelInfo(12) <> - 1 Then Goto DTFECbye :'if not in a table, do nothing
DownToFirstEmptyCell = - 1 :'now success is the default
EndOfColumn
If Not CellIsEmpty Then 'table is filled up, so add a row
EditBookmark .Name = "tempbottom", .SortBy = 1, .Add
While SelInfo(12) = - 1 : LineDown : Wend 'down to first line below the table
StartOfLine 'append a row to the table
TableInsertRow .NumRows = "1"
EditGoTo .Destination = "tempbottom" 'go back where you were
EditBookmark .Name = "tempbottom", .SortBy = 1, .Delete
EndOfColumn 'now go to the new last cell in column
EndIf
While CellIsEmpty 'go up until you find first FILLED cell
If Not LineUp() Then 'top line is empty: error! should never happen
EndOfColumn
DownToFirstEmptyCell = 0
Goto DTFECbye
EndIf
Wend
LineDown 'return to the last empty cell
DTFECbye:
End Function
REM ----------------------------------------------------------------------------
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 SelInfo(12) <> - 1 Then Goto bye1 :REM if not in a table, do nothing
EditBookmark .Name = "TFDBtemp", .SortBy = 1, .Add
EditGoTo .Destination = "\Cell" :REM if sel has > 1 cell, this selects only the first
EditCopy :REM copy cell whether it has text or not
While SelInfo(12) = - 1
If CellIsEmpty Then
EditPaste
Else
EditGoTo .Destination = "\Cell" :REM must select it all
EditCopy
EndIf
LineDown
Wend
EditGoTo .Destination = "TFDBtemp"
EditBookmark .Name = "TFDBtemp", .SortBy = 1, .Delete
TableFillDownBlanks = - 1
bye1:
End Function
REM ----------------------------------------------------------------------------
Function TableFillDownBlanksAll
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 SelInfo(12) <> - 1 Then Goto bye2 :REM if not in a table, do nothing
EditBookmark .Name = "TFDBRtemp", .SortBy = 1, .Add :REM save absolute start loc
EditGoTo .Destination = "\Cell" :REM if sel has > 1 cell, this selects only the first
REM if in last row, it's a success, but do nothing
If SelInfo(13) = SelInfo(15) Then Goto L1
While 1
i = TableFillDownBlanks :REM this leaves cursor at original top of column
oldcol = SelInfo(16) : NextCell : newcol = SelInfo(16)
If newcol <= oldcol Then Goto L1
Wend
L1:
TableFillDownBlanksAll = - 1
bye2:
If ExistingBookmark("TFDBRtemp") Then
EditGoTo .Destination = "TFDBRtemp"
EditBookmark .Name = "TFDBRtemp", .SortBy = 1, .Delete
EndIf
End Function
REM ----------------------------------------------------------------------------
Function OpenDatabase(fullpath$)
REM fullpath$ MUST be the full path name of the MDB file.
OpenDatabase = 0 :REM failure is default
lastbackslash = 0 : dot = 0
For i = 1 To Len(fullpath$)
If Mid$(fullpath$, i, 1) = "\" Then lastbackslash = i
If Mid$(fullpath$, i, 1) = "." Then dot = i
Next i
namelength = dot - lastbackslash - 1
If (lastbackslash = 0) Or (dot = 0) Or (namelength < 1) Then Goto bye3
dbname$ = Mid$(fullpath$, lastbackslash + 1, namelength)
REM it can't distinguish between Microsoft Access and Microsoft Access Help, so close Help.
If AppIsRunning("Microsoft Access 2.0 Help") Then AppClose("Microsoft Access 2.0 Help")
wordWin$ = "Microsoft Word - " + WindowName$()
If Not AppIsRunning("Microsoft Access") Then
Shell fullpath$
AppActivate wordWin$, 1 :REM immediately return to word
If Not AppIsRunning("Microsoft Access") Then Goto bye3
EndIf
REM it either WAS or now IS running, but we don't know for sure which MDB is open.
REM it will only recognize the short dbname$ if the MDB is open
Chan1 = DDEInitiate("MSACCESS", dbname$)
If Chan1 Then
DDETerminate Chan1
OpenDatabase = - 1
Goto bye3
EndIf
DDETerminate Chan1
REM Access was running, but our mdb wasn't, so try one last time to launch it
Shell fullpath$
AppActivate wordWin$, 1
Chan1 = DDEInitiate("MSACCESS", dbname$)
If Chan1 Then OpenDatabase = - 1 :REM everything is ok
DDETerminate Chan1
bye3:
End Function
REM ----------------------------------------------------------------------------
Function OpenRECORDSDatabase
REM this old fn is for temporary convenience because many macros call it.
OpenRECORDSDatabase = OpenDatabase("C:\DATABASE\RECORDS\RECORDS.MDB")
End Function
REM ----------------------------------------------------------------------------
Function StartWTalk
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 - " + WindowName$()
If Not AppIsRunning("WTalk") Then
Shell "C:\AI\TALK\WTALK.EXE"
AppActivate wordWin$, 1 'immediately return to word
EndIf
StartWTalk = - 1 'everything is ok
bye4:
End Function
REM ----------------------------------------------------------------------------
Function DDEField$(Source$, Index)
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 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)
EndIf
End Function
REM ----------------------------------------------------------------------------
Sub CreateDataTableFromMDB(FullPathMDB$, TableName$)
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 = DDEInitiate("MSAccess", FullPathMDB$ + ";TABLE " + TableName$)
If Chan1 = 0 Then Goto bye10
FieldCount = Val(DDERequest$(Chan1, "FieldCount"))
Row$ = DDERequest$(Chan1, "FieldNames")
DDETerminate Chan1
REM blank line at top is because it's hard to insert one after the table is in place.
StartOfDocument : InsertPara : Insert Row$ : EditGoTo .Destination = "\Para"
TextToTable .ConvertFrom = "1", .NumColumns = FieldCount, .NumRows = "1", .InitialColWidth = "Auto", .Format = "0", .Apply = "167"
TableColumnWidth .ColumnWidth = "", .SpaceBetweenCols = "0.15" + Chr$(34), .AutoFit, .RulerStyle = "0"
EditGoTo .Destination = "\cell"
For i = 1 To FieldCount
StartOfLine
a$ = DDEField$(Row$, i)
EditBookmark .Name = a$, .SortBy = 1, .Add
If i <> FieldCount Then NextCell
Next i
StartOfDocument
MsgBox "You probably want to use Ctrl+Shift+Drag Border, which adjusts only the 1 column.", "To Revise Column Widths"
bye10:
End Sub
REM ----------------------------------------------------------------------------
Sub MAIN REM InsertCommas EditGoTo .Destination = "\para" If Len(Selection$()) > 1 Then EditReplace .Find = " ", .Replace = ", ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 End Sub
Sub MAIN
REM MoveARecordToDocTop
REM 5/24/02
StartOfDocument
tofind$ = InputBox$("Record number to find (its MaxID):", "Find and Move To Doc Top")
If Val(tofind$) = 0 Then Goto bye
EditFind .Find = tofind$, .Direction = 0, .MatchCase = 0, .WholeWord = 1, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then
EditGoTo .Destination = "\section"
EditCut
EditGoTo .Destination = "s2"
EditPaste
StartOfDocument
EndIf
bye:
End Sub
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 SelInfo(2) < 2 Then Goto bye EditGoTo .Destination = "\section" EditCut EditBookmark .Name = "MSTTTemp", .SortBy = 0, .Add EndOfDocument EditPaste EditGoTo .Destination = "MSTTTemp" EditBookmark .Name = "MSTTTemp", .SortBy = 0, .Delete bye: End Sub
Sub MAIN REM MoveSectionToTop REM moves the current ONE section (only) to top of records list REM 9/28/02 If SelInfo(2) < 3 Then Goto bye 'must be at or beyond section 3 EditGoTo .Destination = "\section" EditCut EditBookmark .Name = "MSTTTemp", .SortBy = 0, .Add EditGoTo .Destination = "s2" EditPaste EditGoTo .Destination = "MSTTTemp" EditBookmark .Name = "MSTTTemp", .SortBy = 0, .Delete bye: End Sub
Sub MAIN
REM PasteComments, assigned to COMMENTS button, 3/24/02
i = Fns.TransferToDataTable("Comments")
End Sub
Sub MAIN
REM PasteComposer, assigned to COMPOSER button, 3/10/02
i = Fns.TransferToDataTable("Composer")
End Sub
Sub MAIN
REM PasteComposition, assigned to COMPOSITION button, 3/10/02
i = Fns.TransferToDataTable("Composition")
End Sub
Sub MAIN
REM PasteCompositionX2, 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 = Fns.TransferToDataTable("Composition")
i = Fns.TransferToDataTable("Composition")
DoAllAutoFilldowns
End Sub
Sub MAIN
REM PasteConductor, assigned to CONDUCTOR button, 3/10/02
i = Fns.TransferToDataTable("Conductor")
End Sub
Sub MAIN
REM PasteMaxID, 3/10/02
i = Fns.TransferToDataTable("MaxID")
End Sub
Sub MAIN
REM PasteMemo, 3/10/02
i = Fns.TransferToDataTable("Memo")
End Sub
Sub MAIN
REM PasteOrchestra, 3/10/02
i = Fns.TransferToDataTable("Orchestra")
End Sub
Sub MAIN
REM PasteRCID, 3/10/02
i = Fns.TransferToDataTable("RCID")
End Sub
Sub MAIN
REM PasteRPM, 3/10/02
i = Fns.TransferToDataTable("RPM")
End Sub
Sub MAIN
REM PasteSoloist, 3/10/02
REM format the line as you want it before calling, with multiple soloists on same line, if appropriate.
i = Fns.TransferToDataTable("Soloists")
End Sub
Sub MAIN
REM PasteTitle, assigned to TITLE button, 3/10/02
i = Fns.TransferToDataTable("Title")
End Sub
Sub MAIN
REM PasteYear, 3/10/02
i = Fns.TransferToDataTable("Year")
End Sub
Sub MAIN
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 0
DDETerminateAll
ViewZoom .ZoomPercent = "100%"
If Not Fns.OpenDatabase("C:\DATABASE\RECORDS\RECORDS.MDB") Then Goto PORbye
REM the record to process is always in Section 2 of the doc.
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 = Fns.TransferToDataTable("MaxID")
EditGoTo .Destination = "s2" : 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
FormatChangeCase .Type = 2 :REM title case is reliable if it starts all upper or lower
FormatChangeCase .Type = 3 :REM change block to title case
REM push the section end down a line, away from any text we might cut
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\Section"
EditGoTo .Destination = "\EndOfSel" : CharLeft : InsertPara
REM ----- START OF UNION QUERY MUTI-SEARCH SECTION
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
EditCopy :REM preserve original text
s$ = Fns.CopySelOrLine$ :REM this removes paramarks, compresses, trims, and cleans
EditClear :REM delete the modified selection
EditPaste :REM 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$ :REM s$ is stripped for searching
t$ = Chr$(34) + s$ + Chr$(34) :REM t$ is in quotes for the SQL
Dim Composers$(10) : Dim Compositions$(10)'must do here in case section is skipped
If Len(s$) < 5 Then Goto ENDUNIONQUERY :REM 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
Dim SQL$(SQLCount) :REM holds the cut-up pieces of the SQL string
ChunkSize = 255 :REM initial size is the maximum allowable
REM START OF CHUNKING LOOP
StartDDETry:
On Error Goto 0
i = 0 : startpos = 1
While startpos <= Len(q$)
SQL$(i) = Mid$(q$, startpos, ChunkSize) :REM copy the first ChunkSize chars
startpos = startpos + ChunkSize
i = i + 1
Wend
REM Send the SQL query and process result
On Error Goto DDEDone :REM a connect failure is unrecoverable
Chan1 = DDEInitiate("MSAccess", "RECORDS;SQL ")
On Error Goto HandleChunkingError
i = 0
While Len(SQL$(i))
DDEPoke Chan1, "SQLTEXT", SQL$(i)
i = i + 1
Wend
Goto BeyondChunkingError :REM 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 0
Open "c:\database\records\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 :REM abandon DDE and finish the best you can
DDETerminate Chan1
Redim SQL$(SQLCount)
Goto StartDDETry
BeyondChunkingError:
On Error Goto 0
q$ = "" : t$ = "" :REM because we're through with them
Redim SQL$(1) :REM conserves string space?
ComposersIndex = 0 : CompositionsIndex = 0
Loc = 1 : Length = 0
On Error Goto DDEDone :REM we're expecting an End Of Data error eventually
LOOP2:
Row$ = 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$ = Fns.DDEField$(Row$, 1)
Source$ = Fns.DDEField$(Row$, 2)
Loc = Val(Fns.DDEField$(Row$, 3))
Length = Val(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
EndIf
If Source$ = "Composition" Then
Compositions$(CompositionsIndex) = Match$ : CompositionsIndex = CompositionsIndex + 1
Goto DDELoopEnd
EndIf
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\Section"
EditFind .Find = Match$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then
dummy = Fns.TransferToDataTable(Source$)
If ParaIsAllGarbage Then EditGoTo .Destination = "\Para" : EditClear
REM ScreenRefresh
EndIf
DDELoopEnd:
Goto LOOP2
DDEDone:
DDETerminate Chan1
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 = DDEInitiate("MSAccess", "RECORDS;QUERY PatternMatchStringsByLength")
REM ScreenUpdating 0
On Error Goto LABEL1'will get End Of Data error eventually
LOOP1: 'attempt to avoid while-wend missmatch problems
Row$ = DDERequest$(Chan1, "NextRow")
Match$ = Fns.DDEField$(Row$, 1)
Source$ = Fns.DDEField$(Row$, 2)
Discard$ = Fns.DDEField$(Row$, 3)
If Val(Fns.DDEField$(Row$, 4)) = 0 Then UsePatternMatch = 0 Else UsePatternMatch = 1
REM ShowVars
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
EditFind .Find = Match$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = UsePatternMatch, .SoundsLike = 0, .Format = 0, .Wrap = 0
While 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 :REM temp flag whether TransferToDataTable is allowed this time.
If Len(Discard$) Then
EditBookmark .Name = "pmtemp", .SortBy = 1, .Add
REM #error it might be ok to use pattern matching for the discard string
EditFind .Find = Discard$, .Direction = 0, .MatchCase = 1, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then EditClear
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(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 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
EndIf
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
EndIf
EditBookmark .Name = "pmtemp", .SortBy = 1, .Delete
EndIf
If i Then result = Fns.TransferToDataTable(Source$)
If ParaIsAllGarbage Then EditGoTo .Destination = "\Para" : EditClear
REM ScreenRefresh
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
EditFind .Find = Match$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .Format = 0, .Wrap = 0
Wend
Goto LOOP1
LABEL1:
DDETerminate Chan1
REM ScreenRefresh
ScreenUpdating 0'I'm usually reviewing the text, so prevent screen disruption.
REM there should be an easier way to do this
EditGoTo .Destination = "RPM"
If SelInfo(15) = 1 Then 'only 1 row in table
result = Fns.TextToDataTable("33", "RPM")
Else
EditGoTo .Destination = "\cell" : LineDown
If Fns.CellIsEmpty Then result = Fns.TextToDataTable("33", "RPM")
EndIf
REM put a 0 in the Kp column
EditGoTo .Destination = "Kp"
If SelInfo(15) = 1 Then 'only 1 row in table
result = Fns.TextToDataTable("0", "Kp")
Else
EditGoTo .Destination = "\cell" : LineDown
If Fns.CellIsEmpty Then result = Fns.TextToDataTable("0", "Kp")
EndIf
ScreenUpdating 1
REM process all consecutive Tab2c-format lines
EditGoTo .Destination = "s2"
LOOP3:
EditGoTo .Destination = "\Para"
s$ = RTrim$(LTrim$(CleanString$(Selection$()))) :REM 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
StartOfLine
Tableize2Columns
GotOne = - 1
Else
i = i + 1
EndIf
Wend
If GotOne = 0 Then Goto StartTAB1CTests :'else it keeps trying the same failed line
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.
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\Para"
s$ = RTrim$(LTrim$(CleanString$(Selection$()))) :REM get the source
If Len(s$) <= 2 Then StartOfLine : Goto endtab1cproc
s$ = Left$(s$, Len(s$) - 1) :REM 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
ParaDown :REM down 1 line to prospective composition list start
SetStartOfBookmark "\Para", "BeginPara" :REM start building a "selection"
SetStartOfBookmark "\Para", "EndPara" :REM it starts as zero-length
EditGoTo .Destination = "\Para"
i = 0
While Len(Compositions$(i)) > 0
If InStr(Selection$(), Compositions$(i)) Then
ParaDown
SetStartOfBookmark "\Para", "EndPara"
EditGoTo .Destination = "\Para"
EndIf
i = i + 1
Wend
If CmpBookmarks("BeginPara", "EndPara") = 2 Then
EditGoTo .Destination = "BeginPara"
ExtendSelection
EditGoTo .Destination = "EndPara"
Cancel
EndIf
EditBookmark .Name = "BeginPara", .SortBy = 0, .Delete
EditBookmark .Name = "EndPara", .SortBy = 0, .Delete
EndIf
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(Selection$()) = 1 Then
EditGoTo .Destination = "s2" : EditGoTo .Destination = "\section"
SelType 1 'just a signal that the macro is done
EndIf
End Sub
REM ----------------------------------------------------------------------------
Function ParaIsAllGarbage
ParaIsAllGarbage = - 1
REM prevents deleting a section break line.
EditGoTo .Destination = "\para"
EditFind .Find = "^b", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then ParaIsAllGarbage = 0 : Goto PIAGbye
s$ = RTrim$(LTrim$(CleanString$(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 ----------------------------------------------------------------------------
Sub MAIN REM RemoveAllSpaces If Len(Selection$()) <= 1 Then EditGoTo .Destination = "\para" EditReplace .Find = " ", .Replace = "", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 End Sub
Sub MAIN REM Tableize1Column, assigned to TAB1C button, 3/17/02 REM (c)Copyright 2000,2002 by Steven Whitney REM at time of call, selection must either be ON, or CONTAIN, 1 or more lines of compositions, which follow a (not selected) composer's name. EditBookmark .Name = "temp", .SortBy = 1, .Add If Len(Selection$()) <= 1 Then EditGoTo .Destination = "\Para" REM whitespace-strip all the lines (compositions) in user selection, EditReplace .Find = "^w^p", .Replace = "^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 EditReplace .Find = "^p^w", .Replace = "^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 REM put the compositions into column 2 of a 2-column table. TabIn :REM my macro TextToTable .ConvertFrom = "1", .NumColumns = "2", .NumRows = "10", .InitialColWidth = "4" + Chr$(34), .Format = "0", .Apply = "167" TableSelectTable EditBookmark .Name = "temptable", .SortBy = 0, .Add REM go up one line to get composer LineUp 1 EndOfLine : StartOfLine 1 If Len(Selection$()) <= 1 Then Goto bye :REM avoid processing entire document REM compress all its whitespace to a single space, then trim both ends EditReplace .Find = "^w", .Replace = " ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 A$ = RTrim$(LTrim$(CleanString$(Selection$()))) StartOfLine : EndOfLine 1 :REM now select whole line including pmark, to cut it EditCut EditGoTo .Destination = "temptable" 'avoids ambiguity EditBookmark .Name = "temptable", .SortBy = 0, .Delete StartOfLine Insert A$ StartOfLine : EndOfLine 1 'select the whole cell If EndOfColumn(1) Then 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. TableSelectTable EditCut EditBookmark .Name = "temp", .SortBy = 1, .Add EditGoTo .Destination = "Composer" If Not Fns.DownToFirstEmptyCell Then EditGoTo .Destination = "temp" EditPaste bye: EditGoTo .Destination = "temp" End Sub
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. EditBookmark .Name = "temp", .SortBy = 1, .Add If Len(Selection$()) <= 1 Then EditGoTo .Destination = "\Para" REM prepare (whitespace-strip) all the lines (compositions) in user selection, EditReplace .Find = "^w^p", .Replace = "^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 EditReplace .Find = "^p^w", .Replace = "^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 EditReplace .Find = ":^w", .Replace = ":", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 EditReplace .Find = "^w:", .Replace = ":", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 EditReplace .Find = ":", .Replace = "^t", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0 REM NumRows argument doesn't matter. TextToTable .ConvertFrom = "1", .NumColumns = "2", .NumRows = "10", .InitialColWidth = "4" + Chr$(34), .Format = "0", .Apply = "167" TableSelectTable EditCut EditBookmark .Name = "temp", .SortBy = 1, .Add EditGoTo .Destination = "Composer" REM if it fails, paste the original selection back where it was. If Not Fns.DownToFirstEmptyCell Then EditGoTo .Destination = "temp" EditPaste bye: 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.
Sub main
REM 3/18/02 Main is a dummy. This sub does nothing.
REM this macro holds old unused code, for archival purposes in case I need to do something similar later.
REM 12/26/05 it appears to contain methods tried and then abandoned, possibly useful for historical reference,
REM and it looks like it contains some DDE SQL methods that are no longer used anywhere in the project.
End Sub
REM ----------------------------------------------------------------------------
Sub AddCompositionFlag
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(Selection$()) <= 1 Then SelectCurWord
FormatChangeCase .Type = 3 'change selection to title case
REM compress all its whitespace (incl paramarks) to a single space, then trim both ends
EditReplace .Find = "^p", .Replace = " ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
EditReplace .Find = "^w", .Replace = " ", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
tofind$ = RTrim$(LTrim$(CleanString$(Selection$())))
EditCut
EditPaste
If Not 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 = DDEInitiate("MSAccess", "RECORDS;SQL " + LOOKUP$ + ";")
MyData$ = 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!
DDEExecute Chan1, "[OpenTable CompositionFlags,0,1]" :REM open table
DDEExecute Chan1, "[DoMenuItem 11, 1, 6]" :REM Edit|PasteAppend
DDEExecute Chan1, "[DoMenuItem 11, 0, 3]" :REM File|SaveRecord
EndIf
DDETerminate Chan1
bye:
End Sub
REM ----------------------------------------------------------------------------
Function SelIsAComposer
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(Selection$()) <= 1 Then Goto bye5
If Not OpenRECORDSDatabase Then Goto bye5
On Error Goto DDEDone
Chan1 = DDEInitiate("MSAccess", "RECORDS;QUERY ComposersByLength")
While 1 ' while Err <> 503?
MyData$ = DDERequest$(Chan1, "NextRow")
EditFind .Find = MyData$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then
SelIsAComposer = - 1
Goto DDEDone
EndIf
Wend
DDEDone:
DDETerminate Chan1
On Error Goto 0
bye5:
End Function
REM ----------------------------------------------------------------------------
Function SelIsAComposition
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(Selection$()) <= 1 Then Goto bye6
REM EXCLUDE COMMON MISTAKES ("SYMPHONY ORCHESTRA",)
EditFind .Find = "orchestra", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then Goto BYE6
If Not OpenRECORDSDatabase Then Goto bye6
On Error Goto DDEDone
Chan1 = DDEInitiate("MSAccess", "RECORDS;TABLE CompositionFlags")
While 1 ' while Err <> 503?
MyData$ = DDERequest$(Chan1, "NextRow")
EditFind .Find = MyData$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then
SelIsAComposition = - 1
Goto DDEDone
EndIf
Wend
DDEDone:
DDETerminate Chan1
On Error Goto 0
bye6:
End Function
REM ----------------------------------------------------------------------------
Function FindAndTransferFieldData(fieldname$, concatenate) :REM 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.
Count = 0
Cat$ = "" :REM 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.
EditBookmark .Name = "FATFDtemp", .SortBy = 1, .Add
If Len(Selection$()) <= 1 Then Goto bye8
If Not OpenDatabase("C:\DATABASE\RECORDS\RECORDS.MDB") Then Goto bye8
f$ = fieldname$ :REM 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
EditCopy :REM save the original text because it will be altered
REM OriginalText$ = Selection$() :rem a better save method?
s$ = CopySelOrLine$ :REM this removes paramarks, compresses, and strips
EditClear :REM delete the modified selection
EditPaste :REM restore the original text.
t$ = ""
For i = 1 To Len(s$) :REM 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$ = "" :REM 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
Dim SQL$(20) :REM holds the cut-up pieces of the SQL string
i = 0
startpos = 1
While startpos <= Len(q$)
SQL$(i) = Mid$(q$, startpos, 200) :REM copy the first 200 chars
startpos = startpos + 200
i = i + 1
Wend
q$ = ""
REM ----- Send the SQL query and process result
On Error Goto DDEDone
Chan1 = DDEInitiate("MSAccess", "RECORDS;SQL ")
i = 0
While Len(SQL$(i))
DDEPoke Chan1, "SQLTEXT", SQL$(i)
i = i + 1
Wend
REM this loop cuts and pastes ALL that are found.
While 1
MyData$ = DDERequest$(Chan1, "NextRow")
tab = InStr(MyData$, Chr$(9))
MyData$ = Mid$(MyData$, 1, tab - 1)
EditGoTo .Destination = "FATFDtemp"
EditFind .Find = MyData$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then
Count = Count + 1
If concatenate Then
If Len(Cat$) Then Cat$ = Cat$ + "; "
Cat$ = Cat$ + MyData$ :REM note this uses MyData$ from MDB, not the selection
EditCut :REM because we're not using TransferToDataTable, which cuts
Else
result = TransferToDataTable(fieldname$) :REM MOVES selected text to DataTable
EndIf
EndIf
Wend
DDEDone:
DDETerminate Chan1
If concatenate Then If Len(Cat$) Then result = TextToDataTable(Cat$, fieldname$)
On Error Goto 0
If Count > 0 Then Goto bye8 :REM 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.
Dim LeadingFlags$(5)
LeadingFlags$(0) = "conducted by "
Dim 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
EditGoTo .Destination = "FATFDtemp"
EditFind .Find = TrailingFlags$(i), .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
While EditFindFound()
a$ = Selection$() 'save the flag's text, but not to clipboard
EditClear 'remove the flag
WordLeft 2, 1 'and select previous 2 words
If MsgBox("Cut and paste this " + fieldname$ + "?", "Is this the Right One?", 36) = - 1 Then
Count = Count + 1
result = TransferToDataTable(fieldname$) :REM 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.
CharRight
Insert a$
Goto FATFD1
EndIf
EditGoTo .Destination = "FATFDtemp"
EditFind
Wend
Next i
FATFD1:
If Count > 0 Then Goto bye8
For i = 0 To 5
If Len(LeadingFlags$(i)) = 0 Then Goto FATFD2
EditGoTo .Destination = "FATFDtemp"
EditFind .Find = LeadingFlags$(i), .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
While EditFindFound()
a$ = Selection$() 'save the flag's text, but not to clipboard
EditClear 'remove the flag
WordRight 2, 1 'and select next 2 words
If MsgBox("Cut and paste this " + fieldname$ + "?", "Is this the Right One?", 36) = - 1 Then
Count = Count + 1
result = TransferToDataTable(fieldname$) :REM 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.
CharLeft
Insert a$
Goto FATFD2
EndIf
EditGoTo .Destination = "FATFDtemp"
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:
EditGoTo .Destination = "FATFDtemp"
EditBookmark .Name = "FATFDtemp", .SortBy = 1, .Delete
FindAndTransferFieldData = Count
End Function
REM ----------------------------------------------------------------------------
Function FieldDataFoundInSel$(fieldname$)
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$ = ""
EditBookmark .Name = "SHFDtemp", .SortBy = 1, .Add
If Len(Selection$()) <= 1 Then EditGoTo .Destination = "\Para"
If Len(Selection$()) <= 1 Then Goto bye9 :REM nothing to search for
If Not OpenDatabase("C:\DATABASE\RECORDS\RECORDS.MDB") Then Goto bye9
f$ = fieldname$ :REM 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.
EditCopy
REM OriginalText$ = Selection$() :rem a better save method?
s$ = CopySelOrLine$ :REM this removes paramarks, compresses, and strips
EditClear :REM delete the modified selection
EditPaste :REM 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$ = "" :REM 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
Dim SQL$(20) :REM holds the cut-up pieces of the SQL string
i = 0
startpos = 1
While startpos <= Len(q$)
SQL$(i) = Mid$(q$, startpos, 200) :REM copy the first 200 chars
startpos = startpos + 200
i = i + 1
Wend
q$ = ""
REM ----- Send the SQL query and process result
On Error Goto DDEDone
Chan1 = DDEInitiate("MSAccess", "RECORDS;SQL ")
i = 0
While Len(SQL$(i))
DDEPoke Chan1, "SQLTEXT", SQL$(i)
i = i + 1
Wend
MyData$ = DDERequest$(Chan1, "NextRow")
tab = InStr(MyData$, Chr$(9))
MyData$ = Mid$(MyData$, 1, tab - 1)
EditGoTo .Destination = "SHFDtemp"
EditFind .Find = MyData$, .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .Format = 0, .Wrap = 0
If EditFindFound() Then FieldDataFoundInSel$ = Selection$()
DDEDone:
DDETerminate Chan1
On Error Goto 0
bye9:
EditGoTo .Destination = "SHFDtemp"
EditBookmark .Name = "SHFDtemp", .SortBy = 1, .Delete
End Function
REM ----------------------------------------------------------------------------
Sub MAIN
REM misc
REM 11/21/00
REM THIS IS AN ARCHIVE FOR MISC keyboard COMMANDS I USED DURING EDITING records.doc,
REM to fix problems commonly found in scanned text.
REM Its purpose is to store the pattern match strings so I don't have to figure them out again.
REM IT IS FOR REFERENCE ONLY, NOT TO BE RUN.
Stop
REM THIS IS A TINY DOT THAT OFTEN SEPARATES COMPOSITIONS OR SOLOISTS in scanned text
REM IT IS CHR$(183) OR ^0183
EditReplace .Find = "•", .Replace = "^p", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 0
EditReplace .Find = "(Op)([0-9]@>)", .Replace = "Op. \2", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceOne, .Format = 0, .Wrap = 2
EditReplace .Find = "(<Cal)([0-9]@>)", .Replace = "CAL\2", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .FindNext, .Format = 0, .Wrap = 2
REM this search string locates this p r o b l e m, and other errors.
REM "( )([!ABCDEFGIai\-&0-9,.•])( )"
EditReplace .Find = "<Cto>", .Replace = "Concerto", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 2
EditReplace .Find = "(" + Chr$(34), .Replace = "(", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 2
EditReplace .Find = Chr$(34) + ")", .Replace = ")", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 2
EditReplace .Find = "[", .Replace = "", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 2
EditReplace .Find = "]", .Replace = "", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 1, .SoundsLike = 0, .ReplaceAll, .Format = 0, .Wrap = 2
End Sub
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.
Sub MAIN
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
DDETerminateAll
REM MicrosoftAccess
REM MicrosoftExcel
REM to do:
REM msaccess done
REM excel done
REM winword done
Chan1 = DDEInitiate("winword", "System")
If Chan1 = 0 Then
MsgBox "Failed to open DDE channel.", "Cannot Continue", 48
Goto bye
EndIf
a$ = DDERequest$(Chan1, "sysitems")
EndOfDocument
Insert a$
InsertPara
REM Goto bye
REM create a table, then inquire about the topics (now 1 in each cell)
LineUp
StartOfLine
EditGoTo "\Para"
TextToTable .ConvertFrom = "1", .NumColumns = "4", .NumRows = "1", .InitialColWidth = "Auto", .Format = "0", .Apply = "167"
On Error Goto done
While SelInfo(12) = - 1 And NextCell() <> 0
a$ = DDERequest$(Chan1, Selection$())
b$ = b$ + a$ + Chr$(13)
Wend
done:
EndOfDocument
Insert b$
InsertPara
InsertPara
REM DDETerminate Chan1 'WE'RE THROUGH WITH THE SYSTEM TOPIC
On Error Goto 0
bye:
DDETerminateAll
End Sub
Sub MAIN
REM LaunchWTalk
REM tests auto-launch and DDE server use of my program WTalk.exe,
REM which parses text grammatically. Works!
REM 3/6/02
REM (c)Copyright 2002 by Steven Whitney
REM HERE'S HOW YOU USE IT:
If Fns.StartWTalk Then
Chan1 = DDEInitiate("WTALK", "System")
REM send the command to WTALK. It leaves the result in the database.
DDEExecute chan1, "parse this is a test."
DDETerminate Chan1
'VIEW THE RESULT IN MDB
Chan1 = DDEInitiate("MSACCESS", "WTALK")
DDEExecute Chan1, "[OpenQuery ToksEditor]"
DDEExecute Chan1, "[Maximize]"
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]"
DDETerminate Chan1
EndIf
bye:
DDETerminateAll
End Sub
|
|
|
|
|
|