Dim row As Integer
Dim col As Integer
Dim n As Integer
Dim s As Integer
'Dim aVal As Integer
Dim Root As IXMLDOMElement
Dim moduleNode As IXMLDOMElement
Dim sceneElement As IXMLDOMElement
Dim questionElement As IXMLDOMElement
Dim txtElement As IXMLDOMElement
Dim wb As Workbook
Dim ws As Worksheet
Dim dom As DOMDocument30
Dim strName As String
Dim strId As String
Dim intLoop As Integer
Dim mySeal As String
Sub createQuestions()
Set wb = ActiveWorkbook
'SÖKVÄG
For sheetNum = 1 To wb.Worksheets.Count
xName = Left(ActiveWorkbook.name, Len(ActiveWorkbook.name) - 4) 'kapar bort .xls
Set fs = CreateObject("Scripting.FileSystemObject")
XPath = ActiveWorkbook.Path & "\xml\"
'MsgBox xName
If fs.FolderExists(XPath) = False Then
MkDir (XPath)
End If
'''''
'bPath = XPath & "\bilder\"
'If fs.FolderExists(bPath) = False Then
'MkDir (bPath)
'End If
'blnTypeIn = False
'''''
'Set ws = wb.ActiveSheet
'MsgBox wb.Worksheets.Count
Set dom = New DOMDocument30
dom.async = False
Set ws = wb.Worksheets(sheetNum)
Set node = dom.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
dom.appendChild node
Set node = Nothing
courseName = ws.Cells(2, 2)
customer = ws.Cells(3, 2)
random = ws.Cells(4, 2)
percent = ws.Cells(5, 2)
lang = ws.Cells(7, 2)
xName = spaceReplace(xName & "_" & lang)
Set Root = dom.createElement("module")
'Call makeAttrNode("id", Root, createGUID())
Call makeAttrNode("lang", Root, lang)
Call makeAttrNode("percent", Root, percent)
Call makeAttrNode("course", Root, courseName)
Call makeAttrNode("created", Root, Now())
Call makeAttrNode("updated", Root, "")
SceneId = 0
col = 9
qNum = 0
Do While col < 1000
If ws.Cells(col, 1) <> "" Then
SceneId = SceneId + 1
qNum = 0
aNum = 0
If SceneId < 10 Then
sceneNr = "0" & SceneId & "0"
Else
sceneNr = SceneId & "0"
End If
qPoolName = ws.Cells(col, 2)
numberOf = ws.Cells(col + 1, 2)
'numberOf = ws.Cells(col + 1, 2)
Call makeSceneElements(sceneNr, "", qPoolName, numberOf)
col = col + 2
End If
If ws.Cells(col, 2) = "Question text:" Then
qNum = qNum + 1
If qNum < 10 Then
qNr = sceneNr & "_0" & qNum & "0"
Else
qNr = sceneNr & "_" & qNum & "0"
End If
Call makeQuestionElements(name, qNr, ws.Cells(col, 5))
Call makeTxtElements(ws.Cells(col, 3), "typeval", "Q_" + qNr)
End If
If ws.Cells(col, 2) = "Answer alternative:" Then
a = col
Do While a < (col + 10)
txt = Trim(ws.Cells(a, 4))
If txt = "" Then Exit Do
If txt <> "" Then
aNum = aNum + 1
If aNum < 10 Then
aNr = sceneNr & "_0" & aNum & "0"
Else
aNr = sceneNr & "_" & aNum & "0"
End If
Call makeAnswerElements(txt, ws.Cells(a, 3), aNr)
End If
a = a + 1
Loop
End If
Do While row < 5
row = row + 1
Loop
col = col + 1
Loop
MsgBox ("File saved: " & XPath & xName & ".xml")
dom.appendChild Root
'dom.Save (XPath & MyValue & ".xml")
dom.Save (XPath & xName & ".xml")
Next sheetNum
End Sub
Sub putInMenu()
With Application.CommandBars("File")
i = 0
For i = 1 To (.Controls.Count - 2)
If .Controls(i).Caption = "Make An XML" Then
.Controls(i).Delete
End If
Next i
.Controls.Add msoControlButton, , , 7
.Controls(7).Caption = "Make An XML"
.Controls(7).OnAction = "createQuestions"
End With
End Sub
Private Sub makeSceneElements(idNum, template, name, orderNum)
Call makeElementNode("scene", sceneElement, Root)
Call makeAttrNode("id", sceneElement, idNum)
Call makeAttrNode("quantity", sceneElement, orderNum)
'Call makeAttrNode("type", sceneElement, "normal")
Call makeAttrNode("template", sceneElement, template)
Call makeAttrNode("name", sceneElement, name)
'Call makeAttrNode("hide", sceneElement, "true or false")
End Sub
Private Sub makeQuestionElements(name, orderNum, img)
Call makeElementNode("question", questionElement, sceneElement)
Call makeAttrNode("id", questionElement, orderNum)
Call makeAttrNode("image", questionElement, img)
'Call makeAttrNode("name", questionElement, "")
'Call makeAttrNode("order", questionElement, orderNum)
'Call makeAttrNode("type", questionElement, "")
'Call makeAttrNode("goto", questionElement, "maybe a label for flash ")
'Call makeAttrNode("hide", questionElement, "true or false")
End Sub
Private Sub makeAttrNode(name, ByRef node As IXMLDOMElement, val)
Set attr = dom.createAttribute(name)
attr.Value = val
node.setAttributeNode attr
Set attr = Nothing
End Sub
Private Sub makeElementNode(name, ByRef node As IXMLDOMElement, ByRef appendNode As IXMLDOMElement)
Set node = dom.createElement(name)
appendNode.appendChild node
End Sub
Private Sub makeTxtElements(texten, typeval, orderNum)
Call makeElementNode("txt", txtElement, questionElement)
Call makeAttrNode("id", txtElement, orderNum)
Set cdataNode = dom.createCDATASection(texten)
txtElement.appendChild cdataNode
'Call makeAttrNode("ref", txtElement, refId)
'Call makeAttrNode("order", txtElement, orderNum)
'Call makeAttrNode("type", txtElement, typeval)
'Call makeAttrNode("goto", txtElement, "") 'maybe a label in flash
'Call makeAttrNode("style", txtElement, "") ' styleName
'Call makeAttrNode("hide", txtElement, "true or false")
End Sub
Private Sub makeAnswerElements(texten, state, orderNum)
Call makeElementNode("answer", txtElement, questionElement)
Call makeAttrNode("id", txtElement, orderNum)
Call makeAttrNode("state", txtElement, state)
Set cdataNode = dom.createCDATASection(texten)
txtElement.appendChild cdataNode
'Call makeAttrNode("ref", txtElement, refId)
'Call makeAttrNode("order", txtElement, orderNum)
'Call makeAttrNode("type", txtElement, typeval)
'Call makeAttrNode("goto", txtElement, "") 'maybe a label in flash
'Call makeAttrNode("style", txtElement, "") ' styleName
'Call makeAttrNode("hide", txtElement, "true or false")
End Sub
'funktion för att trimma namn
Function GetName(ToTrim)
Dim intTemp
intTemp = InStr(ToTrim, " ")
ToTrim = Left(ToTrim, intTemp - 1)
GetName = ToTrim
End Function
Function spaceReplace(strCurrent)
strReplaced = Replace(strCurrent, " ", "_")
strReplaced = LCase(strReplaced)
spaceReplace = strReplaced
End Function
|
