- ホーム
- Other
- validation
動的な入力規則生成をMSXML DOMでやってみた
入力規則を動的に生成して、３段階の絞り込みを行うという課題があるが、ふと思い立ってMSXML DOMでやってみました。
久しぶりに復習してみただけで（すっかり忘れておりました）仕事につかったら傍迷惑きわまりないですね。
NodeとElementの違いがいまいち分かっておりません。前者だとgetElementsByTagNameが使えません。
Nodeのつもりで取得して、TypeNameを表示してみるとElementであってみたり．．．
☆入力規則生成用のデータ(Sheets(2))
大分類 中分類 小分類
A A1 A11
A A1 A12
A A2 A21
B B1 B11
B B1 B12
B B2 B21
B B2 B22
B B3 B31
（中略）
C C1 C11
C C1 C13
（以下略）
☆標準モジュール
'Microsoft XML V3.0に参照設定
Public oXMLDom As DOMDocument30
'MSXMLDOMの設定
Private Sub settingDOM(ByRef dom As DOMDocument30)
With dom
.async = False
.validateOnParse = False
.resolveExternals = False
.preserveWhiteSpace = True
.setProperty "SelectionLanguage", "XPath"
End With
End Sub
'XMLのヘッダー？の部分を設定
Private Sub setInfo(ByRef dom As DOMDocument30, comment As String)
Dim node As IXMLDOMNode
Set node = dom.createProcessingInstruction("xml", "version=""1.0"" encoding=""Shift_JIS""")
dom.appendChild node
Set node = Nothing
Set node = dom.createComment(comment)
dom.appendChild node
Set node = Nothing
End Sub
Public Sub setDOM()
'Dim oXMLDdom ...
Dim majorCatRange As Range, middleCatRange As Range, minorCatRange As Range
Dim myCell As Range
Dim i As Long, j As Long, k As Long
Dim myXPath As String
Dim root As IXMLDOMElement
Dim newElement As IXMLDOMElement
Dim nexElementsText As IXMLDOMText
Dim retNode As IXMLDOMNodeList
Dim majorNodeElem As IXMLDOMElement, middleNodeElem As IXMLDOMElement, minorNodeElem As IXMLDOMElement
Set oXMLDom = New DOMDocument30
'初期設定
settingDOM oXMLDom
setInfo oXMLDom, "xml test"
'ワークシートから絞り込み選択用リスト取得
With ThisWorkbook.Sheets(2)
Set majorCatRange = Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp))
Set middleCatRange = Range(.Range("B2"), .Range("B" & .Rows.Count).End(xlUp))
Set minorCatRange = Range(.Range("C2"), .Range("C" & .Rows.Count).End(xlUp))
End With
Set root = oXMLDom.createElement("root")
'これを入れ忘れて多方面ではまった
oXMLDom.appendChild root
'大分類
For Each myCell In majorCatRange.Cells
Set retNode = root.getElementsByTagName(myCell.Value)
If retNode.Length = 0 Then
Set newElement = oXMLDom.createElement(myCell.Value)
root.appendChild newElement
End If
Next myCell
'中分類
For Each myCell In middleCatRange.Cells
Set majorNodeElem = root.getElementsByTagName(myCell.Offset(0, -1).Value).Item(0)
Set retNode = majorNodeElem.getElementsByTagName(myCell.Value)
If retNode.Length = 0 Then
Set newElement = oXMLDom.createElement(myCell.Value)
majorNodeElem.appendChild newElement
End If
Next myCell
'小分類
' For Each myCell In minorCatRange.Cells
' Set majorNodeElem = root.getElementsByTagName(myCell.Offset(0, -2).Value).Item(0)
' Set middleNodeElem = majorNodeElem.getElementsByTagName(myCell.Offset(0, -1).Value).Item(0)
' Set retNode = middleNodeElem.getElementsByTagName(myCell.Value)
' If retNode.Length = 0 Then
' Set newElement = oXMLDom.createElement(myCell.Value)
' middleNodeElem.appendChild newElement
' End If
' Next myCell
'小分類ををXPathでやってみた
For Each myCell In minorCatRange.Cells
myXPath = "/" & root.nodeName & "/" & myCell.Offset(0, -2).Value & "/" & myCell.Offset(0, -1).Value
'下記どの書き方でもOK
Set middleNodeElem = root.SelectSingleNode(myXPath)
' Set middleNodeElem = oXMLDom.DocumentElement.SelectSingleNode(myXPath)
' Set middleNodeElem = oXMLDom.SelectSingleNode(myXPath)
Set retNode = root.SelectNodes(myXPath & "/" & myCell.Value)
If retNode.Length = 0 Then
Set newElement = oXMLDom.createElement(myCell.Value)
middleNodeElem.appendChild newElement
End If
Next myCell
End Sub
☆生成したXMLの例
'<?xml version="1.0"?>
'<!--xml test-->
'<root><A><A1><A11/><A12/><A13/></A1><A2><A21/><A22/></A2><A3><A31/></A3></A><B><B1><B11/><B12/><B13/></B1><B2><B21/><B22/></B2><B3><B31/></B3></B><C><C1><C11/><C12/><C13/></C1><C2><C21/><C22/></C2><C3><C31/><C32/></C3></C></root>
☆ワークシートモジュール
A→B→C列にWorksheet_SelectionChangeのイベントにより動的に入力規則を生成します
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If target.Cells.Count > 1 Then Exit Sub
If target.Column > 3 Then Exit Sub
If oXMLDom Is Nothing Then setDOM
setValidation target
End Sub
Private Sub setValidation(target As Range)
Dim i As Long
Dim myXPath As String
Dim root As IXMLDOMElement
Dim retNode As IXMLDOMNodeList
Dim strValidation As String
Set root = oXMLDom.DocumentElement
Select Case target.Column
Case 1
Set retNode = root.ChildNodes
Case 2
If target.Offset(0, -1).Value = "" Then Exit Sub
myXPath = "/" & root.nodeName & "/" & target.Offset(0, -1).Value
Set retNode = root.SelectSingleNode(myXPath).ChildNodes
Case 3
If target.Offset(0, -1).Value = "" Or target.Offset(0, -2).Value = "" Then Exit Sub
myXPath = "/" & root.nodeName & "/" & target.Offset(0, -2).Value & "/" & target.Offset(0, -1).Value
Set retNode = root.SelectSingleNode(myXPath).ChildNodes
Case Else
End Select
If retNode Is Nothing Then Exit Sub
For i = 0 To retNode.Length - 1
If strValidation = "" Then
strValidation = retNode(i).nodeName
Else
strValidation = strValidation & "," & retNode(i).nodeName
End If
setvalidationSub target, strValidation
Next i
End Sub
Private Sub setvalidationSub(target As Range, strValidation As String)
With target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strValidation
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End Sub
おまけで、実行時バインディング版
================================================================
☆標準モジュール
Public oXMLDom As Object
Public Sub setDOM()
Dim catRange As Range, myCell As Range
Dim myXPath As String
Dim root As Object, retNode As Object
Set oXMLDom = CreateObject("MSXML2.DOMDocument")
oXMLDom.setProperty "SelectionLanguage", "XPath"
'ワークシートから絞り込み選択用リスト取得
With ThisWorkbook.Sheets(2)
Set catRange = Range(.Range("A2"), .Range("C" & .Rows.Count).End(xlUp))
End With
'DOMにリストを設定
Set root = oXMLDom.createElement("root")
oXMLDom.appendChild root
'大分類
For Each myCell In catRange.Columns(1).Cells
Set retNode = root.getElementsByTagName(myCell.Value)
If retNode.Length = 0 Then
root.appendChild oXMLDom.createElement(myCell.Value)
End If
Next myCell
'中分類
For Each myCell In catRange.Columns(2).Cells
myXPath = "/" & root.nodeName & "/" & myCell.Offset(0, -1).Value
Set retNode = root.SelectNodes(myXPath & "/" & myCell.Value)
If retNode.Length = 0 Then
root.SelectSingleNode(myXPath).appendChild oXMLDom.createElement(myCell.Value)
End If
Next myCell
'小分類
For Each myCell In catRange.Columns(3).Cells
myXPath = "/" & root.nodeName & "/" & myCell.Offset(0, -2).Value & "/" & myCell.Offset(0, -1).Value
Set retNode = root.SelectNodes(myXPath & "/" & myCell.Value)
If retNode.Length = 0 Then
root.SelectSingleNode(myXPath).appendChild oXMLDom.createElement(myCell.Value)
End If
Next myCell
End Sub
☆シートモジュール
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If target.Cells.Count > 1 Then Exit Sub
If target.Column > 3 Then Exit Sub
If oXMLDom Is Nothing Then setDOM
setValidation target
End Sub
Private Sub setValidation(target As Range)
Dim i As Long
Dim myXPath As String
Dim root As Object, retNode As Object
Dim strValidation As String
Set root = oXMLDom.DocumentElement
Select Case target.Column
Case 1
myXPath = "/" & root.nodeName
Case 2
If target.Offset(0, -1).Value = "" Then Exit Sub
myXPath = "/" & root.nodeName & "/" & target.Offset(0, -1).Value
Case 3
If target.Offset(0, -1).Value = "" Or target.Offset(0, -2).Value = "" Then Exit Sub
myXPath = "/" & root.nodeName & "/" & target.Offset(0, -2).Value & "/" & target.Offset(0, -1).Value
End Select
Set retNode = root.SelectSingleNode(myXPath).ChildNodes
If retNode Is Nothing Then Exit Sub
For i = 0 To retNode.Length - 1
If strValidation = "" Then
strValidation = retNode(i).nodeName
Else
strValidation = strValidation & "," & retNode(i).nodeName
End If
With target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strValidation
End With
Next i
End Sub