vba开发
Sub run() '调用全部过程。
Application.ScreenUpdating = False
Call resource
Call components_xml
Call 每个节点_xml
End Sub
Sub resource()
'
''处理resource
Dim myfilename As String
Dim rang As Range
myfilename = "resources.js"
fn = FreeFile
outdir = Application.ActiveWorkbook.Path
Open outdir & "\" & myfilename For Output Access Write Lock Write As #fn
Print #fn, "var TEXT = {"
Print #fn, """HCDM.WEB.TITLE"":""厦门恒隆兴科技有限公司数据挖掘在线分析平台"""
For ii = 1 To 6
Worksheets("3.2.resource.js").Activate
Print #fn,
If ii = 1 Then
Print #fn, "// 1.节点显示名称"
'Set rang = Range("P5:P10000")
Worksheets("3.2.resource.js").Range("P5:P10000").Select
ElseIf ii = 2 Then
Print #fn, " //2.节点描述信息"
Worksheets("3.2.resource.js").Range("Q5:Q10000").Select
ElseIf ii = 3 Then
Print #fn, " //3.参数显示名称"
Worksheets("3.2.resource.js").Range("R5:R10000").Select
ElseIf ii = 4 Then
Print #fn, " //4.参数描述信息"
Worksheets("3.2.resource.js").Range("S5:S10000").Select
ElseIf ii = 5 Then
Print #fn, " //5.下拉选项显示名称"
Worksheets("3.2.resource.js").Range("T5:T10000").Select
ElseIf ii = 6 Then
Print #fn, "//6.视图组显示名称"
Worksheets("3.2.resource.js").Range("U5:U10000").Select
End If
Selection.Copy
On Error Resume Next
Sheets("temp").Delete
Worksheets.Add.Name = "temp"
ThisWorkbook.Worksheets("temp").Activate
Worksheets("temp").Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$10000").RemoveDuplicates Columns:=Array(1), _
Header:=xlNo
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Worksheets("temp").Cells(i, 1) <> ","""":""""" And Worksheets("temp").Cells(i, 1) <> "" Then
Print #fn, Worksheets("temp").Cells(i, 1)
End If
Next i
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Next ii
Print #fn, "}"
Close #fn
End Sub
''获取列函数
Function F_FindColumn(Name_Column As String) As Integer
Dim m As Integer
''预设50列
For i = 1 To 50
If Cells(4, i) = Name_Column Then
m = i
Exit For
End If
Next i
F_FindColumn = m
End Function
Sub components_xml()
''step 1:定义变量
Dim PathZH, NodeNameEn, NodeNameZh, NodeDescName As String ''定义字段存储变量
Dim ColPathZH, ColNodeNameEn, ColNodeNameZh, ColNodeDescName As Integer ''定义字段所在列
Dim strBeginLab, strEndLab As String ''定义标签变量
Dim CompsFileName, Dir As String ''定义输出文件信息
Dim row, nRows, RowBegin As Integer ''定义记录临时变量
Dim TmpGroups, TmpGroup, TmpGroupPath As String ''定义临时变量
Dim nGroup, PathDiffFlag As Integer
''step 2:初始化变量
ColPathZH = F_FindColumn("PathZH")
ColNodeNameZh = F_FindColumn("NodeNameZHbak")
ColNodeNameEn = F_FindColumn("NodeNameEn")
ColNodeDescName = F_FindColumn("NodeDescNamebak")
' ColPathZH = 2
' ColNodeNameEn = 4
' ColNodeNameZh = 3
' ColNodeDescName = 5
RowBegin = 5
nRows = ActiveSheet.UsedRange.Rows.Count
CompsFileName = "components.xml"
Dir = Application.ActiveWorkbook.Path
''xml文件初始化
fn = FreeFile
Open Dir & "\" & CompsFileName For Output Access Write Lock Write As #fn
Print #fn, "<?xml version=""1.0"" encoding=""GBK""?>" '' <?xml version="1.0" encoding="GBK"?> UTF-8
Print #fn, "<components>"
''step 3:遍历所有记录
For row = RowBegin To nRows
''1.处理路径(在EXCEL中,路径是按照深度由下向上降序排序了的)
'' A.如果路径有变化,则输出路径最末组标签,然后取得新路径值
If Cells(row, ColPathZH) <> PathZH Then
TmpGroups = Cells(row, ColPathZH)
''去掉前后两路径中相同的父组
For nGroup = 1 To Application.WorksheetFunction.Min(Len(TmpGroups) - Len(Replace(TmpGroups, ".", "")), Len(PathZH) - Len(Replace(PathZH, ".", "")))
TmpGroup = Left(TmpGroups, InStr(1, TmpGroups, ".") - 1)
If TmpGroup = Left(PathZH, InStr(1, PathZH, ".") - 1) Then
TmpGroups = Replace(TmpGroups, TmpGroup & ".", "")
PathZH = Replace(PathZH, TmpGroup & ".", "")
Else
''如果某父节点不同,则停止删除
Exit For
End If
Next nGroup
''上面的循环少判断了最后一个组,需要额外处理
If TmpGroups <> "" And PathZH <> "" Then
If InStr(1, TmpGroups, ".") > 0 Then
TmpGroup = Left(TmpGroups, InStr(1, TmpGroups, ".") - 1)
Else
TmpGroup = TmpGroups
End If
If InStr(1, PathZH, ".") > 0 Then
TmpGroupPath = Left(PathZH, InStr(1, PathZH, ".") - 1)
Else
TmpGroupPath = PathZH
End If
If TmpGroup = TmpGroupPathZH Then
TmpGroups = Replace(TmpGroups, TmpGroup, "")
PathZH = Replace(PathZH, TmpGroup, "")
End If
End If
''输出旧路径未输出的结束标签
If Left(PathZH, 1) = "." Then
PathZH = Mid(PathZH, 2)
End If
For nGroup = 1 To Len(PathZH) - Len(Replace(PathZH, ".", ""))
If PathZH <> "" Then
Print #fn, "</group>"
End If
Next nGroup
If PathZH <> "" Then
Print #fn, "</group>"
End If
''输出新路径组的开始标签
If Left(TmpGroups, 1) = "." Then
TmpGroups = Mid(TmpGroups, 2)
End If
For nGroup = 1 To Len(TmpGroups) - Len(Replace(TmpGroups, ".", ""))
TmpGroup = Left(TmpGroups, InStr(1, TmpGroups, ".") - 1)
Print #fn, "<group name=""" & TmpGroup & """>"
TmpGroups = Replace(TmpGroups, TmpGroup & ".", "")
Next nGroup
''输出最后一个GROUP
If TmpGroups <> "" Then
Print #fn, "<group name=""" & TmpGroups & """>"
End If
PathZH = Cells(row, ColPathZH) ''处理后再赋值,是为了找出新路径已经少了的路径,并进行处理,然后再赋值
PathDiffFlag = 1
Else
PathDiffFlag = 0
End If
''2.处理节点
'' 如果记录节点名变化,则输出节点信息
If (Cells(row, ColNodeNameEn) <> NodeNameEn Or PathDiffFlag = 1) And Cells(row, ColNodeNameEn) <> "" Then
NodeNameZh = Cells(row, ColNodeNameZh)
NodeNameEn = Cells(row, ColNodeNameEn)
NodeDescName = Cells(row, ColNodeDescName)
Print #fn, "<component class=""" & NodeNameEn & """>"
Print #fn, "<name>" & NodeNameZh & "</name>"
Print #fn, "<tips>" & NodeDescName & "</tips>"
Print #fn, "</component>"
End If
Next row
'' step 4:最后一条记录处理结束后,输出路径组的结束标签,前提是记录表是规范的,不能有路径和节点名称信息为空的情况
For nGroup = 1 To Len(PathZH) - Len(Replace(PathZH, ".", "")) + 1
If PathZH <> "" Then
Print #fn, "</group>"
End If
Next nGroup
''step 4:关闭文件
Print #fn, "</components>"
Close #fn
End Sub
Sub 每个节点_xml()
''对排序无要求
ThisWorkbook.Worksheets("3.1.节点参数列表").Activate
Dim f_end As String '' ">
Dim m As Integer
Dim i_start As Integer '开始行
Dim x As Integer ''缩进倍数
Dim d_A As Integer ''记录节点开始行
Dim d_int_Z As Integer '' 记录结束行
Dim d_UppLimit As String
Dim d_LowLimit As String
'--------------------------
Dim d_class As String '' Class
Dim d_path As String ''路径
Dim d_newOpt As String ''新路径
Dim d_Single_Option As String ''单一参数
''变量赋值
i_start = 5
nodename = 3
x = 1
''程序优化，获取列函数赋值给变量
''节点英文名称
''NodeNameEn
Dim d_Column_NodeNameEn As Integer
d_Column_NodeNameEn = F_FindColumn("NodeNameEn")
'节点中文名称
Dim d_Column_NodeNameZH As Integer
d_Column_NodeNameZH = F_FindColumn("NodeNameZH")
''NodeShortName
Dim d_Column_NodeNameShort As Integer
d_Column_NodeNameShort = F_FindColumn("NodeNameShort")
''NodeDescName
''节点描述信息
Dim d_Column_NodeDescName As Integer
d_Column_NodeDescName = F_FindColumn("NodeDescName")
''节点类名
Dim d_Column_class As Integer
d_Column_class = F_FindColumn("class")
''节点路径
Dim d_Column_Path As Integer
d_Column_Path = F_FindColumn("Path")
''Option
''参数
Dim d_Column_Option As Integer
d_Column_Option = F_FindColumn("Options")
''OptNameEn
''参数英文名称
Dim d_Column_OptNameEn As Integer
d_Column_OptNameEn = F_FindColumn("OptNameEn")
''OptDispName
''参数中文名称
Dim d_Column_OptDispName As Integer
d_Column_OptDispName = F_FindColumn("OptNameZH")
''ParamDescName
''参数描述信息
Dim d_Column_ParamDescName As Integer
d_Column_ParamDescName = F_FindColumn("OptDescZH")
''Option
''参数字段类型
Dim d_Column_OptValType As Integer
d_Column_OptValType = F_FindColumn("OptValType")
''OptCtlType
Dim d_Column_OptCtlType As Integer
d_Column_OptCtlType = F_FindColumn("OptCtlType")
''ParamVal
''参数值
Dim d_Column_ParamVal As Integer
d_Column_ParamVal = F_FindColumn("ParamVal")
''ParamDispName
''参数值描述信息
Dim d_Column_ParamDispName As Integer
d_Column_ParamDispName = F_FindColumn("ParamValDesc")
''DefaltFlag
''是否默认值
Dim d_Column_DefaltFlag As Integer
d_Column_DefaltFlag = F_FindColumn("DefaltFlag")
''FlagOpt
Dim d_Column_FlagOpt As Integer
d_Column_FlagOpt = F_FindColumn("FlagOpt")
''Option
''关联参数
Dim d_Column_RefOpt As Integer
d_Column_RefOpt = F_FindColumn("RefOpt")
''RefParam
''关联参数值
Dim d_Column_RefParam As Integer
d_Column_RefParam = F_FindColumn("RefParam")
''ExdOpt
''互斥参数
Dim d_Column_ExdOpt As Integer
d_Column_ExdOpt = F_FindColumn("ExdOpt")
''ExdParam
''互斥参数值
Dim d_Column_ExdParam As Integer
d_Column_ExdParam = F_FindColumn("ExdParam")
''Edit
Dim d_Column_Edit As Integer
d_Column_Edit = F_FindColumn("Edit")
''VIEW
Dim d_Column_VIEW As Integer
d_Column_VIEW = F_FindColumn("VIEW")
''VIEWGROUP
Dim d_Column_VIEWGROUP As Integer
d_Column_VIEWGROUP = F_FindColumn("VIEWGROUP")
''VGDescName
Dim d_Column_VGDescName As Integer
d_Column_VGDescName = F_FindColumn("VGDescName")
''VGDispName
Dim d_Column_VGDispName As Integer
d_Column_VGDispName = F_FindColumn("VGDispName")
''LowLimit
Dim d_Column_LowLimit As Integer
d_Column_LowLimit = F_FindColumn("LowLimit")
''UppLimit
Dim d_Column_UppLimit As Integer
d_Column_UppLimit = F_FindColumn("UppLimit")
For i = i_start To ActiveSheet.UsedRange.Rows.Count
If Cells(i, d_Column_NodeNameZH) <> "" Then
If Cells(i - 1, d_Column_NodeNameZH) <> Cells(i, d_Column_NodeNameZH) Then
''记录节点开始行，用于搜索
d_A = i
outdir = Application.ActiveWorkbook.Path
''输出文件名称
myfilename = Cells(i, d_Column_NodeNameEn)
fn = FreeFile
Open outdir & "\" & myfilename & ".xml" For Output Access Write Lock Write As #fn
''写入表头,添加shortname
Print #fn, "<?xml version=""1.0"" encoding=""GBK""?>"
Print #fn, " <Component type=""weka"" serverclass= """ & Cells(i, d_Column_class) & """ name=""" & Cells(i, d_Column_NodeNameEn) & """ NodeNameShort=""" & Cells(i, d_Column_NodeNameShort) & """"
Print #fn, " resource = """ & Cells(i, d_Column_class) & """ Group = """ & Cells(i, d_Column_Path) & """ Icon = """ & Cells(i, d_Column_NodeNameEn) & ".gif"""
Print #fn, " displayName= """ & Cells(i, d_Column_NodeNameZH) & """ description=""" & Cells(i, d_Column_NodeDescName) & """" _
& getNodeLink(Cells(i, d_Column_NodeNameEn)) & " >"
Print #fn, "<PropertyDescriptors>"
End If
If Cells(i - 1, d_Column_OptNameEn) <> Cells(i, d_Column_OptNameEn) Then
''获取默认参数
For y = i To ActiveSheet.UsedRange.Rows.Count
If Cells(y, d_Column_DefaltFlag) = "是" Then
d_DefaltValue = Cells(y, d_Column_ParamVal)
Exit For
''以英文参数名称区分
If Cells(i, d_Column_OptNameEn) <> Cells(y, d_Column_OptNameEn) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next y
''互斥参数
''paramnameen=FgetparamnameEn(nodenameen,path,param);
If Cells(i, d_Column_ExdOpt) <> "" And Cells(i, d_Column_OptNameEn) <> Cells(i - 1, d_Column_OptNameEn) Then
''读取互斥参数英文名称，逗号分隔
''判断有几个互斥参数
m = 0
m = Len(Cells(i, d_Column_ExdOpt)) - Len(Replace(Cells(i, d_Column_ExdOpt), ",", ""))
For Z = 1 To m + 1
''获取当前拆分后的参数
If Z = 1 Then
''第一个参数特殊处理
d_Single_Option = Mid(Cells(i, d_Column_ExdOpt), 1, InStr(1, Cells(i, d_Column_ExdOpt) & ",", ",") - 1)
d_newOpt = Mid(Cells(i, d_Column_ExdOpt), InStr(1, Cells(i, d_Column_ExdOpt), ",") + 1) & ","
d_Single_Optval = Mid(Cells(i, d_Column_ExdParam), 1, InStr(1, Cells(i, d_Column_ExdParam) & ",", ",") - 1)
d_newOptval = Mid(Cells(i, d_Column_ExdParam), InStr(1, Cells(i, d_Column_ExdParam), ",") + 1) & ","
Else
d_Single_Option = Mid(d_newOpt, 1, InStr(1, d_newOpt, ",") - 1)
d_newOpt = Mid(d_newOpt, InStr(1, d_newOpt, ",") + 1) & ","
d_Single_Optval = Mid(d_newOptval, 1, InStr(1, d_newOptval, ",") - 1)
d_newOptval = Mid(d_newOptval, InStr(1, d_newOptval, ",") + 1) & ","
End If
'' -----
For y = d_A To ActiveSheet.UsedRange.Rows.Count
''循环，搜索当前节点下参数对应的值
If Cells(y, d_Column_Option) = d_Single_Option Then ''判断参数与互斥参数相同
d_ExdOpt = Cells(y, d_Column_OptNameEn) ''获取互斥参数英文名
'' d_ExdOpt = Cells(y, d_Column_ExdParam) ''获取参值
If Z = m + 1 Then
''最后一个，不需要逗号
d_exclude = d_exclude & d_ExdOpt & ":" & d_Single_Optval
Else
d_exclude = d_exclude & d_ExdOpt & ":" & d_Single_Optval & ","
End If
Exit For
If Cells(i, d_Column_class) <> Cells(y, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next y
Next Z
Else ''清空变量
d_exclude = ""
End If
''关联参数
If Cells(i, d_Column_RefOpt) <> "" And Cells(i, d_Column_OptNameEn) <> Cells(i - 1, d_Column_OptNameEn) Then
''读取关联参数英文名称，逗号分隔
''判断有几个关联参数
m = 0
m = Len(Cells(i, d_Column_RefOpt)) - Len(Replace(Cells(i, d_Column_RefOpt), ",", ""))
For Z = 1 To m + 1
''获取当前拆分后的参数
If Z = 1 Then
''第一个参数特殊处理
d_Single_Option = Mid(Cells(i, d_Column_RefOpt), 1, InStr(1, Cells(i, d_Column_RefOpt) & ",", ",") - 1)
d_newOpt = Mid(Cells(i, d_Column_RefOpt), InStr(1, Cells(i, d_Column_RefOpt), ",") + 1) & ","
d_Single_Optval = Mid(Cells(i, d_Column_RefParam), 1, InStr(1, Cells(i, d_Column_RefParam) & ",", ",") - 1)
d_newOptval = Mid(Cells(i, d_Column_RefParam), InStr(1, Cells(i, d_Column_RefParam), ",") + 1) & ","
Else
d_Single_Option = Mid(d_newOpt, 1, InStr(1, d_newOpt, ",") - 1)
d_newOpt = Mid(d_newOpt, InStr(1, d_newOpt, ",") + 1) & ","
d_Single_Optval = Mid(d_newOptval, 1, InStr(1, d_newOptval, ",") - 1)
d_newOptval = Mid(d_newOptval, InStr(1, d_newOptval, ",") + 1) & ","
End If
For y = d_A To ActiveSheet.UsedRange.Rows.Count
''循环，搜索当前节点下参数对应的值
If Cells(y, d_Column_Option) = d_Single_Option Then ''判断参数与关联参数相同
d_RefOpt = Cells(y, d_Column_OptNameEn) ''获取关联参数英文名
'd_RefParam = Cells(y, d_Column_RefParam) ''获取参值 RefParam
If Z = m + 1 Then
''最后一个，不需要逗号
d_reference = d_reference & d_RefOpt & ":" & d_Single_Optval
Else
d_reference = d_reference & d_RefOpt & ":" & d_Single_Optval & ","
End If
Exit For
If Cells(i, d_Column_class) <> Cells(y, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next y
Next Z
Else ''清空变量
d_reference = ""
End If
Print #fn, Spc(x * 2 + 2); "<Property type=""" & Cells(i, d_Column_OptValType) & """ name = """ & Cells(i, d_Column_OptNameEn) _
& """ displayName = """ & Cells(i, d_Column_OptDispName) & """"
Print #fn, Spc(x * 2 + 6); "description =""" & Cells(i, d_Column_ParamDescName) _
& """ initial="""; d_DefaltValue & """ FlagOpt=""" & Cells(i, d_Column_FlagOpt) & """ edit = """; Cells(i, d_Column_Edit) & """"
Print #fn, Spc(x * 2 + 6); "reference = """ & d_reference & """ exclude=""" & d_exclude & """> "
''清空变量，否则会重复
d_reference = ""
d_exclude = ""
End If
If InStr(1, Cells(i, d_Column_OptCtlType), "下拉列表") > 0 And Cells(i, d_Column_OptValType) <> "boolean" Then
''下拉列表
If Cells(i - 1, d_Column_OptNameEn) <> Cells(i, d_Column_OptNameEn) Then
If UCase(Cells(i, d_Column_OptCtlType)) = "下拉列表(变量复选)" Then
Print #fn, Spc(x * 2 + 4); "<Control type=""CHOICE_VAR"" multiple = ""true"">"
ElseIf UCase(Cells(i, d_Column_OptCtlType)) = "下拉列表(变量单选)" Then
Print #fn, Spc(x * 2 + 4); "<Control type=""CHOICE_VAR"" multiple = ""false"">"
Else
Print #fn, Spc(x * 2 + 4); "<Control type=""CHOICE"" >"
End If
End If
''下拉参数,参数值显示名称
If Cells(i, d_Column_OptCtlType) = "下拉列表" Then
Print #fn, Spc(x * 2 + 6); "<CHOICE rawValue=""" & Cells(i, d_Column_ParamVal) & """ displayValue= """ & Cells(i, d_Column_ParamDispName); """/>"
End If
If Cells(i + 1, d_Column_OptNameEn) <> Cells(i, d_Column_OptNameEn) Then
Print #fn, Spc(x * 2 + 4); "</Control>"
End If
ElseIf Cells(i, d_Column_OptCtlType) = "输入框" Then
''3. RANGE 仅type为 double或者int时支持 为上限下限控制
If Cells(i, d_Column_OptValType) = "double" Or Cells(i, d_Column_OptValType) = "int" Then
''判断小于0数值格式问题。
d_UppLimit = Cells(i, d_Column_UppLimit)
If Mid(Cells(i, d_Column_UppLimit), 1, 1) = "." Then
d_UppLimit = "0" & Cells(i, d_Column_UppLimit)
End If
d_LowLimit = Cells(i, d_Column_LowLimit)
If Mid(Cells(i, d_Column_LowLimit), 1, 1) = "." Then
d_LowLimit = "0" & Cells(i, d_Column_LowLimit)
End If
Print #fn, Spc(x * 2 + 4); "<Control type=""Range"" max="""; d_UppLimit & """ min="""; d_LowLimit & """/>"
End If
ElseIf UCase(Cells(i, d_Column_OptCtlType)) = "DIALOG" Then
Dim dialogClass As String
dialogClass = "<Control type=""DIALOG"""
If UCase(Cells(i, d_Column_ParamVal)) = "&IMPORT_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&IMPORT_TEST_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&IMPORT_TRAIN_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&IMPORT_SCORE_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&EXPORT_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&EXPORT_TEST_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&EXPORT_TRAIN_DATA" _
Or UCase(Cells(i, d_Column_ParamVal)) = "&EXPORT_SCORE_DATA" _
Then
dialogClass = dialogClass + " class=""FileView"""
End If
dialogClass = dialogClass + "/>"
Print #fn, Spc(x * 2 + 4); dialogClass
ElseIf UCase(Cells(i, d_Column_OptCtlType)) = "TEXTAREA" Then
Print #fn, Spc(x * 2 + 4); "<Control type=""TEXTAREA""/>"
ElseIf Cells(i, d_Column_OptValType) <> "boolean" Then
' Print #fn,Spc(x * 2 + 4);
End If
If Cells(i + 1, d_Column_OptNameEn) <> Cells(i, d_Column_OptNameEn) Then
Print #fn, Spc(x * 2 + 2); "</Property>"
End If
''判断，节点结束前，添加结束符号
If Cells(i + 1, d_Column_NodeNameZH) <> Cells(i, d_Column_NodeNameZH) Then
Print #fn, "</PropertyDescriptors>"
'' Close #fn
''在本节点结束前处理
''视图部分处理，，重新检索
' Dim F_FindColumn("VIEW As Integer ' 视图
' Dim F_FindColumn("VIEWGROUP As Integer ' 视图组名
' Dim F_FindColumn("VGDispName As Integer ' 视图组显示名称
' Dim F_FindColumn("VGDescName As Integer ' 视图组描述信息
Print #fn, "<Views>"
Print #fn, " <View name=""Advanced"" > "
For j = d_A To ActiveSheet.UsedRange.Rows.Count
''查找跟目录下的参数
If InStr(1, UCase(Cells(j, d_Column_VIEW)), "AD") > 0 And Cells(j, d_Column_VIEWGROUP) = "" Then
''获取参数英文名称
If Cells(j, d_Column_OptNameEn) <> Cells(j - 1, d_Column_OptNameEn) Then
Print #fn, "<Property name=""" & Cells(j, d_Column_OptNameEn) & """/>"
End If
End If
If Cells(j, d_Column_class) <> Cells(j + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next j
''处理advanced
For j = d_A To ActiveSheet.UsedRange.Rows.Count
''条件：包含AD，视图不为空，上一视图名不等于本视图组名
If InStr(1, UCase(Cells(j, d_Column_VIEW)), "AD") > 0 And Cells(j, d_Column_VIEWGROUP) <> "" And d_VIEWGROUP_1 <> Mid(Cells(j, d_Column_VIEWGROUP), 1, InStr(1, Cells(j, d_Column_VIEWGROUP) & ".", ".") - 1) Then
''如何去除，重复
For o = d_A To j - 1
If Cells(o, d_Column_VIEWGROUP) = Cells(j, d_Column_VIEWGROUP) And InStr(1, UCase(Cells(j, d_Column_VIEW)), "AD") > 0 And o <> d_A Then
Exit For
Else
''获取第一层,随机取一个值
d_VIEWGROUP_1 = Mid(Cells(j, d_Column_VIEWGROUP), 1, InStr(1, Cells(j, d_Column_VIEWGROUP) & ".", ".") - 1)
Print #fn,
Print #fn, "<Group name=""" & d_VIEWGROUP_1 & """ displayName=""" & Cells(j, d_Column_VGDispName); """>"
For L = d_A To ActiveSheet.UsedRange.Rows.Count
If Cells(L, d_Column_VIEWGROUP) = d_VIEWGROUP_1 Then
Print #fn, "<Property name=""" & Cells(L, d_Column_OptNameEn) & """/>" ''当前路径下参数名称
End If
If Cells(L, d_Column_class) <> Cells(L + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next L
'' 第二层
For k = d_A To ActiveSheet.UsedRange.Rows.Count
m = Len(Cells(k, d_Column_VIEWGROUP)) - Len(Replace(Cells(k, d_Column_VIEWGROUP), ".", "")) ''获取点个数
''Print #fn, InStr(7, Cells(k, F_FindColumn("VIEWGROUP) & ".", ".") - 1
If m >= 1 Then ''必须至少一个点，否则InStr取负值，报错
'' Print #fn, Mid(Cells(k, F_FindColumn("VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, F_FindColumn("VIEWGROUP) & ".", ".") - 1)
If InStr(1, UCase(Cells(k, d_Column_VIEW)), "AD") > 0 And InStr(1, Cells(k, d_Column_VIEWGROUP), d_VIEWGROUP_1) > 0 _
And d_VIEWGROUP_2 <> Mid(Cells(k, d_Column_VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, d_Column_VIEWGROUP) & ".", ".") - 1) Then
''获取第一层,随机取一个值
d_VIEWGROUP_2 = Mid(Cells(k, d_Column_VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, d_Column_VIEWGROUP) & ".", ".") - 1)
Print #fn, "<Group name=""" & d_VIEWGROUP_2 & """ displayName=""" & Cells(k, d_Column_VGDescName); """>"
For L = d_A To ActiveSheet.UsedRange.Rows.Count
If Cells(L, d_Column_VIEWGROUP) = d_VIEWGROUP_2 Then
Print #fn, "<Property name=""" & Cells(L, d_Column_OptNameEn) & """/>" ''当前路径下参数名称
End If
If Cells(L, d_Column_class) <> Cells(L + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next L
Print #fn, "</Group>"; ''d_VIEWGROUP_2
Print #fn,
End If
If Cells(k, d_Column_class) <> Cells(k + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next k
Print #fn,
Print #fn, "</Group>"; ''d_VIEWGROUP_1
Print #fn,
Exit For
End If
Next o
If Cells(j, d_Column_class) <> Cells(j + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next j
Print #fn, "</View>"
'''-----------------------------
Print #fn, " <View name=""Basic"" > "
''处理basic
''初始化参数
d_VIEWGROUP_1 = ""
d_VIEWGROUP_2 = ""
d_VIEWGROUP_3 = ""
''处理查找跟目录下的参数
For j = d_A To ActiveSheet.UsedRange.Rows.Count
If InStr(1, UCase(Cells(j, d_Column_VIEW)), "B") > 0 And Cells(j, d_Column_VIEWGROUP) = "" Then
''获取参数英文名称
''简单处理重复
If Cells(j, d_Column_OptNameEn) <> Cells(j - 1, d_Column_OptNameEn) Then
Print #fn, "<Property name=""" & Cells(j, d_Column_OptNameEn) & """/>"
End If
End If
If Cells(j, d_Column_class) <> Cells(j + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next j
For j = d_A To ActiveSheet.UsedRange.Rows.Count
''条件：包含AD，视图不为空，上一视图名不等于本视图组名
If InStr(1, UCase(Cells(j, d_Column_VIEW)), "BA") > 0 And Cells(j, d_Column_VIEWGROUP) <> "" And d_VIEWGROUP_1 <> Mid(Cells(j, d_Column_VIEWGROUP), 1, InStr(1, Cells(j, d_Column_VIEWGROUP) & ".", ".") - 1) Then
''去除重复，用于查找历史视图中是否有重名
For o = d_A To j - 1
If Cells(o, d_Column_VIEWGROUP) = Cells(j, d_Column_VIEWGROUP) And InStr(1, UCase(Cells(j, d_Column_VIEW)), "BA") > 0 And o <> d_A Then
Exit For
Else
''获取第一层,随机取一个值
d_VIEWGROUP_1 = Mid(Cells(j, d_Column_VIEWGROUP), 1, InStr(1, Cells(j, d_Column_VIEWGROUP) & ".", ".") - 1)
Print #fn,
Print #fn, "<Group name=""" & d_VIEWGROUP_1 & """ displayName=""" & Cells(j, d_Column_VGDispName); """>"
For L = d_A To ActiveSheet.UsedRange.Rows.Count
If Cells(L, d_Column_VIEWGROUP) = d_VIEWGROUP_1 Then
Print #fn, "<Property name=""" & Cells(L, d_Column_OptNameEn) & """/>" ''当前路径下参数名称
End If
If Cells(L, d_Column_class) <> Cells(L + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next L
'' 第二层
For k = d_A To ActiveSheet.UsedRange.Rows.Count
m = Len(Cells(k, d_Column_VIEWGROUP)) - Len(Replace(Cells(k, d_Column_VIEWGROUP), ".", "")) ''获取点个数
''Print #fn, InStr(7, Cells(k, F_FindColumn("VIEWGROUP) & ".", ".") - 1
If m >= 1 Then ''必须至少一个点，否则InStr取负值，报错
'' Print #fn, Mid(Cells(k, F_FindColumn("VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, F_FindColumn("VIEWGROUP) & ".", ".") - 1)
If InStr(1, UCase(Cells(k, d_Column_VIEW)), "BA") > 0 And InStr(1, Cells(k, d_Column_VIEWGROUP), d_VIEWGROUP_1) > 0 _
And d_VIEWGROUP_2 <> Mid(Cells(k, d_Column_VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, d_Column_VIEWGROUP) & ".", ".") - 1) Then
''获取第一层,随机取一个值
d_VIEWGROUP_2 = Mid(Cells(k, d_Column_VIEWGROUP), 1, InStr(Len(d_VIEWGROUP_1) + 2, Cells(k, d_Column_VIEWGROUP) & ".", ".") - 1)
Print #fn, "<Group name=""" & d_VIEWGROUP_2 & """ displayName=""" & Cells(k, d_Column_VGDescName); """>"
For L = d_A To ActiveSheet.UsedRange.Rows.Count
If Cells(L, d_Column_VIEWGROUP) = d_VIEWGROUP_2 Then
Print #fn, "<Property name=""" & Cells(L, d_Column_OptNameEn) & """/>" ''当前路径下参数名称
End If
If Cells(L, d_Column_class) <> Cells(L + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next L
Print #fn, "</Group>"; ''d_VIEWGROUP_2
Print #fn,
End If
If Cells(k, d_Column_class) <> Cells(k + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
End If
Next k
Print #fn,
Print #fn, "</Group>"; ''d_VIEWGROUP_1
Print #fn,
Exit For
End If
Next o
End If
If Cells(j, d_Column_class) <> Cells(j + 1, d_Column_class) Then
Exit For ''当完成当前节点搜索时，跳出for
End If
Next j
Print #fn, "</View>"
Print #fn, "</Views>"
Print #fn, "</Component>"
Close #fn
End If
End If
Next i
Close #fn
End Sub
''对排序无要求
''获取列函数2
Function F_FindColumn2(Name_Column As String) As Integer
Dim m As Integer
''预设50列
For i = 1 To 50
If Cells(2, i) = Name_Column Then
m = i
Exit For
End If
Next i
F_FindColumn2 = m
End Function
Sub 节点封装()
''定义变量
Dim i_start As Integer ''定义起始位置
Dim conn As Object, sql$
''SQL查询模块
Set conn = CreateObject("adodb.connection")
conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=yes';data source=" & ThisWorkbook.FullName
''ActiveWorkbook.Worksheets.Add after:=Sheets(Sheets.Count) ''添加新sheet
'With ActiveSheet ''操作于当前sheet
Dim d_Column_NodeNameZH As Integer
d_Column_NodeNameZH = F_FindColumn2("NodeNameZH")
''变量初始化
i_start = 3
i = 3
For i = i_start To 6
' If Cells(i - 1, d_Column_NodeNameZH) <> Cells(i, d_Column_NodeNameZH) Then
'' ActiveWorkbook.Worksheets ("节点封装")
sql = "select " & Cells(i, 4) & " ," & Cells(i, 4) & " ,* from [sheet1$] where 节点中文名称 = " & i ''""主成分分析"""
ActiveWorkbook.Worksheets("节点封装").Cells(ActiveWorkbook.Worksheets("节点封装").UsedRange.Rows.Count, 1).CopyFromRecordset conn.Execute(sql) '查詢結果插入
'End If
'If Cells(i + 1, d_Column_NodeNameZH) <> Cells(i, d_Column_NodeNameZH) Then
'End If
Next i
conn.Close
Set conn = Nothing
' End With
End Sub
Public Function getNodeLink(NodeNameEn) As String
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sql As String
Dim cnnstr As String
Dim mywbname As String
mywbname = ThisWorkbook.FullName
Application.DisplayAlerts = False
'2007,2012:12.0;2003:8.0
cnnstr = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=excel 12.0;" _
& "data source=" & mywbname
cnnstr = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=excel 8.0;" _
& "data source=" & mywbname
cnn.Open cnnstr
''Step 1:得到连接数
sql = "select linksNbr from [1.cfg_weka_node_link_nbr$] where nodeNameEn='" & NodeNameEn & "'"
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
'Set rs = cnn.Execute(sql,)
If rs.RecordCount = 1 Then
getNodeLink = " maxParent=""" & rs("linksNbr") & """"
Else
MsgBox NodeNameEn & "linksNbr 配置有误,请检查!"
getNodeLink ""
Exit Function
End If
rs.Close
''Step 2:得到父节点''
sql = "select parent_nodeNameEN from [2.cfg_weka_node_link_relation$] where nodeNameEn=""" & NodeNameEn & """ and parent_nodeNameEN<>''"
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
'Set rs = cnn.Execute(sql)
If rs.RecordCount > 0 Then
getNodeLink = getNodeLink & " permitConnect="""
rs.movefirst
For n = 1 To rs.RecordCount - 1
getNodeLink = getNodeLink & rs("parent_nodeNameEN") & ","
n = n + 1
rs.MoveNext
Next n
getNodeLink = getNodeLink & rs("parent_nodeNameEN") & """"
Else
Exit Function
End If
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
End Function
