XSD pro

Option Compare Database
Option Explicit


Public Sub Extract_XML_to_Excel(strPath As String)
On Error GoTo ErrorHandler
    Dim XDoc As Object
    Dim lists As MSXML2.IXMLDOMElement, getFirstChild As Object, toFields As Object, fieldNode As Object
    Dim xmlNode As MSXML2.IXMLDOMNode
    
    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlNode1 As MSXML2.IXMLDOMNode
    Dim xmlNode3 As MSXML2.IXMLDOMNode
    Dim xmlNode2 As MSXML2.IXMLDOMNode
    Dim xmlChildren As MSXML2.IXMLDOMNodeList
    Dim xmlElement As MSXML2.IXMLDOMElement
    Dim l As Integer
    Dim i As Integer
    'excel components
    Dim XL As Excel.Application, WB As Excel.Workbook, WKS As Excel.Worksheet
    Dim sheetName As String
    Dim names As String
    Dim strListValue As String
    
'    Debug.Print xmlChildren(l).ChildNodes.NextNode.ChildNodes.NextNode.Attributes.getNamedItem("name").Text
'                For i = 0 To xmlChildren(l).ChildNodes.Length - 1
'
'                Next
'
'    With New FileSystemObject
'    If .FileExists(Left(strPath, InStrRev(strPath, "\")) & "Template to create SSF reprot.xls") Then
'        .DeleteFile Left(strPath, InStrRev(strPath, "\")) & "Template to create SSF reprot.xls"
'    End If
'    End With
    
    Set XL = New Excel.Application
    XL.Visible = True
    Set WB = XL.Workbooks.Add
    WB.Activate
    
'    Set WKS1 = WB.Worksheets.Add
'        WKS1.Name = "Midsize"
        
    'xmlNode
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.Load (strPath)
    'Set xmlChildren = XDoc.getElementsByTagName("xs:complexType/xs:sequence/xs:element")
    Set xmlChildren = XDoc.getElementsByTagName("xs:complexType")
'    For l = 0 To xmlChildren.Length - 1
'        Debug.Print xmlChildren(l).BaseName
        For Each xmlNode In xmlChildren
            If xmlNode.FirstChild.BaseName = "sequence" Then
                    
                    Debug.Print "node name " & xmlNode.Attributes.getNamedItem("name").Text
                    names = xmlNode.Attributes.getNamedItem("name").Text
                    sheetName = Left(names, InStr(1, names, "_Type") - 1)
                    sheetName = Nz(DLookup("abrivation", "tblModelAbbrivation", "modelEntities = '" & sheetName & "' AND ACTIVE=1"), "NullValue")
                    If sheetName <> "NullValue" Then
                    Set WKS = WB.Worksheets.Add
                    WKS.Activate
                    WKS.Name = sheetName
                    For Each xmlNode1 In xmlNode.ChildNodes
                        i = 1
                        For Each xmlNode2 In xmlNode1.ChildNodes
                            Debug.Print xmlNode2.Attributes.getNamedItem("name").Text
                            WKS.Cells(1, i).Value = xmlNode2.Attributes.getNamedItem("name").Text
                            If xmlNode2.HasChildNodes Then
                                'to get all value of element tag
                                For Each xmlNode3 In xmlNode2.ChildNodes.NextNode.ChildNodes.NextNode.ChildNodes
                                    If xmlNode3.BaseName = "enumeration" Then
                                        strListValue = strListValue & xmlNode3.Attributes.getNamedItem("value").Text & ","
                                    End If
                                Next
                                'assign value to column
                                If strListValue <> "" Then
                                WKS.Columns(i).Select
                                    With Selection.Validation
                                        .Delete
                                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                                        xlLess, Formula1:=Left(strListValue, Len(strListValue) - 1)
                                        .IgnoreBlank = True
                                        .InCellDropdown = True
                                        .InputTitle = ""
                                        .ErrorTitle = ""
                                        .InputMessage = ""
                                        .ErrorMessage = ""
                                        .ShowInput = True
                                        .ShowError = True
                                    End With
                                End If
                            End If
                            i = i + 1
                            strListValue = ""
                        Next
                    Next
                   
                    End If
            End If
            Set WKS = Nothing
        Next
