箭头

/db_自贡黄明儒_

1. Public MsoLineRun1 As Boolean
   
2. 
   
3. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
4.     If MsoLineRun1 Then
   
5.         Call KillMsoLine
   
6.     Else
   
7.         Call MsoLineRun(Sh, Target)
   
8.     End If
   
9. End Sub
   
10. 
    
11. '''增加一个虚箭头
    
12. Function AddMsoLine(ByVal s As String, ByVal Sh As Object) As Object
    
13.     Set AddMsoLine = Sh.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 50)
    
14.     With AddMsoLine.Line
    
15.         .EndArrowheadStyle = msoArrowheadOpen
    
16.         .Visible = msoTrue
    
17.         .DashStyle = msoLineDashDot
    
18.         .ForeColor.RGB = RGB(255, 0, 0)
    
19.         .Weight = 0
    
20.         .Parent.AlternativeText = s
    
21.         .Parent.Name = s
    
22.     End With
    
23. End Function
    
24. 
    
25. ''判断虚箭头是否存在，不存在则添加
    
26. Function MsoLineExist(ByVal s As String, ByVal Sh As Object) As Object
    
27.     For Each x In Sh.Shapes
    
28.         If x.Name = s And x.AlternativeText = s Then Set MsoLineExist = x: Exit For
    
29.     Next
    
30. End Function
    
31. 
    
32. '''小平箭头Hor1,竖直箭头Ver1
    
33. Sub MsoLineRun(ByVal Sh As Object, ByVal Target As Range)
    
34.     Dim obj As Object
    
35.     Dim Left1&, Top1&, Column1&, Row1&
    
36.     Application.ScreenUpdating = False
    
37.     Application.EnableEvents = False
    
38. 
    
39.     If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
    
40.     Application.ScreenUpdating = False
    
41.     Application.ScreenUpdating = True
    
42.         With ActiveCell
    
43.             Left1 = .Left
    
44.             Top1 = .Top
    
45.             Column1 = .Column
    
46.             Row1 = .Row
    
47.         End With
    
48.         Set obj = MsoLineExist("Hor1", Sh)
    
49.         If obj Is Nothing Then Set obj = AddMsoLine("Hor1", Sh)
    
50.         With obj
    
51.             .Left = Left1 + ActiveCell.Width * 0.5
    
52.             .Top = Sh.Cells(1, Column1).Top
    
53.             .Width = 0
    
54.             .Height = Top1
    
55.         End With
    
56.         Set obj = MsoLineExist("Ver1", Sh)
    
57.         If obj Is Nothing Then Set obj = AddMsoLine("Ver1", Sh)
    
58.         With obj
    
59.             .Left = Sh.Cells(Row1, 1).Left
    
60.             .Top = Top1 + ActiveCell.Height * 0.5
    
61.             .Width = Left1
    
62.             .Height = 0
    
63.         End With
    
64.     End If
    
65. 
    
66.     Application.EnableEvents = True
    
67.     Application.ScreenUpdating = True
    
68. End Sub
    
69. 
    
70. '''箭头驻留
    
71. Sub RemainMsoLine()
    
72.     Dim name1$, count1&
    
73.     Dim x As Object
    
74.     Application.ScreenUpdating = False
    
75.     Application.EnableEvents = False
    
76.     count1 = ActiveSheet.Shapes.Count
    
77.     For Each x In ActiveSheet.Shapes
    
78.         name1 = x.Name
    
79.         If name1 = "Hor1" Or name1 = "Ver1" Then
    
80.             x.Name = Left(name1, Len(name1) - 1) & (count1 + 1)
    
81.         End If
    
82.     Next
    
83.     Application.EnableEvents = True
    
84.     Application.ScreenUpdating = True
    
85. End Sub
    
86. 
    
87. '''箭头删除
    
88. Sub KillMsoLine()
    
89.     Application.ScreenUpdating = False
    
90.     Application.EnableEvents = False
    
91.     For Each x In ActiveSheet.Shapes
    
92.         If x.Type = msoAutoShape Then
    
93.             If InStr(x.Name, "Hor") > 0 Or InStr(x.Name, "Ver") > 0 Then x.Delete
    
94.         End If
    
95.     Next
    
96.     Application.EnableEvents = True
    
97.     Application.ScreenUpdating = True
    
98. End Sub
    
99. 
    
