钟表

41668090

求VBA钟表代码

41668090

Sub 开始运行()
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
     Call 生成时钟图像
    On Error Resume Next
    If Err <> 0 Then Exit Sub
    For i = 1 To 600
    ActiveSheet.Shapes("秒针").Rotation = 6 *Int(Timer Mod 60)
   
    ActiveSheet.Shapes("分针").Rotation = 6 *Int(Timer / 60 Mod 60)
    ActiveSheet.Shapes("时针").Rotation = 30 *Int(Timer / 3600)
   
    Pause_T 1  
    Next i
End Sub
Function Pause_T(n As Integer)  '暂停n秒，期间可以进行其他操作
    '前面的代码
    t = Timer
    While Timer < t + n
        DoEvents
    Wend
    '后面的代码
End Function


Sub 生成时钟图像()
'
'定义中心位置
Dim x, y As Integer
Const pi = 3.1415926
x = Selection.Left
y = Selection.Top
If x < 80 Or y < 80 Then MsgBox "中心位置太靠边缘，请重新选择", vbDefaultButton2, x & y: ExitSub
On Error Resume Next
ActiveSheet.Shapes.Delete
   
'画表盘

   ActiveSheet.Shapes.AddShape(msoShapeOval, 425, 50, 575, 190).Select
   
    With Selection.ShapeRange
        .Name = "表盘"
        .Height = 150
        .Width = 150
        .Top = y - 150 / 2
        .Left = x - 150 / 2
    End With

    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor= msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
        .ForeColor.RGB = RGB(0, 176,80)
    End With
   
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(112,48, 160)
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.5
        .Transparency = 0
        .Style = msoLineThickThin
        .Visible = msoTrue
        .Weight = 8
    End With
'画刻度
    For i = 0 To 29
       ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 55, 500,60).Select
        
        With Selection.ShapeRange
             .Name = "刻度A" & i
             If i Mod 5 = 0 Then
                .Height = 10
                .Line.ForeColor.RGB= vbRed
            Else
                 .Height = 8
                .Line.ForeColor.RGB= vbBlack
            End If
            .Width = 0
            .Line .Visible = msoTrue
            .Line.Weight = 2
             .Top = y - 70
             .Left = x
        End With
        
       ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 185, 500,190).Select
        
        With Selection.ShapeRange
                .Name = "刻度B" & i
             If i Mod 5 = 0 Then
                .Height = 10
                .Line.ForeColor.RGB= vbRed
            Else
                .Height = 8
               .Line.ForeColor.RGB =vbBlack
            End If
            .Width = 0
            .Line .Visible = msoTrue
            .Line.Weight = 2
            .Top = y + 70 - .Height
            .Left = x
        End With
        
       ActiveSheet.Shapes.Range(Array("刻度A" & i, "刻度B"& i)).Group.Select
        Selection.ShapeRange.Name ="刻度" & i
       Selection.ShapeRange.Rotation = 6 * i
    Next i
'添加铭牌
   ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, _
        55, 32, 15).Select
    With Selection.ShapeRange
        .Height = 20
        .Width = 80
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
        .Top = y + 15
        .Left = x - 40
       .TextFrame2.TextRange.Font.Name = "微软雅黑"
       .TextFrame2.TextRange.Font.Size = 10
       .TextFrame2.TextRange.Font.Bold = True
       .TextFrame2.TextRange.Characters.Text = "VBAHOME"
        .TextFrame2.TextRange.Characters().Font.Fill.ForeColor.RGB= vbWhite
        .TextFrame2.VerticalAnchor =msoAnchorMiddle
       .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    End With
