|
|
楼主 |
发表于 2009-7-10 00:50
|
显示全部楼层
呵呵，受到奖励，更有动力了!经过进一步完善，增加了点右键自动封闭功能!
'原创:老朽
'网址:http://Club.ExcelHome.net
'日期:2009-7-10 上午 12:45:19
Public X2, Y2, X0, Y0
'先手工在工作表中通过控件工具箱插入一个Lable控件
Private Sub CommandButton1_Click()
Select Case CommandButton1.Caption '一个按钮，根据其显示的文字(Caption)来决定动作
'(本例为一个按钮，三种功效!)
Case "开始画线"
If MsgBox("是否清除当前工作表中的所有线条？", vbYesNo + vbQuestion, "询问：") = vbYes Then
For Each sh In ActiveSheet.DrawingObjects
If sh.Name Like "Line*" Then sh.Delete
Next
'使用循环的目的是为了保留Label和按钮
'否则可以一条语句清除：ActiveSheet.DrawingObjects.Delete
End If
X2 = 0: Y2 = 0
With Label1
.Enabled = True '设为可用
.Visible = True '设为可视
.Top = 0 '置顶
.Left = 0 '放置在最左边
.BackStyle = fmBackStyleTransparent '设为透明
If .Width <> 2400 Then .Width = 2400 '设定宽度= 2400
If .Height <> 2400 Then .Height = 2400 '设定高度= 2400
'设定足够的宽度和高度，使之覆盖整个工作表可视范围
'便于我们画线
End With
CommandButton1.Caption = "结束画线" '改变按钮的显示文字(Caption),为下一个动作作准备
Case "结束画线"
With Label1
.Enabled = False '禁用Label
.Visible = False '不可见
End With
Application.StatusBar = "" 'Label已经不可用，所以得及时将状态栏清空，
'否则还是一直显示Label禁用之前的坐标，造成误会
CommandButton1.Caption = "显示坐标"
Case "显示坐标"
With Label1
.Enabled = True
.Visible = True
.Top = 0
.Left = 0
.BackStyle = fmBackStyleTransparent
If .Width <> 2400 Then .Width = 2400
If .Height <> 2400 Then .Height = 2400
End With
CommandButton1.Caption = "开始画线"
End Select
End Sub
Private Sub Label1_MouseDown(ByVal Button As Integer , ByVal Shift As Integer , ByVal X As Single , ByVal Y As Single )
Application.ScreenUpdating = False
If Button = 1 Then
If CommandButton1.Caption = "结束画线" Then
Label1.Visible = False '暂时不显示Label，以便能实时看到我们所绘的图形
'记录封闭点坐标
X0 = IIf(X2 = 0, X, X0) '原始起点X座标，刚刚启动绘图时，X2为0，
Y0 = IIf(Y2 = 0, Y, Y0) '原始起点Y座标
X2 = IIf(X2 = 0, X, X2) '起点X座标，刚刚启动绘图时，X2为0，
Y2 = IIf(Y2 = 0, Y, Y2) '起点Y座标
ActiveSheet.Shapes.AddLine(X2, Y2, X, Y).Select '绘制一条直线,使用Select方法是便于用户实时看到节点位置，
'当然，我们完全可以通过 Set cc=ActiveSheet.Shapes.AddLine(X2, Y2, X, Y),这样用户将不能实时看到所绘线条的节点
X2 = X: Y2 = Y '将本次XY坐标作为下次的起点坐标
Label1.Visible = True
Else '有人可能会以为下面两行代码是画蛇添足
Label1.Visible = False '非也，通过以下步骤，可以快速返回控制权，否则较长时间内显示为空白
Label1.Visible = True '感兴趣的朋友可以不加这两行代码试验一下
End If
Else '如果按下的不是鼠标左键
ActiveSheet.Shapes.AddLine(X2, Y2, X0, Y0).TopLeftCell.Activate '强行封闭，焦点转移到工作表，避免线条处于选中状态
CommandButton1_Click '结束画线
End If
Application.ScreenUpdating = True
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer , ByVal Shift As Integer , ByVal X As Single , ByVal Y As Single )
'利用Label的MouseMove事件，得到X,Y坐标，将其显示在状态栏中
Application.StatusBar = "当前坐标 X:" & X & " Y:" & Y
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-7-9 22:26