100. '''箭头开关,这个值应该保存在注册表中，auto_open时读取
     
101. Sub SwitchMsoLine()
     
102.     MsoLineRun1 = Not MsoLineRun1
     
103. End Sub
     

Public MsoLineRun1 As Boolean<br /> <br /> Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)<br />     If MsoLineRun1 Then<br />         Call KillMsoLine<br />     Else<br />         Call MsoLineRun(Sh, Target)<br />     End If<br /> End Sub<br /> <br /> '''增加一个虚箭头<br /> Function AddMsoLine(ByVal s As String, ByVal Sh As Object) As Object<br />     Set AddMsoLine = Sh.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 50)<br />     With AddMsoLine.Line<br />         .EndArrowheadStyle = msoArrowheadOpen<br />         .Visible = msoTrue<br />         .DashStyle = msoLineDashDot<br />         .ForeColor.RGB = RGB(255, 0, 0)<br />         .Weight = 0<br />         .Parent.AlternativeText = s<br />         .Parent.Name = s<br />     End With<br /> End Function<br /> <br /> ''判断虚箭头是否存在，不存在则添加<br /> Function MsoLineExist(ByVal s As String, ByVal Sh As Object) As Object<br />     For Each x In Sh.Shapes<br />         If x.Name = s And x.AlternativeText = s Then Set MsoLineExist = x: Exit For<br />     Next<br /> End Function<br /> <br /> '''小平箭头Hor1,竖直箭头Ver1<br /> Sub MsoLineRun(ByVal Sh As Object, ByVal Target As Range)<br />     Dim obj As Object<br />     Dim Left1&, Top1&, Column1&, Row1&<br />     Application.ScreenUpdating = False<br />     Application.EnableEvents = False<br /> <br />     If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then<br />     Application.ScreenUpdating = False<br />     Application.ScreenUpdating = True<br />         With ActiveCell<br />             Left1 = .Left<br />             Top1 = .Top<br />             Column1 = .Column<br />             Row1 = .Row<br />         End With<br />         Set obj = MsoLineExist("Hor1", Sh)<br />         If obj Is Nothing Then Set obj = AddMsoLine("Hor1", Sh)<br />         With obj<br />             .Left = Left1 + ActiveCell.Width * 0.5<br />             .Top = Sh.Cells(1, Column1).Top<br />             .Width = 0<br />             .Height = Top1<br />         End With<br />         Set obj = MsoLineExist("Ver1", Sh)<br />         If obj Is Nothing Then Set obj = AddMsoLine("Ver1", Sh)<br />         With obj<br />             .Left = Sh.Cells(Row1, 1).Left<br />             .Top = Top1 + ActiveCell.Height * 0.5<br />             .Width = Left1<br />             .Height = 0<br />         End With<br />     End If<br /> <br />     Application.EnableEvents = True<br />     Application.ScreenUpdating = True<br /> End Sub<br /> <br /> '''箭头驻留<br /> Sub RemainMsoLine()<br />     Dim name1$, count1&<br />     Dim x As Object<br />     Application.ScreenUpdating = False<br />     Application.EnableEvents = False<br />     count1 = ActiveSheet.Shapes.Count<br />     For Each x In ActiveSheet.Shapes<br />         name1 = x.Name<br />         If name1 = "Hor1" Or name1 = "Ver1" Then<br />             x.Name = Left(name1, Len(name1) - 1) & (count1 + 1)<br />         End If<br />     Next<br />     Application.EnableEvents = True<br />     Application.ScreenUpdating = True<br /> End Sub<br /> <br /> '''箭头删除<br /> Sub KillMsoLine()<br />     Application.ScreenUpdating = False<br />     Application.EnableEvents = False<br />     For Each x In ActiveSheet.Shapes<br />         If x.Type = msoAutoShape Then<br />             If InStr(x.Name, "Hor") > 0 Or InStr(x.Name, "Ver") > 0 Then x.Delete<br />         End If<br />     Next<br />     Application.EnableEvents = True<br />     Application.ScreenUpdating = True<br /> End Sub<br /> <br /> '''箭头开关,这个值应该保存在注册表中，auto_open时读取<br /> Sub SwitchMsoLine()<br />     MsoLineRun1 = Not MsoLineRun1<br /> End Sub<br />

qqqincccken

谢谢提供好好试试看了

Yruz

这个就有点厉害了

开心68602

感谢黄老师分享