I use this function for printing out a textual version of calculation results so that they can be incorporated into a report without a lot of re-typing.
I have attached (I hope) a zip with the original PDF printout, along with the Word document for comparison.
I hope that this will be of use to someone!
Iain Johnstone
Code:
'======================================================
FUNCTION OutputToWord (message AS STRING, orientationtype AS LONG, fontname AS STRING, fontsize AS SINGLE, _
fontstyle AS LONG, colour AS LONG, linealignment AS LONG, setupflag AS LONG,printflag AS LONG,closeflag AS LONG) EXPORT AS LONG
'Thanks to Richard Angell, Fred Harris and Jose Roca for their help with this.
'Function usage:-
'Syntax (eg) = OutputToWord Message,0,"Courier New",10,0,1,0,1,1,0
' where Message is formatted text to print
' orientation - 0=portrait, 1=landscape
' typeface name e.g. "Arial"
' fontsize in points
' styles - normal=0, bold=1, italic=2, underscore=4 - may be added together for combined effects - e.g. 3 = bold italic
' colour - Auto = 0, Black = 1, Blue = 2, Turquoise = 3, BrightGreen = 4, Pink = 5, Red = 6, Yellow = 7, White = 8, DarkBlue = 9
' Teal = 10, Green = 11, Violet = 12, DarkRed = 13, DarkYellow = 14, Gray50 = 15, Gray25 = 16
' linealignment - 0=left, 1=centre, 2=right
' start - 1 to start up Word, 0 to ignore
' print - 1 to print text, 0 to ignore
' close - 1 to close Word, 0 to ignore
'so the above example will start Word and print the message in Courier New at 10 points in normal face, in black and left aligned
' OutputToWord Message,0,"Arial",12,1, 2, 1, 0,1,0 will continue to print in Arial 12 pt, in blue bold face and centred
' OutputToWord "",0,"",0,0,0,0,0,0,1 will close Word
STATIC oWordApp AS Int__Application ' Application Interface
STATIC oWordDoc AS Int__Document ' Document Interface
STATIC oWordSel AS Selection ' Selection
STATIC oWordFont AS Int__Font 'font
STATIC oPara AS Int__ParagraphFormat
LOCAL vFile AS VARIANT
LOCAL vFileFmt AS VARIANT
LOCAL result AS STRING
LOCAL iDocCount AS LONG
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
IF setupflag<>0 THEN
' Open an instance of MSWORD
IF ISTRUE ISOBJECT(oWordApp) THEN 'no, not with this code ...
MSGBOX "Tsk, Tsk ... finish the current MSWORD document first!"
EXIT FUNCTION
END IF
oWordApp = NEWCOM $PROGID_Application
' Could MSWORD be opened? If not, terminate this app
IF ISFALSE ISOBJECT(oWordApp) THEN
MSGBOX "Unable to open or start MSWORD!"
EXIT FUNCTION
END IF
' Make MSWORD visible in for example normal show state
oWordApp.Visible = 1
oWordApp.WindowState = %wdWindowStateNormal
' Get the current document count from the "documents collection"
iDocCount = oWordApp.Documents.Count
oWordDoc = oWordApp.Documents.Add
IF ISFALSE ISOBJECT(oWordDoc) THEN
MSGBOX "MSWORD was not able to start a new document." & $CR & _
"Please ensure MSWord and VBA are installed."
GOTO Terminate
END IF
oWordSel = oWordApp.Selection
IF ISFALSE ISOBJECT(oWordSel) THEN
MSGBOX "MSWORD was not able to get a Selection." & $CR & _
"Please ensure MSWord and VBA are installed."
GOTO Terminate
END IF
oWordFont = oWordSel.Font
IF ISFALSE ISOBJECT(oWordFont) THEN
MSGBOX "MSWORD was not able get a font objectt." & $CR & _
"Please ensure MSWord and VBA are installed."
GOTO Terminate
END IF
' Get the current document count from the "documents collection" - This should be one value higher than before
iDocCount = oWordApp.Documents.Count
'set orientation and margins
oWordDoc.PageSetup.SectionStart = %wdSectionNewPage
oWordDoc.PageSetup.orientation= orientationtype ' from header
oWordApp.Options.MeasurementUnit=3 'points
'measurements in points
oWordDoc.PageSetup.TopMargin=72
oWordDoc.PageSetup.BottomMargin=90
oWordDoc.PageSetup.LeftMargin=36
oWordDoc.PageSetup.RightMargin=36
oWordDoc.PageSetup.Gutter=0
IF orientationtype=1 THEN 'landscape A4 converted to points
oWordDoc.PageSetup.PageWidth = (72*11.66)
oWordDoc.PageSetup.PageHeight = (72*8.25)
ELSE
oWordDoc.PageSetup.PageHeight = (72*11.66)
oWordDoc.PageSetup.PageWidth = (72*8.25)
END IF
oWordSel = oWordApp.Selection
END IF
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
IF printflag<>0 THEN
'set font - face may change through document
IF oWordFont.Name <> ACODE$(fontname) THEN
'for Int_Font
oWordFont.Name= UCODE$(fontname) 'string from header
END IF
IF oWordFont.Size <> fontsize THEN
oWordFont.Size=fontsize 'single from header
END IF
'set style
SELECT CASE Fontstyle
CASE 0
oWordFont.Bold = 0
oWordFont.italic = 0
oWordFont.underline = 0
CASE 1
oWordFont.Bold = 1
oWordFont.italic = 0
oWordFont.underline = 0
CASE 2
oWordFont.Bold = 0
oWordFont.italic = 1
oWordFont.underline = 0
CASE 3
oWordFont.Bold = 1
oWordFont.italic = 1
oWordFont.underline = 0
CASE 4
oWordFont.Bold = 0
oWordFont.italic = 0
oWordFont.underline = 1
CASE 5
oWordFont.Bold = 1
oWordFont.italic = 0
oWordFont.underline = 1
CASE 5
oWordFont.Bold = 0
oWordFont.italic = 1
oWordFont.underline = 1
CASE 7
oWordFont.Bold = 1
oWordFont.italic = 1
oWordFont.underline = 1
END SELECT
'set colour
oWordFont.ColorIndex = colour
'set line alignment
oWordSel = oWordApp.Selection
oPara = oWordSel.ParagraphFormat
oPara.Alignment=LineAlignment
'printing starts here
oWordSel = oWordApp.Selection
oWordSel.TypeText(UCODE$(message))
' Set a paragraph marker (end of paragraph)
oWordSel.TypeParagraph
END IF
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
IF closeflag <>0 THEN
' Close the current document and then close MSWORD completely if required
templong=MSGBOX ("Close MSWORD?",%MB_YESNO OR %MB_TASKMODAL,"Masterdrain")
IF templong=%IDYES THEN
'save file
result=INPUTBOX$("Enter filename to save","About to save the document...", "Output.doc") 'this is untidy
IF RIGHT$(result,4)<>".doc" THEN result=result+".doc"
vFile = result
vFileFmt = %wdFormatDocument
oWordDoc.SaveAs(vFile, vFileFmt)
oWordApp.ActiveWindow.CLOSE
oWordApp.Quit
' Close all of the Interfaces
oWordSel = NOTHING
oWordDoc = NOTHING
oWordApp = NOTHING
oWordFont = NOTHING
END IF
END IF
FUNCTION =1:EXIT FUNCTION
Terminate:
oWordApp.ActiveWindow.CLOSE
oWordApp.Quit
' Close all of the Interfaces
oWordSel = NOTHING
oWordDoc = NOTHING
oWordApp = NOTHING
oWordFont = NOTHING
FUNCTION =1
END FUNCTION
'=======================================================