在Excel中玩Bingo

2009年06月19日, 9:08 下午
1 颗星2 颗星3 颗星4 颗星5 颗星 (目前还没有人投票)
Loading ... Loading ...

一直都想很好地研究一下Excel中的形状功能，特别是使用VBA制作形状的技术，因为自已很想在Excel中使用VBA来自动完成工程项目网络计划图的制作。前段时间，在Dicks的博客上看到了一篇关于在Excel中玩Bingo的文章，很有趣。于是，自已很是研究了一番。
刚才在网上查了一下，才知道Bingo是一种填写格子的游戏，在游戏中第一个成功者以喊“Bingo”表示取胜而得名。现在，不止是在游戏中，也表示答对了，猜中了或者是做到了某件事情，即因出乎意料的成功而兴奋的叫声。

示例文档下载：

工作簿中有两个工作表，工作表Bingo中用来画图，单击“绘图”按钮一次就得到一个形状，并依次放置在下方，单击“重置”按钮，清除工作表中的临时形状；工作表Sheet2是隐藏的工作表，有两列数据，用来为形状命名。
在这里，将代码贴出来并附上一些中文注解，供有兴趣的朋友参考与交流。
下面的代码用来设置形状：

Public Const gsBALLNAME As String = "BingoBall"
Public Const glBALLCNT As Long = 6
 
Sub DrawNumber()
 
    Dim sDraw As String
 
    '获取形状编号
    sDraw = GetRandomDraw
    '使形状动起来
    AnimateShapes
    '设置形状6的文本和字体颜色
    With wshDraw.Shapes(gsBALLNAME & glBALLCNT)
        .TextFrame.Characters.Text = sDraw
        .TextFrame.Characters.Font.Color = vbWhite
    End With
 
    '使Excel朗读出形状的文本
    Application.Speech.Speak sDraw
 
    StoreNumber
 
    With wshDraw.Shapes(gsBALLNAME & glBALLCNT)
        .TextFrame.Characters.Font.Color = RGB(51, 102, 255)
        .Visible = msoFalse
    End With
 
End Sub
 
Sub Reset()
 
    Dim shp As Shape
 
    '删除临时形状
    For Each shp In wshDraw.Shapes
        If shp.Name Like "Temp*" Then
            shp.Delete
        End If
    Next shp
 
End Sub
Function AnimateShapes()
 
    Dim i As Long, j As Long
 
    '从形状1至形状6依次显示
    '形状1至形状5显示后隐藏
    For i = 1 To glBALLCNT
        wshDraw.Shapes(gsBALLNAME & i).Visible = msoCTrue
        For j = 1 To 10000: DoEvents: Next j
        If i < glBALLCNT Then
            wshDraw.Shapes(gsBALLNAME & i).Visible = msoFalse
        End If
    Next i
 
End Function
 
'给形状编号
Function GetRandomDraw() As String
 
    Dim lNumber As Long
    Dim lLetter As Long
    Dim sNumber As String
    Dim sLetter As String
    Dim lHigh As Long, lLow As Long
 
    'lNumber = Rnd * (75 - 1) + 1
    lLetter = Rnd * (5 - 1) + 1
    lHigh = lLetter * 15
    lLow = lHigh - 14
 
    lNumber = Rnd * (lHigh - lLow) + lLow
 
    sNumber = Format(wshStore.Range("rngNumbers").Item(lNumber).Value, "00")
    sLetter = wshStore.Range("rngLetters").Item(lLetter).Value
 
    GetRandomDraw = sLetter & "-" & sNumber
 
End Function
 
Function StoreNumber()
 
    Dim shp As Oval
    Dim lTop As Long, lLeft As Long
 
    '复制形状
    wshDraw.Shapes(gsBALLNAME & glBALLCNT).Copy
    DoEvents
    '粘贴形状作为临时形状
    wshDraw.Paste
    Set shp = Selection
    '获得临时形状的位置并命名
    shp.Top = wshDraw.Shapes(gsBALLNAME & glBALLCNT).Top
    shp.Left = wshDraw.Shapes(gsBALLNAME & glBALLCNT).Left
    shp.Name = "Temp" & Format(Rnd * 10000, "00000")
 
    '获取形状的位置
    GetCoordinates lTop, lLeft
 
    '使形状动起来
    Do Until Abs(shp.Top - lTop) < 1 And Abs(shp.Left - lLeft) < 1
        If shp.Top < lTop Then
            If Abs(shp.Top - lTop) > 10 Then
                shp.ShapeRange.IncrementTop 5
            Else
                shp.ShapeRange.IncrementTop 1
            End If
        Else
            If Abs(shp.Top - lTop) > 10 Then
                shp.ShapeRange.IncrementTop -5
            Else
                shp.ShapeRange.IncrementTop -1
            End If
        End If
 
        If shp.Left < lLeft Then
            If Abs(shp.Left - lLeft) > 10 Then
                shp.ShapeRange.IncrementLeft 5
            Else
                shp.ShapeRange.IncrementLeft 1
            End If
        Else
            If Abs(shp.Left - lLeft) > 10 Then
                shp.ShapeRange.IncrementLeft -5
            Else
                shp.ShapeRange.IncrementLeft -1
            End If
        End If
        DoEvents
    Loop
 
End Function
 
'设置形状的位置
Function GetCoordinates(ByRef lTop As Long, ByRef lLeft As Long)
 
    If wshDraw.Ovals.Count <= glBALLCNT + 1 Then
        lTop = 350
        lLeft = 10
    Else
        With wshDraw.Ovals(wshDraw.Ovals.Count - 1)
            lTop = .Top
            lLeft = .Left + .Width + 10
        End With
    End If
 
End Function

下面的代码用来为形状命名并在工作表中放置形状：

Sub DrawingShapes()
    Dim i As Long
 
    '准备6个圆形形状
    '用于在复制前创建动画效果
    For i = 1 To 6
        wshDraw.Shapes.AddShape Type:=msoShapeOval, Left:=60, Top:=60, Width:=20, Height:=20
    Next i
    '设置形状的大小
    SetWidths
    HideAllShapes
End Sub
 
Sub HideAllShapes()
 
    Dim i As Long
 
    Const bSHOW As Boolean = False
    '隐藏形状
    For i = 1 To 6
        wshDraw.Shapes(i).Visible = bSHOW
    Next i
 
 
End Sub
 
Sub SetWidths()
 
    Dim i As Long
    Dim vaWidths As Variant
 
    vaWidths = Array(20, 30, 40, 50, 60, 70)
 
    '将形状尺寸由小到大,这样依次出现时仿造动画效果
    For i = 1 To 6
        With wshDraw.Shapes(i)
            .Name = "BingoBall" & i
            .Height = i * 10 + 10
            .Width = i * 10 + 10
            .Top = 200 - (5 * (7 - i))
            .Left = 200 - (5 * (7 - i))
            .Visible = msoFalse
        End With
    Next i
 
    With wshDraw.Shapes(6).TextFrame
        .Characters.Text = "Sample"
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlHAlignCenter
        .Characters.Font.Size = 16
        .Characters.Font.Bold = True
        .Characters.Text = ""
    End With
 
End Sub

相关文章

标签：, , , ,
分类目录： Excel图表与图形, VBA  |  评论 (RSS)  |  Trackback  | 706 次阅读

发表评论