●　Excel マクロの解説 「 簡易CADマクロ 」編　●

「 簡易CADマクロ 」について、簡単ですが赤字で解説を入れました。
参考になれば、幸いです。

H26.07.15 現在
------------------   ここから ThisWorkBook コード -------------------
ブックを閉じた時に、アドインとユーザーフォームを消去する
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error GoTo e0002:
    Application.CommandBars("Cell").Reset
    aリセット
e0002:
End Sub
---------------------------------------------------------------------
ブックを開いた時に、アドインの設定とUForm1のユーザーフォームを開く
Private Sub Workbook_Open()
    Application.CommandBars("Cell").Controls(1).BeginGroup = True
    aセット
End Sub
-----------------------   ここから UForm1のコード  ------------------
[左右反転]ボタンクリックで選択されている図形を左右反転する。
Private Sub CommandButton1_Click()
    '左右反転
    Selection.ShapeRange.Flip msoFlipHorizontal
End Sub
---------------------------------------------------------------------
[横幅(m)]ボタンクリックで「横幅」サブルーチンを実行
Private Sub CommandButton15_Click()
    横幅
End Sub
---------------------------------------------------------------------
[縦幅(m)]ボタンクリックで「縦幅」サブルーチンを実行
Private Sub CommandButton16_Click()
    縦幅
End Sub
---------------------------------------------------------------------
[一点鎖線の─]ボタンクリックで「LineDrow」サブルーチンを実行
Private Sub CommandButton21_Click()
    LineDrow
End Sub
---------------------------------------------------------------------
[一点鎖線の│]ボタンクリックで「VLineDrow」サブルーチンを実行
Private Sub CommandButton22_Click()
    VLineDrow
End Sub
---------------------------------------------------------------------
[一点鎖線の＼]ボタンクリックで「LineDrow下がり」サブルーチンを実行
Private Sub CommandButton23_Click()
    LineDrow下がり
End Sub
---------------------------------------------------------------------
[一点鎖線の／]ボタンクリックで「LineDrow上がり」サブルーチンを実行
Private Sub CommandButton24_Click()
    LineDrow上がり
End Sub
---------------------------------------------------------------------
[点線の─]ボタンクリックで「TLineDrow」サブルーチンを実行
Private Sub CommandButton25_Click()
    TLineDrow
End Sub
---------------------------------------------------------------------
[点線の│]ボタンクリックで「TVLineDrow」サブルーチンを実行
Private Sub CommandButton26_Click()
    TVLineDrow
End Sub
---------------------------------------------------------------------
[点線の＼]ボタンクリックで「TLineDrow下がり」サブルーチンを実行
Private Sub CommandButton27_Click()
    TLineDrow下がり
End Sub
---------------------------------------------------------------------
[点線の／]ボタンクリックで「TLineDrow上がり」サブルーチンを実行
Private Sub CommandButton28_Click()
    TLineDrow上がり
End Sub
---------------------------------------------------------------------
[90°右]ボタンクリックで選択された図形を右へ90度回転する。
Private Sub CommandButton3_Click()
    '90°右
     Selection.ShapeRange.IncrementRotation 90#
End Sub

---------------------------------------------------------------------
[─文字]ボタンクリックで「アート文字3」サブルーチンを実行
Private Sub CommandButton34_Click()
    互換モード対応　テキストボックス/ワードアート文字の切替
    Excelのバージョン"2000","2002","2003" ---> ワードアート文字
    Excelのバージョン"2007","2010"        --->  テキストボックス文字
    N = Val(Application.Version)        <-- Excelのバージョンを取得する。
    Excelのバージョン"2000","2002","2003"の判定
    If N = 9 Or N = 10 Or N = 11 Then アート文字31: Exit Sub
    Excelのバージョン"2007","2010","2013","2016"の判定
    If N = 12 Or N = 14 Or N = 15 Or N = 16 Then アート文字3: Exit Sub
End Sub
---------------------------------------------------------------------
[│文字]ボタンクリックで「アート文字4」サブルーチンを実行
Private Sub CommandButton36_Click()
    互換モード対応　テキストボックス/ワードアート文字の切替
    Excelのバージョン"2000","2002","2003" ---> ワードアート文字
    Excelのバージョン"2007","2010"        ---> テキストボックス文字
    N = Val(Application.Version)        <-- Excelのバージョンを取得する。
    Excelのバージョン"2000","2002","2003"の判定
    If N = 9 Or N = 10 Or N = 11 Then アート文字41: Exit Sub 
    Excelのバージョン"2007","2010","2013","2016"の判定
    If N = 12 Or N = 14 Or N = 15 Or N = 16 Then アート文字4: Exit Sub
End Sub
---------------------------------------------------------------------
[↑]ボタンクリックで選択された図形の角度を+1度回転する。
Private Sub CommandButton37_Click()
    Dim kakudo1, kakudo2 As Single
    kakudo1 = UForm1.TextBox1.Value   <-- TextBox1の設定値を取得する。
    kakudo2 = kakudo1 + 1               <-- TextBox1の設定値 + 1 をする。
    '+ 1 した値をTextBox1に設定する。
    UForm1.TextBox1.Value = kakudo2 
    図形回転                            <-- 図形を回転させるサブルーチン
End Sub
---------------------------------------------------------------------
[↓]ボタンクリックで選択された図形の角度を-1度回転する。
Private Sub CommandButton38_Click()
    Dim kakudo1, kakudo2 As Single
    kakudo1 = UForm1.TextBox1.Value
    kakudo2 = kakudo1 - 1
    
    UForm1.TextBox1.Value = kakudo2
    図形回転
