構内常駐の業者さんが、作業指示書に手書きで矢印線を書いていたので、人助けしたくなったのさ ー 図形オートシェイプ（ＶＢＡ）

       

エクセルには、オートシェープで図形を描く機能があり、よく使うと思います。

中でも、スケジュール表で矢印を引くのに重宝しますが、書式設定が面倒だな。

以外に手間取るので、よく使う設定を固定したプログラムをVBAで作りたいな。

そう思ってプログラムを書いてみたので、アップしますから参考にして下さい。

先ず、このプログラムを書いたブックを作って適当なフォルダーに保存します。

次に、矢印を書き込む必要のあるブックを、フォルダーに移動させておきます。

それから、プログラムのブックを開くと、ターゲットのファイルが開きますな。

もちろん、プログラムのブックは邪魔にならないように、最小化にしておいた。

それから、このフォルダーに目的以外のファイルがあるとブックは開きません。

加えて、線を引くコマンドをショートカットキーで実行できるようにしました。

先ず、セル範囲を指定すると、[F6]キーが縦線で、[F7]キーで横線が引けます。

ブックを閉じると機能は解除されるので、別ブックを開いても影響されません。

仕事上、初心者でも手軽に使えるように配慮して、コードを書いてみた次第ね。

両端に矢印を引く設定しかありませんが、線の太さ、矢印の大きさは変更可能。

変数が数値設定なので自分の好みに変えてもＯＫで、色々と試してみください。

というわけで、オートシェープ機能を、ＶＢＡで制御するのは奥が深いと思う。

先ず手始めに、資料作りなどで多用する矢印を、描きやすいようにＶＢＡプログラム化してみただけのことで、これから他のシェープに用途が見つかったのなら、コツコツとコードを書いてみようかと思った、自分なのでした。

<ThisWorkbookの記述>

Private Sub Workbook_Open() 'ショートカットキー設定

  Application.OnKey "{F6}", "VrtclLine"

  Application.OnKey "{F7}", "HrztlLine"

    Application.WindowState = xlMinimized

      Call TrgtFleOpn

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

  Application.OnKey "{F6}", ""

  Application.OnKey "{F7}", "" 'ショートカットキー設定解除

End Sub

<Module1の記述> ※参照設定：Microsoft Scripting Runtimが必要

Sub TrgtFleOpn()  'フォルダー内ターゲットファイルオープン

Dim fso As FileSystemObject, fl As Folder, f As File

  Set fso = New FileSystemObject ' インスタンス化

  Set fl = fso.GetFolder(ThisWorkbook.Path & "\") ' フォルダを取得

If fl.Files.Count > 3 Or fl.Files.Count < 3 Then ThisWorkbook.Close SaveChanges:=False

  For Each f In fl.Files ' フォルダ内のファイルを取得

    If f.Name = ThisWorkbook.Name Or Mid(f.Name, 2, 1) = "$" Then GoTo Skip

    If Not (Right(f.Name, 4) = "xlsx") Then GoTo Skip

    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & f.Name

    Application.WindowState = xlMaximized

Skip:

  Next

    Set fso = Nothing

End Sub

Sub VrtclLine() '垂直両端矢印線

Dim R As Range

Set R = Selection

  With ActiveSheet.Shapes. _

    AddLine(R.Left + R.Width / 2, R.Top, R.Left + R.Width / 2, R.Top + R.Height).Line

      .ForeColor.RGB = RGB(0, 0, 255)

      .Style = 1　'直線

      .BeginArrowheadStyle = 3　’先端矢印幅広

      .BeginArrowheadLength = 3　'先端矢印長さ

      .EndArrowheadStyle = 3　'終端矢印幅広

      .EndArrowheadLength = 3　'終端矢印長さ

      .Weight = 2　'線の太さ

    End With

End Sub

Sub HrztlLine()  '水平両端矢印線

Dim R As Range

Set R = Selection

  With ActiveSheet.Shapes. _

    AddLine(R.Left, R.Top + R.Height / 2, R.Left + R.Width, R.Top + R.Height / 2).Line

    .ForeColor.RGB = RGB(0, 0, 255)

      .Style = 1

      .BeginArrowheadStyle = 3　’先端矢印幅広

      .BeginArrowheadLength = 3　'先端矢印長さ

      .EndArrowheadStyle = 3　'終端矢印幅広

      .EndArrowheadLength = 3　'終端矢印長さ

      .Weight = 2　'線の太さ

End With

End Sub

フォルダの作り方

いいねと思ったら、三つポチっとね！
  
にほんブログ村    にほんブログ村      にほんブログ村