Страницы: 1
RSS
Run-time error '424': Object required, Проблема excel
 
Всем привет, народ помогите баг исправить
Run-time error '424': Object required

Код
Private Sub makeElementNode(name, ByRef node As IXMLDOMElement, ByRef appendNode As IXMLDOMElement)
    Set node = dom.createElement(name)
    appendNod.appendChild node  ' выделяет эту страку при дебаге
End Sub
Изменено: zlodeh - 23.02.2016 16:56:13
 
Цитата
zlodeh написал:
Set node = dom.createElement(name)
appendNod.appendChild nod
nod это node или какой-то другой объект?
Изменено: Казанский - 23.02.2016 16:28:33
 
Цитата
Казанский написал: node
ДА - исправиль
 
zlodeh ,выложите весь код пожалуйста.
 
Код
  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

 
Этот вариант теперь уже работает?
Нужные библиотеки все подключены?
 
Вариант не работает, а вот по поводу библиотек можно подробнее
 
Кросс на Excel-vba
 
По поводу библиотек - если в коде пишите As IXMLDOMElement - значит должна быть подключена библиотека (Tools->References). Какая именно - не знаю, это Doober спец по XML. Но что-то с XML в названии нужно подключать.
Был бы файл/файлы - можно глянуть точнее, потестить - а так я пас.

P.S.Кстати кросс есть ещё и на кибере (без ссылки, они против ссылок :) )
Изменено: Hugo - 23.02.2016 22:23:19
 
Игорь, они на Кибере против каких ссылок - на ИХ сайт? Или против того, чтобы на ИХ сайте давали сторонние ссылки?
 
Цитата
Юрий М написал:
против того, чтобы на ИХ сайте давали сторонние ссылки
именно против этого они.
Цитата
Hugo написал:
если в коде пишите As IXMLDOMElement - значит должна быть подключена библиотека (Tools->References)
Если бы она была не подключена, то ошибку выдало бы еще на строке объявления. Плюс ошибка была бы вида Cant find Project or library.
Поэтому дело скорее всего в отсутствии возможности сделать указанный элемент дочерним для другого элемента. Но без файла(чтобы хотя бы видеть значения для lang и остальных переменных) сложно говорить что-то наверняка.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Скрытый текст

С библиотеками согласен, не актуально. Но раз человек про них вообще не в курсе - актуально :)
 
Игорь, зря ты испугался: в ту сторону можно ссылки давать ))
 
Цитата
Юрий М написал:
в ту сторону можно ссылки давать
Ага. Только желания совершенно нет. Как они к другим - так и другие к ним :) Я полагаю, Игорь это имел ввиду
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Вот Дима меня понял :)
Кто знает про сайт - тот и сам может тему легко найти, но пока там нет никакого движения.
 
Добрый вечер) У меня аналогичная проблема, имеется макрос завязанный на открытие книги, первая половина макроса срабатывает, а на второй выдает ошибку Object required бьюсь с ним давно, но никак не могу определить причину ошибки( Вот сам код
Код
Option Explicit
Private Sub Workbook_Open()
   
  'ОСАГО
Dim wb As Workbook
Dim ar As Range, ar2 As Range
Dim c As Range, c2 As Range
Dim dtRazn%, dtRazn2%
Dim s$, s2$
Dim Msg$, Msg2$
    On Error Resume Next
For Each ar In ['ОСАГО'!E:E].SpecialCells(2, 1).Areas
For Each c In ar.Cells
dtRazn = Date - c
s = ""
Select Case dtRazn
                Case Is > 0: s = "На " & Abs(dtRazn) & "дн. просрочен "
                Case 0: s = "Сегодня заканчивается "
                Case Is >= -5, Is > 0: s = "Через " & -dtRazn & " дн. заканчивается "
End Select
            If s <> "" Then Msg = Msg & IIf(Msg <> "", vbCrLf, "") & s & _
                "страховой полис ОСАГО на автомобиль " & c.Offset(, -3) & _
                " регистрационный номер " & c.Offset(, -4)
Next
If Msg <> "" Then MsgBox Msg: Debug.Print MsgNext
'АКБ
For Each ar2 In ['АКБ'!'E:E].SpecialCells(2, 1).Areas ' Срабатывает ошибка
For Each c2 In ar2.Cells
dtRazn2 = Date - c2
s2 = ""
Select Case dtRazn2
                 Case Is > 0: s2 = "Можно произвести замену АКБ "
End Select
            If s2 <> "" Then Msg2 = Msg2 & IIf(Msg2 <> "", vbCrLf, "") & s2 & _
                "на автомобиле " & c.Offset(, -2) & _
                " регистрационный номер " & c.Offset(, -3)
Next
If Msg2 <> "" Then MsgBox Msg2: Debug.Print Msg2
Next
End Sub
Изменено: Kcuxa_xa - 17.02.2019 22:35:23
Страницы: 1
Наверх