End Sub
---------------------------------------------------------------------
[写真貼付]ボタンクリックで「S写真選択」サブルーチンを実行
Private Sub CommandButton39_Click()
    '　図・写真貼付
    S写真選択
End Sub
---------------------------------------------------------------------
[↓]ボタンクリックで選択されている図形を下へ 0.75ポイント移動する。
※ Excelの座標の単位は、ポイントです。
　1ポイント = 1/72 インチ( 0.3528mm )
Private Sub CommandButton41_Click()
    On Error GoTo end41:             <-- エラー時のジャンプ先の設定
    Selection.ShapeRange.IncrementTop -0.75
end41:
End Sub
---------------------------------------------------------------------
[↑]ボタンクリックで選択されている図形を上へ 0.75ポイント移動する
Private Sub CommandButton42_Click()
    On Error GoTo end42:
    Selection.ShapeRange.IncrementTop 0.75
end42:
End Sub
---------------------------------------------------------------------
[←]ボタンクリックで選択されている図形を左へ 0.75ポイント移動する
Private Sub CommandButton43_Click()
    On Error GoTo end43:
    Selection.ShapeRange.IncrementLeft 0.75
end43:
End Sub
---------------------------------------------------------------------
[→]ボタンクリックで選択されている図形を右へ 0.75ポイント移動する
Private Sub CommandButton44_Click()
    On Error GoTo end44:
    Selection.ShapeRange.IncrementLeft -0.75
end44:
End Sub
---------------------------------------------------------------------
[直線の／]ボタンクリックで「LLineDrow上がり」サブルーチンを実行
Private Sub CommandButton45_Click()
    '横線
    LLineDrow
End Sub
---------------------------------------------------------------------
[直線の│]ボタンクリックで「LVLineDrow」サブルーチンを実行
Private Sub CommandButton46_Click()
    '縦線
    LVLineDrow
End Sub
---------------------------------------------------------------------
[直線の＼]ボタンクリックで「LLineDrow下がり」サブルーチンを実行
Private Sub CommandButton47_Click()
    '左下がり
    LLineDrow下がり
End Sub

---------------------------------------------------------------------
[直線の／]ボタンクリックで「LLineDrow上がり」サブルーチンを実行
Private Sub CommandButton48_Click()
    '右上がり
    LLineDrow上がり
End Sub
---------------------------------------------------------------------
[矢印縦]ボタンクリックで「矢印縦線引き」サブルーチンを実行
Private Sub CommandButton50_Click()
    矢印縦線引き
End Sub
---------------------------------------------------------------------
[矢印横]ボタンクリックで「矢印横線引き」サブルーチンを実行
Private Sub CommandButton49_Click()
    矢印横線引き
End Sub
---------------------------------------------------------------------
[90°左]ボタンクリックで図形を90°左に回転させる。
Private Sub CommandButton5_Click()
    '90°左
    Selection.ShapeRange.IncrementRotation -90#
End Sub
---------------------------------------------------------------------
長い[↓]ボタンクリックで「引出線引き」サブルーチンを実行
Private Sub CommandButton51_Click()
    引出線引き
End Sub
---------------------------------------------------------------------
[消去]ボタンクリックで選択されている図を削除する。
Private Sub CommandButton54_Click()
    On Error GoTo end54:             <-- エラー時のジャンプ先の設定
    Selection.ShapeRange.Delete
end54:
End Sub
---------------------------------------------------------------------
[セルサイズを変更]ボタンクリックでセルサイズを四角にする。
Private Sub CommandButton55_Click()
    ' シートのセルサイズを変更する

    Bname = ActiveWorkbook.Name        <-- ブック名を取得する。
    Sname = ActiveSheet.Name           <-- シート名を取得する。
    本マクロであったら強制終了する。
    If Bname = AAname Then Exit Sub
    [マクロの表紙]から、変更するセルの横・縦のサイズを取得する。
    N1 = Workbooks(AAname).Worksheets(BBname).Cells(5, 1).Value ' 横
    N2 = Workbooks(AAname).Worksheets(BBname).Cells(6, 1).Value ' 縦
    '
    互換モード対応  Excelのバージョンコードを取得し、最終横位置を決める。
    '
    N = Val(Application.Version)       <-- Excelのバージョンを取得する。
Excelのバージョンの"2000","2002","2003"時、横範囲(1～256)を
A～IVを選択する。
    If N = 9 Or N = 10 Or N = 11 Then Columns("A:IV").Select 
Excelのバージョンの"2007","2010","2013","2016"時、横範囲(1 ～ 702)を
 A ～ ZZ を選択する。
    If N = 12 Or N = 14 Or N = 15 Or N = 16 Then _
                             Columns("A:ZZ").Select
    '
        Selection.ColumnWidth = N1     <-- 横幅をN1に変更する。
        Rows("1:1000").Select          <-- 縦範囲 1 ～　1000 を選択する。
        Selection.RowHeight = N2       <-- 縦幅(セルの高さ)をN2に変更する。
        Range("A1").Select             <-- セルの範囲選択を解除する。
    '
End Sub
---------------------------------------------------------------------
[セルの幅で描画]ボタンクリックで「任意角度直線」のサブルーチンを実行
Private Sub CommandButton56_Click()
     ドラックしたセルの幅を直線の長さにする。
    CCF = 0     <-- [セルの幅で描画]ボタンクリックで 0 する。
    任意角度直線 CCF
