Проверка XML с XSD в MS Access

Question

Я хочу проверить файл xml. Я не знаю, как правильно обращаться к xsd. В нем указывается «объект, требуемый» для строки «Установить xmlDoc.schemas = strXSDFile».

Function CheckXML() 

Dim strFileName As String 
Dim strXSDFile As String 


    strFileName = "C:\mylocation\xmlfile.txt" 

    strXSDFile = "C:\mylocation\xsdfile.xsd" 


    Set xmlDoc = LoadXmlFile(strFileName) 
    Set xmlDoc.schemas = strXSDFile 
    Set objErr = xmlDoc.validate() 


    If objErr.errorCode = 0 Then 
     Debug.Print "No errors found" 
    Else 
     Debug.Print "Error parser: " & objErr.errorCode & "; " & objErr.reason 
    End If 

End Function 

Function LoadXmlFile(Path As String) As MSXML2.DOMDocument60 
    Set LoadXmlFile = New MSXML2.DOMDocument60 

    With LoadXmlFile 
     .async = False 
     .validateOnParse = False 
     .resolveExternals = False 
     .Load Path 
    End With 
End Function 

Answer 1

Перед загрузкой XML-документа добавьте схему. Вы можете комбинировать их в одну функцию, как показано ниже. Я использовал ящики сообщений, чтобы я мог форматировать текст, но вы могли бы поднимать проблемы как ошибки VBA.

Public Function LoadAndValidateXML(strXMLPath As String, strXSDPath As String) As MSXML2.DOMDocument60 
    Dim xmldom As MSXML2.DOMDocument60 
    Set xmldom = New MSXML2.DOMDocument60 

    Dim xmlschema As MSXML2.XMLSchemaCache60 
    Set xmlschema = New MSXML2.XMLSchemaCache60 
    xmlschema.Add "", strXSDPath 

    Set xmldom.schemas = xmlschema 
    xmldom.async = False 
    xmldom.Load strXMLPath 

    If xmldom.parseError.errorCode <> 0 Then 
     MsgBox "Validation Error: " & xmldom.parseError.errorCode & " " & TrimWhiteSpace(xmldom.parseError.reason) 
     MsgBox xmldom.parseError.srcText 
    Else 
     Set LoadAndValidateXML = xmldom 
    End If 
End Function 

---

Public Function TrimWhiteSpace(strString As String) As String 
    Dim a As Integer 
    Dim b As Integer 

    For a = 1 To Len(strString) 
     Select Case Mid(strString, a, 1) 
      Case vbCr, vbLf, vbTab, " ": 
       a = a + 1 
      Case Else: 
       Exit For 
     End Select 
    Next 

    For b = Len(strString) To 1 Step -1 
     Select Case Mid(strString, a, 1) 
      Case vbCr, vbLf, vbTab, " ": 
       b = b + 1 
      Case Else: 
       Exit For 
     End Select 
    Next 

    TrimWhiteSpace = Mid(strString, a, b - a) 
End Function