论坛 › VBA、COM-ActiveX › 箭头

/db_自贡黄明儒_ 发表于 2019-7-10 17:10:35

箭头

本帖最后由 /db_自贡黄明儒_ 于 2019-7-10 17:15 编辑


Public MsoLineRun1 As Boolean

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If MsoLineRun1 Then
      Call KillMsoLine
    Else
      Call MsoLineRun(Sh, Target)
    End If
End Sub

'''增加一个虚箭头
Function AddMsoLine(ByVal s As String, ByVal Sh As Object) As Object
    Set AddMsoLine = Sh.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 50)
    With AddMsoLine.Line
      .EndArrowheadStyle = msoArrowheadOpen
      .Visible = msoTrue
      .DashStyle = msoLineDashDot
      .ForeColor.RGB = RGB(255, 0, 0)
      .Weight = 0
      .Parent.AlternativeText = s
      .Parent.Name = s
    End With
End Function

''判断虚箭头是否存在，不存在则添加
Function MsoLineExist(ByVal s As String, ByVal Sh As Object) As Object
    For Each x In Sh.Shapes
      If x.Name = s And x.AlternativeText = s Then Set MsoLineExist = x: Exit For
    Next
End Function

'''小平箭头Hor1,竖直箭头Ver1
Sub MsoLineRun(ByVal Sh As Object, ByVal Target As Range)
    Dim obj As Object
    Dim Left1&, Top1&, Column1&, Row1&
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
    Application.ScreenUpdating = False
    Application.ScreenUpdating = True
      With ActiveCell
            Left1 = .Left
            Top1 = .Top
            Column1 = .Column
            Row1 = .Row
      End With
      Set obj = MsoLineExist("Hor1", Sh)
      If obj Is Nothing Then Set obj = AddMsoLine("Hor1", Sh)
      With obj
            .Left = Left1 + ActiveCell.Width * 0.5
            .Top = Sh.Cells(1, Column1).Top
            .Width = 0
            .Height = Top1
      End With
      Set obj = MsoLineExist("Ver1", Sh)
      If obj Is Nothing Then Set obj = AddMsoLine("Ver1", Sh)
      With obj
            .Left = Sh.Cells(Row1, 1).Left
            .Top = Top1 + ActiveCell.Height * 0.5
            .Width = Left1
            .Height = 0
      End With
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'''箭头驻留
Sub RemainMsoLine()
    Dim name1$, count1&
    Dim x As Object
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    count1 = ActiveSheet.Shapes.Count
    For Each x In ActiveSheet.Shapes
      name1 = x.Name
      If name1 = "Hor1" Or name1 = "Ver1" Then
            x.Name = Left(name1, Len(name1) - 1) & (count1 + 1)
      End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'''箭头删除
Sub KillMsoLine()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For Each x In ActiveSheet.Shapes
      If x.Type = msoAutoShape Then
            If InStr(x.Name, "Hor") > 0 Or InStr(x.Name, "Ver") > 0 Then x.Delete
      End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'''箭头开关,这个值应该保存在注册表中，auto_open时读取
Sub SwitchMsoLine()
    MsoLineRun1 = Not MsoLineRun1
End Sub

qqqincccken 发表于 2019-7-10 19:03:28

谢谢提供好好试试看了

Yruz 发表于 2019-7-11 09:11:55

这个就有点厉害了

开心68602 发表于 2024-8-9 13:02:11

感谢黄老师分享

查看完整版本: 箭头