End Sub
---------------------------------------------------------------------
[既設の直線で描画]ボタンクリックで「任意角度直線」のサブルーチンを実行
Private Sub CommandButton57_Click()
     選択した水平直線を回転する。
    CCF = 1     <-- [既設の直線で描画]ボタンクリックで 1 する。
    任意角度直線 CCF
End Sub
---------------------------------------------------------------------
【グループ化】ボタンクリックで「SHAPESのグループ化」の
サブルーチンを実行
Private Sub CommandButton58_Click()
    ' H29.01.04 追加
    ' 全ての図形 ( Shapes ) を選んでグループ化する
    SHAPESのグループ化
End Sub
---------------------------------------------------------------------
[属性変更]ボタンクリックで「属性変更」のサブルーチンを実行
Private Sub CommandButton7_Click()
    属性変更
End Sub
---------------------------------------------------------------------
UForm1の初期設定をする。
Private Sub UserForm_Initialize()
    With UForm1
        .OpB2 = True               <-- 文字の色(黒)を設定する。
        .OptionButton2 = True      <-- 線の色(黒)を設定する。
        .OptionButton4 = True      <-- 縮尺線の種類(中)を設定する。
        .OptionButton7 = True      <-- 文字の大きさ(中)を設定する。
        .OptionButton11 = True     <-- 線の種類(直線)を設定する。
        .TextBox1 = 45             <-- 図形の回転角(45度)を設定する。
        .TextBox2 = 100            <-- 縮尺率(1/100)を設定する。
    End With
End Sub
----------------------   ここから　module1のコード    --------------------
マクロブック・シートの名前を定義、変数の宣言
    '----------------------------------------------------
'       簡易ＣＡＤもどきマクロ
'
'        このマクロを自由に改造することは、勝手にどうぞ
'　　　　ただし、結果に対する責任は、負いません。
'
    '----------------------------------------------------
    Public Bname, Sname, Fname, Rname, RBname As String
    Public x, y, x1, y1, x2, y2, x3, x4, hosei As Long
    Public mm, N, N1, N2, N3, N4, nn, ii, iii, Bcnt As Integer
    Public CNT, Scnt, zz, kzu As Integer
' AAnameとBBnameは、変更しないでください。
' ブック名を変更した時は、AAnameの名前も、ブック名に変更してください。
    Public Const AAname As String = "簡易CADマクロ.xlsm"
    Public Const BBname As String = "表紙"
    Public Const PI As Double = 3.14159265358979
    ' ネットワークドライブの参照
        Public Declare Function SetCurrentDirectory _
                Lib "kernel32" Alias "SetCurrentDirectoryA" _
                                 (ByVal lpPathName As String) As Long

-----------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
    '----------------------------------------------------
    '  Excel 起動時にメニューバーをアドインに移動させる処理
    '----------------------------------------------------

    この様にしないといつまでも Excelブックがオープンしない
     ' タイムディレー処理直ぐに、サブルーチン AddIN を実行させる
    Application.OnTime Now + TimeValue("00:00:00"), "AddIN"   
                                                  
End Sub
-----------------------------------------------------------------------
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
    Sheets(BBname).Select            <---- 所定のシートを表示させる
    N = Val(Application.Version)     <---- Excelのバージョンを取得する
     
    Excelのバージョンの"2000 ; 9","2002 ; 10","2003 ; 11"時は、何もしない
    If N = 9 Or N = 10 Or N = 11 Then Exit Sub
    
Excelのバージョンの"2007 ; 12","2010 ; 14","2013 ; 15","2016 ; 16"時は、
アドインに移動
' [ALT]-->[X]-->[ALT]のキー入力を実行
    Application.SendKeys ("%X%")
    
End Sub
---------------------------------------------------------------------
アドインの表示処理
Sub B01セット()
    Dim Mycontrol As CommandBarControl
    Dim mysubmenu As CommandBarControl
    Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
    Controls.Add(msoControlPopup)
    Mycontrol.Caption = "【■】"
    Mycontrol.OnAction = "表示"
End Sub
---------------------------------------------------------------------
アドインの削除処理 
Sub B02リセット()
    On Error Resume Next
    CommandBars("Worksheet Menu Bar").Controls("【■】").Delete
    Unload UForm1
End Sub
---------------------------------------------------------------------
ニーザーフォームの表示処理
Sub Show表示()
　　vbModelessを付けるとユーザーフォームの表示位置を
    自由に移動できるようになる。
    UForm1.Show vbModeless
End Sub
---------------------------------------------------------------------
ニーザーフォームの表示位置を表示するサブルーチン
Sub ichi()
    With UForm1
　　ユーザーフォームUForm1の表示位置を左・上位置を取得表示する。
      MsgBox "Left=" & .Left & " " & "Top=" & .Top
    End With
End Sub
---------------------------------------------------------------------
セルの結合を解除するサブルーチン
Sub 結合解除()
    Selection.ShapeRange.Ungroup.Select
End Sub
---------------------------------------------------------------------
セルを結合するサブルーチン
Sub 結合()
    Selection.ShapeRange.Group.Select
End Sub
---------------------------------------------------------------------
すべての図形の属性「図形セルのサイズ変更しても追従させない」に
変更するサブルーチン
Sub 属性変更()
    Dim kzu, N As Long
