用单元格边框模拟的电子表

爱疯

电子表.rar (13.9 KB, 下载次数: 24)

2015-3-4 10:52 上传

点击文件名下载附件

请在2楼下载最新附件


看到一个动画，想起也做下。
可惜没想到什么好思路，只是老老实实做的。
希望能想到和学习好的思路！








'以下是Sheet1中的代码
Private Sub CommandButton1_Click()
    If k = False Then
        k = True
        CommandButton1.Caption = "取消"
        Call test
    Else
        k = False
        CommandButton1.Caption = "运行"
    End If
End Sub





'以下是模块中的代码
Option Explicit
Public k As Boolean    '声明一个公共变量k，用于判断当前是否继续执行

Sub test()
    Dim upRange As Range, downRange As Range
    Dim t, str$, r, c, i, j

    If Sheet1.CommandButton1.Caption = "运行" Then Exit Sub
    Cells.Clear    '每次都需清空
    t = Now
    [a1] = Format(t, "hh:mm:ss")
    str = Format(t, "hhmmss")
    r = 6    '从第6行开始显示
    c = 5    '从第5列开始显示
    j = c

    For i = 1 To 6
        Set upRange = Cells(r, j)
        Set downRange = Cells(r + 1, j)
        Select Case Mid(str, i, 1)
        Case 0
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeLeft).LineStyle = 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeLeft).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        Case 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
        Case 2
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            upRange.Borders(xlEdgeBottom).LineStyle = 1
            downRange.Borders(xlEdgeLeft).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        Case 3
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            upRange.Borders(xlEdgeBottom).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        Case 4
            upRange.Borders(xlEdgeLeft).LineStyle = 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            upRange.Borders(xlEdgeBottom).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
        Case 5
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeLeft).LineStyle = 1
            upRange.Borders(xlEdgeBottom).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        Case 6
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeLeft).LineStyle = 1
            downRange.Borders(xlEdgeLeft).LineStyle = 1
            upRange.Borders(xlEdgeBottom).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        Case 7
            upRange.Borders(xlEdgeTop).LineStyle = 1
            upRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
        Case 8
            Application.Union(upRange, downRange).Borders.LineStyle = 1
        Case 9
            upRange.Borders.LineStyle = 1
            downRange.Borders(xlEdgeRight).LineStyle = 1
            downRange.Borders(xlEdgeBottom).LineStyle = 1
        End Select
        j = j + 2

        '如果下次是分钟或秒，则表达冒号
        If j = c + 4 Or j = c + 10 Then
            Cells(r, j) = "."
            Cells(r + 1, j) = "."
            j = j + 2
        End If
    Next i

    Application.OnTime Now + TimeValue("00:00:01"), "test"
End Sub

爱疯

电子表9.rar (14.52 KB, 下载次数: 40)

2016-1-20 16:46 上传

点击文件名下载附件

还是没好思路，只是整理了下代码，感觉小清新多了{:021:}




'以下是Sheet1中的代码
Private Sub CommandButton1_Click()
    If k = False Then
        k = True
        CommandButton1.Caption = "取消"
        Call showTime
    Else
        k = False
        CommandButton1.Caption = "运行"
    End If
End Sub



'以下是模块中的代码
Option Explicit
Public k As Boolean    '声明一个公共变量k，用于判断当前是否继续执行

'主程序
Sub main()
    Dim rng, num, u, d, r%, c%, j%, str
    If Sheet1.CommandButton1.Caption = "运行" Then Exit Sub
    Set rng = [e6]: r = rng.Row: c = rng.Column
    Call setBorders(rng, "0000")
    Call setBorders(rng.Offset(1, 0), "0000")
    str = Format(Now, "hh:mm:ss"): [a1] = str

    For j = 1 To Len(str) * 2 Step 2  '字符之间用1列分隔
        Set u = Cells(r, j + c - 1)
        Set d = Cells(r + 1, j + c - 1)
        num = Mid(str, (j + 1) / 2, 1)
        If j = 5 Or j = 11 Then
            u.Value = ".": d.Value = u.Value
        Else
            Call setBorders(u, Mid(num2str(num), 1, 4))
            Call setBorders(d, Mid(num2str(num), 5, 4))
        End If
    Next j

    Application.OnTime Now + TimeValue("00:00:01"), "main"
End Sub

'数字转换为边框值字符串
Function num2str(num) As String
    Select Case num
    Case 0
        num2str = "11011011"
    Case 1
        num2str = "00010001"
    Case 2
        num2str = "01111110"
    Case 3
        num2str = "01110111"
    Case 4
        num2str = "10110101"
    Case 5
        num2str = "11100111"
    Case 6
        num2str = "11101111"
    Case 7
        num2str = "01010001"
    Case 8
        num2str = "11111111"
    Case 9
        num2str = "11110111"
    End Select
    '8位含义：左上下右左上下右
    '前4位对应上面的单元格边框值，后4位为下面的。
End Function

'设置边框
Sub setBorders(rng, str)
    Dim i
    '按"左上下右"顺序，设置单元格边框
    For i = 7 To 10
        rng.Borders(i).LineStyle = Mid(str, i - 6, 1)
    Next i
End Sub

脱水的小龙

感觉蛮好玩的

老九别走

有趣，好东东。

ddyy004

页面很清晰

d346836673

收下了。感觉还是满好的。

zjdh

挺有意思的，学习了！

傻坐一天