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
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
  • #1

    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
    Tags: None
Previous template Next
Working...
X

We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

I Agree