| |
▼えいち さん：
こんばんは。
>アナログ時計表示をさせたいと"width"や"height"利用して、シェイプの角度を変えたりなんだかんだしたりして、針を表現しようとしましたが、mmm難しいです。
>
>仮に、セル "A1" に、任意の時間(hh:mm:ss)が入力されているとして、マクロを実行したとき、 その時刻をアナログ時計で表現したいのです。
>（実際の時間に合わせて１秒１秒動く必要はない）
例題にすぎません。装飾はしていませんが・・・。
丸い時計をイメージして見ました。
長針も短針も秒針もただの線です。
'============================================================
Sub main()
Call Mk_en(ActiveSheet, 300, 100, 80) ' 丸い時計のつもり
disp_time = Now()
For idx = 1 To 5
Call mk_analog_clock(ActiveSheet, 300, 100, disp_time) '時計の針の設定
DoEvents
MsgBox Format(disp_time, "hh:mm:ss")
disp_time = disp_time + TimeSerial(1, 5, idx) '時刻を少しづつ進ませました
Next
End Sub
'==================================================================
Sub Mk_en(sht As Worksheet, x As Double, y As Double, rs As Double)
'円を作成する
'sht-----作成するシート
'x,y-----中心座標
'rs------半径
pai = WorksheetFunction.pi
With sht.Shapes.BuildFreeform(msoEditingAuto, x + rs, y)
For idx = 0.15 To 2 * pai Step 0.001
.AddNodes msoSegmentLine, msoEditingAuto, x + rs * Cos(idx), y + rs * Sin(idx)
Next idx
Set para = .ConvertToShape
para.Fill.Visible = msoFalse
End With
End Sub
'========================================================================
Sub mk_analog_clock(sht As Worksheet, x As Double, y As Double, disp_time)
'短針、長針、秒針の設定
'sht-----作成するシート
'x,y-----中心座標
'disp_time--時刻のシリアル値
On Error Resume Next
Dim pi As Double
pi = WorksheetFunction.pi
sht.Shapes.Range(Array("h_hand", "m_hand", "s_hand")).Delete
h_rad = ((Hour(disp_time)) * 60 + Minute(disp_time) - 180) / 1440 * pi * 4 '短針の角度の計算
Call mk_line(sht, "h_hand", x, y, x + 50 * Cos(h_rad), y + 50 * Sin(h_rad), 1.5)
m_rad = (Minute(disp_time) - 15) / 60 * pi * 2 '長針の角度の計算
Call mk_line(sht, "m_hand", x, y, x + 65 * Cos(m_rad), y + 65 * Sin(m_rad), 1.5)
s_rad = (Second(disp_time) - 15) / 60 * pi * 2 '秒針の角度計算
Call mk_line(sht, "s_hand", x, y, x + 65 * Cos(s_rad), y + 65 * Sin(s_rad), 1)
End Sub
'=========================================================================
Sub mk_line(sht As Worksheet, nm As String, x1 As Double, y1 As Double, x2 As Double, y2 As Double, we, Optional vh As Long = 0)
'線を引く
Set Ln = sht.Shapes.AddLine(x1, y1, x2, y2)
Ln.Line.Weight = we '線の太さ
If vh = 1 Then
Ln.Width = 0#
ElseIf vh = 2 Then
Ln.Height = 0#
End If
Ln.Name = nm
End Sub
後は、線の形を矢印にしたり、円に半透明の色を付けたり
工夫してみて下さい
まずは、確認してみて下さい。
|
|
ichinose
- 04/5/9(日) 19:17 -
