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