Attempting to create a template document that can be pre-populated / generated from an excel template.
Not overly experienced with VBA so I currently have a lot of repeating code. Nonetheless it seems to work okay but only runs successfully maybe 1/3 times.
On failed attempts I get the following error message:
Run-time error '462': The remote server machine does not exist or unavailable
Any help appreciated
Option Explicit
Sub Gen_Proposal()
Dim wrdApp As Word.Application
Dim WdDoc As Word.Document
Dim BmkNm As String
Dim newBooktxt As String
Dim FileNm As String
Dim Customer As String
Dim State As String
Dim ProposalType As String
Dim Version As String
Dim ProjectNum As String
Dim ProposalDate As String
Dim ws As Excel.Worksheet
'Select Proposal input excel sheet
Set ws = Excel.Worksheets("Sheet1")
Customer = ws.Range("Customer").Value
State = ws.Range("State").Value
ProposalType = ws.Range("ProposalType").Value
Version = ws.Range("Version").Value
ProjectNum = ws.Range("ProjectNum").Value
ProposalDate = ws.Range("ProposalDate").Value
Set wrdApp = CreateObject("Word.Application")
FileNm = Application.ActiveWorkbook.Path & "\Template.docx"
Set WdDoc = wrdApp.Documents.Add(FileNm)
wrdApp.Visible = True
Dim oCC As ContentControl
Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer").Item(1)
oCC.Range.Text = Customer
Set oCC = ActiveDocument.SelectContentControlsByTitle("State").Item(1)
oCC.Range.Text = State
Set oCC = ActiveDocument.SelectContentControlsByTitle("ProposalType").Item(1)
oCC.Range.Text = ProposalType
Set oCC = ActiveDocument.SelectContentControlsByTitle("Version").Item(1)
oCC.Range.Text = Version
Set oCC = ActiveDocument.SelectContentControlsByTitle("ProjectNum").Item(1)
oCC.Range.Text = ProjectNum
Set oCC = ActiveDocument.SelectContentControlsByTitle("ProposalDate").Item(1)
oCC.Range.Text = ProposalDate
WdDoc.Fields.Update
WdDoc.PrintPreview
WdDoc.ClosePrintPreview
wrdApp.Activate
End Sub
I looked at similar questions' answers and could not find that were applicable to what I am trying to do.
Here is some code that loads an instance of IE , goes to Apple's financials, and attempts to scrape the table on that webpage.
The error happens on Set IEDocument = IEObject.document
Sub ScrapeTable2()
Dim IEObject As InternetExplorer
Set IEObject = New InternetExplorer
IEObject.Visible = True
IEObject.navigate URL:="https://finance.yahoo.com/quote/AAPL/financials?p=AAPL"
Debug.Print IEObject.LocationURL
Dim IEDocument As HTMLDocument
Set IEDocument = IEObject.document
Dim IETables As IHTMLElementCollection
Dim IETable As IHTMLTable
Dim IERow As IHTMLTableRow
Dim IECell As IHTMLTableCell
Set IETable = IEDocument.getElementsByTagName("table")
RowCount = 1
max_rows = IETable.Rows.Length
For Each IERow In IETable.Rows
Debug.Print IERow.innerText
Next
End Sub
I wrote a Subroutine to move a page in a different section compared to the original one but it does't work! May someone help me?
Private Sub CreateInNewSection(onote As OneNote.Application, pageXML As String, newSecId As String, title As String)
Dim pDoc As MSXML2.DOMDocument60
Set pDoc = New MSXML2.DOMDocument60
If pDoc.LoadXML(pageXML) Then
Dim cNodes As MSXML2.IXMLDOMNodeList
Dim fNodes As MSXML2.IXMLDOMNodeList
Dim iNodes As MSXML2.IXMLDOMNodeList
Dim cNode As MSXML2.IXMLDOMNode
Dim fNode As MSXML2.IXMLDOMNode
Dim iNode As MSXML2.IXMLDOMNode
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
pDoc.setProperty "SelectionNamespaces", soapNS
Set cNodes = pDoc.DocumentElement.SelectNodes("//one:T")
Set fNodes = pDoc.DocumentElement.SelectNodes("//one:InsertedFile")
Set iNodes = pDoc.DocumentElement.SelectNodes("//one:Image")
Dim nPageID As String
onote.CreateNewPage newSecId, nPageID, npsDefault
Dim oXML As String
onote.GetPageContent nPageID, oXML, piAll, xs2013
'oXML = pageXML
Dim nDoc As MSXML2.DOMDocument60
Set nDoc = New MSXML2.DOMDocument60
If nDoc.LoadXML(oXML) Then
Dim npNode As MSXML2.IXMLDOMNode
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
nDoc.setProperty "SelectionNamespaces", soapNS
Set npNode = nDoc.SelectSingleNode("//one:Page")
' Find the Title element.
Dim tNode As MSXML2.IXMLDOMNode
Set tNode = nDoc.SelectSingleNode("//one:Page/one:Title/one:OE/one:T")
' Get the CDataSection where OneNote store's the Title's text.
Dim cdataChild As MSXML2.IXMLDOMNode
Set cdataChild = tNode.SelectSingleNode("text()")
' Change the title in the local XML copy.
cdataChild.Text = title
' Write the update to OneNote.
'oneNote.UpdatePageContent doc.XML
'---------- For Text Nodes -----------
For Each cNode In cNodes
If cNode.Text <> "" Then
Dim newTextNodeElement As MSXML2.IXMLDOMElement
Dim newTextNode As MSXML2.IXMLDOMNode
' Create Outline node.
Set newTextNodeElement = nDoc.createElement("one:Outline")
Set newTextNode = npNode.appendChild(newTextNodeElement)
' Create OEChildren.
Set newTextNodeElement = nDoc.createElement("one:OEChildren")
Set newTextNode = newTextNode.appendChild(newTextNodeElement)
' Create OE.
Set newTextNodeElement = nDoc.createElement("one:OE")
Set newTextNode = newTextNode.appendChild(newTextNodeElement)
' Create TE.
Set newTextNodeElement = nDoc.createElement("one:T")
Set newTextNode = newTextNode.appendChild(newTextNodeElement)
' Add the text for the Page's content.
Dim newcd As MSXML2.IXMLDOMCDATASection
Set newcd = nDoc.createCDATASection(cNode.Text)
newTextNode.appendChild newcd
End If
Next
---------- For File Nodes -----------
For Each fNode In fNodes
'Set newFileNode = fNode
Set npNode = npNode.appendChild(fNode)
Next
onote.UpdatePageContent nDoc.XML, DateTime.Now, xs2013
End If
End If
End Sub
The onenote.UpdatePageContent continues to fail with a runtime error -2147213296 (80042010). The code works if i consider only text nodes, while if i add the code for File Nodes it doesn't work anymore.
I tried to change the code for File Nodes with this code:
For Each fNode In fNodes
Dim newFileNodeElement As MSXML2.IXMLDOMElement
Dim newFileNode As MSXML2.IXMLDOMNode
'Set newFileNode = fNode
'Set npNode = npNode.appendChild(fNode)
Set newFileNodeElement = nDoc.createElement("one:InsertedFile")
Set newFileNode = npNode.appendChild(newFileNodeElement)
For i = 0 To fNode.Attributes.Length - 1
Dim attrName As String
Dim attrValue As String
Dim attr As MSXML2.IXMLDOMAttribute
Dim namedNodeMap As MSXML2.IXMLDOMNamedNodeMap
attrName = fNode.Attributes(i).nodeName
attrValue = fNode.Attributes(i).NodeValue
Set attr = nDoc.createNode(2, attrName, "")
attr.Value = attrValue
Set namedNodeMap = nDoc.DocumentElement.LastChild.Attributes
Set newFileNode = namedNodeMap.setNamedItem(attr)
Next i
Next
but the results are the same.
OneNote error codes are listed here, so that error is "The last modified date does not match. ".
The second argument to UpdatePageContent is:
dateExpectedLastModified – (Optional) The date and time that you think
the page you want to update was last modified. If you pass a non-zero
value for this parameter, OneNote proceeds with the update only if the
value you pass matches the actual date and time the page was last
modified. Passing a value for this parameter helps prevent
accidentally overwriting edits users made since the last time the page
was modified.
Remove the DateTime.Now argument (omit it), if you don't need it, or correct the value. It is an additional check parameter, not a date-stamp.
I solved this issue using a different approach: i used Publish method in order to create a new section with the name of the page i needed to copy, and the MergeSections method to copy the page in the section i wished. Here is the code:
Private Sub CreateInNewSection(onote As onenote.Application, pageXML As String,
newSecId As String, title As String, nbID As String, path As String)
Dim pDoc As MSXML2.DOMDocument60
Set pDoc = New MSXML2.DOMDocument60
If pDoc.LoadXML(pageXML) Then
Dim pNode As MSXML2.IXMLDOMNode
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
pDoc.setProperty "SelectionNamespaces", soapNS
Set pNode = pDoc.SelectSingleNode("//one:Page")
Dim oldPageId As String
Dim oldPageName As String
oldPageId = pNode.Attributes.getNamedItem("ID").Text
oldPageName = pNode.Attributes.getNamedItem("name").Text
path = path + "\" + oldPageName + ".one"
Debug.Print path
onote.Publish oldPageId, path, pfOneNote, ""
Dim sXml As String
onote.GetHierarchy nbID, hsSections, sXml, xs2013
Dim sDoc As MSXML2.DOMDocument60
Set sDoc = New MSXML2.DOMDocument60
Dim nowSecId As String
If sDoc.LoadXML(sXml) Then
' select the Section nodes
Dim sNodes As MSXML2.IXMLDOMNodeList
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
sDoc.setProperty "SelectionNamespaces", soapNS
Set sNodes = sDoc.DocumentElement.SelectNodes("//one:Section")
Dim j As Integer
If Not sNodes Is Nothing Then
' Get the first section.
Dim sNode As MSXML2.IXMLDOMNode
For j = 0 To (sNodes.Length - 1)
If sNodes(j).Attributes.getNamedItem("name").Text = oldPageName Then
nowSecId = sNodes(j).Attributes.getNamedItem("ID").Text
Exit For
End If
Next j
End If
onote.MergeSections nowSecId, newSecId
onote.DeleteHierarchy nowSecId
onote.DeleteHierarchy oldPageId
End If
End If
End Sub
I am trying to use a conditional code for Object such that if value/text is found in object (in my example it is JSONObject) then do something otherwise nothing. But when I run the code it is working only when found in object and shows "runtime error" when it is not found in object.
The code is:-
Private Sub CommandButton3_Click()
Dim jsonText As String
Dim FSO As New FileSystemObject
Dim JsonTS As TextStream
Dim jsonObject As Object('It is an object created )
myfile = Application.GetOpenFilename(FileFilter:="JSON file (*.json), *.json", Title:="Get File", MultiSelect:=True)
Set JsonTS = FSO.OpenTextFile(myfile, ForReading)
jsonText = JsonTS.ReadAll
JsonTS.Close
Set jsonObject = JsonConverter.ParseJson(jsonText)
' Condition that if in jsonObect, "b2b" is found then
If Not jsonObject("b2b") Is Nothing Then
For Each item In jsonObject("b2b") '("inv")
Sheet3.Cells(a, 2) = jsonObject("fp")
Sheet3.Cells(a, 1) = item("ctin")
End If
End Sub
I'd rather have JSON to test with but you could attempt to set jsonObject("b2b") into a new variable wrapped within an On Error Resume Next and then test that for If Not Is Nothing
Dim b2bObject As Object
Dim item As Variant '<<=== ? missing from your code
On Error Resume Next
Set b2bObject = jsonObject("b2b")
On Error GoTo 0
If Not b2bObject Is Nothing Then
For Each item In b2bObject
Sheet3.Cells(a, 2) = jsonObject("fp")
Sheet3.Cells(a, 1) = item("ctin")
Next
End If
If using in a loop you may wish to Set b2bObject = Nothing before End If as safeguard.
I've been working with the code below and can't seem to figure out what's causing PowerPoint to crash on the last line. I've used the same block of code in other subs without issue. I suspect this may somehow be related to the onslideshowpagechange function.
The code runs through the VBA editor in PowerPoint with the following libraries.
Reference Libraries
I essentially want the code to execute when a slide change occurs in presentation mode. The part of the code that causes the crash I want to add a slide back in.
Thanks ahead of time for any help!
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Sub onslideshowpagechange(ByVal SSW As SlideShowWindow)
Dim oXL As Object 'Excel.Application
Dim oWb As Object 'Excel.Workbook
Dim oSld As Slide
' Check excel workbook file status, if not open then open
Dim file_status
file_status = IsWorkBookOpen("C:\Users\schuec1\Desktop\Peoria 2017 Media\Live Analysis\Live_Analysis.xlsx")
If file_status = False Then
Set oXL = CreateObject("Excel.Application")
Set oWb = oXL.Workbooks.Open(FileName:="C:\Users\schuec1\Desktop\Peoria 2017 Media\Live Analysis\Live_Analysis")
Else
Set oXL = Excel.Application
Set oWb = ActiveWorkbook
End If
Dim sld_no As Long
Dim course As String
Dim sld_offset As Long
Dim teamno As Long
Dim lead_sld As Long
Dim cntry As String
Dim pic_flag As Shape
Dim row_space As Shape
Dim team_range As Range
Dim school As String
Dim time_car As Double
Dim diff As Double
Dim time_one As Double
Dim pos As Long
Dim dist As Double
Dim dist_one As Double
Dim pplayout As CustomLayout
sld_no = SSW.View.CurrentShowPosition
'Acceleration leaderboard
If sld_no = 1001 Then
lead_sld = sld_no
With ActivePresentation
.Slides(lead_sld).Delete
End With
Debug.Assert lead_sld <> sld_no
Set oSld = ActivePresentation.Slides.AddSlide(lead_sld, GetLayout("accel"))