Dim Shared Additional_Text$, Add_Date, Add_Time
Dim Shared IncludeProgram, PrintDone, File_Name$, Key_Word$
Dim Shared NameFont$, SizeFont$, HdrFont$, HdrSize$, Page_Num
Dim Shared Cancel_Macro$, NumOfWords, KW_Array$(100), KWArray_Num
Dim Shared Options_Dlg As UserDialog

Dim Shared Def_AT$, Def_IP, Def_ID, Def_IT, Def_HF$, Def_HS$
Dim Shared Def_PD, Def_EP, Def_PF$, Def_PS$, KWFile$

Sub MAIN

ScreenUpdating(0)
Cancel_Macro$ = "NO"
Open_File
If Cancel_Macro$ = "YES" Then Goto Done
Get_Options
If Cancel_Macro$ = "YES" Then Goto Done
Do_Header
Format_Program
StartOfDocument
ScreenUpdating(1)

Done:
End Sub

Sub Do_Header

' Create Header 
HDR$ = ""
   
' Add Date
If Add_Date = 1 Then
   HDRDate$ = Date$() + "  "
   HDR$ = "YES"
End If

' Add Time
If Add_Time = 1 Then
   HDRTime$ = Time$() + "  "
   HDR$ = "YES"
End If

' Add Program Name
If IncludeProgram = 1 Then
   HDRProgName$ = File_Name$ + String$((35 - Len(File_Name$)), " ")
   HDR$ = "YES"
Else
   HDRProgName$ = String$(35, " ")
End If

' Add Additional Text
If LTrim$(Additional_Text$) <> "" Then
   HDRAT$ = Additional_Text$
   HDR$ = "YES"
End If

If HDR$ = "YES" Then
   Print "Creating Header"
   NormalViewHeaderArea
   If HDRDate$ <> "" Or HDRTime$ <> "" Then
      Bold(1)
      Insert "Printed : "
      Bold(0)
      Insert HDRDate$ + "   " + HDRTime$ + Chr$(13)
   EndIf
   If HDRProgName$ <> "" Then
      Bold(1)
      Insert "File Name : "
      Bold(0)
      Insert HDRProgName$ + Chr$(13)
   EndIf
   If HDRAT$ <> "" Then
      Bold(1)
      Insert "Additional Information : "
      Bold(0)
      Insert HDRAT$
   EndIf
   Insert Chr$(13)
      
   ' Turn page numbering on ... if selected
   If Page_Num = 1 Then InsertPageNumbers .Type = 0, .Position = 2

   ExtendSelection
   LineUp(1, 0)
   StartOfLine
   BorderLineStyle(3)
   BorderBottom
   LineUp(1, 1)
   LineUp(1, 1)
   Font HdrFont$, Val(HdrSize$)
   ViewHeader()
   CloseViewHeaderFooter
EndIf

End Sub

Sub Open_File

Print "Select Pascal File to Print"
ChDir "C:\TP\PROGS"
Dim File_Dialog As FileOpen
GetCurValues File_Dialog
File_Dialog.Name = "*.pas"
X = Dialog(File_Dialog)
If X = 0 Then
   Cancel_Macro$ = "YES"
   Goto Done
End If
FileOpen File_Dialog
File_Name$ = UCase$(FileName$())

Done:
End Sub

Sub Get_Options
' Show the dialog box ... get options to print the program with

If Files$("C:\WINDOWS\PASPRT.INI") <> "" Then Read_Defaults

' Fill Font List
Dim FontList$(CountFonts() - 1), HdrFontList$(CountFonts() - 1)
For Count = 0 To CountFonts() - 1
    FontList$(Count) = Font$(Count + 1)
      If Font$(Count + 1) = Def_PF$ Then PF = Count
    HdrFontList$(Count) = Font$(Count + 1)
      If Font$(Count + 1) = Def_HF$ Then HF = Count
Next Count

' Fill Font Size 
Dim FontSize$(10), HdrFontSize$(10)
X = 0
For Count = 8 To 18 Step 2
    FontSize$(X) = Str$(Count)
      If LTrim$(FontSize$(X)) = Def_PS$ Then PS = X
    HdrFontSize$(X) = Str$(Count)
      If LTrim$(FontSize$(X)) = Def_HS$ Then HS = X
    X = X + 1
Next Count

' Fill Key Word ListBox
Dim KeyWords$(100)
For X = 0 To 100
    KeyWords$(X) = KW_Array$(X)
Next X

