Word COM function

[Iain Johnstone]

Bit of a joint effort, this one! My thanks to all those that helped to get it on the road.

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

'======================================================
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
'=======================================================