'
' 図形セルのサイズ変更しても追従させない。
'
    kzu = ActiveSheet.Shapes.Count     <-- 図形の数を取得する。
    For N = 1 To kzu                   <-- すべての図形に対して処理する。
    ActiveSheet.Shapes(N).Select
        With Selection
            .Placement = xlFreeFloating   <-- セルに合わせて移動しない設定
            .PrintObject = True   <-- オブジェクトを印刷するに設定
        End With
    Next N
    MsgBox "変更おわり"           <-- 設定終了メッセージ
End Sub
---------------------------------------------------------------------
「全ての図形 ( Shapes ) を選んでグループ化する」サブルーチン
Sub SHAPESのグループ化()
  ' H29.01.04 追加
  With ActiveSheet.Shapes
    If .Count >= 2 Then   ' Shapes が二個以上の時だけ有効
      .SelectAll                            '全ての Shapes を選択する
      Selection.ShapeRange.Group.Select     'グループ化をする
      Selection.Placement = xlFreeFloating  'セル幅に対して移動させない指定
    End If
  End With
End Sub
---------------------------------------------------------------------
選択されたセル位置に横直線を引くサブルーチン
Sub LLineDrow()
選択されたセル座標を取得する。
With Selection
    x1 = .Left      <-- セルの左からの位置座標値
    y1 = .Top       <-- セルの上からの位置座標値
    x2 = .Width     <-- セルの幅の値
    y2 = .Height    <-- セルの高さの値
End With
    直線を表示する。
    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1 + y2).Select
()内の説明 : ([始点の横位置],[始点の縦位置],[終点の横位置],[終点の縦位置])

    Selection.ShapeRange.Line.Weight = 0.75       <-- 線の太さ
    Selection.ShapeRange.Line.Visible = msoTrue   <-- 線を表示
    線の色を設定する。
    カラーインデックス番号は、10:赤 8:黒 7:シアン 6:マゼンタ
     5:黄 4:青 3:緑 2:赤 1:白
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    線の色 黒が選択されていたら、黒にする。
    If UForm1.OptionButton2 = True Then _
                     Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    線の始点と終点の処理 ---- 矢印なし
    ' 始点
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
msoArrowheadNone
    ' 終点
    Selection.ShapeRange.Line.EndArrowheadStyle = _
msoArrowheadNone
RGBコードでは、
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0) と
書きます。
End Sub
---------------------------------------------------------------------

---------------------------------------------------------------------
選択されたセル位置に縦直線を引くサブルーチン
Sub LVLineDrow()
「LLineDrow」と同じですので解説を省略します。
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

  ActiveSheet.Shapes.AddLine(x1, y1, x1, y1 + y2).Select
  Selection.ShapeRange.Line.Weight = 0.75
  Selection.ShapeRange.Line.Visible = msoTrue
  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
  If UForm1.OptionButton2 = True Then _
               Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
  Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone
  Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone
  
End Sub
---------------------------------------------------------------------
選択されたセル位置に斜め下がり直線を引くサブルーチン
Sub LLineDrow下がり()
「LLineDrow」と同じですので解説を省略します。
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

  ActiveSheet.Shapes.AddLine(x1, y1, x1 + x2, y1 + y2).Select
    
  Selection.ShapeRange.Line.Weight = 0.75
  Selection.ShapeRange.Line.Visible = msoTrue
  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
  If UForm1.OptionButton2 = True Then _
               Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
  Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone
  Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone
 
End Sub
---------------------------------------------------------------------
選択されたセル位置に斜め上がり直線を引くサブルーチン
Sub LLineDrow上がり()
「LLineDrow」と同じですので解説を省略します。
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

  ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1).Select
  
  Selection.ShapeRange.Line.Weight = 0.75
  Selection.ShapeRange.Line.Visible = msoTrue
  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
  If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
  Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone
  Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone
   
End Sub
---------------------------------------------------------------------
選択されたセル位置に両矢印の縦直線を引くサブルーチン
Sub 矢印縦線引き()
'
' 矢印縦線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1, y1 + y2).Select

    If UForm1.OptionButton2 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    If UForm1.OptionButton1 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
 
    Selection.ShapeRange.Line.Weight = 0.5
    ' 透明度の設定(不透明)
    Selection.ShapeRange.Line.Transparency = 0#
    透明度は、0(不透明) ～ 1(透明)
    Selection.ShapeRange.Line.Visible = msoTrue      <-- 表示をする設定
    線の始点と終点の処理
    始点側 : 矢印の長さ 中
    Selection.ShapeRange.Line.BeginArrowheadWidth = _
 msoArrowheadWidthMedium  
    始点側 : 開いた矢印
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
 msoArrowheadOpen         
    終点側 : 矢印の長さ 中
    Selection.ShapeRange.Line.EndArrowheadWidth = _
 msoArrowheadWidthMedium    
    終点側 : 開いた矢印
    Selection.ShapeRange.Line.EndArrowheadStyle = _
 msoArrowheadOpen           
End Sub
---------------------------------------------------------------------
選択されたセル位置に両矢印の横直線を引くサブルーチン
「矢印縦線引き」と同じですので解説を省略します。
Sub 矢印横線引き()
'
' 矢印横線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1 + y2).Select

    If UForm1.OptionButton2 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    If UForm1.OptionButton1 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
   
    Selection.ShapeRange.Line.Weight = 0.5
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    
    Selection.ShapeRange.Line.BeginArrowheadWidth = _
 msoArrowheadWidthMedium
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
 msoArrowheadOpen
    Selection.ShapeRange.Line.EndArrowheadWidth = _
 msoArrowheadWidthMedium
    Selection.ShapeRange.Line.EndArrowheadStyle = _
 msoArrowheadOpen
    