'添加表盘数字
For j = 1 To 12
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal,100, _
        55, 32, 15).Select
   With Selection.ShapeRange
    .Height = 8
    .Width = 16
    .Line.Visible = msoFalse
    .Fill.Visible = msoFalse
   
        If Sin(j * pi / 6) >= 0Then
            .Top = y + 60 * Sin(j *pi / 6) - 8
        Else
            .Top = y + 60 * Sin(j *pi / 6)
        End If
        
        If Cos(j * pi / 6) >= 0Then
            .Left = x + 60 * Cos(j *pi / 6) - 16
        Else
            .Left = x + 60 * Cos(j *pi / 6)
        End If
        
        If (j + 2) Mod 12 + 1 = 6Then
            .Left = x + 60 * Cos(j *pi / 6) - 8
            .Top = y + 60 * Sin(j *pi / 6) - 8
        End If
        If (j + 2) Mod 12 + 1 = 12Then
            .Left = x + 60 * Cos(j *pi / 6) - 8
        End If
     
     End With
     
    WithSelection.ShapeRange.TextFrame2
        .TextRange.Characters.Text =(j + 2) Mod 12 + 1
        .TextRange.Font.Name ="微软雅黑"
        .TextRange.Font.Size = 8
        .TextRange.Font.Bold = True
        .TextRange.Characters().Font.Fill.ForeColor.RGB= RGB(255, 0, 0)
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
       .TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .VerticalAnchor =msoAnchorMiddle
    End With
   
Next j
'画时针
   ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 120, 500,90).Select
   
    With Selection.ShapeRange
        .Name = "时针1"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 30
        .Width = 0
        .Top = y - 30
        .Left = x
        .Line.Visible = msoTrue
        .Line.Weight = 4
    End With
   
       ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 120, 500,150).Select
   
    With Selection.ShapeRange
        .Name = "时针2"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 30
        .Width = 0
        .Top = y
        .Left = x
        .Line.Visible = msoFalse
        .Line.Weight = 4
    End With
   
  ActiveSheet.Shapes.Range(Array("时针2", "时针1")).Group.Select
    Selection.ShapeRange.Name ="时针"
   


'画分针
   ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 120, 500,80).Select
   
     With Selection.ShapeRange
        .Name = "分针1"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 40
        .Width = 0
        .Top = y - 40
        .Left = x
        .Line.Visible = msoTrue
        .Line.Weight = 3
    End With
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight,500, 120, 500, 160).Select
   
    With Selection.ShapeRange
        .Name = "分针2"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 40
        .Width = 0
        .Top = y
        .Left = x
        .Line.Visible = msoFalse
        .Line.Weight = 3
    End With

   ActiveSheet.Shapes.Range(Array("分针2", "分针1")).Group.Select
    Selection.ShapeRange.Name ="分针"
   
'画秒针

   ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 120, 500, 70).Select
   
    With Selection.ShapeRange
        .Name = "秒针1"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 50
        .Width = 0
        .Top = y - 50
        .Left = x
        .Line.Visible = msoTrue
        .Line.Weight = 2
    End With
   
   ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 500, 120, 500,170).Select
   
     With Selection.ShapeRange
        .Name = "秒针2"
        .Line.EndArrowheadStyle =msoArrowheadTriangle
        .Height = 50
        .Width = 0
        .Top = y
        .Left = x
        .Line.Visible = msoFalse
        .Line.Weight = 2
    End With
   
   ActiveSheet.Shapes.Range(Array("秒针2", "秒针1")).Select
   Selection.ShapeRange.Group.Select
    Selection.ShapeRange.Name ="秒针"
   
        '画表中心
   ActiveSheet.Shapes.AddShape(msoShapeOval, 495, 116.25, 525,12.75).Select
   
    With Selection.ShapeRange
        .Name = "表心"
        .Height = 8
        .Width = 8
        .Top = y - 8 / 2
        .Left = x - 8 / 2
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB =RGB(255, 0, 0)
        .Fill.Transparency = 0
        .Fill.Solid
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(0,0, 255)
        .Line.Transparency = 0
        .ZOrder msoBringToFront
    End With
R = ActiveSheet.Shapes("表盘").TopLeftCell.Address
Range(R).Select
End Sub