Re:自己做的专利关联关系分析工具,有人感兴趣吗?
\'有问题联系 dongliangf@gmail.com
\'飞信号:644747509
\'版权所有,如果转载请注明
\'可自由使用,拷贝
Sub ReadAndDraw()
Set emp = ActivePage.DrawLine(5, 5, 6, 6) \'先画一个无用的东西,否则下面的selectall不一定能用
\'先情况所有的形状
Application.ActiveWindow.SelectAll
Application.ActiveWindow.Selection.Delete
Dim XlsFileName$, XlsDirName$
\'Dim XlsApp As Application
\'Dim XlsBook As Workbook
Dim ArrStr
\'读取excel中的信息
Set XlsApp = CreateObject(\"Excel.Application\")
\'DictVsoIPCLine的数据结构,key里面放两个IPC,value放对应这两个IPC连接的连接线
Dim DictVsoIPCShape, DictVsoIPCLine \'存放visio中已经有的IPC和圆之间的对应关系.
Set DictVsoIPCShape = CreateObject(\"Scripting.Dictionary\")
Set DictVsoIPCLine = CreateObject(\"Scripting.Dictionary\")
DictVsoIPCShape.RemoveAll
DictVsoIPCLine.RemoveAll
seprator = \" / \" \'IPC分隔符
Dim initR, circleStep, downStep \'圆初始半径,圆递增的步长 ,圆下沉的步长
Dim vsoLstX, vsoLstY, vsoLstOff \'上次画的圆的坐标,左下角位置,非圆心.vsoLstOff是间距
Dim circled As Visio.Shape
Dim vsoCharacters1 As Visio.Characters
Dim lineStep
\'初始化圆数据 坐标等
vsoLstX = 0
vsoLstY = 0
initR = 0.8
circleStep = 0.3
lineStep = 0.08
vsoLstOff = 3
downStep = 3
\'如果线条宽度超过这个值,则改变颜色
Dim chgColorCnt
chgColorCnt = 4
Dim InitLineWeight \'记录初始线宽
InitLineWeight = 0
Dim InitCircleWidth \'记录初始圆直径
InitCircleWidth = 0
XlsDirName = ThisDocument.Path & \"source\\\" \'遍历当前excel所在目录的source子目录
XlsFileName = Dir(XlsDirName & \"*.xls\")
Do Until XlsFileName = \"\"
Set XlsBook = XlsApp.Workbooks.Open(XlsDirName & XlsFileName)
For Each i In XlsBook.Sheets(1).Range(\"i2:i200\").Cells \'遍历excel I列元素
If Len(i.Value) < 1 Then \'不必要的循环不做
Exit For
End If
\'分解i字段.分隔符为空格包围的/
ArrStr = Split(i.Value, seprator)
For IPcIndex = 0 To UBound(ArrStr) \'遍历分解得到IPC组,看visio图中是否已经有这个IPC对应的圆,及连接线
If DictVsoIPCShape.exists(ArrStr(IPcIndex)) Then
\'存在这个圆.将该圆半径加一个step.如果超过最大值,就不要再往上加了
If (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep < 100 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") + circleStep
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Height\") + circleStep
\'同时往下平移,增加区分
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY) = DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY) - downStep
End If
\'修改为不透明
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegndTrans).FormulaU = \"10%\"
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillBkgndTrans).FormulaU = \"10%\"
\'统一修改颜色
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(230,210,250)\"
\'再次区分一下颜色
If (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep > 80 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(5,5,250)\"
ElseIf (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep > 60 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(50,50,250)\"
ElseIf (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep > 40 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(100,100,255)\"
ElseIf (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep > 20 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(150,150,255)\"
\'改变文字的大小
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = \"200 pt\"
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionCharacter, 0, visCharacterColorTrans).FormulaU = \"0%\" \'改成不透明
ElseIf (DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Width\") - InitCircleWidth) / circleStep > 10 Then
DictVsoIPCShape.Item(ArrStr(IPcIndex)).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = \"RGB(200,200,255)\"
End If
Else
\'不存在圆.画一个圆.位置采用N列矩阵方式确定 横向纵向上用随机数做偏移
tempRnd = Int((vsoLstOff * Rnd) + 1)
Set circled = ActivePage.DrawOval(vsoLstX + tempRnd, vsoLstY + tempRnd, vsoLstX + tempRnd + initR * 2, vsoLstY + tempRnd + initR * 2)
\'放到顶层
circled.BringToFront
\'一开始圆是半透明的
circled.CellsSRC(visSectionObject, visRowFill, visFillForegndTrans).FormulaU = \"80%\"
circled.CellsSRC(visSectionObject, visRowFill, visFillBkgndTrans).FormulaU = \"80%\"
\'没有外围线
circled.CellsSRC(visSectionObject, visRowLine, visLinePattern).FormulaU = \"0\"
\'如果没有文字,则为圆添加文字描述
Set vsoCharacters1 = circled.Characters
If Len(vsoCharacters1.Text) < 1 Then
vsoCharacters1.Begin = 0
vsoCharacters1.End = 0
vsoCharacters1.Text = ArrStr(IPcIndex)
End If
\'文字也是半透明的
circled.CellsSRC(visSectionCharacter, 0, visCharacterColorTrans).FormulaU = \"80%\"
If InitCircleWidth = 0 Then
InitCircleWidth = circled.Cells(\"Width\")
End If
\'vsoLstX, vsoLstY 记录画的圆的坐标
vsoLstX = vsoLstX + vsoLstOff
If vsoLstX / vsoLstOff > 20 Then
vsoLstX = 0
vsoLstY = vsoLstY + vsoLstOff
End If
\'把 IPC和对应的圆 添加到字典里
DictVsoIPCShape.Add ArrStr(IPcIndex), circled
End If
Next IPcIndex
For IPcIndex = 0 To UBound(ArrStr) \'
For IPcIndex2 = IPcIndex + 1 To UBound(ArrStr) \'从当前IPC的下一个遍历分解得到IPC组,判断visio图中之间的连接
If DictVsoIPCLine.exists((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))) Then
\'存在此连接,将线条加粗
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).Cells(\"LineWeight\") + lineStep
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"50%\" \'透明度调整
\'如果数目超过一定的值,则改变颜色
If (DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt * 3 Then
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"8\"
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
ElseIf (DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt * 2 Then
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"2\"
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
ElseIf (DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt Then
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"6\"
DictVsoIPCLine.Item((ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
End If
ElseIf DictVsoIPCLine.exists((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))) Then
\'存在此连接,将线条加粗
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).Cells(\"LineWeight\") + lineStep
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"50%\" \'透明度调整
\'如果数目超过一定的值,则改变颜色
If (DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt * 3 Then
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"8\"
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
ElseIf (DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt * 2 Then
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"2\"
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
ElseIf (DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).Cells(\"LineWeight\") - InitLineWeight) / lineStep > chgColorCnt Then
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = \"6\"
DictVsoIPCLine.Item((ArrStr(IPcIndex2) & \"+\" & ArrStr(IPcIndex))).CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"0%\" \'修改成不透明的
End If
Else
\'不存在此连接,画出此线
Set line1 = ActivePage.DrawLine(5, 5, 6, 6) \'先随便画一条线,再移动首末两点到两个圆的圆心
line1.CellsSRC(visSectionObject, visRowLine, visLineColorTrans).FormulaU = \"80%\" \'开始是半透明的
line1.SendToBack \'置于底层
If InitLineWeight = 0 Then
InitLineWeight = line1.Cells(\"LineWeight\")
End If
Set glueFrom = line1.CellsU(\"BeginX\")
Set GlueTo = DictVsoIPCShape.Item(ArrStr(IPcIndex)).Cells(\"Geometry1.X1\")
glueFrom.GlueTo GlueTo
Set glueFrom = line1.CellsU(\"EndX\")
Set GlueTo = DictVsoIPCShape.Item(ArrStr(IPcIndex2)).Cells(\"Geometry1.X1\")
glueFrom.GlueTo GlueTo
\'添加 这一对IPC 和 连接线 到字典里
DictVsoIPCLine.Add ArrStr(IPcIndex) & \"+\" & ArrStr(IPcIndex2), line1
End If
Next IPcIndex2
Next IPcIndex
Next \'对应遍历excel I列元素
XlsBook.Close
XlsFileName = Dir \'依次读取 xls 文件，文件名赋值给fn
Loop
DictVsoIPCShape.RemoveAll
DictVsoIPCLine.RemoveAll
XlsApp.Quit
\'对出现次数少的圆做清除,否则太多了
End Sub |
|
