'***********************************************
'*    macro basCreateXBRLInstance              *
'*                                             *
'*    part 1 of 3                              *
'***********************************************
Sub GenerateXBRL()
    'Generates the XBRL output
    Dim StartedAtSheet As String
    StartedAtSheet = ActiveWorkbook.ActiveSheet.Name
    
    Application.ScreenUpdating = False
    
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim fs As FileSystemObject
    Dim ts As TextStream
       
    Range("C2").Select
    
    OutputFile = ThisWorkbook.Path
    OutputFile = OutputFile & "\" & Worksheets("Setup").Range("B2").Value
    
    If OutputFile = "" Then
       'cancel button pressed
       Exit Sub
    End If

    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile(OutputFile)

'Root element
    ts.WriteLine ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "utf-8" & Chr(34) & "?>")
    ts.WriteLine ("<!-- HelloWorld Example -->")
    ts.WriteLine ("<!-- Date/time created: " & Now() & " -->")
    
    'Writes the initial group with all the namespace declarations and schemaLocations
    ts.WriteLine ("<xbrl  xmlns='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("       xmlns:xbrli = 'http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("       xmlns:link = 'http://www.xbrl.org/2003/linkbase'")
    ts.WriteLine ("       xmlns:xlink = 'http://www.w3.org/1999/xlink'")
    ts.WriteLine ("       xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'")
    ts.WriteLine ("       xmlns:iso4217='http://www.xbrl.org/2003/iso4217'")
 
 
    'Go grab the schemas....
    Worksheets("Taxonomies").Select
    ActiveSheet.Range("A2").Select
    
    Dim sTargetNamespace As String
    Dim sSchemaLocation As String
    
    Dim sElement As String
    Dim sContext As String
    Dim sValue As Variant
    Dim sScale As Variant
    Dim sSheet As String
    Dim sCell As String
    
'Write namespace declarations
    Do While Len(ActiveCell.Value) > 1
        ts.WriteLine ("       xmlns:" & ActiveCell.Value & "='" & ActiveCell.Offset(0, 1).Value & "'")
        ActiveCell.Offset(1, 0).Select
    Loop
    
    ActiveSheet.Range("A2").Select
    ts.WriteLine ("       xsi:schemaLocation='")
    Do While Len(ActiveCell.Value) > 1
        If ActiveCell.Offset(0, 4) = "Yes" Then
           ts.WriteLine ("                 " & ActiveCell.Offset(0, 1).Value & " " & ActiveCell.Offset(0, 2).Value & " ")
        End If
        ActiveCell.Offset(1, 0).Select
    Loop
    ts.WriteLine ("       '>")
    
    ts.WriteBlankLines (1)
    
'Write schemaRefs
    ActiveSheet.Range("A2").Select
    Do While Len(ActiveCell.Value) > 1
        If ActiveCell.Offset(0, 3) = "Yes" Then
           ts.WriteLine ("   <link:schemaRef xlink:type='simple' xlink:href='" & ActiveCell.Offset(0, 2).Value & "' />")
        End If
        
        ActiveCell.Offset(1, 0).Select
        
    Loop
    
'Process contexts....
    Worksheets("Contexts").Select
    ActiveSheet.Range("A2").Select
    
    Dim sContextID As String
    Dim sEntity As String
    Dim sEntityID As String
    Dim sPeriod As String
    
    ts.WriteBlankLines (1)
    ts.WriteLine ("   <!-- Contexts -->")
    
    Do While Len(ActiveCell.Value) > 1
        sContextID = ActiveCell.Value
        ts.WriteLine ("   <context id='" & ActiveCell.Value & "'>")
        ts.WriteLine ("      <entity>")
        ts.WriteLine ("         <identifier scheme='" & ActiveCell.Offset(0, 2).Value & "'>" & ActiveCell.Offset(0, 1).Value & "</identifier>")
'Disables XBRL Dimensions for HelloWorld example
'        ts.WriteLine ("         <segment>")
        'This is the old way, unnecessary
        'ts.WriteLine ("            " & ActiveCell.Offset(0, 6).Value)
        
        Worksheets("Dimensions").Select
        ActiveSheet.Range("A2").Select
        
        ' Iterate through all the dimensions, finding the ones which match the contextID of the contexts
        Do While Len(ActiveCell.Value) > 1
            'MsgBox ActiveCell.Offset(0, 3).Value
            If ActiveCell.Value = sContextID Then
                'Write the dimension
                ts.WriteLine ("            <xbrldi:explicitMember dimension='" & ActiveCell.Offset(0, 2).Value & "'>" & ActiveCell.Offset(0, 3).Value & "</xbrldi:explicitMember>")
            Else
                'do nothing
            End If
            
            ActiveCell.Offset(1, 0).Select
        Loop
        
        'Go back to the contexts worksheet
        Worksheets("Contexts").Select
        
        
        
'        ts.WriteLine ("         </segment>")
        ts.WriteLine ("      </entity>")
        ts.WriteLine ("      <period>")
                
        Select Case ActiveCell.Offset(0, 3).Value
            Case "Instant"
                ts.WriteLine ("         <instant>" & ActiveCell.Offset(0, 5).Value & "</instant>")
            Case "Duration"
                ts.WriteLine ("         <startDate>" & ActiveCell.Offset(0, 4).Value & "</startDate>")
                ts.WriteLine ("         <endDate>" & ActiveCell.Offset(0, 5).Value & "</endDate>")
            Case Else
                ts.WriteLine ("         <instant>ERROR</instant>")
        End Select
        
        ts.WriteLine ("      </period>")
        'ts.WriteLine ("      <scenario>")
        'ts.WriteLine ("                " & ActiveCell.Offset(0, 6).Value)
        'ts.WriteLine ("      </scenario>")
        ts.WriteLine ("   </context>")
        
        ActiveCell.Offset(1, 0).Select
    Loop

'Process units
    Worksheets("Units").Select
    ActiveSheet.Range("A2").Select
    
    Dim sUnitID As String
    Dim sUnit As String
    
    ts.WriteBlankLines (1)
    ts.WriteLine ("   <!-- Units -->")
    
    Do While Len(ActiveCell.Value) > 1

        ts.WriteLine ("   <unit id='" & ActiveCell.Value & "'>")
        ts.WriteLine ("      <measure>" & ActiveCell.Offset(0, 1).Value & "</measure>")
        ts.WriteLine ("   </unit>")
        
        ActiveCell.Offset(1, 0).Select
    Loop

    
'Fact values output based on mapping information
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim EmptyCellCount As Integer
    EmptyCellCount = 0
    
    ts.WriteBlankLines (1)
    ts.WriteLine ("   <!-- Fact values -->")

    Do Until EmptyCellCount = 100
        
        If IsEmpty(ActiveCell.Value) Then
            'cell is empty
            EmptyCellCount = EmptyCellCount + 1
        
        Else
            EmptyCellCount = 0
            'MsgBox "Not null"
            
            
            sSheet = ActiveCell.Offset(0, 0).Value
            sCell = ActiveCell.Offset(0, 1).Value
            sElement = ActiveCell.Offset(0, 2).Value
            sLabel = ActiveCell.Offset(0, 2).Value
            sContext = ActiveCell.Offset(0, 3).Value
            sUnitRef = ActiveCell.Offset(0, 4).Value
            sDecimals = ActiveCell.Offset(0, 5).Value
            
            
            sValue = Worksheets(sSheet).Range(ActiveCell.Offset(0, 1).Value)
            sScale = ActiveCell.Offset(0, 6).Value
            
            If IsNumeric(sValue) Then
                sValue = sValue * sScale
            Else
                sValue = sValue
            End If
            
            If Len(sContext) < 1 Then
                MsgBox "Context not set for row " & ActiveCell.Row & " . Set to ERROR.  Please correct and re-run."
                sContext = "ERROR"
                End If
            sRow = ActiveCell.Row
            
            'Write the mapping information
            If Worksheets("Setup").Range("B4:B4").Value = "Yes" Then
                ts.WriteLine ("   <!-- AUDIT INFORMATION: Sheet=" & sSheet & " Cell=" & sCell & " -->")
            End If
            
            If Len(sUnitRef) = 0 Then
                'No unit ref, is string
                ts.WriteLine ("   <" & sElement & " contextRef='" & sContext & "'" & ">" & sValue & "</" & sElement & ">")
            Else
                'Has unit ref, is numeric
                ts.WriteLine ("   <" & sElement & " contextRef='" & sContext & "'" & " unitRef='" & sUnitRef & "' " & "decimals='" & sDecimals & "'>" & sValue & "</" & sElement & ">")
            End If

                                        
        End If
        
        ActiveCell.Offset(1, 0).Select
    Loop
        
    ts.WriteLine ("</xbrl>")
    
    Set fs = Nothing
    Set ts = Nothing
        
    'MsgBox "Instance document has been created and stored at: " & vbCrLf & vbCrLf & outputfile, vbInformation, "Output..."
    Application.ScreenUpdating = True
    
    'Go back to the workbook from which you started
    Worksheets(StartedAtSheet).Select
    

End Sub

Sub InitializeData()
'Sets the instance document to zero
    
    Dim StartedAtSheet As String
    StartedAtSheet = ActiveWorkbook.ActiveSheet.Name
        
    Application.ScreenUpdating = False
    
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim EmptyCellCount As Integer
    EmptyCellCount = 0
    
    Dim sSpreadsheet As String
    Dim sCell As String
    Dim sConcept As String
    Dim sContextRef As String
    Dim sUnitRef As String
    Dim sDecimals As Variant
    Dim sValue As Variant
    Dim sScale As Double
    
    Do Until EmptyCellCount = 100
        
        If IsEmpty(ActiveCell.Value) Then
            'cell is empty
            EmptyCellCount = EmptyCellCount + 1
        Else
            sSpreadsheet = ActiveCell.Offset(0, 0).Value
            sCell = ActiveCell.Offset(0, 1).Value
            sConcept = ActiveCell.Offset(0, 2).Value
            sContextRef = ActiveCell.Offset(0, 3).Value
            sUnitRef = ActiveCell.Offset(0, 4).Value
            sDecimals = ActiveCell.Offset(0, 5).Value
            
            'Tests to see if it is a start/stop tuple, if so, skips row in mapping table.
            If Not Len(sContextRef) = 0 Then
                If Not Len(sUnitRef) = 0 And Not Len(sDecimals) = 0 Then
                    'Has unit ref and decimals, therefore is Numeric
                    sValue = 0
                Else
                    'No unit ref or decimals, so string
                    'MsgBox "Cell:" & sCell & vbCrLf & "Concept: " & sConcept & vbCrLf & "Unit ref: " & sUnitRef & vbCrLf & "Length UR: " & Len(sUnitRef)
                    'Text
                    sValue = "[enter text here]"
                End If
                
                'sets the value
                Worksheets(sSpreadsheet).Range(sCell) = sValue
            End If
            
            
        End If
        
        ActiveCell.Offset(1, 0).Select
    Loop
    
    'MsgBox "Done!", vbInformation, "Information Retrived"
    Worksheets(StartedAtSheet).Select
    
    Application.ScreenUpdating = True

End Sub



Sub GenerateAuditInformation()
'Sets the instance document to zero
    
    Dim StartedAtSheet As String
    StartedAtSheet = ActiveWorkbook.ActiveSheet.Name
    
    
    Application.ScreenUpdating = False
    Application.StatusBar = "Setting up"
    
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim EmptyCellCount As Integer
    EmptyCellCount = 0
    
    Dim sValue As Variant
    Dim sContextRef As String
    Dim sUnitRef As String
    Dim sSpreadsheet As String
    Dim sCell As String
    Dim sConcept As String
    Dim sDecimals As String
    Dim sScale As Variant
    Dim sTemp As String
    Dim txtContextInfo As String
    Dim txtDimensionsInfo As String
    
    sTemp = "xxxx"
        
    Dim iCounter As Integer
    iCounter = 0

    
    'On Error Resume Next
    Do Until EmptyCellCount = 100
        iCounter = iCounter + 1
        If IsEmpty(ActiveCell.Value) Then
            'cell is empty
            EmptyCellCount = EmptyCellCount + 1
        Else
            sSpreadsheet = ActiveCell.Offset(0, 0).Value
            sCell = ActiveCell.Offset(0, 1).Value
            sConcept = ActiveCell.Offset(0, 2).Value
            sContextRef = ActiveCell.Offset(0, 3).Value
            sUnitRef = ActiveCell.Offset(0, 4).Value
            sDecimals = ActiveCell.Offset(0, 5).Value
            sValue = 0
            sScale = ActiveCell.Offset(0, 6).Text
           
             
            'If iCounter > 75 And iCounter < 100 Then
            '    MsgBox "Counter: " & iCounter & vbCrLf & "Concept: " & sConcept & vbCrLf & "Tuple status: " & TupleStatus & vbCrLf & "Tuple element: " & TupleElement
            'End If
            
            Sheets("Contexts").Select
            ActiveSheet.Range("A2").Select
            txtContextInfo = ""
            txtContextInfo = GetContextInfo(sContextRef)
            
            Worksheets("Dimensions").Select
            ActiveSheet.Range("A2").Select
            txtDimensionsInfo = ""
            txtDimensionsInfo = GetDimensionsInfo(sContextRef)
            
                
            Sheets(sSpreadsheet).Select
            Range(sCell).Select
            sValue = ActiveCell.Value
            Selection.ClearComments
            ActiveCell.AddComment
            ActiveCell.Comment.Visible = False
            
            
            If Not Len(sUnitRef) = 0 Then
              'Is numeric
              ActiveCell.Comment.Text Text:= _
                  "~~~~~~~~~~~~~~~~~~XBRL Fact Value Details~~~~~~~~~~~~~~~~~~" & vbLf & _
                  "Concept: " & sConcept & vbLf & _
                  "Context ID: " & sContextRef & vbLf & _
                  "Units: " & sUnitRef & vbLf & _
                  "Decimals: " & sDecimals & vbLf & _
                  "Fact Value: " & sValue & vbLf & _
                  "Scale: " & sScale & vbLf & _
                  vbLf & _
                  "XBRL: " & vbLf & "<" & sConcept & " contextRef='" & sContextRef & "' unitRef='" & sUnitRef & "' decimals='" & sDecimals & "'>" & sValue & "</" & sConcept & ">" & vbLf & _
                  vbLf & _
                  "~~~~~~~~~~~~~~~~~~Context Details~~~~~~~~~~~~~~~~~~~~~" & vbLf & _
                  txtContextInfo & vbLf & _
                  txtDimensionsInfo & vbLf & _
                  vbLf
              Else
              'Is text
              ActiveCell.Comment.Text Text:= _
                  "~~~~~~~~~~~~~~~~~~XBRL Fact Value Details~~~~~~~~~~~~~~~~~~" & vbLf & _
                  "Concept: " & sConcept & vbLf & _
                  "Context ID: " & sContextRef & vbLf & _
                  "Fact Value: " & sValue & vbLf & _
                  vbLf & _
                  "XBRL: " & vbLf & "<" & sConcept & " contextRef='" & sContextRef & "'>" & sValue & "</" & sConcept & ">" & vbLf & _
                  vbLf & _
                  "~~~~~~~~~~~~~~~~~~Context Details~~~~~~~~~~~~~~~~~~~~~" & vbLf & _
                  txtContextInfo & vbLf & _
                  txtDimensionsInfo & vbLf & _
                  vbLf
              End If
                               
        End If
        
        Worksheets("Mapping").Select
        ActiveCell.Offset(1, 0).Select
        Application.StatusBar = "Updating - Sheet: '" & sSpreadsheet & " Cell:" & sCell
            

    Loop
    
    'MsgBox "Done!", vbInformation, "Information Retrived"
    Worksheets(StartedAtSheet).Select

    'Formats all the comments
    Application.StatusBar = "Generating audit information as Excel comments..."
    Dim oComment As Comment
    For Each oComment In ActiveSheet.Comments
        With oComment.Shape.TextFrame
            .AutoSize = True
        End With
        With oComment.Shape.TextFrame.Characters.Font
            .Name = "Arial"
            .Size = 8
            .Bold = False
        End With
    Next

    Application.ScreenUpdating = True
    Application.StatusBar = "Done"

End Sub

Sub ClearAuditInformation()
'Clears all the comments from the spreadsheet
    
    Dim StartedAtSheet As String
    StartedAtSheet = ActiveWorkbook.ActiveSheet.Name
    
    
    Application.ScreenUpdating = False
    
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim EmptyCellCount As Integer
    EmptyCellCount = 0
    
    Dim sValue As Double
    Dim sSpreadsheet As String
    Dim sCell As String
    Dim sConcept As String
    
    Do Until EmptyCellCount = 100
        
        If IsEmpty(ActiveCell.Value) Then
            'cell is empty
            EmptyCellCount = EmptyCellCount + 1
        Else
            
            sSpreadsheet = ActiveCell.Offset(0, 0).Value
            sCell = ActiveCell.Offset(0, 1).Value
            Worksheets(sSpreadsheet).Range(sCell).ClearComments
            'Selection.ClearComments
            
            
        End If
        
        ActiveCell.Offset(1, 0).Select
    Loop
    
    'MsgBox "Done!", vbInformation, "Information Retrived"
    Worksheets(StartedAtSheet).Select
    
    Application.ScreenUpdating = True

End Sub


Sub PopulateSpreadsheet()
    
    Dim StartedAtSheet As String
    StartedAtSheet = ActiveWorkbook.ActiveSheet.Name
    
    
    Application.ScreenUpdating = False
    
    Dim FilePath As String
    
    
    If Mid(Worksheets("Setup").Range("B5:B5").Value, 1, 7) = "http://" Then
        FilePath = Worksheets("Setup").Range("B5:B5").Value
            Else
        FilePath = ThisWorkbook.Path & "\" & Worksheets("Setup").Range("B2").Value
    End If
    
    MsgBox "Loading data from: " & FilePath
       
    
    Dim oDocument As MSXML2.DOMDocument30
    Set oDocument = New MSXML2.DOMDocument30
    
    oDocument.async = False
    oDocument.validateOnParse = False
    oDocument.Load (FilePath)
    
    'Checks for errors in loading document...
    If oDocument.parseError.errorCode <> 0 Then
        MsgBox "Error loading file: " & vbCrLf & vbCrLf & _
            "File URL: " & oDocument.parseError.URL & vbCrLf & _
            "Line: " & oDocument.parseError.Line & vbCrLf & _
            "Character: " & oDocument.parseError.linepos & vbCrLf & _
            "File position: " & oDocument.parseError.filepos & vbCrLf & _
            "Source text: " & oDocument.parseError.srcText & vbCrLf & _
            "Error Code: " & oDocument.parseError.errorCode & vbCrLf & _
            "Error Description: " & oDocument.parseError.reason & vbCrLf _
            , vbCritical
            Exit Sub
    End If
    
    
    Worksheets("Mapping").Select
    ActiveSheet.Range("A2").Select
    
    Dim EmptyCellCount As Integer
    EmptyCellCount = 0
    
    Dim sValue As Variant
    Dim sContextRef As String
    Dim sUnitRef As String
    Dim sSpreadsheet As String
    Dim sCell As String
    Dim sConcept As String
    Dim sScale As Variant
    
    Dim TupleStatus As String
    Dim TupleElement As String
    Dim TupleNumber As Integer
    Dim iCounter As Integer
    
    TupleStatus = "False"
    TupleElement = ""
    TupleNumber = 0
    iCounter = 0
    

    Do Until EmptyCellCount = 100
        iCounter = iCounter + 1
        
        If IsEmpty(ActiveCell.Value) Then
            'The cell is empty, therefore a blank; skip this row.  Otherwise, process
            EmptyCellCount = EmptyCellCount + 1
        
        Else
            'process because NOT an empty row...
            
            sValue = "[error]"
            sSpreadsheet = ActiveCell.Offset(0, 0).Value
            sCell = ActiveCell.Offset(0, 1).Value
            sConcept = ActiveCell.Offset(0, 2).Value
            sContextRef = ActiveCell.Offset(0, 3).Value
            sUnitRef = ActiveCell.Offset(0, 4).Value
            sDecimals = ActiveCell.Offset(0, 5).Value
            sScale = ActiveCell.Offset(0, 6).Text
            
 
            'If iCounter > 75 And iCounter < 100 Then
            '    MsgBox "Counter: " & iCounter & vbCrLf & "Concept: " & sConcept & vbCrLf & "Tuple status: " & TupleStatus & vbCrLf & "Tuple element: " & TupleElement
            'End If
        
                
            If Not Len(sUnitRef) = 0 And Not Len(sDecimals) = 0 Then
                'Numeric
                sValue = oDocument.selectSingleNode("//" & sConcept & "[@contextRef='" & sContextRef & "']").Text
                sValue = sValue / sScale
            Else
                'Text
                sValue = oDocument.selectSingleNode("//" & sConcept & "[@contextRef='" & sContextRef & "']").Text
            End If
            
            Worksheets(sSpreadsheet).Range(sCell) = sValue
                    
        
        'Test to see if blank row
        End If
        
        ActiveCell.Offset(1, 0).Select
    Loop
    
    
    Set oDocument = Nothing
    Set oNode = Nothing
    Set oNodeList = Nothing
    'MsgBox "Done!", vbInformation, "Information Retrived"
    Worksheets(StartedAtSheet).Select

    Application.ScreenUpdating = True

End Sub




Function GetContextInfo(sContextRef As String) As String
    Do While Len(ActiveCell.Value > 1)
        If ActiveCell.Value = sContextRef Then
        
            GetContextInfo = ""
            GetContextInfo = GetContextInfo & "Context ID: " & ActiveCell.Offset(0, 0).Value & vbLf
            GetContextInfo = GetContextInfo & "Entity Scheme: " & ActiveCell.Offset(0, 2).Value & vbLf
            GetContextInfo = GetContextInfo & "Entity ID: " & ActiveCell.Offset(0, 1).Value & vbLf
            Select Case ActiveCell.Offset(0, 3).Value
                Case "Instant"
                    GetContextInfo = GetContextInfo & "Period: [As of] " & ActiveCell.Offset(0, 5).Value & vbLf
                Case "Duration"
                    GetContextInfo = GetContextInfo & "Period: [For Period] " & ActiveCell.Offset(0, 4).Value & " to " & ActiveCell.Offset(0, 5).Value & vbLf
                Case Else
            End Select
            
            GetContextInfo = GetContextInfo & "Period: " & ActiveCell.Offset(0, 3).Value & vbLf
            GetContextInfo = GetContextInfo & vbLf
            GetContextInfo = GetContextInfo & "Dimensions: " '& ActiveCell.Offset(0, 7).Value & vbLf
            'MsgBox GetContextInfo
            Exit Do
            
        Else
            ' Do nothing
        End If
        
        ActiveCell.Offset(1, 0).Select
        
    Loop

End Function

Function GetDimensionsInfo(sContextRef As String) As String
    GetDimensionsInfo = ""
    'GetDimensionsInfo = GetDimensionsInfo & "Context ID: " & sContextRef & vbLf
    Dim intCounter As Integer
    intCounter = 0
    Do While Len(ActiveCell.Value > 1)
        If ActiveCell.Value = sContextRef Then
            GetDimensionsInfo = GetDimensionsInfo & vbLf
            GetDimensionsInfo = GetDimensionsInfo & "Dimension: " & ActiveCell.Offset(0, 2).Value & vbLf
            GetDimensionsInfo = GetDimensionsInfo & "Member: " & ActiveCell.Offset(0, 3).Value & vbLf
            'Exit Do
            
        Else
            ' Do nothing
        End If
        Debug.Print intCounter
        
        intCounter = intCounter + 1
        If intCounter > 100 Then
            Exit Do
        End If
        
        
        ActiveCell.Offset(1, 0).Select
        
    Loop

End Function
'***********************************************
'*    end of macro basCreateXBRLInstance       *
'*                                             *
'*    part 1 of 3                              *
'***********************************************


'***********************************************
'*    macro basCreateXBRLTaxonomy              *
'*                                             *
'*    part 2 of 3                              *
'***********************************************

Sub GenerateTaxonomy()
    'Generates the taxonomy
    
    Dim fs As FileSystemObject
    Dim ts As TextStream
    Dim OutputFile As String

    OutputFile = ThisWorkbook.Path
    OutputFile = OutputFile & "\" & Range("C6").Value

    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile(OutputFile)

    ts.WriteLine ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "utf-8" & Chr(34) & "?>")
    ts.WriteLine ("<!-- HelloWorld Example -->")
    ts.WriteLine ("<!-- Date/time created: " & Now() & " -->")
    
    ts.WriteLine ("<schema  xmlns='http://www.w3.org/2001/XMLSchema'")
    ts.WriteLine ("         xmlns:xbrli='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("         xmlns:link='http://www.xbrl.org/2003/linkbase'")
    ts.WriteLine ("         xmlns:xlink='http://www.w3.org/1999/xlink'")
    ts.WriteLine ("         xmlns:" & Range("C4").Value & "='" & Range("C5").Value & "'")
    ts.WriteLine ("         targetNamespace='" & Range("C5").Value & "'")
    ts.WriteLine ("         elementFormDefault='qualified'")
    ts.WriteLine ("         attributeFormDefault='unqualified'>")
 
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("   <import")
    ts.WriteLine ("      namespace='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("      schemaLocation='http://www.xbrl.org/2003/xbrl-instance-2003-12-31.xsd' />")
    
    ts.WriteBlankLines (1)
        
    ActiveSheet.Range("C10").Select

    'Write the elements
    Do While Len(ActiveCell.Value) > 1
        'ts.WriteBlankLines (1)
        ts.WriteLine ("   <element")
        ts.WriteLine ("       name='" & ActiveCell.Value & "'")
        ts.WriteLine ("       type='" & ActiveCell.Offset(0, 1) & "'")
        ts.WriteLine ("       substitutionGroup='" & ActiveCell.Offset(0, 3) & "'")
        ts.WriteLine ("       xbrli:periodType='" & ActiveCell.Offset(0, 2) & "' />")
        
        ActiveCell.Offset(1, 0).Select
    Loop
        
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("</schema>")
    
    Set fs = Nothing
    Set ts = Nothing

End Sub

Sub GenerateTaxonomy()
    'Generates the taxonomy
    
    Dim fs As FileSystemObject
    Dim ts As TextStream
    Dim OutputFile As String

    OutputFile = ThisWorkbook.Path
    OutputFile = OutputFile & "\" & Range("C6").Value

    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile(OutputFile)

    ts.WriteLine ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "utf-8" & Chr(34) & "?>")
    ts.WriteLine ("<!-- HelloWorld Example -->")
    ts.WriteLine ("<!-- Date/time created: " & Now() & " -->")
    
    ts.WriteLine ("<schema  xmlns='http://www.w3.org/2001/XMLSchema'")
    ts.WriteLine ("         xmlns:xbrli='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("         xmlns:link='http://www.xbrl.org/2003/linkbase'")
    ts.WriteLine ("         xmlns:xlink='http://www.w3.org/1999/xlink'")
    ts.WriteLine ("         xmlns:" & Range("C4").Value & "='" & Range("C5").Value & "'")
    ts.WriteLine ("         targetNamespace='" & Range("C5").Value & "'")
    ts.WriteLine ("         elementFormDefault='qualified'")
    ts.WriteLine ("         attributeFormDefault='unqualified'>")
 
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("   <import")
    ts.WriteLine ("      namespace='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("      schemaLocation='http://www.xbrl.org/2003/xbrl-instance-2003-12-31.xsd' />")
    
    ts.WriteBlankLines (1)
        
    ActiveSheet.Range("C10").Select

    'Write the elements
    Do While Len(ActiveCell.Value) > 1
        'ts.WriteBlankLines (1)
        ts.WriteLine ("   <element")
        ts.WriteLine ("       name='" & ActiveCell.Value & "'")
        ts.WriteLine ("       type='" & ActiveCell.Offset(0, 1) & "'")
        ts.WriteLine ("       substitutionGroup='" & ActiveCell.Offset(0, 3) & "'")
        ts.WriteLine ("       xbrli:periodType='" & ActiveCell.Offset(0, 2) & "' />")
        
        ActiveCell.Offset(1, 0).Select
    Loop
        
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("</schema>")
    
    Set fs = Nothing
    Set ts = Nothing

End Sub

Sub GenerateTaxonomy()
    'Generates the taxonomy
    
    Dim fs As FileSystemObject
    Dim ts As TextStream
    Dim OutputFile As String

    OutputFile = ThisWorkbook.Path
    OutputFile = OutputFile & "\" & Range("C6").Value

    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile(OutputFile)

    ts.WriteLine ("<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "utf-8" & Chr(34) & "?>")
    ts.WriteLine ("<!-- HelloWorld Example -->")
    ts.WriteLine ("<!-- Date/time created: " & Now() & " -->")
    
    ts.WriteLine ("<schema  xmlns='http://www.w3.org/2001/XMLSchema'")
    ts.WriteLine ("         xmlns:xbrli='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("         xmlns:link='http://www.xbrl.org/2003/linkbase'")
    ts.WriteLine ("         xmlns:xlink='http://www.w3.org/1999/xlink'")
    ts.WriteLine ("         xmlns:" & Range("C4").Value & "='" & Range("C5").Value & "'")
    ts.WriteLine ("         targetNamespace='" & Range("C5").Value & "'")
    ts.WriteLine ("         elementFormDefault='qualified'")
    ts.WriteLine ("         attributeFormDefault='unqualified'>")
 
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("   <import")
    ts.WriteLine ("      namespace='http://www.xbrl.org/2003/instance'")
    ts.WriteLine ("      schemaLocation='http://www.xbrl.org/2003/xbrl-instance-2003-12-31.xsd' />")
    
    ts.WriteBlankLines (1)
        
    ActiveSheet.Range("C10").Select

    'Write the elements
    Do While Len(ActiveCell.Value) > 1
        'ts.WriteBlankLines (1)
        ts.WriteLine ("   <element")
        ts.WriteLine ("       name='" & ActiveCell.Value & "'")
        ts.WriteLine ("       type='" & ActiveCell.Offset(0, 1) & "'")
        ts.WriteLine ("       substitutionGroup='" & ActiveCell.Offset(0, 3) & "'")
        ts.WriteLine ("       xbrli:periodType='" & ActiveCell.Offset(0, 2) & "' />")
        
        ActiveCell.Offset(1, 0).Select
    Loop
        
    ts.WriteBlankLines (1)
    
    ts.WriteLine ("</schema>")
    
    Set fs = Nothing
    Set ts = Nothing

End Sub

'***********************************************
'*    end of macro basCreateXBRLTaxonomy       *
'*                                             *
'*    part 2 of 3                              *
'***********************************************


'***********************************************
'*    macro basValidation                      *
'*                                             *
'*    part 3 of 3                              *
'***********************************************

Private m_MessageNumber As Integer

Sub RunValidation()
    'Delete all the existing messages...
    Worksheets("Messages").Select
    ActiveSheet.Range("A2").Select
   
    Rows("2:500").Select
    Selection.Delete Shift:=xlUp
    
    m_MessageNumber = 1
    
    ActiveCell.Value = m_MessageNumber
    ActiveCell.Offset(0, 1).Value = "Information"
    ActiveCell.Offset(0, 2).Value = "Validation started"

    Validate_HelloWorld

    'End of validation
    ActiveCell.Offset(1, 0).Select
    m_MessageNumber = m_MessageNumber + 1

    ActiveCell.Value = m_MessageNumber
    ActiveCell.Offset(0, 1).Value = "Information"
    ActiveCell.Offset(0, 2).Value = "Validation complete"


End Sub




Function Validate_HelloWorld()
    'Validates the Schedule worksheet
    
    
    'Set up variables
    Dim lngPPE As Long
    Dim lngPPESum As Long
    
    '2007 PPE Totals
    ActiveCell.Offset(1, 0).Select
    m_MessageNumber = m_MessageNumber + 1
    
    lngPPE = CLng(Worksheets("Hello World Instance").Range("C14").Value)
    lngPPESum = CLng(Worksheets("Hello World Instance").Range("C9").Value) + CLng(Worksheets("Hello World Instance").Range("C10").Value) + CLng(Worksheets("Hello World Instance").Range("C11").Value) + CLng(Worksheets("Hello World Instance").Range("C12").Value) + CLng(Worksheets("Hello World Instance").Range("C13").Value)
    'MsgBox "PPE: " & lngPPE & " Sum PPE: " & lngPPESum
    
    If lngPPE = lngPPESum Then
        'PPE is OK!
        ActiveCell.Value = m_MessageNumber
        ActiveCell.Offset(0, 1).Value = "Information"
        ActiveCell.Offset(0, 2).Value = "Property, Plant and Equipment for 2007 foots on 'Hello World Example'."
    Else
        'Error in 2007 PPE
        ActiveCell.Value = m_MessageNumber
        ActiveCell.Offset(0, 1).Value = "ERROR"
        ActiveCell.Offset(0, 2).Value = "Property, Plant and Equipment for 2007 does not foot!  Total Property, Plant and Equipment for group = " & lngPPE & ", whereas the sum of the components of PPE is " & lngPPESum & ". Please correct discrepency on 'Hello World Example'."
    End If


    '2006 PPE Totals
    ActiveCell.Offset(1, 0).Select
    m_MessageNumber = m_MessageNumber + 1
    
    lngPPE = CLng(Worksheets("Hello World Instance").Range("D14").Value)
    lngPPESum = CLng(Worksheets("Hello World Instance").Range("D9").Value) + CLng(Worksheets("Hello World Instance").Range("D10").Value) + CLng(Worksheets("Hello World Instance").Range("D11").Value) + CLng(Worksheets("Hello World Instance").Range("D12").Value) + CLng(Worksheets("Hello World Instance").Range("D13").Value)
    'MsgBox "PPE: " & lngPPE & " Sum PPE: " & lngPPESum
    
    If lngPPE = lngPPESum Then
        'PPE is OK!
        ActiveCell.Value = m_MessageNumber
        ActiveCell.Offset(0, 1).Value = "Information"
        ActiveCell.Offset(0, 2).Value = "Property, Plant and Equipment for 2006 foots on 'Hello World Example'."
    Else
        'Error in 2007 PPE
        ActiveCell.Value = m_MessageNumber
        ActiveCell.Offset(0, 1).Value = "ERROR"
        ActiveCell.Offset(0, 2).Value = "Property, Plant and Equipment for 2006 does not foot!  Total Property, Plant and Equipment for group = " & lngPPE & ", whereas the sum of the components of PPE is " & lngPPESum & ". Please correct discrepency on 'Hello World Example'."
    End If

    

End Function

'***********************************************
'*    end macro basValidation                  *
'*                                             *
'*    part 3 of 3                              *
'***********************************************