'      Next
'        Debug.Print xmlChildren(l).FirstChild.BaseName
        'Debug.Print xmlChildren(l).Attributes.getNamedItem("name")
        'Debug.Print xmlChildren(l).Attributes.getNamedItem("name").Text
        'Debug.Print xmlChildren(l).ParentNode.ParentNode.Attributes.getNamedItem("name")
    WB.SaveAs FileName:=Left(strPath, InStrRev(strPath, "\")) & "Template to create SSF reprot", FileFormat:=xlWorkbookNormal
    WB.Close
    XL.Quit
    
    
    
    
'    l = xmlDoc.getElementsByTagName("complexType").Length
'    'Get Document Elements
'    Set lists = XDoc.DocumentElement
'    Set toFields = XDoc.SelectNodes("//complexType/sequence")
'    Set xmlNode = lists.SelectSingleNode("complexType")
'    Set xmlChildren = XDoc.DocumentElement.getElementsByTagName("complexType")
'    For Each fieldNode In lists.ChildNodes
'            Debug.Print "[" & fieldNode.BaseName & "] = [" & fieldNode.XML & "]"
'    Next fieldNode
'
'     For Each fieldNode In xmlNode.ChildNodes
'            Debug.Print "[" & fieldNode.BaseName & "] = [" & fieldNode.XML & "]"
'    Next fieldNode
'
'    'Get first child ( same as ChildNodes(0) )
'    Set getFirstChild = lists.FirstChild
'    'Print first child XML
'    Debug.Print getFirstChild.XML
'    'Print first child Text
'    Debug.Print getFirstChild.Text
    Set XDoc = Nothing

Exit Sub
ErrorHandler:
MsgBox Err.Number & Err.Description
End Sub




Public Sub Extract_Metadata_XML_to_Excel(strPath As String)
On Error GoTo ErrorHandler
    Dim XDoc As Object
    Dim lists As MSXML2.IXMLDOMElement, getFirstChild As Object, toFields As Object, fieldNode As Object
    Dim xmlNode As MSXML2.IXMLDOMNode
    
    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlNode1 As MSXML2.IXMLDOMNode
    Dim xmlNode3 As MSXML2.IXMLDOMNode
    Dim xmlNode2 As MSXML2.IXMLDOMNode
    Dim xmlChildren As MSXML2.IXMLDOMNodeList
    Dim xmlElement As MSXML2.IXMLDOMElement
    Dim l As Integer
    Dim i As Integer
    'excel components
    Dim XL As Excel.Application, WB As Excel.Workbook, WKS As Excel.Worksheet
    Dim sheetName As String
    Dim names As String
    

    Set XL = New Excel.Application
    XL.Visible = True
    Set WB = Excel.Application.Workbooks.Open(Left(strPath, InStrRev(strPath, "\")) & "Template to create SSF reprot.xls")
    WB.Activate
    

    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.Load (strPath)

    Set xmlChildren = XDoc.getElementsByTagName("xs:complexType/xs:sequence")
    
        For Each xmlNode In xmlChildren
                    sheetName = "MetaData"
                    Set WKS = WB.Worksheets.Add
                    WKS.Activate
                    WKS.Name = sheetName
                     i = 1
                    For Each xmlNode1 In xmlNode.ChildNodes
'                        If xmlNode1.BaseName = "sequence" Then
                                
                               
'                                For Each xmlNode2 In xmlNode1.ChildNodes
                                    Debug.Print xmlNode1.Attributes.getNamedItem("name").Text
                                    WKS.Cells(1, i).Value = xmlNode1.Attributes.getNamedItem("name").Text
                                    i = i + 1
'                                Next
                               
'                        End If
                    Next
            Exit For
        Next
'    WB.SaveAs FileName:=Left(strPath, InStrRev(strPath, "\")) & "Template to create SSF reprot", FileFormat:=xlWorkbookNormal
    WB.Save
    WB.Close
    XL.Quit
    Set XDoc = Nothing

Exit Sub
ErrorHandler:
MsgBox Err.Number & Err.Description
End Sub
===================================================================================================================================
Option Compare Database
Option Explicit
Public strFilePathPayload As String
Public strFilePathMetaData As String

Private Sub cmdGenerateTemplate_Click()
Dim strFileName As String
Dim strPath As String
Dim intChoice As Integer
Dim fso As New Scripting.FileSystemObject
On Error GoTo err_handler
    DoCmd.Hourglass True
    If txtFilePathPayload.Value = "" Or txtFilePathMetaData.Value = "" Then
        MsgBox "Please select file ..."
        'lblPayloadMandatory
         If strFilePathPayload = "" Then
            lblPayloadMandatory.Visible = True
         End If
         If strFilePathMetaData = "" Then
            lblMetadataMandatory.Visible = True
         End If
    Else
    lblPayloadMandatory.Visible = False
    lblMetadataMandatory.Visible = False
    Call Extract_XML_to_Excel(strFilePathPayload)
    Call Extract_Metadata_XML_to_Excel(strFilePathMetaData)
    MsgBox "File Generated successfully!..."
    End If
    DoCmd.Hourglass False
Exit Sub
err_handler:
    DoCmd.Hourglass False
    MsgBox Err.Number & Err.Description
End Sub

Private Sub cmdReport_Click()
 Call SendMail
End Sub

'Private Sub cmdSelectFile_Click()
'Dim strFileName As String
'Dim strPath As String
'Dim intChoice As Integer
'Dim fso As New Scripting.FileSystemObject
'On Error GoTo err_handler
'    DoCmd.Hourglass True
'    DoCmd.Maximize
'    Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
'    Call Application.FileDialog(msoFileDialogOpen).Filters.Add("XSD File only ", "*.xsd")
'
'    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'    intChoice = Application.FileDialog(msoFileDialogOpen).Show
'    If intChoice <> 0 Then
'        strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
'    End If
'    Call Extract_XML_to_Excel(strPath)
'    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'    intChoice = Application.FileDialog(msoFileDialogOpen).Show
'    If intChoice <> 0 Then
'        strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
'    End If
'    Call Extract_Metadata_XML_to_Excel(strPath)
''    With Application.FileDialog(msoFileDialogFolderPicker)
''        If .Show = -1 Then
''            strPath = .SelectedItems(1)
''        Else
''            DoCmd.Hourglass False
''        End If
''    End With
''    If strPath <> "" Then
''        'DoCmd.OutputTo acOutputReport, Me.Name, acFormatPDF, strPath & "\Statistics per CI _" & Format(Now(), "dd-mm-yyyy hh-mm-ss") & ".pdf"
''        MsgBox "file selected", vbInformation, "SSF Test rool"
''    End If
'    DoCmd.Hourglass False
'Exit Sub
'err_handler:
'    DoCmd.Hourglass False
'    MsgBox Err.Number & Err.Description
'End Sub





Private Sub cmdSelectFileMetadata_Click()
Dim strFileName As String
Dim strPath As String
Dim intChoice As Integer
Dim fso As New Scripting.FileSystemObject
On Error GoTo err_handler
    DoCmd.Hourglass True
    DoCmd.Maximize
    Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
    Call Application.FileDialog(msoFileDialogOpen).Filters.Add("XSD File only ", "*.xsd")

    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    If intChoice <> 0 Then
        strFilePathMetaData = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    End If
    txtFilePathMetaData.Value = strFilePathMetaData
    DoCmd.Hourglass False
Exit Sub
err_handler:
    DoCmd.Hourglass False
    MsgBox Err.Number & Err.Description
End Sub

Private Sub cmdSelectFilePayload_Click()
Dim strFileName As String
Dim strPath As String
Dim intChoice As Integer
Dim fso As New Scripting.FileSystemObject
On Error GoTo err_handler
    DoCmd.Hourglass True
    DoCmd.Maximize
    Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
    Call Application.FileDialog(msoFileDialogOpen).Filters.Add("XSD File only ", "*.xsd")

    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    If intChoice <> 0 Then
        strFilePathPayload = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
    End If
    txtFilePathPayload.Value = strFilePathPayload
    DoCmd.Hourglass False
Exit Sub
err_handler:
    DoCmd.Hourglass False
    MsgBox Err.Number & Err.Description
End Sub
'---------------------------------------------------

'Public Sub SendNotesMail(Subject as string, attachment as string,
'recipient as string, bodytext as string,saveit as Boolean)
'This public sub will send a mail and attachment if neccessary to the
'recipient including the body text.
'Requires that notes client is installed on the system.
Public Sub SendNotesMail(Subject As String, Attachment As String, Recipient As String, BodyText As String, SaveIt As Boolean)
'Set up the objects required for Automation into lotus notes
    Dim Maildb As Object 'The mail database
    Dim UserName As String 'The current users notes name
    Dim MailDbName As String 'THe current users notes mail database name
    Dim MailDoc As Object 'The mail document itself
    Dim AttachME As Object 'The attachment richtextfile object
    Dim Session As Object 'The notes session
    Dim EmbedObj As Object 'The embedded object (Attachment)
    'Start a session to notes
    Set Session = CreateObject("Notes.NotesSession")
    'Next line only works with 5.x and above. Replace password with your password
    Session.Initialize ("password")
    'Get the sessions username and then calculate the mail file name
    'You may or may not need this as for MailDBname with some systems you
    'can pass an empty string or using above password you can use other mailboxes.
    UserName = Session.UserName
    MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
    'Open the mail database in notes
    Set Maildb = Session.GetDatabase("", MailDbName)
     If Maildb.IsOpen = True Then
          'Already open for mail
     Else
         Maildb.OPENMAIL
     End If
    'Set up the new mail document
    Set MailDoc = Maildb.CreateDocument
    MailDoc.Form = "Memo"
    MailDoc.sendto = Recipient
    MailDoc.Subject = Subject
    MailDoc.Body = BodyText
    MailDoc.SaveMessageOnSend = SaveIt
    'Set up the embedded object and attachment and attach it
    If Attachment <> "" Then
        Set AttachME = MailDoc.CreateRichTextItem("Attachment")
        Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "Attachment")
        MailDoc.CreateRichTextItem ("Attachment")
    End If
    'Send the document
    MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
    MailDoc.send 0, Recipient
    'Clean Up
    Set Maildb = Nothing
    Set MailDoc = Nothing
    Set AttachME = Nothing
    Set Session = Nothing
    Set EmbedObj = Nothing
End Sub