Sub transformXML(ByRef xml As Variant)

    'Cоздание объекта XSL
    Set xsl = CreateObject("MSXML2.DOMDocument")
    
    'Загрузка XSL из строки (не требует наличия отдельного XSL-файла)
    xsl.LoadXML ("<xsl:stylesheet version='1.0' xmlns:xsl='http://www.w3.org/1999/XSL/Transform'>" & vbCrLf & _
    "<xsl:output method='xml' version='1.0' encoding='windows-1251' indent='yes'/>" & vbCrLf & _
    "<xsl:template match='@*|node()'>" & vbCrLf & _
    "<xsl:copy>" & vbCrLf & _
    "<xsl:apply-templates select='@*|node()' />" & vbCrLf & _
    "</xsl:copy>" & vbCrLf & _
    "</xsl:template>" & vbCrLf & _
    "</xsl:stylesheet>")
    
    'Выполнение преобразования
    xml.transformNodeToObject xsl, xml

End Sub

Sub валидация_xml(xml_file_path)


    boundary = "---------------------------208003683426966885813351456447"

    xsd_file_path = "\\server\Data\Schema.xsd"
    xml_file_name = Mid(xml_file_path, InStrRev(xml_file_path, "\") + 1)
    xsd_file_name = Mid(xsd_file_path, InStrRev(xsd_file_path, "\") + 1)

    With CreateObject("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile (xml_file_path)
        xml_post_data = .ReadText()
    End With
    
    With CreateObject("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile (xsd_file_path)
        xsd_post_data = .ReadText()
    End With
    
    post_data = "--" & boundary & vbCrLf & _
    "Content-Disposition: form-data; name=""schema""; filename=""" & xsd_file_name & """" & vbCrLf & _
    "Content-Type: application/octet-stream" & vbCrLf & vbCrLf & xsd_post_data & vbCrLf & "--" & boundary & vbCrLf & _
    "Content-Disposition: form-data; name=""instance""; filename=""" & xml_file_name & """" & vbCrLf & _
    "Content-Type: text/xml" & vbCrLf & vbCrLf & xml_post_data & vbCrLf & "--" & boundary & "--" & vbCrLf


With CreateObject("WinHttp.WinHttpRequest.5.1")

    .Open "get", "https://xmltools.corefiling.com/miniSchemaValidate/index.jsp", 0
    .Send
        
    teg1 = "SESSIONID="
    teg2 = ";"
    SessionID = Split(Split(.getAllResponseHeaders(), teg1)(1), teg2)(0)
    
    .Open "POST", "https://xmltools.corefiling.com/miniSchemaValidate/Controller", 0
    .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
    .setRequestHeader "Cookie", "JSESSIONID=" & SessionID
    .Send post_data
    
    .Open "get", "https://xmltools.corefiling.com/miniSchemaValidate/results.jsp", 0
    .setRequestHeader "Cookie", "JSESSIONID=" & SessionID
    .Send
    Validate_result = .responseText
End With
        
  teg1 = "Well Formed: <font color="""
  teg2 = """"
  Well_Formed_color = Split(Split(Validate_result, teg1)(1), teg2)(0)
    
  teg1 = "Schema Validation: <font color="""
  teg2 = """"
  Schema_Validation_color = Split(Split(Validate_result, teg1)(1), teg2)(0)
    
  If Well_Formed_color <> "GREEN" Or Schema_Validation_color <> "GREEN" Then
      MsgBox "обнаружены ошибки"
  Else
      MsgBox "всё ок, ошибок нет"
  End If
   
End Sub

sub отправить_почту()

sUsername = "test@gmail.com" ' Учетная запись на сервере
sPass = "YCxAHX71"    ' Пароль к почтовому аккаунту
sSubject = "тема письма"
sTo = "test1@gmail.com" 
sFrom = "test@gmail.com"  
sBody = "Здравствуйте"
sAttachment = ""
BCC = "test2@gmail.com"  
SMTPServer = "smtp.gmail.com"
Call отправка_email(SMTPServer, sUsername, sPass, sTo, sFrom, sSubject, sBody, vFolders, BCC) 
end sub 


Sub отправка_email(SMTPServer, sUsername, sPass, sTo, sFrom, sSubject, sBody, sAttachment, Optional BCC)'отправляем почту
'======================
If sSubject = "" Then Exit Sub
If sTo = "" Then Exit Sub


sTo = WorksheetFunction.Trim(sTo)


    Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
    Dim oCDOCnf As Object, oCDOMsg As Object
'    Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
'    Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String
'    On Error Resume Next
    'sFrom - как правило совпадает с sUsername
    If Len(SMTPServer) = 0 Then MsgBox "Не указан SMTP сервер", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sUsername) = 0 Then MsgBox "Не указана учетная запись", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sPass) = 0 Then MsgBox "Не указан пароль", vbInformation, "www.Excel-VBA.ru": Exit Sub


    'Проверка наличия файла по указанному пути
'    If Dir(sAttachment, vbDirectory) = "" Then sAttachment = ""
    'Назначаем конфигурацию CDO
    Set oCDOCnf = CreateObject("CDO.Configuration")
    With oCDOCnf.Fields
        .Item(CDO_Cnf & "sendusing") = 2
        .Item(CDO_Cnf & "smtpauthenticate") = 1
        .Item(CDO_Cnf & "smtpserver") = SMTPServer
        'если необходимо указать SSL
        .Item(CDO_Cnf & "smtpserverport") = 465 'для Яндекса и Gmail 465
        .Item(CDO_Cnf & "smtpusessl") = True
        '=====================================
        .Item(CDO_Cnf & "sendusername") = sUsername
        .Item(CDO_Cnf & "sendpassword") = sPass
        .Update
    End With
    'Создаем сообщение
    Set oCDOMsg = CreateObject("CDO.Message")
    With oCDOMsg
        Set .Configuration = oCDOCnf
        .BodyPart.Charset = "Windows-1251"
        .From = sFrom
        .To = sTo
        .BCC = BCC
        .Subject = sSubject
        .TextBody = sBody
        If IsArray(sAttachment) Then
        
            For n = 0 To UBound(sAttachment)
            .AddAttachment sAttachment(n)
            Next
        ElseIf Len(sAttachment) > 0 Then
        .AddAttachment sAttachment
        End If


'        If Len(sAttachment) > 0 Then .AddAttachment sAttachment
'On Error Resume Next
        .Send
    End With
    
    Debug.Print Err.Number
'    MsgBox Err.Number
'    Select Case Err.Number
'    Case -2147220973: sMsg = "Нет доступа к Интернет"
'    Case -2147220975: sMsg = "Отказ сервера SMTP"
'    Case 0: sMsg = "Письмо отправлено"
'    Case Else: sMsg = "Ошибка номер: " & Err.Number & vbNewLine & "Описание ошибки: " & Err.Description
'    End Select
    On Error GoTo 0
'    MsgBox sMsg, vbInformation
    Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
    
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
ActiveSheet.EnableCalculation = True
Application.ScreenUpdating = True
   
End Sub