End Sub
---------------------------------------------------------------------
選択されたセル位置に片矢印の縦直線を引くサブルーチン
Sub 引出線引き()
'
' 引出線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1, y1 + y2).Select

    If UForm1.OptionButton2 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    If UForm1.OptionButton1 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
 
    Selection.ShapeRange.Line.Weight = 0.5
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    始点は、矢印なし
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
 msoArrowheadNone
    終点は、三角矢印
    Selection.ShapeRange.Line.EndArrowheadStyle = _
 msoArrowheadTriangle
    終点側 : 矢印の幅 中
    Selection.ShapeRange.Line.EndArrowheadWidth = _
 msoArrowheadWidthMedium
    終点側 : 矢印の長さ 中
    Selection.ShapeRange.Line.EndArrowheadLength = _
 msoArrowheadLengthMedium

End Sub
----------------------   ここから　module2のコード    -----------------
選択された図形の座標位置を表示するサブルーチン
このマクロは、「マクロの実行」から実行できます。
Sub a図形位置サイズ()

With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    MsgBox Format(x1, "#,##0") + "   " + Format(y1, "#,##0") + "   " 

End Sub
---------------------------------------------------------------------
ページ内のすべての図形を消去するサブルーチン
このマクロは、「マクロの実行」から実行できます。
Sub a図形消去()
    Dim Lx1 As Long
    On Error Resume Next
    Lx1 = ActiveSheet.Shapes.Count     <-- 図形の数を取得する。
    '
    If Lx1 = 0 Then Exit Sub           <-- 図形が無い時は、終了する。
    For x1 = 0 To Lx1
      ActiveSheet.Shapes(x1).Delete    <-- x1番目の図形を消去する。
    Next x1
    
End Sub
---------------------------------------------------------------------
選択されたセル位置に写真を張付けるサブルーチン
Sub S写真選択()
'
    On Error GoTo errorend0:
    Dim LN As Single
    Dim Xichi1, Xhaba, Yichi1, Yhaba, Xichi, Yichi As Single
    Dim Zom As Long
    Dim myFname, Gname, Tname As String
    Dim F_array As Variant
    Dim A_cnt, C_cnt, L_cnt As Integer
    
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value

    If ADir <> "" Then
       If Left(ADir, 2) = "\\" Then
	  ' ネットワークドライブの参照
          Call SetCurrentDirectory(ADir) <-- ネットワークドライブの参照 
       Else
          ChDrive Left(ADir, 2)          <-- PC内ドライブの参照
          ChDir ADir
       End If
    End If
    
    写真選択のダイヤログを表示し、張付ける写真を指定してもらう。
    myFname = Application.GetOpenFilename("写真ファイル _
      (*.JPG;*.BMP;*.GIF;*.WMF;*.TIF),*.JPG;*.BMP;*.GIF;*.WMF;*.TIF")
    If myFname = False Then Exit Sub      <---- 何も選択されない時の処理
    '
    '-------------------------------------------------------------------
    ' 次読込の為のパスを記録する。
       ' 次読込の為のパスを記録する。
        AAA = myFname
        nn = Len(AAA): XX = 1
パス設定AA:
        N = InStr(XX, AAA, "\")
        If N <> 0 Then M = N: XX = N + 1: GoTo パス設定AA:
        N = M
        ' 読込側のパス設定
        Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value = _
         Left(AAA, N - 1)
    '-------------------------------------------------------------------
    ' 2019.02.05　写真貼り付け方法を改良( 簡素化出来ました )
    ' 下記マクロが、アクティブセルに張り付く事に注目しました。
    ' Left:=Selection.Left, Top:=Selection.Top でアクティブセルに貼付
    ' width:=Xhaba, height:=Yhaba で貼付サイズ指定
    '-------------------------------------------------------------------
   写真を貼付けるセルのサイズデータ( 幅・高さ )を取得する。
        With Selection
            Xhaba = .Width
            Yhaba = .Height
        End With

      Set objShape = ActiveSheet.Shapes.AddPicture( _
          filename:=myFname, _     <-- 挿入する写真ファイル名を
                                                パス付きで指定
          LinkToFile:=False, _     <-- False で独立した写真としての指定
                                       True で元のファイルとのリンクを設定
          SaveWithDocument:=True, _ <-- True で Excelファイルと共に保存
                                          False でリンク情報だけを保存
          Left:=Selection.Left, _  <-- アクティブセルの左端位置を指定
          Top:=Selection.Top, _    <-- アクティブセルの上端位置を指定
          Width:=Xhaba, _          <-- 張付け写真の横幅を指定
          Height:=Yhaba)           <-- 張付け写真の高さを指定
          
          写真表面に文字・図形が描けるように、表示順序を最背面にする。 

          objShape.ZOrder msoSendToBack

　　Exit Sub

errorend0:
    'N = Err.Number
    'If N = 76 Then MsgBox ("デフォルトパスに移動します。")
    保存されている参照パスが、無効の時にはデフォルトパスのにする。
    ADir = Application.DefaultFilePath: GoTo S写真選択00:
End Sub

---------------------------------------------------------------------
された選択図形をTextBox1の値分回転するサブルーチン
Sub 図形回転()
    On Error GoTo 図形回転end:     　 <-- エラーの時のジャンプ先を
                                                指定する。
    kakudo = Val(UForm1.TextBox1.Value)     <-- TextBox1の設定値を
                                                取得し、数値に変換する。
    Selection.ShapeRange.Rotation = kakudo  <-- 選択された図形を
                                                回転する。
図形回転end:
End Sub
---------------------------------------------------------------------
テキストボックスで文字を表示するサブルーチン
Sub アート文字3()
    Dim Msize, Wsize, LN As Single
    
    On Error GoTo アート文字3end:  <-- エラーの時のジャンプ先を指定する。
    文字を表示する位置の座標値を取得する。
    With Selection
        x1 = .Left
        y1 = .Top
    End With
    オプションボタンの選択状況から文字の大きさを決める。
　　   ' 文字サイズ 標準
    If UForm1.OptionButton6 = True Then Msize = 7: Wsize = 20
　    ' 文字サイズ 中
    If UForm1.OptionButton7 = True Then Msize = 10: Wsize = 30
　    ' 文字サイズ 大
    If UForm1.OptionButton8 = True Then Msize = 14: Wsize = 40
   
    ss = InputBox("文字を入力して下さい。") 　<-- 表示する文字の入力。
    表示する文字数からテキストボックスのサイズを計算する。
    LN = Len(ss): LN = 10 + LN * 8.5
    テキストボックスを表示する。
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
        x1, y1, LN, Wsize).Select
    テキストボックスの文字サイズを設定する。
    Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Msize
    
    If UForm1.OpB2 = True Then 　　　   <--- 文字色 黒の時の処理
       With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue　　　        <--- 文字表示する
        .ForeColor.RGB = RGB(0, 0, 0)   <--- 文字色 黒
        文字の色をRGBの三原色の配列で指定する方法です。
        .Transparency = 0　　　         <--- 文字の透明度(不透明)
        .Solid
       End With
    End If
    If UForm1.OpB1 = True Then 　　　   <--- 文字色 赤の時の処理
       With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0) 　　　   <--- 文字色 赤
        .Transparency = 0
        .Solid
      End With
    End If
    テキストボックスの文字を設定する。
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ss
   
    Selection.ShapeRange.Line.Visible = msoFalse
          ' 背景の透明度の設定(透明)
    Selection.ShapeRange.Fill.Transparency = 1
    透明度は、0(不透明) ～ 1(透明)

