'MacroName:PrintLQ
'MacroDescription:Print letter-quality records with the SOM character always printing correctly.
'  Created by: Joel Hahn, Niles Public Library District

'***************************************************************************
'*
'* Note: You must set the file locations information to reflect your 
'* CatME settings.  Look for
'*     WherePrint$ =
'*     WherePrintDir$ =
'* and change the data after the equals signs to your local settings.
'*
'***************************************************************************
'*
'* Note: In order to print letter-quality, you must have a letter-quality
'* printer (such as HP LaserJet) set as your "default" Windows printer
'* (in Start Menu / Settings / Printers).  The macro will remind you of this 
'* if you forget.
'*
'* If you also use the PrintRecordNoDiacritics macro, this setting does not
'* affect the output of that macro; it should still print in draft mode.
'*
'***************************************************************************

Option Explicit

Declare Function ReplaceDiacritics(Text$) As String

'Set up information needed for API calls
Const PRINTER_ENUM_DEFAULT = &H1
Type PRINTER_INFO_1
  flags As Long
  pDescription As String
  pName As String
  pComment As String
End Type
Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" _
   (ByVal flags As Long, ByVal pName As String, ByVal Level As Long, _
   pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, _
   pcReturned As Long) As Long
Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long

'***************************************************************************
sub main
   'Set up variables for API calls
   Dim Prntr As PRINTER_INFO_1
   Dim lhPrinter As Long
   Dim lReturn As Long
   Dim arraybuf() As Long
   Dim needed As Long
   Dim numitems As Long

   'Set up variables for file locations
   Dim WherePrint$
   Dim WherePrintDir$
   Dim FontPath$

   'Set up other variables
   Dim directory
   Dim filename$, filename2$
   Dim filenum%, filenum2%
   Dim x, y
   Dim RecLine$
   Dim Outdata$
   Dim bool

'***************************************************************************
'FILE LOCATIONS
   'The path CatME uses to print records to a file, and the directory part of 
   'that path
   WherePrint$ = "C:\OCLCAPPS\CatME\records.txt"
   WherePrintDir$ = "C:\OCLCAPPS\CatME\"

'***************************************************************************
   'Set up CS shortcut
   Dim CS as Object
   Set CS = CreateObject("CatME.Application")

   'Check that there is a record to print
   Err = 0
   On Error Resume Next
   CS.GetActiveRecord
   If Err Then
     MsgBox "There is not an active record in the display.  Exiting..."
     Goto Done
   End If
   On Error Goto 0

   'If necessary, copy the ALA font to the Windows\Fonts directory,
   'so that other programs can use it
   FontPath$ = Dir("C:\Windows\Fonts\ALACOUR.TTF",6) 
   If FontPath$ = "" Then
     FileCopy "C:\OCLCAPPS\ALACOUR.TTF", "C:\Windows\Fonts\ALACOUR.TTF"
   End If

   lReturn = EnumPrinters(PRINTER_ENUM_DEFAULT, "", 1, 0, 0, needed, numitems)
   ' Resize the array buffer to the needed size in bytes.
   ReDim arraybuf(0 To needed / 4 - 1)  ' remember each element is 4 bytes
   ' Retrieve the information about the default printer.
   lReturn = EnumPrinters(PRINTER_ENUM_DEFAULT, "", 1, arraybuf(0), needed, needed, numitems)
   ' Copy the printer name into the structure.  The rest is unnecessary.
   Prntr.pName = Space(lstrlen(arraybuf(2)))
   lReturn = lstrcpy(Prntr.pName, arraybuf(2))  
   'MsgBox Prntr.pName
   
   If InStr(Prntr.pName, "Generic") Then
     Outdata$ = "In order to print letter-quality, you must have a printer "
     Outdata$ = Outdata$ + "other than '" + Prntr.pName + "' selected as "
     Outdata$ = Outdata$ + "your WINDOWS default printer.  Print Anyway?"
     bool = MsgBox(Outdata$, 4, "Non-LQ Printer")
     If bool = 7 Then
       Goto Done
     End If
   End If

   'The macro may have problems if there are multiple records in an output
   'file, so if the file already exists, delete it first.
   directory=Dir ("C:\OCLCAPPS\CATME\*.*")
   Do While directory<>""
     If directory="records.txt" Then Kill "C:\OCLCAPPS\CATME\records.txt"
     directory=Dir
   Loop

   'Print the record 
   bool = CS.Print

   'Open the Record Print output file
   filename$ = WherePrint$
   filenum% = Freefile
   Open filename$ for Input As filenum%

   'Open the RTF file that will be sent to the printer
   filename2$ = WherePrintDir$ + "records.rtf"
   filenum2% = FreeFile
   Open filename2$ for Output As filenum2%

   'Output the RTF header info
   Print #filenum2%, "{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}{\f3\froman Times New Roman;}{\f4\fmodern\fcharset2 ALA BT Courier;}}"
   Print #filenum2%, "{\colortbl\red0\green0\blue0;}"
   Print #filenum2%, "\deflang1033\pard\plain\f4\fs20 ";

   'Chug through the record, a line at a time
   x=1
   Do Until x=Lof(1)
     Line Input #filenum%, RecLine$

     'Replace diacritics with RTF equivalents
     RecLine$ = ReplaceDiacritics(RecLine$)
     'Add the new RTF-format line to the output file
     If x>1 Then
       Print #filenum2%, "\par " + RecLine$
     Else
       Print #filenum2%, RecLine$
     End If

     x=x+1
     y=Seek(1)
     If y>Lof(1) then
       x=Lof(1)
     Else
       Seek 1,y
     End If
   Loop
 
   'Output the RTF footer info
   Print #filenum2%, "\par \plain\f2\fs20"
   Print #filenum2%, "\par }"
   Print #filenum2%, "a"

   Close filenum2%
   Close filenum%

   'Use WordPad to print the RTF file
   bool = Shell("write.exe /p "+WherePrintDir$ + "records.rtf", 7)

   'Clean up
   Kill WherePrint$
   '***Note: the RTF file cannot also be deleted here; if it is deleted, 
   '***then WordPad won't print it.  However, since the file is overwritten
   '***each time this macro is run, this isn't a problem.

Done:
end sub

'***************************************************************************
Function ReplaceDiacritics(Text$) As String
  Dim lt$
  Dim rt$
  Dim StrLen%
  Dim Char$
  Dim Result%
  Dim CheckDiacritic


  StrLen%=Len(Text$)
  'For CheckDiacritic=1 to StrLen%
  CheckDiacritic = 1
  Do
    Char$=Mid$(Text$, CheckDiacritic, 1)
    Result%=Asc(Char$)

    If Result%>127 Then
      If Result% = 255 Then Result% = 220
      lt$ = Left(Text$, CheckDiacritic-1)
      rt$ = Mid(Text$, CheckDiacritic+1)
      'MsgBox LCase(Hex(Result%))
      Text$ = lt$ + "\'" + LCase(Hex(Result%)) + rt$
      'MsgBox Text$
      StrLen% = StrLen% + 3
    End If
  'Next CheckDiacritic
   CheckDiacritic = CheckDiacritic + 1
  Loop While CheckDiacritic <= StrLen%

  ReplaceDiacritics$ = Text$
End Function
'***************************************************************************