Sub Vision_Batch1()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 01\" + Date2 + "-01 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub

Sub Vision_Batch2()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 02\" + Date2 + "-02 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub

Sub Vision_Batch3()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 03\" + Date2 + "-03 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub


Sub Vision_Batch4()
'
' PasteToVision_Correspondence MMacro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 04\" + Date2 + "-04 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub


Sub Vision_Batch5()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 05\" + Date2 + "-05 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub


Sub Vision_Batch6()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 06\" + Date2 + "-06 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub

Sub Vision_Batch7()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 07\" + Date2 + "-07 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub

Sub Vision_Batch8()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 08\" + Date2 + "-08 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub

Sub Vision_Batch9()
'
' PasteToVision_Correspondence Macro Version 0.8
' Macro created 09/01/2001 by Simon Child
' © Simon Child 09/01/2001
    
On Error GoTo noselectError
    
Selection.Find.ClearFormatting

 'Replace tabs by spaces
 
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    ' Replace invalid apostrophes with ascii apostrophes
    
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = Chr(180)
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    
    
     ' Copy the letter to clipboard, then to DataObject LetterText, then make
     ' a string "Contents" containing the letter preceded by \\ and ended by two linefeeds
    Dim LetterText As New DataObject
    Dim Contents
    Selection.Copy
    LetterText.GetFromClipboard
    ' for Vision I shall add a few more keystrokes to set the correct type of correspondence, out-of-practice, etc
    Contents = "\\ " + LetterText.GetText(1) + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    
     ' Get the date, format it and store it with batch and filename info in "Message"
    Dim Date1, Date2, Message
    Date1 = Format(Date, "mmm d yyyy")
    Date2 = Format(Date, "dd-mm-yy")
    sYear = Format(Date, "yyyy")
    sMonth = Format(Date, "mmmm")
    sDay = Format(Date, "dd")
    
     ' To make a macro for batch 2, change the 1 and 01 in the next line to 2 and 02
    '  Message = "This letter has been scanned but the image file has not been saved" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    ' Message = "Letter image stored in Batch 1, " + Date1 + ", Filename " + Date2 + "-01.tif" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Message = "Image file in " + Chr(34) + "F:\Scans\" + sYear + "\" + sMonth + "\Day " + sDay + "\Batch 09\" + Date2 + "-09 Page" + ".tif" + Chr(34) + Chr(13) + Chr(10) + Chr(13) + Chr(10)

     
     ' Combine the two strings into one DataObject and put it on the clipboard
    Dim PasteString As New DataObject
    PasteString.SetText (Contents) + (Message)
    PasteString.PutInClipboard
     
On Error GoTo appnotopenError
    
     ' change to Notepad/Correspondence Add - put title of appropriate window between the inverted commas
     
    AppActivate "Clinical Correspondence - Add"
    
    ' AppActivate "test.txt - Notepad"
    
     ' Paste clipboard contents to Vision/Notepad, and exit
        
    SendKeys "%y{UP 4}%p%s^V{TAB 3}{ENTER}"
    
Exit Sub

noselectError:
    
    MsgBox "You have not selected any text to copy to Vision."
    Exit Sub
    Resume

appnotopenError:
    MsgBox "You have not opened the correct correspondence box in the patient's Vision record ready to receive the text of this letter." + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "Make sure that Vision is running, that the correct patient is selected, and that the Clinical Correspondence - Add box has been opened."
    Exit Sub
    Resume

End Sub