String text in Word html. Passing info between Word and Excel

**DocAElstein** · 07-04-2019, 03:41 PM

Coding in support of this Thread
http://www.excelfox.com/forum/showth...1384#post11384

Code:

Option Explicit
'Sub LateEarlyBinding()
' On Error Resume Next ' If it is always there you get  Name steht in Konflikt mit vorhandenem Modul, Projekt oder vorhandener Objektbibliothek  RuntimeError32813.JPG : https://imgur.com/N0BN7m2     If it is not there then usually it does not error, but will in Debug F8 mode  Change to the hold mode is not possible at this time.JPG : https://imgur.com/v9inlwM but it works anyway and ignores the error handler in this case
' ThisWorkbook.VBProject.References.AddFromguid GUID:="{420B2830-E718-11CF-893D-00A0C9054228}", major:=1, Minor:=0
' Debug.Print Err.Description
' On Error GoTo 0 ' Clears exception and the   Err.Description   also is cleared
'End Sub
Sub MakeTagList() ' A Table  is made and embedded in the main body text of an existing .htm Word readable file which must already exist and be in the same folder as this workbook. That is set to pop up in word briefly. (The main body of the htm file can  then used later as the .HTMLBody in an email )
'                                            Call LateEarlyBinding ' Microsoft Scripting Runtime
Rem 4 Array from range
Dim arrNuts() As Variant: Let arrNuts() = ThisWorkbook.Worksheets.Item(1).Range("A2:B3").Value
Rem 6 get Template File as long HTML string . Template file is an almost empty Word .htm file with just    "I would like to put here Table1. Here is some other text"  .
Dim FileNum As Long: Let FileNum = FreeFile(1)    ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
 Let PathAndFileName = ThisWorkbook.Path & "\" & "WordFile.htm" ' Template file never changes
  Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
    TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
    Get #FileNum, , TotalFile
  Close #FileNum
 Debug.Print TotalFile
Rem 7 modify main body text section of the template file
'7a) Start bit, and call of HTML table genarator Function
Dim MyLengthyStreaming As String
 Let MyLengthyStreaming = "<p></p><p></p>" & MyLengthyStreaming & ProTble(arrNuts())
 Let TotalFile = Replace(TotalFile, "Table:_1.<o:p></o:p></span></i></p>", "Table:_1.<o:p></o:p></span></i></p>" & vbCrLf & MyLengthyStreaming, 1, 1, vbTextCompare)
'7b) anything after table
Dim sT As String, aFt As String: Let sT = "Bit after table to aid in adding stuff in main code" ' This string was put on the end od the final HTML table so as to have a thing to replace with something like the end of th table
 Let aFt = "<p>" & ThisWorkbook.Worksheets.Item(1).Range("A1").Value & "</p><p>.</p>" ' Put table Header under table
' Let aFt = "<p><span style=""color: #ff00ff;"">'_---Table made " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ====Daily Foods Table End ======</span></p>"
 Let TotalFile = Replace(TotalFile, sT, aFt, 1, 1, vbBinaryCompare)
' Debug.Print TotalFile
Rem 8 Make new file with modified long HTML string
Dim HighwayToHelloPro As Long ' For rewrite of modified DailyProtable.htm as DailyProtable.htm2
 Let HighwayToHelloPro = FreeFile(0)
 Open ThisWorkbook.Path & "\" & "WordFile2.htm" For Output As #HighwayToHelloPro ' Will be made if not there, and overwritten as Output rahter than Append
 Print #HighwayToHelloPro, TotalFile
 Close #HighwayToHelloPro
Rem 9 get Word using Excel
Dim appWord As Object                           '  Dim appWord As Word.Application
 Set appWord = CreateObject("Word.Application") '   Set appWord = New Word.Application '
 appWord.Visible = True
 appWord.Documents.Open Filename:=ThisWorkbook.Path & "\" & "WordFile2.htm", ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", Format:=0, XMLTransform:="", DocumentDirection:=0
 appWord.Documents("WordFile2.htm").Activate
 Application.WindowState = xlMinimized
 Application.OnTime Now + TimeSerial(0, 0, 5), "Modul1.GetWordObjClose"
'9b) Some Word Formatting
'Windows("ProAktuellex8600x211.3.xlsm").Activate
'Dim docMsg As Document '
' Set docMsg = ActiveDocument ' Documents("DailyProtableFilled")
' docMsg.Range(0, 100).Select
'  Selection.WholeStory
'    With Selection.ParagraphFormat
'     .SpaceBeforeAuto = False
'     .SpaceAfterAuto = False
'    End With
End Sub
Sub GetWordObjClose() ' Close the daily pro in word
 Application.WindowState = xlNormal
Dim appWord As Object ' Dim appWord As Word.Application
 Set appWord = GetObject(, "Word.Application"): appWord.Visible = True ' This will open new instance of word and make it visible ( with no document). If one is open then it will be set to the appWord variable
Dim Dock As Variant
    For Each Dock In appWord.Documents
     Dock.Save
     Dock.Close
    Next Dock
' appWord.ActiveDocument.Save
' appWord.ActiveDocument.Close
 appWord.Quit
 Application.WindowState = xlNormal
 'Application.Windows("" & ProWb.Name & "").Activate
 'Application.Windows("" & ProWb.Name & "").WindowState = xlNormal
 'ActiveWindow.WindowState = xlNormal
End Sub
Function ProTble(ByRef arrNuts() As Variant) As String
' Table start
Let ProTble = _
"<table width=800" & vbCrLf & _
"<col width=400" & vbCrLf & _
"<col width=400>" & vbCrLf & vbCrLf
Dim iCnt As Long, jCnt As Long ' data "rows" , "columns"
    For jCnt = 1 To UBound(arrNuts(), 1)
    Dim LisRoe As String
     Let LisRoe = LisRoe & "<tr height=16>" & vbCrLf
        For iCnt = 1 To UBound(arrNuts(), 2)
         Let LisRoe = LisRoe & "<td>" & arrNuts(jCnt, iCnt) & "</td>" & vbCrLf
        Next iCnt
     Let LisRoe = LisRoe & "</tr>" & vbCrLf & vbCrLf
     Let ProTble = ProTble & LisRoe
     Let LisRoe = ""
    Next jCnt
Let ProTble = ProTble & "</table>" ' table end
' Bit after table to aid in adding stuff in main code
 Let ProTble = ProTble & "Bit after table to aid in adding stuff in main code"
End Function