Excel绘制交叉口流量流向图VBA程序

1、Excel 绘制交叉口流量流向图 VBA 程序打开 Excel，在 Excel 左上角编辑交叉口转向流量表,和定义斜交角度(东北角),新建宏文件 DrawFlowMap,将文后代码复制进宏文件， 执行宏文件,即可绘制交叉口流量流向图。附代码：来自世界代码联盟，作者：一起玩狗的Sub text(top_x, top_y, t) 定义文本框 ActiveSheet.Shapes.AddShape(msoShapeRectangle, top_x, top_y, 120, 120).SelectSelection.Characters.text = tWith Selection.Character

2、s(Start:=1, length:=30).Font.Name = Times New Roman.FontStyle = 常规.Size = 20.Strikethrough = False.Superscript = False.Subscript = False.OutlineFont = False.Shadow = False.Underline = xlUnderlineStyleNone.ColorIndex = xlAutomatic End WithSelection.ShapeRange.Fill.Visible = msoTrueSelection.ShapeRang

3、e.Fill.SolidSelection.ShapeRange.Fill.ForeColor.SchemeColor = 9Selection.ShapeRange.Fill.Transparency = 0Selection.ShapeRange.Line.Weight = 0.75 Selection.ShapeRange.Line.DashStyle = msoLineSolid Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Line.Transparency = 0 Selection.Sha

4、peRange.Line.Visible = msoFalseEnd SubSub DrawFlowMap() 画路口流量流向图 Dim F_to_T As BooleanDim tt As StringDim factor As Double factor = 0.02定义斜交角Dim tha, tha1 As Single tha1 = Cells(2, 7)tha = Application.WorksheetFunction.Radians(tha1)判断、清除图形ActiveSheet.DrawingObjects.Select Selection.Delete清除图形结束 东进口t

5、t = 东进口流量 & Chr(10) & 左转: & Cells(2, 2) & Chr(10) & 直行: & Cells(3, 2) & Chr(10) & 右转: & Cells(4, 2)Call text(1550, 750, tt) 东进口直行ActiveSheet.Shapes.AddLine(800, 800, 1500, 800).SelectSelection.ShapeRange.Line.ForeColor.SchemeColor = 10Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)Selec

6、tion.ShapeRange.Line.Weight = Cells(3, 2) * factor绘制出口箭头ActiveSheet.Shapes.AddLine(725, 800, 801, 800).SelectSelection.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

7、.AddShape(msoShapeIsoscelesTriangle, 675,775, 40, 50).SelectSelection.ShapeRange.Line.Visible = msoFalse With Selection.ShapeRange.Fill.Visible = msoTrue.ForeColor.RGB = RGB(0, 0, 255).Transparency = 0.Solid End WithSelection.ShapeRange.IncrementRotation 270Selection.ShapeRange.IncrementLeft 5东进口右转A

8、ctiveSheet.Shapes.AddShape(msoShapeArc, 1400, 800, 200 - 200 / Tan(tha), 200).SelectSelection.ShapeRange.Flip msoFlipHorizontal Selection.ShapeRange.Flip msoFlipVertical Selection.ShapeRange.Line.Weight = Cells(4, 2) * factor Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)Selection.ShapeRan

9、ge.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).SelectSelection.ShapeRange.Flip msoFlipHorizontal Selection.ShapeRange.Line.Weight = Cells

10、(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.IncrementLeft 400Selection.ShapeRange.IncrementTop -2 图形置顶Selection.ShapeRange.ZOrder msoBringToFront

11、西进口tt = 西进口流量 & Chr(10) & 左转: & Cells(2, 3) & Chr(10) & 直行: & Cells(3, 3) & Chr(10) & 右转: & Cells(4, 3)Call text(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)

12、Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) 绘制出口箭头ActiveSheet.Shapes.AddLine(1400, 1000, 1475, 1000).SelectSelection.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 Act

13、iveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle,1480, 975, 40, 50).SelectSelection.ShapeRange.Line.Visible = msoFalse With Selection.ShapeRange.Fill.Visible = msoTrue.ForeColor.RGB = RGB(255, 0, 0).Transparency = 0.Solid End WithSelection.ShapeRange.IncrementRotation 90 西进口右转ActiveSheet.Shapes.Ad

14、dShape(msoShapeArc, 800, 1000, 200 - 200 / Tan(tha), 200).SelectSelection.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.Sh

15、apes.AddShape(msoShapeArc, 800, 1000, 400 + 200 / Tan(tha), 400).SelectSelection.ShapeRange.Flip msoFlipVertical 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.Shap

