做到能精确绘制地图的vba代码

gu2015

初步做到了利用cad绘制地图数据导入excel，再用EXCEL自由曲线绘制地图，请各位欣赏，也请各位大侠指出不足。
文件里面，有例子，也有目标！

thestronger

厉害。不过，干嘛用excel呢？

gu2015

thestronger 发表于 2015-4-5 13:04
厉害。不过，干嘛用excel呢？

cad可以导入数据描出地图，还要操作填充着色。
excel如果能够像cad那样精确绘图，其着色就很方便，而且应用数据和图表，就比其他软件容易和清楚，更重要的是电子表格很普及，大家都能用！

liucqa

1. Sub test1()
   
2.     Dim arr1()
   
3.     On Error GoTo 100
   
4.     arr = Application.InputBox("在工作表中选择XY坐标数组", "选择区域", Type:=8)
   
5.     n = Application.CountA(arr) / 2
   
6.     ReDim arr1(1 To n)
   
7.     arr1 = Application.Transpose(arr)
   
8.     Set myDocument = Worksheets(1)
   
9.     With myDocument.Shapes.BuildFreeform(msoEditingAuto, _
   
10.                                          Application.Transpose(arr1(2, 1)), _
    
11.                                          Application.Transpose(arr1(1, 1)))
    
12.         For i = 2 To n - 1
    
13.             ar1 = Application.Transpose(arr1(2, i))
    
14.             ar2 = Application.Transpose(arr1(1, i))
    
15.             .AddNodes msoSegmentLine, msoEditingAuto, ar1, ar2
    
16.         Next
    
17.         cctype = Application.InputBox("图块输入：0" & Chr(10) & "线条输入：1", "", 0)
    
18.         If cctype = 0 Then
    
19.             .AddNodes msoSegmentLine, msoEditingAuto, _
    
20.                       Application.Transpose(arr1(2, 1)), _
    
21.                       Application.Transpose(arr1(1, 1))
    
22.             '    .ConvertToShape
    
23.             .ConvertToShape.Select
    
24.             Selection.ShapeRange().Rotation = -90
    
25. 
    
26.             With Selection.ShapeRange.Fill
    
27.                 '        .Visible = msoTrue
    
28.                 .ForeColor.RGB = RGB(255, 66, 102)
    
29.                 .Transparency = 0
    
30.                 .Solid
    
31.             End With
    
32.         ElseIf cctype = 1 Then
    
33.             .AddNodes msoSegmentLine, msoEditingAuto, _
    
34.                       Application.Transpose(arr1(2, n)), _
    
35.                       Application.Transpose(arr1(1, n))
    
36.             '   .ConvertToShape
    
37.             .ConvertToShape.Select
    
38.             Selection.ShapeRange().Rotation = -90
    
39. 
    
40.         End If
    
41.         .Shapes.Range.Left = 300
    
42.         .Shapes.Range.Top = 800
    
43.     End With
    
44. 100:
    
45. End Sub
    

复制代码

jpj123

不错的作品，先学习一下！

575504963

没看懂这个，能解释用处吗