アート文字3end:
End Sub
---------------------------------------------------------------------
テキストボックスで文字(横向き縦方向)を表示するサブルーチン
Sub アート文字4()
    アート文字3
    アート文字3で表示した文字を 270度回転する。
    Selection.ShapeRange.Rotation = 270#
アート文字4end:
End Sub
---------------------------------------------------------------------
ワードアートで文字(横文字)を表示するサブルーチン
Sub アート文字31()
    Dim Msize, Wsize As Single
    On Error GoTo アート文字31end: <--- エラーの時のジャンプ先を指定
    文字を表示する位置の座標値を取得する。
    With Selection
        x1 = .Left
        y1 = .Top
    End With
    オプションボタンの選択状況から文字の大きさを決める。
    ' 文字サイズ 標準
    If UForm1.OptionButton6 = True Then Msize = 5.4: Wsize = 6
　    ' 文字サイズ 中
    If UForm1.OptionButton7 = True Then Msize = 7: Wsize = 9
    ' 文字サイズ 大
    If UForm1.OptionButton8 = True Then Msize = 10: Wsize = 11
    ss = InputBox("文字を入力して下さい。") 　　 <-- 表示する文字の入力。
    入力された文字でワードアートで文字を表示する。
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, ss, _
           "ＭＳ Ｐゴシック", Wsize, msoFalse, msoFalse, x1, y1).Select
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10　 <-- 文字色 赤
     「文字の色」の文字色オプションボタンの黒が、選択された時、黒にする。
    If UForm1.OpB2 = True Then _
          Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.Visible = msoFalse　　 <-- 文字表示設定
　　msoFalse を設定すると、サイズを変更するときに
    図形の高さと幅を個別に変更できます。
    msoTrue を設定すると、指定した図形のサイズを変更しても
    元の比率が保持されます。
    Selection.ShapeRange.LockAspectRatio = _
                         msoFalse  <-- 文字サイズ変更可に設定
    Selection.ShapeRange.Height = Msize　　          <-- 文字高さの設定

アート文字31end:
End Sub
---------------------------------------------------------------------
ワードアートで文字(横向き縦方向)を表示するサブルーチン
Sub アート文字41()
    Dim Msize, Wsize As Single
    On Error GoTo アート文字41end: 　 <--- エラーの時のジャンプ先を指定
    With Selection
        x1 = .Left
        y1 = .Top
    End With
    
    If UForm1.OptionButton6 = True Then Msize = 5.4: Wsize = 6
    If UForm1.OptionButton7 = True Then Msize = 7: Wsize = 9
    If UForm1.OptionButton8 = True Then Msize = 10: Wsize = 11
    
    ss = InputBox("文字(縦書き)を入力して下さい。")
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, ss, _
       "ＭＳ Ｐゴシック", Wsize, msoFalse, msoFalse, x1, y1).Select
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
    If UForm1.OpB2 = True _
             Then Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Msize
    アート文字31で表示した文字を 270度回転する。
    Selection.ShapeRange.Rotation = 270# 
アート文字41end:
End Sub
---------------------------------------------------------------------
横の一点鎖線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub LineDrow()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1 + y2).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
    線種を一点鎖線にする。
    Selection.ShapeRange.Line.DashStyle = msoLineLongDashDot
End Sub
---------------------------------------------------------------------
縦の一点鎖線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub VLineDrow()
'
' 直線線引き Macro

With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1, y1 + y2).Select
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                      msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                      msoArrowheadNone
    Selection.ShapeRange.Line.DashStyle = msoLineLongDashDot
