Excel绘制交叉口流量流向图VBA程序.docx
- 文档编号:2397203
- 上传时间:2022-10-29
- 格式:DOCX
- 页数:10
- 大小:94.24KB
Excel绘制交叉口流量流向图VBA程序.docx
《Excel绘制交叉口流量流向图VBA程序.docx》由会员分享,可在线阅读,更多相关《Excel绘制交叉口流量流向图VBA程序.docx(10页珍藏版)》请在冰豆网上搜索。
Excel绘制交叉口流量流向图VBA程序
Excel绘制交叉口流量流向图VBA程序
打开Excel,在Excel左上角编辑交叉口转向流量表,和定义斜交角度(东北角),新建宏文件DrawFlowMap,将文后代码复制进宏文件,执行宏文件,即可绘制交叉口流量流向图。
附代码:
来自世界代码联盟,作者:
一起玩狗的
Subtext(top_x,top_y,t)
'
'定义文本框
'
'
ActiveSheet.Shapes.AddShape(msoShapeRectangle,top_x,top_y,120,120).Select
Selection.Characters.text=t
WithSelection.Characters(Start:
=1,length:
=30).Font
.Name="TimesNewRoman"
.FontStyle="常规"
.Size=20
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.ColorIndex=xlAutomatic
EndWith
Selection.ShapeRange.Fill.Visible=msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor=9
Selection.ShapeRange.Fill.Transparency=0
Selection.ShapeRange.Line.Weight=0.75
Selection.ShapeRange.Line.DashStyle=msoLineSolid
Selection.ShapeRange.Line.Style=msoLineSingle
Selection.ShapeRange.Line.Transparency=0
Selection.ShapeRange.Line.Visible=msoFalse
EndSub
SubDrawFlowMap()
'
'画路口流量流向图
'
'
DimF_to_TAsBoolean
DimttAsString
DimfactorAsDouble
factor=0.02
'定义斜交角
Dimtha,tha1AsSingle
tha1=Cells(2,7)
tha=Application.WorksheetFunction.Radians(tha1)
'判断、清除图形
ActiveSheet.DrawingObjects.Select
Selection.Delete
'清除图形结束
'
'东进口
tt="东进口流量"&Chr(10)&"左转:
"&Cells(2,2)&Chr(10)&"直行:
"&Cells(3,2)&Chr(10)&"右转:
"&Cells(4,2)
Calltext(1550,750,tt)
'东进口直行
ActiveSheet.Shapes.AddLine(800,800,1500,800).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor=10
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Line.Weight=Cells(3,2)*factor
'绘制出口箭头
ActiveSheet.Shapes.AddLine(725,800,801,800).Select
Selection.ShapeRange.Line.ForeColor.RGB=RGB(255,0,0)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Line.Weight=Cells(3,2)*factor
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle,675,775,40,50).Select
Selection.ShapeRange.Line.Visible=msoFalse
WithSelection.ShapeRange.Fill
.Visible=msoTrue
.ForeColor.RGB=RGB(0,0,255)
.Transparency=0
.Solid
EndWith
Selection.ShapeRange.IncrementRotation270
Selection.ShapeRange.IncrementLeft5
'东进口右转
ActiveSheet.Shapes.AddShape(msoShapeArc,1400,800,200-200/Tan(tha),200).Select
Selection.ShapeRange.FlipmsoFlipHorizontal
Selection.ShapeRange.FlipmsoFlipVertical
Selection.ShapeRange.Line.Weight=Cells(4,2)*factor
Selection.ShapeRange.Line.ForeColor.RGB=RGB(255,0,0)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Fill.Visible=msoFalse
Selection.ShapeRange.IncrementTop-400
'东进口左转
ActiveSheet.Shapes.AddShape(msoShapeArc,1400,800,400+200/Tan(tha),400).Select
Selection.ShapeRange.FlipmsoFlipHorizontal
Selection.ShapeRange.Line.Weight=Cells(2,2)*factor
Selection.ShapeRange.Line.ForeColor.RGB=RGB(255,0,0)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Fill.Visible=msoFalse
'Selection.ShapeRange.IncrementLeft400
'Selection.ShapeRange.IncrementTop-2
'图形置顶
Selection.ShapeRange.ZOrdermsoBringToFront
'西进口
tt="西进口流量"&Chr(10)&"左转:
"&Cells(2,3)&Chr(10)&"直行:
"&Cells(3,3)&Chr(10)&"右转:
"&Cells(4,3)
Calltext(550,935,tt)
'西进口直行
ActiveSheet.Shapes.AddLine(700,1000,1400,1000).Select
Selection.ShapeRange.Line.Weight=Cells(3,3)*factor
Selection.ShapeRange.Line.ForeColor.RGB=RGB(0,0,255)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
'绘制出口箭头
ActiveSheet.Shapes.AddLine(1400,1000,1475,1000).Select
Selection.ShapeRange.Line.ForeColor.RGB=RGB(255,0,0)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Line.Weight=Cells(3,2)*factor
ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle,1480,975,40,50).Select
Selection.ShapeRange.Line.Visible=msoFalse
WithSelection.ShapeRange.Fill
.Visible=msoTrue
.ForeColor.RGB=RGB(255,0,0)
.Transparency=0
.Solid
EndWith
Selection.ShapeRange.IncrementRotation90
'西进口右转
ActiveSheet.Shapes.AddShape(msoShapeArc,800,1000,200-200/Tan(tha),200).Select
Selection.ShapeRange.Line.Weight=Cells(4,3)*factor
Selection.ShapeRange.Line.ForeColor.RGB=RGB(0,0,255)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Fill.Visible=msoFalse
'西进口左转
ActiveSheet.Shapes.AddShape(msoShapeArc,800,1000,400+200/Tan(tha),400).Select
Selection.ShapeRange.FlipmsoFlipVertical
Selection.ShapeRange.Line.Weight=Cells(2,3)*factor
Selection.ShapeRange.Line.ForeColor.RGB=RGB(0,0,255)
Selection.ShapeRange.Line.BackColor.RGB=RGB(255,255,255)
Selection.ShapeRange.Fill.Visible=msoFalse
Selection.ShapeRange.IncrementTop-
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel 绘制 交叉口 流量 流向 VBA 程序
![提示](https://static.bdocx.com/images/bang_tan.gif)