Print "Select Printing Options"
DTitle$ = "Pascal Print [" + File_Name$ + "]"
Begin Dialog UserDialog 502, 282, DTitle$, .Dlg_Function
	OKButton 196, 252, 88, 21
	CancelButton 407, 254, 88, 21
	GroupBox 7, 9, 490, 112, "Header Information"
	DropListBox 378, 88, 60, 40, HdrFontSize$(), .HdrFontSize
	Text 21, 90, 124, 13, "Font Information", .Text3
	DropListBox 160, 88, 204, 67, HdrFontList$(), .HdrFonts
	CheckBox 18, 63, 196, 16, "Include program name", .Includeprog
	CheckBox 221, 63, 127, 16, "Include Date", .IncludeDate
	CheckBox 354, 63, 127, 16, "Include Time", .IncludeTime
	TextBox 149, 30, 333, 18, .Name$
	Text 16, 32, 125, 13, "Additional Text :", .Text2
	GroupBox 192, 123, 305, 57, "Options"
	CheckBox 208, 158, 211, 16, "Enable Page Numbering", .NumberPages
	CheckBox 208, 139, 152, 16, "Print when done", .Printdone
	GroupBox 193, 184, 305, 43, "Program Font Information"
	DropListBox 420, 202, 60, 40, FontSize$(), .FontSize
	DropListBox 204, 201, 204, 67, FontList$(), .FontList_lb
	GroupBox 8, 123, 180, 151, "Key Words"
	ListBox 16, 138, 164, 79, KeyWords$(), .KeyWords_lb
	PushButton 116, 248, 64, 21, "Add", .AddKW_btn
	PushButton 16, 248, 68, 21, "Delete", .DelKW_btn
	TextBox 17, 223, 160, 19, .NewKeyWord$
End Dialog

' write defaults to dialog box
Options_Dlg.FontList_lb = PF
Options_Dlg.HdrFonts = HF
Options_Dlg.Fontsize = PS
Options_Dlg.HdrFontSize = HS
Options_Dlg.Name$ = Def_AT$
Options_Dlg.IncludeProg = Def_IP
Options_Dlg.IncludeDate = Def_ID
Options_Dlg.IncludeTime = Def_IT
Options_Dlg.NumberPages = Def_EP
Options_Dlg.PrintDone = Def_PD

X = Dialog(Options_Dlg)

' Check for cancel click on dialog box
If X = 0 Then
   Cancel_Macro$ = "YES"
   Goto Done
End If

' Assign Dialog information to Variables
Additional_Text$ = Options_Dlg.Name$
IncludeProgram = Options_Dlg.IncludeProg
Add_Date = Options_Dlg.IncludeDate
Add_Time = Options_Dlg.IncludeTime
PrintDone = Options_Dlg.PrintDone
Page_Num = Options_Dlg.NumberPages
NameFont$ = FontList$(Options_Dlg.FontList_Lb)
SizeFont$ = LTrim$(FontSize$(Options_Dlg.FontSize))
HdrFont$ = HdrFontList$(Options_Dlg.HdrFonts)
HdrSize$ = LTrim$(HdrFontSize$(Options_Dlg.HdrFontSize))

SaveSettings

Done:
End Sub

Sub Format_Program

' Do Formating of the program
Print "Formatting Text"
EndOfDocument(1)
Font NameFont$, Val(SizeFont$)

StartOfDocument
Skip_Char$ = " ,)][(.!@#$%^&*-_=+:"
Comment$ = "No"
InText$ = "NO"
While AtEndOfDocument() <> - 1

   If WordRight(1, 1) = 0 Then Goto Done
  
   ' check if this selection should be skipped
   If Len(Selection$()) = 1 Then
      If InStr(Skip_Char$, Selection$()) > 0 Then
         ShrinkSelection
         If WordRight(1, 0) = 0 Then Goto Done
         Goto Loop
      End If
   End If

   If Comment$ = "No" Then Italic(0)
   If Right$(Selection$(), 1) = "'" And InText$ = "YES" Then
      InText$ = "NO"
   End If

   ' turn italic for comments on or keep it on
   If InStr(Selection$(), "{") > 0 Or Comment$ = "Yes" Then
      Italic(1)
      Comment$ = "Yes"
   End If   

   ' turn italic for comments off
   If InStr(Selection$(), "}") > 0 Then
      Comment$ = "No"
   End If

  ' add space to end of selection if needed
  If Right$(Selection$(), 1) <> " " Then
     ST$ = Selection$() + " "  
  Else
     ST$ = Selection$()
  EndIf
  
  ' Add Space to Selection if not there
  If Left$(ST$, 1) <> " " Then
     ST$ = " " + ST$
  Else
     ST$ = ST$
  EndIf

  ' Bold Key Word
  If Len(Selection$()) > 1 Then
     If Mid$(ST$, 2, 1) = "'" Then InText$ = "YES"
  End If
   
  If InStr(Key_Word$, UCase$(ST$)) > 0 And Comment$ = "No" Then
    If InText$ = "NO" Then
      ' lower case whole selection then Capitalize first letter      
      ChangeCase(0)
      ChangeCase(3)   
      Bold(1)
      ShrinkSelection
      If WordRight(1, 0) = 0 Then Goto Done
    Else
      ShrinkSelection
      If WordRight(1, 0) = 0 Then Goto Done
    End If
  Else
    ' Routine for checking if text marks are in same selection
    If InText$ = "YES" Then
       For Y = Len(Selection$()) To 1 Step - 1
           If Mid$(Selection$(), Y, 1) = "'" And Y > 1 Then
              InText$ = "NO"
              Goto Exit_For
           End If
       Next Y
    End If
