这是我在论坛上发布的用于构建六边形瓷砖的脚本的旧帖子。有些调用是针对 GIS API，但我认为您可能可以提取所需的 VBA 代码：
.. VB script to create some hexagon tiles.
It creates tiles of a given radius (circle around a tile), not side length. If you want side length you will need to do the math and updte the code.
Here is the Comments from the .map file:
Creating a drawing of hexagon tiles:
R - radius
Radius of circumscribed circle around tile
a - Apothem:
Distance from centroid perpendicular to a side
a = R * cos(1/2 * 360/n) (n=6 for a hexagon
A set of hexagon tiles would be a series of six sided
"circles" centered on two point grids (1 & 2). Both grids
would have the spacing of:
in X --- 3R
in Y --- 2a
Grid 2 would be offset from grid 1 by:
in X ---- 3R/2
in Y ---- 2a/2
To test script delete all objects in A then
run the script.
This sample was only tested with a lat/long drawing. I'm not
sure of all the ramifications of using a projected drawing.
To use with your data set the start point (upper left) in the script and desired radius.
Set precision and run Normailize Topology when done to join
the tiles.
Code was based on the FreeStuff sample scripts ScriptRandomPoints
and ScriptSpatialOperations.
Please post any problems you find with this code.
Hmmm.. the attachments option is gone? :-?
Send me your address via email and send the .map file if you'd like.
Here's the code:
Sub Main
' test lat/long drawing
' ** ** delete all objects in A to test
set drawing = Application.ActiveDocument.ComponentSet("A")
set objects = drawing.ObjectSet
sides = 6
pi = 3.14159
R = 2.5 ' radius in degrees
interiorAngle = (360/6) * (pi / 180) ' in radians
a = abs(R * cos(0.5 * interiorAngle)) ' apothem
' pick/make a start point - upper left
Set startPoint = Application.NewPoint
startPoint.X = -25
startPoint.Y = 73.6602540378444
' grid (4x3x2)
for i = 0 to 3
for j = 0 to 2
' -- create point grid 1
Set point = Application.NewPoint
point.X = startPoint.X + (i * 3 * R)
point.Y = startPoint.Y - (j * 2 * a)
' objects.Add Application.NewGeom(GeomPoint, point) ' centroid
Set pointSet = Application.NewPointSet
For k = 0 To sides -1
Set pt = Application.NewPoint
' calculate angle
angle = (k*2*Pi/sides)' - (360/sides)/2
' obtain point on circle
pt.X = point.X + R*Cos(angle)
pt.Y = point.Y + R*Sin(angle)
pointSet.Add(pt)
Next
objects.Add Application.NewGeom(GeomArea, pointSet)
' -- create point grid 2
Set point = Application.NewPoint
point.X = startPoint.X + (i * 3 * R) + ((3 * R)/2)
point.Y = startPoint.Y - (j * 2 * a) - a
' objects.Add Application.NewGeom(GeomPoint, point) ' centroid
Set pointSet = Application.NewPointSet
For k = 0 To sides -1
Set pt = Application.NewPoint
' calculate angle
angle = (k*2*Pi/sides)' - (360/sides)/2
' obtain point on circle
pt.X = point.X + R*Cos(angle)
pt.Y = point.Y + R*Sin(angle)
pointSet.Add(pt)
Next
objects.Add Application.NewGeom(GeomArea, pointSet)
next
next
msgbox "Done!"
End Sub
这是一个只开发一个十六进制图块的清理版本。你应该可以修改它来做你想做的事。
Sub xx()
Dim startPoint As clsPoint
Dim Point As clsPoint
Dim pt As clsPoint
Dim pts As Collection
Dim s As String
' lat/long (western hemisphere?)
Dim sides, i, j, k As Integer
Dim Pi, R, interiorAngle, A, Angle As Double
sides = 6
Pi = 3.14159
R = 0.25 ' radius in degrees
interiorAngle = (360 / 6) * (Pi / 180) ' in radians
A = Abs(R * Cos(0.5 * interiorAngle)) ' apothem
' pick/make a start point - upper left
Set startPoint = New clsPoint
startPoint.X = -121.5
startPoint.Y = 35.5
s = "Longitude" & vbTab & "Latitude" & vbCrLf
s = s & startPoint.X & vbTab & startPoint.Y & vbCrLf
Set Point = New clsPoint
Point.X = startPoint.X '+ (i * 3 * R)
Point.Y = startPoint.Y '- (j * 2 * A)
Set pts = New Collection
For k = 0 To sides - 1
Set pt = New clsPoint
' calculate angle
Angle = (k * 2 * Pi / sides) ' - (360/sides)/2
' Debug.Print Angle
' obtain point on circle
pt.X = Point.X + R * Cos(Angle)
pt.Y = Point.Y + R * Sin(Angle)
pts.Add pt
Next
For Each pt In pts
s = s & pt.X & vbTab & pt.Y & vbCrLf
Next
Debug.Print s
Stop
End Sub
clsPoint 只包含：
Public X As Double
Public Y As Double