看看你的照片符合黄金比例吗？

爱疯

保存练习，请多多指出错误和意见，谢谢！

爱疯

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)

2017-1-5 09:39 上传

点击文件名下载附件

爱疯

qqyyh

真是神了，用得到。谢谢

爱疯

qqyyh 发表于 2017-1-5 10:13
真是神了，用得到。谢谢

谢谢，希望能做的更好些

刘苏

我福，我柯

exc姜

蛮好，谢谢

renyz2006

真是神了！好好学习吧！

ghoob

怎样才能符合