End Sub
---------------------------------------------------------------------
右下がりの一点鎖線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub LineDrow下がり()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1 + x2, y1 + y2).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.DashStyle = msoLineLongDashDot
End Sub
---------------------------------------------------------------------
右上がりの一点鎖線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub LineDrow上がり()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.DashStyle = msoLineLongDashDot
End Sub
---------------------------------------------------------------------
横の点線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub TLineDrow()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1 + y2).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    線種を点線にする。
    Selection.ShapeRange.Line.DashStyle = msoLineDash
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
     
End Sub
---------------------------------------------------------------------
縦の点線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub TVLineDrow()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1, y1 + y2).Select
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.DashStyle = msoLineDash
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
End Sub
---------------------------------------------------------------------
右下がりの点線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub TLineDrow下がり()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1, x1 + x2, y1 + y2).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.DashStyle = msoLineDash
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                      msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                      msoArrowheadNone
     
End Sub
---------------------------------------------------------------------
右上がりの点線を引くサブルーチン
「矢印縦線引き」とほぼ同じですので解説を省略します。
Sub TLineDrow上がり()
'
' 直線線引き Macro
'
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

    ActiveSheet.Shapes.AddLine(x1, y1 + y2, x1 + x2, y1).Select
    
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.DashStyle = msoLineDash
    Selection.ShapeRange.Line.BeginArrowheadStyle = 
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
     
End Sub
---------------------------------------------------------------------
縮尺した横の直線を引くサブルーチン
Sub 横幅()
    Dim Sizu As Single
    ｍ単位の長さの入力。
    If UForm1.CheckBox1 = False Then mm = _
                        Application.InputBox("横幅(m)を入力")
    1間単位の長さの入力。
    If UForm1.CheckBox1 = True Then mm = _
                        Application.InputBox("横幅(1間単位)を入力")
    縮尺計算をする。標準は、1/100としています。
    nn = 1 / ((UForm1.TextBox2) / 100)
    縮尺補正値を「マクロの表紙」から取得する。
    hosei = Workbooks(AAname).Worksheets(BBname).Cells(15, 1).Value
    1間単位の表示長を計算する。
    If UForm1.CheckBox1 = False Then mm = mm * 28.4 * nn * hosei
    ｍ単位の表示長を計算する。。
    If UForm1.CheckBox1 = True _
                  Then mm = mm * 28.4 * nn * 1.818 * hosei
    線を表示するセル位置の座標値を取得する。。
    With Selection
        x = .Left
        y = .Top
    End With
    ActiveSheet.Shapes.AddLine(x, y, x + mm, y).Select
  　' 線種 直線を指定する。
    Selection.ShapeRange.Line.Style = msoLineSingle
    線を太さを決定する。。
    If UForm1.OptionButton3 = True Then Sizu = 0.75　<-- 細い線
    If UForm1.OptionButton4 = True Then Sizu = 1.5　 <-- 少し太い線
    If UForm1.OptionButton5 = True Then Sizu = 3: _　<-- 間取りの線
              Selection.ShapeRange.Line.Style = msoLineThinThin
    Selection.ShapeRange.Line.Weight = Sizu　        <-- 線種 直線を指定
    Selection.ShapeRange.Line.Visible = msoTrue　    <-- 線種 直線を指定
    表示する線の表示順序を指定する。
           msoBringToFront …最前面に移動する。
　        msoSendToBack　 …最背面に移動する。
　        msoBringForward …前面に移動する。 
　        msoSendBackward …背面に移動する。
    Selection.ShapeRange.ZOrder msoSendToBack        <-- 最背面に移動
    線の両端 矢印なしに設定する。
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
　  ' 影を表示しないを指定する。
    Selection.ShapeRange.Shadow.Visible = msoFalse
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
              Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
End Sub
---------------------------------------------------------------------
縮尺した縦の直線を引くサブルーチン
「横幅」とほぼ同じですので解説を省略します。
Sub 縦幅()
    Dim Sizu As Single
    If UForm1.CheckBox1 = False Then mm = _
               Application.InputBox("縦幅(m)を入力")
    If UForm1.CheckBox1 = True Then mm = _
          Application.InputBox("縦幅(1間単位)を入力")
    nn = 1 / ((UForm1.TextBox2) / 100)
    hosei = Workbooks(AAname).Worksheets(BBname).Cells(15, 1).Value
    If UForm1.CheckBox1 = False Then mm = mm * 28.4 * nn * hosei
    If UForm1.CheckBox1 = True Then _
                             mm = mm * 28.4 * nn * 1.818 * hosei
    With Selection
        x = .Left
        y = .Top
    End With
    ActiveSheet.Shapes.AddLine(x, y, x, y + mm).Select
    Selection.ShapeRange.Line.Style = msoLineSingle
    If UForm1.OptionButton3 = True Then Sizu = 0.75
    If UForm1.OptionButton4 = True Then Sizu = 1.5
    If UForm1.OptionButton5 = True Then Sizu = 3: _ 
           Selection.ShapeRange.Line.Style = msoLineThinThin
    Selection.ShapeRange.Line.Weight = Sizu
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.ZOrder msoSendToBack
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                      msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                      msoArrowheadNone
    Selection.ShapeRange.Shadow.Visible = msoFalse
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
    If UForm1.OptionButton2 = True Then _
          Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
End Sub
------------------------   ここから　module3のコード    -------------
任意角度の直線を引くサブルーチン
    Dim CF As Long
    '-------------------------------------