16、eRange.Fill.Visible = msoFalse Selection.ShapeRange.IncrementTop -800图形置底Selection.ShapeRange.ZOrder msoSendToBack南进口tt = 南进口流量 & Chr(10) & 左转: & Cells(2, 4) & Chr(10) & 直行: & Cells(3, 4) & Chr(10) & 右转: & Cells(4, 4)Call text(1240 - 400 / Tan(tha), 1350, tt)南进口直行ActiveSheet.Shapes.AddLine(1200 - 50

17、0 / Tan(tha), 1300, 1200+ 200 / Tan(tha), 600).Select Selection.ShapeRange.Line.Weight = Cells(3, 4) * factorSelection.ShapeRange.Line.ForeColor.RGB = RGB(0, 153, 0)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)绘制出口箭头ActiveSheet.Shapes.AddLine(1200 + 200 / Tan(tha), 600, 1200 + 278 / T

18、an(tha), 523).SelectSelection.ShapeRange.Line.Weight = Cells(3, 4) * factor Selection.ShapeRange.Line.ForeColor.RGB = RGB(128, 0, 128)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 1180+ 325 / Tan(tha), 475, 40, 50).Select Selection

19、.ShapeRange.Line.Visible = msoFalse With Selection.ShapeRange.Fill.Visible = msoTrue.ForeColor.RGB = RGB(128, 0, 128).Transparency = 0.Solid End WithSelection.ShapeRange.IncrementRotation (90 - tha1) Selection.ShapeRange.IncrementLeft (-25 * Cos(tha) Selection.ShapeRange.IncrementTop (25 / Tan(tha)

20、/ 2 *Cos(tha)南进口右转ActiveSheet.Shapes.AddShape(msoShapeArc, 1400, 800, 200 + 400 / Tan(tha), 200).SelectSelection.ShapeRange.Flip msoFlipVertical Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Rotation = 180 Selection.ShapeRange.Line.Weight = Cells(4, 4) * factor Selection.Shape

21、Range.Line.ForeColor.RGB = RGB(0, 153, 0)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)Selection.ShapeRange.Fill.Visible = msoFalseSelection.ShapeRange.IncrementTop 200图形置底Selection.ShapeRange.ZOrder msoSendToBack南进口左转ActiveSheet.Shapes.AddShape(msoShapeArc, 800, 800, 400 - 400 / Tan(t

22、ha), 400).SelectSelection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Line.Weight = Cells(2, 4) * factor Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 153, 0)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)Selection.ShapeRange.Fill.Visible = msoFalse 图形置底Selection.Shape

23、Range.ZOrder msoSendToBack北进口tt = 北进口流量 & Chr(10) & 左转: & Cells(2, 5) & Chr(10) & 直行: & Cells(3, 5) & Chr(10) & 右转: & Cells(4, 5)Call text(950 + 400 / Tan(tha), 350, tt)北进口直行ActiveSheet.Shapes.AddLine(1000 + 500 / Tan(tha), 500, 1000 - 200 / Tan(tha), 1200).SelectSelection.ShapeRange.Line.Weight = C

24、ells(3, 5) * factor Selection.ShapeRange.Line.ForeColor.RGB = RGB(128, 0, 128)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) 绘制出口箭头ActiveSheet.Shapes.AddLine(1000 - 200 / Tan(tha), 1200, 1000 - 278 / Tan(tha), 1278).SelectSelection.ShapeRange.Line.Weight = Cells(3, 5) * factor Selectio

25、n.ShapeRange.Line.ForeColor.RGB = RGB(0, 153, 0)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 980- 275 / Tan(tha), 1275, 40, 50).Select Selection.ShapeRange.Line.Visible = msoFalse With Selection.ShapeRange.Fill.Visible = msoTrue.F

26、oreColor.RGB = RGB(0, 153, 0).Transparency = 0.Solid End WithSelection.ShapeRange.IncrementRotation (270 - tha1)Selection.ShapeRange.IncrementLeft (-25 * Cos(tha) Selection.ShapeRange.IncrementTop (25 / Tan(tha) / 2 *Cos(tha)北进口左转ActiveSheet.Shapes.AddShape(msoShapeArc, 1400, 1000, 400 - 400 / Tan(t

27、ha), 400).SelectSelection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Rotation = 180 Selection.ShapeRange.Line.Weight = Cells(2, 5) * factor Selection.ShapeRange.Line.ForeColor.RGB = RGB(128, 0, 128)Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) Selection.ShapeRange.Fill.Visible = msoFalse Selection.ShapeRange.IncrementTop -800图形置底Selection.ShapeRange.ZOrder msoSendToBack北进口右转ActiveSheet.Shapes.AddShape(msoShapeArc, 800, 800, 200 + 400 / Tan(tha), 200).SelectSelection.ShapeRange.Flip msoFlipHorizontal Selection.ShapeRange.LockAspect