VBA - Visual Studio (2017) Interop - Automated copy source of XHTML file

Summary: This VBA will copy a file into a Visual Studio Project Item, in this case an XHTML to check for XHTML5 compliance but could be used for copying other source to other project items.

So, I had cause to upgrade some HTML4 to XHTML5, the best validator would be Visual Studio (I'm using 2017), if one creates a C# WebApplication and adds a WebForm then the default HTML schema is XHTML5 with closed tags and no upper case element tagnames or attributes as well as other structural syntax changes. I needed to eyeball a whole directory of HTML files with this validator so I chose to write some code to automate.

The code first gets hold of the solution from the Running Object Table, in VBA.GetObject will do this. Then we find the project, the project item and then the text. The copy across is based on EditPoints. Warning, the Microsoft web sites for this has long running scripts which is a pain.

The test standard module

Option Explicit
Option Private Module
Private Sub TestReplaceWebPageText()
    
    Dim oVisualStudioSolutionHandler As VisualStudioSolutionHandler
    Set oVisualStudioSolutionHandler = New VisualStudioSolutionHandler
    
    Call oVisualStudioSolutionHandler.ReplaceWebPageText( _
                "C:\Users\Simon\source\repos\WebApplication1\WebApplication1.sln", _
                "WebApplication1", "WebForm1.aspx", _
                "C:\Users\Simon\AppData\Local\Temp\foobar.xhtml")
End Sub

VisualStudioSolutionHandler class module

Option Explicit

'* Tools References
'*
'*   EnvDTE           
'*     Microsoft Development Environment 8.0 (Version 7.0 Object Model)    
'*     C:\Program Files (x86)\Common Files\Microsoft Shared\MSEnv\dte80a.olb
'*
'*   Scripting
'*     Microsoft Scripting Runtime                                         
'*     C:\Windows\SysWOW64\scrrun.dll


Private Function SafeTypeNameGetObject(ByVal sRunningObject As String) As String
    On Error Resume Next
    SafeTypeNameGetObject = TypeName(GetObject(sRunningObject))
End Function

Public Sub ReplaceWebPageText(ByVal sSolutionPath As String, _
                                ByVal sProjectName As String, _
                                ByVal sWebFormName As String, _
                                ByVal sXhtmlFileName As String)

    Const csWebFormHeader As String = _
        "<%@ Page Language=""C#"" AutoEventWireup=""true"" CodeBehind=""WebForm1.aspx.cs"" Inherits=""WebApplication1.WebForm1"" %>"

    If Len(sSolutionPath) = 0 Then Err.Raise vbObjectError, , "#Null sSolutionName!"
    If Len(sProjectName) = 0 Then Err.Raise vbObjectError, , "#Null sProjectName!"
    If Len(sWebFormName) = 0 Then Err.Raise vbObjectError, , "#Null sWebFormName!"
    If Len(sXhtmlFileName) = 0 Then Err.Raise vbObjectError, , "#Null sXhtmlFileName!"

    If StrComp(Right$(sXhtmlFileName, 6), ".xhtml", vbTextCompare) <> 0 Then _
                    Err.Raise vbObjectError, , "#sXhtmlFileName  '" & sXhtmlFileName & "' should end with '.xhtml'!"

    Static fso As New Scripting.FileSystemObject
    If Not fso.FileExists(sXhtmlFileName) Then Err.Raise vbObjectError, , "#sXhtmlFileName '" & sXhtmlFileName & "' does not exist!"
    If Not fso.FileExists(sSolutionPath) Then Err.Raise vbObjectError, , "#sSolutionPath '" & sSolutionPath & "' does not exist!"
    
    If VBA.StrComp(Right$(sSolutionPath, 4), ".sln", vbTextCompare) <> 0 Then _
                    Err.Raise vbObjectError, , "#sSolutionPath '" & sSolutionPath & "' should end with '.sln'!"
    
    Dim sResolvedType As String
    sResolvedType = SafeTypeNameGetObject(sSolutionPath)
    If VBA.StrComp(sResolvedType, "Solution", vbTextCompare) <> 0 Then Err.Raise vbObjectError, , _
            "#Expectin sSolutionPath '" & sSolutionPath & "' to resolve to a solution instead resolved to '" & sResolvedType & "'!"
    
        
    
    Dim sReplacementText As String
    sReplacementText = csWebFormHeader & vbNewLine & vbNewLine
    
    Dim txtIn As Scripting.TextStream
    Set txtIn = fso.OpenTextFile(sXhtmlFileName, ForReading, False, TristateUseDefault)
    
    While Not txtIn.AtEndOfStream
        DoEvents
        sReplacementText = sReplacementText & vbNewLine & txtIn.ReadLine
    Wend
    
    
    Dim sol As EnvDTE.Solution
    Set sol = GetObject(sSolutionPath)

    Dim webProj As EnvDTE.Project
    Set webProj = GetVSProject(sol, sProjectName)

    Dim webForm1 As EnvDTE.ProjectItem
    Set webForm1 = webProj.ProjectItems.Item(sWebFormName)
    
    
    
    Dim webForm1Doc As EnvDTE.Document
    Set webForm1Doc = webForm1.Document

    Dim webForm1TextDoc As EnvDTE.TextDocument
    Set webForm1TextDoc = webForm1Doc.Selection.Parent

    'https://docs.microsoft.com/en-us/dotnet/api/envdte.textdocument.createeditpoint?redirectedfrom=MSDN&view=visualstudiosdk-2017
    Debug.Assert webForm1TextDoc Is webForm1Doc.Object("TextDocument")

    Dim objStartPt As EnvDTE.EditPoint
    Set objStartPt = webForm1TextDoc.CreateEditPoint(webForm1TextDoc.StartPoint)

    Dim objEndPt As EnvDTE.EditPoint
    Set objEndPt = webForm1TextDoc.CreateEditPoint(webForm1TextDoc.EndPoint)


    'https://docs.microsoft.com/en-us/dotnet/api/envdte.editpoint.replacetext?view=visualstudiosdk-2017
    objStartPt.ReplaceText objEndPt, sReplacementText, 0
    
    webForm1.Save

    'Stop
SingleExit:
End Sub


Public Function GetVSProject(ByVal sol As EnvDTE.Solution, ByVal sProjectName As String) As EnvDTE.Project

    If Not sol Is Nothing Then
    
        Dim lProjectLoop As Long
        For lProjectLoop = 1 To sol.Projects.Count
            
            Dim prjLoop As EnvDTE.Project
            Set prjLoop = sol.Projects.Item(lProjectLoop)
            
            If VBA.StrComp(prjLoop.Name, sProjectName, vbTextCompare) = 0 Then
                Set GetVSProject = prjLoop
                GoTo SingleExit
            
            End If
        
        Next lProjectLoop
    
    End If
SingleExit:

End Function