|
以下代码供网友学习参考： '* +++++++++++++++++++++++++++++++++++++++ '* Created By 守柔@ExcelHome 2004-12-08 6:15:03 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [标准模块-模块1]^' '* -------------------------------------------------------------------------- Public BeforeShapes As Integer
Sub 画坐标系()
UserForm1.Show
End Sub
'----------------------
Sub SelAllShapes()
Dim AllShapes(), ShapeCount As Integer, N As Shape, Y As Integer
ShapeCount = ActiveDocument.Shapes.Count
Y = 0
'定义一维上标可变数组,从0开始
ReDim AllShapes(ShapeCount - BeforeShapes - 1)
With ActiveDocument
For Each N In .Shapes
If N.Name Like "已有图形*" = False Then
AllShapes(Y) = N.Name
Y = Y + 1
End If
Next N
With .Shapes.Range(AllShapes).Group
.ZOrder msoSendToBack
.Select
' .Name = "坐标系"
End With
End With
End Sub
'----------------------
'* +++++++++++++++++++++++++++++++++++++++ '* Created By 守柔@ExcelHome 2004-12-08 6:15:22 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [用户窗体-UserForm1]^' '* -------------------------------------------------------------------------- Private Sub CommandButton1_Click()
Dim XLeft As Single, XTop As Single, YLeft As Single, YTop As Single, XLong As Single
Dim YTtop As Single, YHight As Single, XLine As Shape, YLine As Shape, i As Single
Dim M As Byte, MyTextbox As Shape, MyValue As Single, ModValue As Byte
On Error Resume Next '忽略错误
'必要数据判断
If Me.TextBox1 = "" Or Int(Me.TextBox1) <> Me.TextBox1 * 1 Then MsgBox "无效数据!", _
vbInformation: Exit Sub
If Me.TextBox2 = "" Or Int(Me.TextBox2) <> Me.TextBox2 * 1 Then MsgBox "无效数据!", _
vbInformation: Exit Sub
If Me.TextBox3 = "" Or Int(Me.TextBox3) <> Me.TextBox3 * 1 Then MsgBox "无效数据!", _
vbInformation: Exit Sub
If Me.TextBox3 * 1 > Me.TextBox1 * 1 Or Me.TextBox3 * 1 > Me.TextBox2 * 1 Then _
MsgBox "无效数据!", vbInformation: Exit Sub
' TextBox1为原点横坐标 , TextBox2为原点纵坐标
Application.ScreenUpdating = False
XLeft = CentimetersToPoints(Me.TextBox1 - Me.TextBox3 / 2)
XLong = CentimetersToPoints(Me.TextBox3 + 0.5)
XTop = CentimetersToPoints(Me.TextBox2)
YLeft = CentimetersToPoints(Me.TextBox1) '左边距
'顶部距离为原点纵坐标+高度/2,从下至上.则上部顶点为原点纵坐标-TextBox3/2-0.5
YTop = CentimetersToPoints(Me.TextBox2 + Me.TextBox3 / 2)
YTtop = CentimetersToPoints(Me.TextBox2 - Me.TextBox3 / 2 - 0.5)
YHight = CentimetersToPoints(Me.TextBox3)
With ActiveDocument
BeforeShapes = .Shapes.Count '获取工作之前的图形总数
If BeforeShapes >= 1 Then
For i = 1 To BeforeShapes
.Shapes(i).Name = "已有图形" & BeforeShapes & i '避免重复命名值出错
Next
End If
' If BeforeShapes >= 1 Then MsgBox "非完全版，请删除其它图形或者在另一文档中重新建立坐标系！" _
: Exit Sub
Set XLine = .Shapes.AddLine(XLeft, XTop, XLeft + XLong, XTop)
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, XLeft + XLong - 5, XTop + 5, 20, 15)
With MyTextbox '设置X轴文本框
.Line.Visible = msoFalse
.TextFrame.MarginBottom = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 10
.TextFrame.TextRange = "X"
End With
With XLine '设置箭头形状
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
End With
Set YLine = .Shapes.AddLine(YLeft, YTop, YLeft, YTtop)
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, YLeft - 20, YTtop, 15, 15)
With MyTextbox '设置Y轴文本框
.Line.Visible = msoFalse
.TextFrame.MarginBottom = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 10
.TextFrame.TextRange = "Y"
End With
With YLine '设置箭头形状
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
End With
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(Me.TextBox1) - 10, CentimetersToPoints(Me.TextBox2) - 1, 15, 15)
With MyTextbox '设置原点O文本框
.Line.Visible = msoFalse
.TextFrame.MarginBottom = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange = "O"
.ZOrder msoSendToBack
End With
If Me.OptionButton1.Value = True Then Call SelAllShapes: Exit Sub '未选刻度值退出
If Me.OptionButton2.Value = True Then MyValue = 0.5: ModValue = 2
If Me.OptionButton3.Value = True Then MyValue = 0.125: ModValue = 5
For i = 0 To Me.TextBox3 * 1 Step MyValue
M = VBA.IIf(VBA.IIf(MyValue = 0.5, i * 10 Mod 10 = 0, i * 10 Mod 5 = 0), 10, 5)
.Shapes.AddLine CentimetersToPoints(i + Me.TextBox1 - Me.TextBox3 / 2), XTop - M, _
CentimetersToPoints(i + Me.TextBox1 - Me.TextBox3 / 2), XTop
.Shapes.AddLine YLeft, CentimetersToPoints(Me.TextBox2 + Me.TextBox3 / 2 - i), _
YLeft + M, CentimetersToPoints(Me.TextBox2 + Me.TextBox3 / 2 - i)
If M = 10 And i - Me.TextBox3 / 2 <> 0 Then '逢0.5和1标识数值,忽略0值(与零点合)
'对X轴刻度
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(i + Me.TextBox1 - Me.TextBox3 / 2) - 3, XTop + 3, 10, 10)
With MyTextbox '设置刻度文本框及值
.Line.Visible = msoFalse
.TextFrame.MarginBottom = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 5
.TextFrame.TextRange = i - Me.TextBox3 / 2
.ZOrder msoSendToBack
End With
'对Y轴刻度
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, YLeft + 12, _
CentimetersToPoints(Me.TextBox2 + Me.TextBox3 / 2 - i) - 8, 10, 10)
With MyTextbox '设置刻度文本框及值
.Line.Visible = msoFalse
.TextFrame.MarginBottom = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 5
.TextFrame.TextRange = i - Me.TextBox3 / 2
.ZOrder msoSendToBack
End With
End If
Next
Call SelAllShapes '全选图形宏(SelAllShapes)
End With
Application.ScreenUpdating = True
End Sub
'----------------------
Private Sub CommandButton2_Click()
Me.TextBox1 = ""
Me.TextBox2 = ""
Me.TextBox3 = ""
End Sub
'----------------------
Private Sub CommandButton3_Click()
End
End Sub
'----------------------
Private Sub UserForm_Activate()
Me.TextBox3.SetFocus
Me.CommandButton1.Default = True
End Sub
'----------------------
以上代码主要修正了五楼中关于已有自选图形时后画图形的组合问题。 | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-12-5 13:52
楼主