Exit_For:
      ShrinkSelection
      If WordRight(1, 0) = 0 Then Goto Done
  End If

Loop:
Wend

Done:

' if Print when done option selected then print 
  If PrintDone = 1 Then FilePrint

End Sub

Sub SaveSettings
' Save the options to the ini file
a = SetPrivateProfileString("HEADER", "AdditionalText", Additional_Text$, \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("HEADER", "IncludeProgram", LTrim$(Str$(IncludeProgram)), \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("HEADER", "IncludeDate", LTrim$(Str$(Add_Date)), \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("HEADER", "IncludeTime", LTrim$(Str$(Add_Time)), \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("HEADER", "HeaderFontName", HdrFont$, \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("HEADER", "HeaderFontSize", HdrSize$, \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("OPTIONS", "PrintWhenDone", LTrim$(Str$(PrintDone)), \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("OPTIONS", "EnablePageNumbers", LTrim$(Str$(Page_Num)), \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("OPTIONS", "ProgramFontName", NameFont$, \
"C:\WINDOWS\PasPrt.ini")

a = SetPrivateProfileString("OPTIONS", "ProgramFontSize", SizeFont$, \
"C:\WINDOWS\PasPrt.ini")

' Save Keywords to File ... Build KeyWord Text String
Open KWFile$ For Output As #1
For X = 0 To KWArray_Num
    If KW_Array$(X) = "" Then Goto Done
    Print #1, KW_Array$(X)
    Key_Word$ = Key_Word$ + " " + KW_Array$(X)
Next X

Done:
Close #1
End Sub

Sub Read_Defaults
' Read the ini file for previously saved defaults

Def_AT$ = GetPrivateProfileString$("HEADER", "AdditionalText", "C:\windows\pasprt.ini")

Def_IP = Val(GetPrivateProfileString$("HEADER", "IncludeProgram", "C:\windows\pasprt.ini"))

Def_ID = Val(GetPrivateProfileString$("HEADER", "IncludeDate", "C:\windows\pasprt.ini"))

Def_IT = Val(GetPrivateProfileString$("HEADER", "IncludeTime", "C:\windows\pasprt.ini"))

Def_HF$ = GetPrivateProfileString$("HEADER", "HeaderFontName", "C:\windows\pasprt.ini")

Def_HS$ = GetPrivateProfileString$("HEADER", "HeaderFontSize", "C:\windows\pasprt.ini")

Def_PD = Val(GetPrivateProfileString$("OPTIONS", "PrintWhenDone", "C:\windows\pasprt.ini"))

Def_EP = Val(GetPrivateProfileString$("OPTIONS", "EnablePageNumbers", "C:\windows\pasprt.ini"))

Def_PF$ = GetPrivateProfileString$("OPTIONS", "ProgramFontName", "C:\windows\pasprt.ini")

Def_PS$ = GetPrivateProfileString$("OPTIONS", "ProgramFontSize", "C:\windows\pasprt.ini")

KWFile$ = GetPrivateProfileString$("GENERAL", "KeyWordsFile", "C:\windows\pasprt.ini")

Open KWFile$ For Input As #1
KWArray_Num = 0
While Not Eof(1)
   Input #1, KW_Array$(KWArray_Num)
   KWArray_Num = KWArray_Num + 1
Wend
KWArray_Num = KWArray_Num - 1
Close #1

End Sub

Function Dlg_Function(ControlID$, Action, SuppValue)

Select Case Action
Case 2
 Select Case ControlID$
  Case "AddKW_btn"
    ' assign text to variable check for validness
    nwkw$ = UCase$(DlgText$("NewKeyWord$"))
    If nwkw$ = "" Then Goto Done
    If KW_There(nwkw$) = - 1 Then Goto Add_Done
   
    ' add new keyword to array
    KWArray_Num = KWArray_Num + 1
    KW_Array$(KWArray_Num) = nwkw$
    KW_Array$(KWArray_Num + 1) = ""

    ' rebuild listbox 
    DlgListBoxArray "KeyWords_lb", KW_Array$()
  
Add_Done:
    DlgText$ "NewKeyWord$", ""
    Dlg_Function = 3
  
  Case "DelKW_btn"

    ' Delete a KeyWord from the Listbox
    Start_At = DlgValue("KeyWords_lb")
    For S = Start_At To KWArray_Num - 1
        KW_Array$(S) = KW_Array$(S + 1)
    Next S
    KW_Array$(KWArray_Num) = ""
    KWArray_Num = KWArray_Num - 1
    DlgListBoxArray "KeyWords_lb", KW_Array$()
    Dlg_Function = 3

  Case Else
    Dlg_Function = 0
 End Select
Case Else

End Select

Done:
End Function

Function KW_There(nwkw$)

' This function checks if the new key word is already there and returns
' true or false

KW_There = 0
For X = 0 To KWArray_Num
    If LTrim$(UCase$(nwkw$)) = LTrim$(UCase$(KW_Array$(X))) Then
       KW_There = - 1
       MsgBox "Key Word Already Exists. Can't Add!"
       Goto Done
    End If
Next X

Done:
End Function
