|
楼主 |
发表于 2017-1-5 09:39
|
显示全部楼层
Option Explicit
'主程序
Dim PicPath As String
Sub test()
Application.ScreenUpdating = False
PicPath = Application.GetOpenFilename()
If PicPath = "False" Then End
Call Style(1, 1, 1)
Call Style(2, -1, 1)
Call Style(3, 1, -1)
Call Style(4, -1, -1)
Sheets(1).Select
End Sub
'清除
Private Sub ClearObject()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoLinkedPicture Or shp.Type = msoLine Or shp.Type = msoAutoShape Then shp.Delete
Next shp
End Sub
'斐波纳契数列
Function Fib(n)
If n = 0 Then
Fib = 0
ElseIf n = 1 Then
Fib = 1
Else
Fib = Fib(n - 1) + Fib(n - 2)
End If
End Function
'某种样式
Sub Style(idx, x, y)
Dim L, T, W, H
Dim BeginX, BeginY, EndX, EndY
Dim Gold As Double
Dim i As Integer
Dim n As Integer
Sheets(idx).Select
Range("A1").Select
n = 8
Call ClearObject
With ActiveSheet.Pictures.Insert(PicPath)
L = .Left: T = .Top: W = .Width: H = .Height
End With
'根据工作表索引,确定第1个Begin和第1个End。
Select Case idx
Case 1
BeginX = L: BeginY = T: EndX = L + W: EndY = T
Case 2
BeginX = L + W: BeginY = T: EndX = L: EndY = T
Case 3
BeginX = L: BeginY = T + H: EndX = L + W: EndY = T + H
Case 4
BeginX = L + W: BeginY = T + H: EndX = L: EndY = T + H
End Select
For i = 1 To n
Gold = Fib(n - i) / (Fib(n - i) + Fib(n + 1 - i))
If i Mod 2 Then
BeginX = BeginX + x * W * Gold
'BeginY 不变
EndX = BeginX
EndY = BeginY + y * H
W = W * Gold
x = x * -1
Else
'BeginX 不变
BeginY = BeginY + y * H * Gold
EndX = BeginX + x * W
EndY = BeginY
H = H * Gold
y = y * -1
End If
'Call NewShape(BeginX, BeginY, 60, 20, "Begin " & i, 255 ^ 2) '测试
'Call NewShape(EndX, EndY, 60, 20, "End " & i, 255) '测试
Call NewLine(BeginX, BeginY, EndX, EndY)
Next i
End Sub
'创建直线
Sub NewLine(BeginX, BeginY, EndX, EndY)
With ActiveSheet.Shapes.AddLine(BeginX, BeginY, EndX, EndY)
.line.ForeColor.RGB = IIf(Sheets(5).[L8] = "彩色", _
RGB(255 * Rnd, 255 * Rnd, 255 * Rnd), _
RGB(255, 255, 255))
.line.Weight = 2
End With
End Sub
'创建矩形
Sub NewShape(L, T, W, H, Text, Color)
With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
.Fill.Visible = msoFalse
.line.ForeColor.RGB = Color
.line.Weight = 0.5
.TextFrame2.TextRange.Characters.Text = Text
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Color
End With
End Sub
构图28.rar
(187.11 KB, 下载次数: 23)
|
|