Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Word COM with multiple documents

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Word COM with multiple documents

    Code:
    'This builds on an example at http://www.powerbasic.com/support/pbforums/showthread.php?t=38506 
    'to make a function which multiple documents can be in progress toward completion , likely where they
    'would have some relative association one with another.
    '
    'Feel free to post alter version here as well.  Perhaps one with globals allowing the big OutputToWord
    'function to be made into several smaller ones.
    '
    'Thanks to Ian Johnston, Fred Harris and Jose Roca for portions of the code, modded here as shown.
    
    #COMPILE EXE
    #DIM ALL
    #INCLUDE "msWord.inc"
    
    
    FUNCTION PBMAIN () AS LONG
        DIM MyWords(1 TO 2) AS LONG
        MyWords(1) = OutputToWord (0,"Hello Earth"+$CRLF,0,"Arial",16,0,0,0,1,1,0)
        ? "Created & printed to document "+FORMAT$(MyWords(1))
        MyWords(2) = OutputToWord (0,"Hello Moon"+$CRLF,0,"Courier",32,1,6,0,1,1,0) ' this test triggers the checking
        ? "Created & printed to document "+FORMAT$(MyWords(2))
    
        MyWords(1) = OutputToWord (1,"Hello Forum"+$CRLF,0,"Arial",32,0,4,0,0,1,0)
        ? "Printed to document "+FORMAT$(MyWords(1))
        MyWords(2) = OutputToWord (2,"Hello PB"+$CRLF,0,"Courier",16,1,2,3,0,1,0)
        ? "Printed to document "+FORMAT$(MyWords(2))
    
        MyWords(1) = OutputToWord(1,"",0,"",0,0,0,0,0,0,1)
        ? "Closed document "+FORMAT$(-1* MyWords(1))
        MyWords(2) = OutputToWord(2,"",0,"",0,0,0,0,0,0,1)
        ? "Closed document "+FORMAT$(-1* MyWords(2))
    END FUNCTION
    
    FUNCTION OutputToWord (BYVAL oindx AS LONG,BYVAL message AS STRING,BYVAL orientationtype AS LONG, _
                           BYVAL fontname AS STRING,BYVAL fontsize AS SINGLE, fontstyle AS LONG, _
                           colour AS LONG, linealignment AS LONG, BYVAL setupflag AS LONG, _
                           BYVAL printflag AS LONG,BYVAL closeflag AS LONG) EXPORT AS LONG
    
    'Function usage:-
    'Syntax (eg) = OutputToWord Message,0,"Courier New",10,1,1,0
    '   where Message is formatted text to print
    '         orientation - 0=port, 1=land
    '         typeface name
    '         fontsize
    '         start - 1 to start up Word
    '         print - 1 to print text
    '         close - 1 to close Word
    'so the above example will start Word and print the message in Courier New at 10 points
    '        OutputToWord Message,0,"Arial",12,0,1,0  will continue to print in Arial 12 pt
    '        OutputToWord Message,0,"Courier New",10,0,0,1  will close Word
    
        '*** must have STATIC object vars to re-enter this function ... or objects created are not accessible.
        DIM oWordApp                AS STATIC Int_Application ' Application Interface
        DIM oWordDoc(1 TO 1)        AS STATIC Int_Document    ' Document Interface
        DIM oWordSel                AS Selection       ' Selection
        DIM oWordFont(1 TO 1)       AS STATIC Int_Font        'font  or TextEffectFormat?
        DIM oWordPageSetup(1 TO 1)  AS STATIC PageSetup       'set orientation etc
        DIM oWordOptions(1 TO 1)    AS STATIC Options         'set orientation etc
        DIM WordDocStatus(1 TO 1)   AS STATIC LONG            'keep track of available indexes
        DIM oPara                   AS Int_ParagraphFormat    'set paragraph info
    
        LOCAL vFile                 AS VARIANT
        LOCAL vFileFmt              AS VARIANT
        STATIC vWhat                AS VARIANT
        STATIC vWhere               AS VARIANT
        STATIC vWhich               AS VARIANT
        LOCAL result                AS STRING
    
        LOCAL iDocCount             AS LONG
        LOCAL templong              AS LONG
        LOCAL i                     AS LONG
    
    '/////////////////////////// Adding Document
    IF setupflag<>0 THEN
        vWhat =  %wdGoToPage
        vWhere = %wdGoToLine
        vWhich = %wdGoToLast
    ' Open an instance of MSWORD
        IF oindx = 0 THEN
            FOR i = 1 TO UBOUND(WordDocStatus)
                IF WordDocStatus(i) = 0 THEN 'empty slot
                    oindx = i
                    WordDocStatus(oindx) = oindx
                    EXIT FOR
                END IF
                IF i = UBOUND(WordDocStatus)THEN
                    oindx = i + 1
                    EXIT FOR
                END IF
            NEXT i
    
        ELSEIF oindx > UBOUND(oWordDoc) THEN
            'seek open slot first
            FOR i = 1 TO UBOUND(WordDocStatus)
                IF WordDocStatus(i) = 0 THEN 'empty slot
                    oindx = i
                    WordDocStatus(oindx) = oindx
                    EXIT FOR
                END IF
                    IF i = UBOUND(WordDocStatus)THEN
                        oindx = i + 1
                    EXIT FOR
                END IF
            NEXT i
        ELSEIF WordDocStatus(oindx) = 0 THEN
            WordDocStatus(oindx) = oindx
        END IF
        '
        IF oindx > UBOUND(oWordDoc) THEN
            'Expanding Arrays
            REDIM PRESERVE oWordDoc(1 TO oindx)    AS STATIC Int_Document
            REDIM PRESERVE oWordSel(1 TO oindx)    AS STATIC Selection
            REDIM PRESERVE oWordFont(1 TO oindx)   AS STATIC Int_Font
            REDIM PRESERVE oWordPageSetup(1 TO oindx)AS STATIC PageSetup
            REDIM PRESERVE WordDocStatus(1 TO oindx) AS STATIC LONG
            WordDocStatus(oindx) = oindx
        END IF
    
        IF ISFALSE ISOBJECT(oWordApp) THEN
            'attempt to open MS Word
            oWordApp = NEWCOM $PROGID_Word_Application
        END IF
    
        'Could MSWORD be opened? If not, terminate this app
        IF ISFALSE ISOBJECT(oWordApp) THEN
            MSGBOX "Unable to open or start MSWORD!"
            EXIT FUNCTION
        ELSE
            'Make MSWORD visible in for example normal show state
            oWordApp.Visible = 1
            oWordApp.WindowState = %wdWindowStateNormal
        END IF
    
        oWordDoc(oindx) = oWordApp.Documents.Add
    
        IF ISFALSE ISOBJECT(oWordDoc(oindx)) THEN
          MSGBOX "MSWORD was not able to start a new document." & $CR & _
                        "Please ensure MSWord and VBA are installed."
          GOTO Terminate
        END IF
    
         oWordDoc(oindx).SELECT
         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(oindx) = oWordSel.font
        IF ISFALSE ISOBJECT(oWordFont(oindx)) 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(oindx).PageSetup.SectionStart = %wdSectionNewPage
    
        oWordDoc(oindx).PageSetup.orientation= orientationtype ' from header
    
        oWordApp.Options.MeasurementUnit=3   'points
    
    '   'measurements in points
        oWordDoc(oindx).PageSetup.TopMargin=72
        oWordDoc(oindx).PageSetup.BottomMargin=90
        oWordDoc(oindx).PageSetup.LeftMargin=36
        oWordDoc(oindx).PageSetup.RightMargin=36
        oWordDoc(oindx).PageSetup.Gutter=0
    
        IF orientationtype=1 THEN 'landscape A4 converted to points
            oWordDoc(oindx).PageSetup.PageWidth = (72*11.66)
            oWordDoc(oindx).PageSetup.PageHeight = (72*8.25)
        ELSE
            oWordDoc(oindx).PageSetup.PageHeight = (72*11.66)
            oWordDoc(oindx).PageSetup.PageWidth = (72*8.25)
        END IF
        FUNCTION = oindx
    END IF
    '/////////////////////////// Adding Text  ///////////////////////////
    IF printflag<>0 THEN
        'see if we need to
        IF ISFALSE ISOBJECT(oWordSel) THEN
             oWordDoc(oindx).SELECT
             oWordSel = oWordApp.Selection
             IF ISFALSE ISOBJECT(oWordFont(oindx)) THEN
                oWordFont(oindx) = oWordSel.font
             END IF
        END IF
    
        oWordSel.goto(vWhat,vWhich)
        oWordSel.goto(vWhere,vWhich)
    
        'set style
        SELECT CASE Fontstyle
            CASE 0
                oWordFont(oindx).BOLD = 0
                oWordFont(oindx).italic = 0
                oWordFont(oindx).underline = 0
    
            CASE 1
                oWordFont(oindx).BOLD = 1
                oWordFont(oindx).italic = 0
                oWordFont(oindx).underline = 0
    
            CASE 2
                oWordFont(oindx).BOLD = 0
                oWordFont(oindx).italic = 1
                oWordFont(oindx).underline = 0
    
            CASE 3
                oWordFont(oindx).BOLD = 1
                oWordFont(oindx).italic = 1
                oWordFont(oindx).underline = 0
    
            CASE 4
                oWordFont(oindx).BOLD = 0
                oWordFont(oindx).italic = 0
                oWordFont(oindx).underline = 1
    
            CASE 5
                oWordFont(oindx).BOLD = 1
                oWordFont(oindx).italic = 0
                oWordFont(oindx).underline = 1
    
            CASE 5
                oWordFont(oindx).BOLD = 0
                oWordFont(oindx).italic = 1
                oWordFont(oindx).underline = 1
    
            CASE 7
                oWordFont(oindx).BOLD = 1
                oWordFont(oindx).italic = 1
                oWordFont(oindx).underline = 1
        END SELECT
    
    'set colour
            oWordFont(oindx).ColorIndex = colour
    
    'set line alignment
             oPara    = oWordSel.ParagraphFormat
             oPara.Alignment=LineAlignment
    
    
    
        IF ISFALSE ISOBJECT(oWordFont(oindx)) THEN
          MSGBOX "MSWORD was not able get a font objectt." & $CR & _
                        "Please ensure MSWord and VBA are installed."
          GOTO Terminate
        END IF
    
    'set font - may change through document
         IF oWordFont(oindx).NAME <> ACODE$(fontname) THEN
             'for Int_Font
             oWordFont(oindx).NAME = UCODE$(fontname)   'string from header
         END IF
         IF oWordFont(oindx).SIZE <> fontsize THEN
             oWordFont(oindx).SIZE=fontsize    'single from header
         END IF
    
        'printing starts here
        oWordSel.TypeText(UCODE$(message))
        'Set a paragraph marker (end of paragraph)
        oWordSel.TypeParagraph
        oWordSel= NOTHING   'release the selection
        FUNCTION = oindx
    END IF
    '/////////////////////////// Closing Document/App  ///////////////////////////
    IF closeflag <>0 THEN
    
        IF ISFALSE ISOBJECT(oWordFont(oindx)) THEN
          MSGBOX "MSWORD was not able get a font objectt." & $CR & _
                        "Please ensure MSWord and VBA are installed."
          GOTO Terminate
        END IF
    '
    ' Close the current document and then close MSWORD completely if required
    Terminate:
        templong = MSGBOX ("Save Document?",%MB_YESNO OR %MB_TASKMODAL,"Save question")
        IF templong = %IDYES THEN
    'save file
            vFile    = "*.doc"      'force tthe saave as dialogh in MS Word
            vFileFmt = %wdFormatDocument
            oWordDoc(oindx).SaveAs(vFile, vFileFmt)
        END IF
        'if you want more contol over when to clost th document then
        'revise the code below such that this program will clean up
        'its references before exiting.
        IF ISTRUE ISOBJECT(oWordSel) THEN oWordSel = NOTHING
        vFile = %wdDoNotSaveChanges
        oWordApp.ActiveWindow.CLOSE(vFile)  'do not save changes
        'Close all of the Interfaces
        oWordPageSetup(oindx)   = NOTHING
        oWordFont(oindx)        = NOTHING
        oWordDoc(oindx)         = NOTHING
        WordDocStatus(oindx) = 0
        FOR i = 1 TO UBOUND(WordDocStatus)
            IF WordDocStatus(i) <> 0 THEN EXIT IF
        NEXT i
        IF i > UBOUND(WordDocStatus) THEN
            oWordApp.Quit
            oWordApp            = NOTHING
        END IF
        FUNCTION = -oindx
      END IF
     IF ISTRUE ISOBJECT(oWordSel) THEN oWordSel = NOTHING
    END FUNCTION
    '==============================================================================
    Last edited by Richard Angell; 8 Sep 2008, 07:12 AM. Reason: Improved Code
    Rick Angell
Working...
X