Sub MakeSlideRule()
Dim vs As Shape
Dim lineWeight As Double
Dim longLength As Double
Dim middleLength As Double
Dim shortLength As Double
Dim yLocation As Double
Dim slideRuleHeight As Double
slideRuleHeight = 0.7
yLocation = 4
longLength = 0.2
middleLength = 0.1
shortLength = 0.05
lineWeight = 0.001
Dim i As Integer
Dim x As Double
'枠線を引きます。
Set vs = ActivePage.DrawLine(ValueToLocation(0.9), yLocation, ValueToLocation(11), yLocation)
vs.Cells("LineWeight") = lineWeight
Set vs = ActivePage.DrawLine(ValueToLocation(0.9), yLocation - slideRuleHeight, ValueToLocation(0.9), yLocation + slideRuleHeight)
vs.Cells("LineWeight") = lineWeight
Set vs = ActivePage.DrawLine(ValueToLocation(0.9), yLocation + slideRuleHeight, ValueToLocation(11), yLocation + slideRuleHeight)
vs.Cells("LineWeight") = lineWeight
Set vs = ActivePage.DrawLine(ValueToLocation(11), yLocation - slideRuleHeight, ValueToLocation(11), yLocation + slideRuleHeight)
vs.Cells("LineWeight") = lineWeight
Set vs = ActivePage.DrawLine(ValueToLocation(0.9), yLocation - slideRuleHeight, ValueToLocation(11), yLocation - slideRuleHeight)
vs.Cells("LineWeight") = lineWeight
'1から2までの目盛線を引きます。
For i = 0 To 100
x = ValueToLocation(1 + i / 100)
If i Mod 10 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - longLength, x, yLocation + longLength)
ElseIf i Mod 5 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - middleLength, x, yLocation + middleLength)
Else
Set vs = ActivePage.DrawLine(x, yLocation - shortLength, x, yLocation + shortLength)
End If
vs.Cells("LineWeight") = lineWeight
Next i
'2.02から5までの目盛線を引きます。
For i = 1 To 150
x = ValueToLocation(2 + i / 50)
If i Mod 25 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - longLength, x, yLocation + longLength)
ElseIf i Mod 5 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - middleLength, x, yLocation + middleLength)
Else
Set vs = ActivePage.DrawLine(x, yLocation - shortLength, x, yLocation + shortLength)
End If
vs.Cells("LineWeight") = lineWeight
Next i
'5.05から10までの目盛線を引きます。
For i = 1 To 100
x = ValueToLocation(5 + i / 20)
If i Mod 10 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - longLength, x, yLocation + longLength)
ElseIf i Mod 2 = 0 Then
Set vs = ActivePage.DrawLine(x, yLocation - middleLength, x, yLocation + middleLength)
Else
Set vs = ActivePage.DrawLine(x, yLocation - shortLength, x, yLocation + shortLength)
End If
vs.Cells("LineWeight") = lineWeight
Next i
'1から10までの数字を書きます。
For i = 1 To 10
x = ValueToLocation(CDbl(i))
Set vs = ActivePage.DrawRectangle(x - 0.2, yLocation - longLength - 0.2, x + 0.2, yLocation - longLength)
vs.Text = CStr(i)
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 12
Set vs = ActivePage.DrawRectangle(x - 0.2, yLocation + longLength + 0.2, x + 0.2, yLocation + longLength)
vs.Text = CStr(i)
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 12
Next i
'尺名を書きます。
x = ValueToLocation(CDbl(0.95))
Set vs = ActivePage.DrawRectangle(x - 0.2, yLocation - longLength - 0.15, x + 0.2, yLocation - longLength + 0.05)
vs.Text = "D"
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 20
x = ValueToLocation(CDbl(0.95))
Set vs = ActivePage.DrawRectangle(x - 0.2, yLocation + longLength - 0.1, x + 0.2, yLocation + longLength + 0.1)
vs.Text = "C"
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 20
'タイトルを書きます。
x = ValueToLocation(CDbl(1.2))
Set vs = ActivePage.DrawRectangle(x - 1.5, yLocation + slideRuleHeight, x + 1.5, yLocation + slideRuleHeight + 0.5)
vs.Text = "基本計算尺"
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 30
x = ValueToLocation(CDbl(6))
Set vs = ActivePage.DrawRectangle(x - 3, yLocation - slideRuleHeight - 0.1, x + 3, yLocation - slideRuleHeight + 0.4)
vs.Text = "計算尺推進委員会 http://www.pi-sliderule.net/"
vs.LineStyle = "Text Only"
vs.FillStyle = "Text Only"
vs.Cells("Char.size").Result("pt") = 18
End Sub
Static Function Log10(x) As Double
Log10 = Log(x) / Log(10)
End Function
'1<=x<=10の引数に対して、線を表示する位置をインチ単位で返します。
Static Function ValueToLocation(x As Double) As Double
ValueToLocation = Log10(x) * 25 / 2.54 + 1
End Function