Sub 任意角度直線(CCF As Variant)
    Dim DDeg As Variant
     ドラック範囲の座標値を取得する。
    With Selection
        x1 = .Left
        y1 = .Top
        x2 = .Width
        y2 = .Height
	y1 =y1 - y2     <---  座標値の起点がセルの左上なので左下に移動
    End With
      既設の水平線を回転か？
    If CCF = 1 Then
         水平線かチェックする。
        If y2 <> 0 Then Exit Sub     <--- 水平線でない時には、強制終了
            Selection.ShapeRange.Delete    <--- 元の線は、消去
    End If
    '
    InData = UForm1.TextBox3.Text
     文字列 ｢度-分-秒｣を度(360進表示)に変換する
    Atext_deg InData, textdeg
     エラー処理 データ未設定時には、強制終了
    If textdeg = "" Then Exit Sub
    　直角方向は、特別処理をする。
    If textdeg = 90 Or textdeg = -90 Or textdeg = 180 Or _
                                             textdeg = 270 Then
        If textdeg = 180 Then x2 = -x2: y2 = 0
        If textdeg = 90 Then y2 = x2: x2 = 0
        If textdeg = -90 Or textdeg = 270 Then y2 = -x2: x2 = 0
    Else
                         PI = 3.14159265358979
        DDeg = textdeg * PI / 180       <---  度(360進)をラジアン値にする。
         基準位置からの、高さ(y2)と底辺長(x2)を求める。
        y2 = x2 * Sin(DDeg): x2 = x2 * Cos(DDeg)
        
    End If
      ドラック位置を基準に直線を引く
    ActiveSheet.Shapes.AddLine(x1, y1, x1 + x2, y1 - y2).Select
    '
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
     線の色 赤指定か？
    If UForm1.OptionButton2 = True Then _
                  Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                     msoArrowheadNone
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                     msoArrowheadNone
    '
    With UForm1
         一点鎖線
        If .OptionButton9 = True Then _
                Selection.ShapeRange.Line.DashStyle = msoLineLongDashDot
         点線
        If .OptionButton10 = True Then _
                Selection.ShapeRange.Line.DashStyle = msoLineDash
         以外は、直線
    End With
  
End Sub
---------------------------------------------------------------------
文字列 ｢度-分-秒｣を度(360進表示)に変換するくサブルーチン
  " 10-20-30" ---->  10.34166667
 引  数 : InData(度-分-秒)   As Variant
 戻り値 : textdeg(度)        As Variant

Sub Atext_deg(InData, textdeg As Variant)
    Dim MPt As Long
    Dim MS As String
     角度はマイナスか?(先頭に"-"有るかをチェック)
    CF = 0: N = Len(InData)
     先頭に"-"有るときは、フラグをONにして、"-"取り去る。
    If Left(InData, 1) = "-" Then CF = 1:  InData = Mid(InData, 2, N - 1)
    '------------------------------------------
     データ未設定　エラー処理
    If InData = "" Then textdeg = "": Exit Sub
        MPt = InStr(InData, "-")         <---  分の区切り"-"位置検出
        MPt=0  --> 度のみ
        MPt<>0 --> 度-分のみ
     度のみの処理
    If MPt = 0 Then AAA = InData: BBB = "0": CCC = "0": _
                                               GoTo text_deg00:
    '------------------------------------------
    N = Len(InData)                     <---  文字数
    AAA = Left(InData, MPt - 1)         <---  度のデータ抽出
    BBB = Mid(InData, MPt + 1, N - MPt) <---  分-秒データのみにする。
    MPt = InStr(BBB, "-")               <---  秒の区切り"-"位置検出
        MPt=0  --> 度-分のみ
        MPt<>0 --> 度-分-秒
    If MPt = 0 Then
         度-分のみの処理
        CCC = "0"
    Else
         度-分-秒の処理
        DDD = BBB
        N = Len(DDD)
        BBB = Left(DDD, MPt - 1)              <---  分のデータ抽出
        CCC = Mid(DDD, MPt + 1, N - MPt)      <---  秒のデータ抽出
    End If
    '------------------------------------------
text_deg00:
     度(AAA)・分(BBB)・秒(CCC)の文字列を角度(360進)の数値に変換する。
    textdeg = Val(AAA) + Val(BBB) / 60 + Val(CCC) / 3600
     角度を -360 <= 角度 <=360 に変換する
    If textdeg > 360 Then AM360 InData, DEG: textdeg = DEG
     元データが、マイナス時には、マイナスにする。
    If CF = 1 Then textdeg = -textdeg
End Sub
---------------------------------------------------------------------
角度を -360 <= 角度 <=360にするサブルーチン
 引  数 : InData(度.分秒 or 度)  As Variant
 戻り値 : PM360 (度.分秒 or 度)  As Variant

Sub AM360(InData, PM360 As Variant)
   データ未設定　エラー処理
  If InData = "" Then PM360 = "": Exit Sub
  
  Else
      CF = 0
       角度はマイナスか?
      マイナスとの時には、絶対値を取りプラスの値にする。
      If InData < 0 Then CF = 1: InData = Abs(InData)  <-- 絶対値を取る。
       360より大きい時には、360以内にする。
                         (元データ)÷360の整数値に、360を掛けて引く
      If InData > 360 Then InData = InData - Int(InData / 360) * 360
       元データが、マイナス時には、マイナスにする
      If CF = 1 Then InData = -InData
      PM360 = InData      <---  変換結果を設定する。
  End If
End Sub