t-hom’s diary

主にVBAネタを扱っているブログです。

VBA ユーザーフォームでDual Listboxを作成

今回紹介するのは、複数アイテムの選択でよく見かけるDual Listbox UI。
f:id:t-hom:20190323193129p:plain

一応説明しておくと、左のリストからアイテムを選択し、右へ移動させ、最終的に右にあるものが選択したアイテムとして扱われるユーザーインターフェースだ。

構造はそれほど難しくないが、作ってみたら意外に手間だったので記事に残しておく。

フォームデザイン

各部のオブジェクト名は次のとおり設定する。
f:id:t-hom:20190323201332p:plain

AvailableListBoxとSelectedListBoxには次の値を設定する。

BorderStyle 1 - fmBorderStyleSingle
MultiSelect 2 - fmMultiSelectExtended

その他、全コントロールのフォントをMeiryo UIに設定する。

TabIndexは次のように設定したが、適宜お好みで良いと思う。
f:id:t-hom:20190323194913p:plain

コード

フォームモジュール DualListBoxForm のコード

このコードのポイントは外部から直接フォームをShowさせるのではなく、OpenForm関数の呼び出しによってフォームモジュール内部からShowさせていること。

通常はメインコードでモーダルフォームをShowし、フォーム操作の後にフォームをHideする。
そのフォームで選択された結果を取得するコードもメインコードに書かなければならない。
しかし今回の方法なら、モーダルフォームのクローズから状態取得までを関数に内包させることができ、メインコードが汚れずに済む。

Option Explicit
Public OKClicked As Boolean

Public Function OpenForm(string_collection As Collection, Optional caption_ As String = "Dual ListBox") As Collection
    Me.Caption = caption_
    Dim ret As Collection
    Dim s
    For Each s In string_collection
        AvailableListBox.AddItem s
    Next
    Me.Show
    If OKClicked Then
        Set ret = New Collection
        Dim i As Long
        For i = 0 To SelectedListBox.ListCount - 1
            ret.Add SelectedListBox.List(i)
        Next
    Else
        'ret keeps Nothing
    End If
    Set OpenForm = ret
    Unload Me
End Function

Private Sub AddButton_Click()
    MoveSelectedItems AvailableListBox, SelectedListBox
End Sub

Private Sub AvailableListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    MoveSelectedItems AvailableListBox, SelectedListBox
End Sub

Private Sub RemoveButton_Click()
    MoveSelectedItems SelectedListBox, AvailableListBox
End Sub

Private Sub SelectedListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    MoveSelectedItems SelectedListBox, AvailableListBox
End Sub

Private Sub AddAllButton_Click()
    MoveSelectedItems AvailableListBox, SelectedListBox, True
End Sub

Private Sub RemoveAllButton_Click()
    MoveSelectedItems SelectedListBox, AvailableListBox, True
End Sub

Private Sub OKButton_Click()
    OKClicked = True
    Me.Hide
End Sub

Private Sub CancelButton_Click()
    Me.Hide
End Sub

Private Sub MoveSelectedItems(from_list As MSForms.ListBox, to_list As MSForms.ListBox, Optional target_all As Boolean = False)
    Dim i As Long
    For i = from_list.ListCount - 1 To 0 Step -1
        If from_list.Selected(i) Or target_all Then
            Dim j As Long
            For j = 0 To to_list.ListCount - 1
                If to_list.List(j) >= from_list.List(i) Then
                    Exit For
                End If
            Next
            to_list.AddItem from_list.List(i), j
            from_list.RemoveItem i
        End If
    Next
End Sub

標準モジュールのコード

DualListBoxの選択結果をイミディエイトウインドウに出力するコードを書いてみた。
フォームモジュールのOpenForm関数にString型データの入ったコレクションを渡すとAvailableListに表示され、フォームを閉じるとSelectedListの内容がコレクションで返る仕組み。

Sub hoge()
    Dim c As Collection: Set c = New Collection
    For i = Asc("A") To Asc("E")
        c.Add Chr(i)
    Next

    'フォームを開き、操作結果を取得
    Set c = DualListBoxForm.OpenForm(c)
    
    If Not c Is Nothing Then
        For Each s In c
            Debug.Print s
        Next
    End If
End Sub

リストの準備と返ってきたリストの処理色々ごちゃごちゃやってるように見えるが、フォームからのデータ取得はたったの一行で済む。使い勝手はMsgBoxやInputBoxに近づいたと思う。

あとがき

実際に使ってみて、ボタンの並び順をちょっと失敗したかなと思った。
選択したものだけを移動したいときに、間違えて先頭にあるAddAllButtonを押してしまう。
Add, Remove, AddAll, RemoveAllの順の方が使いやすいかも。
でも記事書いちゃったのでこれはこれで。。

以上

VBA 繰り返される定常業務の工数を見える化するアイデア

サービス業において、業務工数を見える化するというのはとても難しい。
実績ベースで工数入力をしている職場は多いと思うけど、実際のところその方法は担当者の匙加減で何とでもなってしまう。

工数分析をしようと思ったら、工数は理論値で出して、実績との乖離をヒアリングによって突き止めるのが良いと思う。
それで今回は、以下のようなタスクごとの工数値を管理する表を考えてみた。
f:id:t-hom:20190321192342p:plain

これをVBAで集計処理することで、担当者ごとの日々の工数をグラフ化する。
すると、年間を通してスタッフごとの繁忙期・繁忙曜日などが見えてくる。
f:id:t-hom:20190321192407p:plain

※スタッフの工数にあまり偏りが無いのは、業務を調整したあとでスクリーンショットを取った為。

ベースになるExcel表の解説

コードを紹介する前に、Excel表から解説する。

まず冒頭の表は1業務を1行で表している。
ヘッダーの上に薄い文字でManとかSelectとかCalcと書かれているのは、Manが手入力項目、Selectが選択項目、Calcが自動計算項目であることを表す。

一番目の項目群(Basic Information)について

単にタスクの情報を書いているだけなので、工数管理に直接影響はない。

二番目の項目群(Workload)について

f:id:t-hom:20190321195214p:plain

Workload per Cycleは、その業務1回ごとの標準的な工数を分単位で記入する。
ここで、何をもって1回とするかも重要で、明細数によって工数が左右される場合は、1明細を1回とすれば良い。
たとえばID管理業務などで、1依頼につき、複数名が含まれる場合、1名登録に何分かかるかを書く。

次にMonthly Occasionは、その業務が月に何回発生するかを記入する。
Dailyなら20、Weeklyなら4、Monthlyなら1、Quarterlyなら=1/4、Annuallyなら=1/12と入力する。

リクエストベースの業務は見積もりが難しいので、昨年実績があれば12カ月で等分すればよい。
これでMonthly Workload(月間工数)とAnnually Workload(年間工数)が自動計算される。

(ここでAnnually(年次の意味)をAnnualy(エルがたりない)と間違えて書いてたことが発覚したけどスクリーンショット取ってしまったので、まぁいいや。。)

三番~六番目の項目群(Ratio of xxxx)について

これは、業務工数の偏りを比率で表すものである。1を100%として実数で記入する。
たとえば年間を通じてコンスタントに行う業務であれば、Ratio of each monthesは各月 = 1/12になる。(つまり0.08)
年次で9月だけ行うような業務であればSepが1で他は0となる。

Ratio of each weeksは週ごとの偏りを表す。
ただしここでいう週はその月の何週目ではなくて、第3木曜日などと言ったときの3のことである。
たとえば2019年3月21日は、3月の第四週目に位置するが、第三木曜日と呼ばれるので、ここでいう3rd Weekに相当する。

ちなみにこの記事の前に公開した以下の記事は今回の記事の布石だった。
thom.hateblo.jp

Ratio of each day of the weekは曜日ごとの偏りを表す。

最後にRatio of each staffsはスタッフごとの業務分担率を表す。

いずれの項目群もトータル値は1に近似しなければならない。

コードの紹介

まずタスクの一覧シートはオブジェクト名をTaskSheetとしておく。
それから出力シートはオブジェクト名をOutputSheetとしておく。

※オブジェクト名についてはこちらを参照
thom.hateblo.jp

OutputSheetのコード

Option Explicit
Public Cursor As Long
Sub WriteLine(ParamArray arr())
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        Me.Cells(Cursor, i + 1).Value = arr(i)
    Next
    Cursor = Cursor + 1
End Sub
Sub Init()
    Cursor = 2
End Sub

標準モジュールのコード

Option Explicit
Const HEADER = 5
Enum Col
    Code = 1
    Workload = 9
    January = 10
    FirstWeek = 22
    Sunday = 26
    Staffs = 33
End Enum
Function WeekNumberByDayOfTheWeek(d As Date) As Long
    Dim ret As Long
    Dim target As Long: target = Weekday(d)
    Dim i As Date
    For i = DateSerial(Year(d), Month(d), 1) To d
        If Weekday(i) = target Then ret = ret + 1
    Next
    If ret > 4 Then ret = 4 '5週目以降は4週目と見做す。
    WeekNumberByDayOfTheWeek = ret
End Function

Sub AggregateStaffWorkloadsForEachDay()
    OutputSheet.Init
    Dim d As Date
    For d = #1/1/2019# To #12/31/2019#
        Dim i
        For i = HEADER + 1 To TaskSheet.Cells(Rows.Count, Col.Code).End(xlUp).Row
            Dim AnnualWorkload: AnnualWorkload = TaskSheet.Cells(i, Col.Workload).Value
            Dim RatioOfMonth: RatioOfMonth = TaskSheet.Cells(i, Col.January + Month(d) - 1).Value
            Dim RatioOfWeek: RatioOfWeek = TaskSheet.Cells(i, Col.FirstWeek + WeekNumberByDayOfTheWeek(d) - 1).Value
            Dim RatioOfWeekday: RatioOfWeekday = TaskSheet.Cells(i, Col.Sunday + Weekday(d) - 1).Value
            Dim staffWorkloads(1 To 3)
            Dim j
            For j = 1 To 3
                staffWorkloads(j) = staffWorkloads(j) + _
                    AnnualWorkload * RatioOfMonth * RatioOfWeek * RatioOfWeekday _
                    * TaskSheet.Cells(i, Col.Staffs + j - 1).Value
            Next
        Next
        If Weekday(d) <> 1 And Weekday(d) <> 7 Then
            OutputSheet.WriteLine d, staffWorkloads(1), staffWorkloads(2), staffWorkloads(3)
        End If
        Dim k As Long
        For k = 1 To 3
            staffWorkloads(k) = 0
        Next
    Next
    MsgBox "Completed"
End Sub

あとはAggregateStaffWorkloadsForEachDayを実行するとOutputSheetに出力されるので、グラフ化するだけ。

手抜き免責事項

  • スタッフを3名決め打ちでハードコードしている。

汎用化を考えてるけど、まずは動くところまでこぎつけたかったので雑に作った。
(それくらい直してから記事にすればと言われそうだけど、とりあえず動いた興奮が冷めないうちに記事化してしまわないと、執筆が面倒くさくなる。)

  • OutputSheetのヘッダーは手入力しないと入らない。
  • 表の構成を記事で説明してない件について

説明が難しいのでGithubでブックごと公開してしまった方が速いんだろうけど、やり方を忘れて調べるのが面倒。。
(とりいそぎ、ヘッダのセル位置だけ公開しておくので再現したい方は頑張ってください。)

A5    Code
B5    Category
C5    Task Name
D5    Description
E5    Cycle
F5    Workload per Cycle (Unit: Minutes)
G5    Monthly Occasion (Unit: Times)
H5    Monthly Workload (Unit: Hours)
I5    Annualy Workload (Unit: Hours)
J5    Jan
K5    Feb
L5    Mar
M5    Apr
N5    May
O5    Jun
P5    Jul
Q5    Aug
R5    Sep
S5    Oct
T5    Nov
U5    Dec
V5    1st Week
W5    2nd Week
X5    3rd Week
Y5    4th/5th Week
Z5    Sun
AA5    Mon
AB5    Tue
AC5    Wed
AD5    Thu
AE5    Fri
AF5    Sat
AG5    Staff A
AH5    Staff B
AI5    Staff C

おわりに

私がブログ記事のタイトルに「アイデア」と付けるときは大抵、未完成品である。
VBAerならアイデアを取得して応用できるだろうと思って、熱意があるうちにサクッと公開してしまう方針なのでどうかご理解いただきたい。
(キチンと完成にこぎつけてから公開しようと思ってると、そのうち熱が冷めてしまってお蔵入りになるので。)

VBA 特定日付が、第何週目の何曜日なのかを求める関数

今回は特定日付が、第何週目の何曜日なのかを求める関数を紹介する。
といっても曜日はWeekday関数やFormat関数で簡単に求まるので、今回紹介するのは月のうちの何週目に相当するかを求める関数だ。

まず、特定月のうち何週目に当たるのかは、次の関数で求められる。

Function WeekOfTheMonth(d As Date) As Long
    WeekOfTheMonth = DatePart("ww", d) - DatePart("ww", DateSerial(Year(d), Month(d), 1)) + 1
End Function

ただ作ってみてこれは私が求めている結果と違うことに気付いた。
実務では第二火曜日とか、第三木曜日に特定の処理を行うことがある。

たとえば2019年3月21日は、3月の第四週目にあたる。
でも、2019年3月21日は第三木曜日である。

その月の何回目の木曜日かを数える必要があるのだ。

そこで、愚直に数え上げる関数を作った。
これが本記事のメインである。

Function WeekNumberByDayOfTheWeek(d As Date) As Long
    Dim ret As Long
    Dim target As Long: target = Weekday(d)
    Dim i As Date
    For i = DateSerial(Year(d), Month(d), 1) To d
        If Weekday(i) = target Then ret = ret + 1
    Next
    WeekNumberByDayOfTheWeek = ret
End Function

関数を試すコードが以下。最初に紹介したWeekOfTheMonthも使用している。

Sub hoge()
    Dim d As Date
    For d = #1/1/2019# To #4/1/2019#
        Debug.Print Format(d, "yyyy年m月d日"); "は、";
        Debug.Print Month(d); "月の第"; WeekOfTheMonth(d); "週目、";
        Debug.Print "第"; WeekNumberByDayOfTheWeek(d); Format(d, "aaa"); "曜日です。"
    Next
End Sub

結果はこんな感じ

2019年1月1日は、 1 月の第 1 週目、第 1 火曜日です。
2019年1月2日は、 1 月の第 1 週目、第 1 水曜日です。
2019年1月3日は、 1 月の第 1 週目、第 1 木曜日です。
2019年1月4日は、 1 月の第 1 週目、第 1 金曜日です。
2019年1月5日は、 1 月の第 1 週目、第 1 土曜日です。
2019年1月6日は、 1 月の第 2 週目、第 1 日曜日です。
2019年1月7日は、 1 月の第 2 週目、第 1 月曜日です。
2019年1月8日は、 1 月の第 2 週目、第 2 火曜日です。
2019年1月9日は、 1 月の第 2 週目、第 2 水曜日です。
2019年1月10日は、 1 月の第 2 週目、第 2 木曜日です。
2019年1月11日は、 1 月の第 2 週目、第 2 金曜日です。
2019年1月12日は、 1 月の第 2 週目、第 2 土曜日です。
2019年1月13日は、 1 月の第 3 週目、第 2 日曜日です。
2019年1月14日は、 1 月の第 3 週目、第 2 月曜日です。
…つづく

おわりに

今回は英語の関数名を考えるのに苦労した。
もう日本語で「第X曜日」という関数名にしようかと思ったけど最近は英語の識別子に拘ってしまう。

日本語だと「曜日」の2文字で済むものが、英語だと「Day of the week」になる。
既存関数のようにWeekdayという単語を使っても良かったんだけど、平日限定の意味を含んでしまう気がしてやめた。

PowerPoint VBA スライドにプロジェクトのスケジュール図をプロットするマクロ

今回はパワポでよくあるこういうスケジュールスライドを作るVBAコードを紹介。
f:id:t-hom:20190319224303p:plain

と言っても現段階では完成度は低いのであまり期待されると困ってしまう。

ところどころハードコーディングしているし、クラスモジュール内でSelectionを参照しちゃってるし、変数名がまだまだ適当なところあるし変数宣言もしてたりしてなかったりだしといった具合。
使い勝手という意味でも、スケジュールはコードにベタ打ちだし、微調整が効かずイマイチ。

でも良いアイデアだと思うので、使えそうなら部品取りして改造するなりこれをヒントにイケてるツールを作るなりしてもらえれば幸い。私は私で、ブラッシュアップしてみようと思う。

コード

書き殴りでもクラスモジュールは使う。むしろオートシェイプ系は座標計算が入ってくるのでクラスを使って操作性をシンプルに保たないと頭がこんがらがる。

クラスモジュール Task

Public StartDay As Date
Public EndDay As Date
Public Title As String
Public Property Get Self() As Object
    Set Self = Me
End Property

クラスモジュール Schedule

Private schedule_ As Collection
Public Width As Double
Public Height As Double
Public StartDay As Date
Public EndDay As Date
Property Get MonthCount() As Long
    MonthCount = DateDiff("m", StartDay, EndDay) + 1
End Property
Property Get MonthlyWidth() As Double
    MonthlyWidth = Width / MonthCount
End Property

Function CalcDateLocation(d As Date) As Double
    Dim ret As Double
    ret = DateDiff("m", StartDay, d) * MonthlyWidth
    ret = ret + (MonthlyWidth * CalcRatioOfDateInMonth(d))
    CalcDateLocation = ret
End Function

Sub Add(t As Task)
    schedule_.Add t
End Sub

Private Sub Class_Initialize()
    Set schedule_ = New Collection
End Sub

Private Function CalcRatioOfDateInMonth(d As Date)
    CalcRatioOfDateInMonth = Day(d) / Day(CalcEndOfMonth(d))
End Function
Private Function CalcEndOfMonth(d As Date)
  CalcEndOfMonth = DateSerial(Year(d), Month(d) + 1, 0)
End Function

Public Sub Plot()
    OFFSET_L = 50
    OFFSET_T = 50
    Margin = 50
    Dim calender As Table
    Set calender = ActiveWindow.Selection.SlideRange.Shapes.AddTable(NumRows:=2, NumColumns:=MonthCount, Left:=OFFSET_L, Top:=OFFSET_T, Width:=Width).Table
    calender.ApplyStyle "{5940675A-B579-460E-94D1-54222C63F5DA}"
    
    Dim m As Long: m = Month(StartDay)
    calender.Rows(2).Height = Height
    For i = 1 To MonthCount
        calender.Cell(1, i).Shape.TextFrame.TextRange.Text = Format(DateSerial(2019, m, 1), "mmm")
        m = m + 1
    Next
    
    Dim t As Task
    
    Dim targetSlide As Slide
    Set targetSlide = ActiveWindow.Selection.SlideRange(1)
    
    start_y = OFFSET_T + calender.Rows(1).Height + Margin / 2
    arrowWeight = calender.Rows(2).Height / schedule_.Count - Margin
    
    For Each t In schedule_
        L = CalcDateLocation(t.StartDay)
        W = CalcDateLocation(t.EndDay) - CalcDateLocation(t.StartDay)
        start_x = L + OFFSET_L
        arrowLength = W
        targetSlide.Shapes.AddShape(msoShapePentagon, start_x, start_y, arrowLength, arrowWeight).Select
        start_y = start_y + arrowWeight + Margin
    Next
End Sub

標準モジュール (任意名称)

Sub スケジュールのプロット()
    Dim s As Schedule
    Set s = New Schedule
    s.Width = ActivePresentation.PageSetup.SlideWidth * 0.8
    s.Height = ActivePresentation.PageSetup.SlideHeight * 0.8
    s.StartDay = Now
    s.EndDay = #7/10/2019#
    With New Task
        .StartDay = Now
        .EndDay = #3/31/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #4/5/2019#
        .EndDay = #5/15/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #5/17/2019#
        .EndDay = #6/20/2019#
        s.Add .Self
    End With
    With New Task
        .StartDay = #6/22/2019#
        .EndDay = #7/20/2019#
        s.Add .Self
    End With
    s.Plot
End Sub

使い方

白紙のスライドを選択し、スケジュールのプロットを実行するとコード内で定義されたタスクがスライドにプロットされる。

ScheduleオブジェクトのStartDayとEndDayは、背景に配置する表を何月から何月とするかを決定している。

たとえば2019/1/1から2019/12/1まで指定すると12分割される。
f:id:t-hom:20190319225721p:plain

タスクを表すシェイプの高さはタスクの数によって変動する。均等割りされるのでタスクが1個とか2個だとすごく太いシェイプになる。

今後の展望

  • フォームモジュールでタスク登録のUIを作る。
  • コードのリファクタリング
  • サイズの指定を比率と固定値で選択できるように
  • タスクの名称をシェイプに入れる(Titleフィールドだけ用意して放置中)

以上

VBA マクロのバージョン番号の付け方

ソフトウェアは一度作って終わりではなく、公開後もバグの修正や機能向上のため修正を繰り返すことになる。
マクロも同様で、通常はバージョン番号をつけて管理したりする。

バージョン番号の付け方は特に決まっているわけではないが、一般的には次のルールにしていてることが多いようだ。

メジャーバージョン番号.マイナーバージョン番号.リビジョン番号

番号名 意味(私の解釈)
メジャーバージョン番号 コンセプトはそのままに一から作り直した場合や、作り直しに相当するほどの大きな変更があった場合に更新。外観の大きな変更を伴うことが多い。
マイナーバージョン番号 機能の追加・削除、操作性の変更等があった場合に更新。
リビジョン番号 バグ修正・リファクタリング(動作に影響を与えないソースコードの整理)等があった場合に更新。

使い捨てマクロならともかく、ある程度使いまわす予定があるならどのみちバージョン管理する羽目になるので、初めからHistoryシートを用意していつどのような更新を行ったのかを書いておくと良い。

かくいう私もHistoryシートを用意し始めたのは今日の話なんだけど。

f:id:t-hom:20190310184441p:plain

リビジョン番号はまだ付けてないけど、このあとバグ修正とかあれば付けていこうかなと考えている。

同日追記

Twitterでimihitoさんが以下を紹介されていたのでこちらでも紹介。
semver.org

Semanticというのは「意味」を表す言葉。「意味付けされた~」と解釈すれば良い。

上記ではメジャー.マイナー.パッチと呼んでいるが、考え方は同じ。
※メジャーバージョンを上げる基準としてAPI互換性を基準に上げているけどVBAの場合はそこはあんまり関係ない。

ひとつ参考にしたいなと思ったのは、メジャーバージョンの0はリリース前の開発中バージョンを表すということ。ベータ版として開発中のものを先行公開する場合は、メジャーバージョン0を採用しようと思う。

VBA Win32API GetAsyncKeyStateを使ってマクロ実行時に特定キーが押されているかを検知する。

今回はWin32APIのGetAsyncKeyStateを使ってマクロ実行時に特定キーが押されているかを検知するコード。
この手の情報は既に沢山出ているが、検索したサイトはいずれも情報が完全ではなかったので少し苦労した。

では、早速完成コードを紹介する。
今回はシフトキーが押されているかどうかを検知した。

コード

#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As LongLong) As Integer
#Else
    #If VBA6 Or VBA5 Then
        Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
    #Else
        Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
    #End If
#End If
'GetAsyncKeyStateは、-32768, 1, -32767, 0 のうちいずれかの16ビット整数を返す。
'これは二進数に直したときのビットに意味がある。
'-32768: 1000 0000 0000 0000  最上位ビットが1なら、現在そのキーが押されていることを示す。
'1         : 0000 0000 0000 0001 最下位ビットが1なら、最後のGetAsyncKeyState呼び出しの後にそのキーが押されたことを示す。
'-32767: 1000 0000 0000 0001 従って、これは両方に該当することを示す。
'0         :0000 0000 0000 0000 これは、どちらでもないことを示す。
'つまり現在キーが押されているかどうかを知るには、GetAsyncKeyStateの結果を-32768のAndマスクに掛け、
'-32768になればOKということ。

Function IsShiftKeyPressed() As Boolean
    Const KEY_PRESSED = -32768      '1000 0000 0000 0000 最上位ビットが1であることを示す。
    IsShiftKeyPressed = (GetAsyncKeyState(vbKeyShift) And KEY_PRESSED) = KEY_PRESSED
End Function

Sub hoge()
    Debug.Print IsShiftKeyPressed
End Sub

用途

私が公開しているフローチャート作成ツール BreadChart に機能搭載するのが目的。
Connectorモードのとき、条件分岐するシチュエーションにおいて、新しいコネクタから開始するのにわざわざモードをOff・OnしないといけないのをShift+Clickで出来るようにした。
thom.hateblo.jp

というワケで、昨日1.2を出したところだけど、1.3をしれっと公開済み。

参考サイトと苦労したポイント

最初に検索にヒットしたのがこちら。
officetanaka.net
ただ中身をみてみるとコマンドボタン限定なので今回の用途にはマッチしなかった。

次にこちら。
excel-excel.com
キーコード付きでサンプルが掲載されていてとてもわかりやすい。

そしてWin32APIを使う以上、64bit対応も考慮したかったので、こちらも参考にした。
ameblo.jp

それで単純なサンプルを書いてみた。

#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As LongLong) As Long
#Else
    #If VBA6 Or VBA5 Then
        Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
    #Else
        Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
    #End If
#End If

Sub hoge()
    Debug.Print IIf(GetAsyncKeyState(vbKeyControl), "Pressed", "Not Pressed")
End Sub

しかし、なぜかCtrlを押してない時までPressedになることがあり、次のコードで値を見てみた。

Sub hoge()
    Debug.Print GetAsyncKeyState(vbKeyControl)
End Sub

結果は、Ctrlが押されているときが32768か-32767、押されていない時が1か0になる。
なんじゃこれと思って調べてみると、以下のサイトに解説があった。
tokovalue.jp

この関数は、最上位ビットと最下位ビットに意味があるのだが、そもそもこれ、戻り値はInteger(16ビット整数)だそうだ。
最上位ビットは符号を表すので、IntegerとLongでは解釈が異なってしまう。

ということで修正。

#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As LongLong) As Integer
#Else
    #If VBA6 Or VBA5 Then
        Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
    #Else
        Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
    #End If
#End If

これで戻り値はCtrlが押されているときが-32768か-32767、押されていない時が1か0になった。

Ctrlが押されているとき、

  • 32768は1000 0000 0000 0000
  • 32767は1000 0000 0000 0001

Ctrlが押されていないとき、
1は0000 0000 0000 0001
0は0000 0000 0000 0000

つまり、最上位ビットが1かどうかを知りたければ、戻り値と-32768をAndしてやれば良い。
それで完成したのが冒頭のコードだ。

なんでShiftに変えたかというと、BreadChartに組み込む際に、Ctrl+クリックではマクロが発動する以前にオートシェイプの選択として機能してしまい、使えなかったので。

以上。

VBA フローチャート作成ツールBread Chartに挿入機能検討

先ほど新版を公開したところだけど、以前から悩んでいた機能がなんとか実現できそうな感じがしてきたので、取り急ぎコードだけここに書いておく。
thom.hateblo.jp

実現したい機能

たとえば下図のようなことをやりたいとする。
f:id:t-hom:20190309235109p:plain

しかし、単純に列ごと切り取って挿入すると、コネクターが切れてぐちゃぐちゃに。
f:id:t-hom:20190309235433p:plain

また、単純に行挿入したけれど、プレースホルダーが無くてプロセスを配置できない。
f:id:t-hom:20190309235637p:plain

現状のバージョン1.2では、ひな形から作り直すしかない。

今回はこれを何とかするコードをとりあえず書いてみた。
とりあえずなので、ユーザーインターフェースはなく、F8で実行する仕様。
もちろん、中途半端なのでGitHubには反映させていない。

コード

標準モジュールを挿入してUtilとでもしておくと良い。

Sub FixConnectorBug()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        Select Case sh.AutoShapeType
        Case _
            msoShapeFlowchartProcess, _
            msoShapeFlowchartDecision

            '切れたように見えて論理的につながっているコネクタの表示を直すには、
            'コネクタがつながっているシェイプを少し移動すれば良いことに気付いた。
            '移動してから戻すというコードを考えたけれど、
            'マクロで対応するときは移動しなくても位置を再設定さえすれば直った。
            '以下の一行は一見無意味に見えて、表示バグを修正しているコード。
            sh.Left = sh.Left
        End Select
    Next
End Sub

Sub InsertPlaceholderToSelection()
    Const ProcessWidth As Double = 100
    Const ProcessHeight As Double = 40
    Dim r As Range
    For Each r In Selection
        Dim sh As Shape
        Set sh = ChartSheet.Shapes.AddShape( _
            Type:=msoShapeFlowchartProcess, _
            Left:=r.Left + (r.Width - ProcessWidth) / 2, _
            Top:=r.Top + (r.Height - ProcessHeight) / 2, _
            Width:=ProcessWidth, _
            Height:=ProcessHeight)
        Call DeactivateProcess(sh)
        sh.OnAction = "Click"
    Next
End Sub

FixConnectorBugについて

列ごと入れ替えるとコネクターが切れると書いたけど、実は切れているわけではない。
コネクターを選択すると接続されていることを示す緑の端点が表示される。
実は下図でいう赤丸同士は、論理的にはつながっていて、表示がおかしいだけなのだ。
f:id:t-hom:20190310000235p:plain

右クリックで接続されているプロセスシェイプのどちらかを選択し(左だとマクロが発動するので)、その状態で左クリックでドラッグすると接続が元に戻ることを発見した。
f:id:t-hom:20190310000717g:plain

FixConnectorBugを実行するとすべてのシェイプを探索し、プロセスか判断だった場合(つまりコネクタ以外)はLeftプロパティで位置を再設定する。これでコネクターの表示が正常に戻る。

InsertPlaceholderToSelection

これは、プロセスのプレースホルダーが無いセルを選択して実行するとそこにプレースホルダーを作成するマクロ。
ひな型作成コードの一部を取り出しただけなので、なにも苦労は無かった。さっさと作っておけばよかった。

課題

今のところ手作業で行列の挿入・セルの挿入等を行った後にマクロで補完する方式なので、機能としてマクロに搭載するならまるっと自動でやりたい。でも欲張るとなかなか公開できないのが悩みどころ。

先行で使いたい方いたら今回の記事からコピペしていただくと良いかと。

あと、セルの挿入機能を使う以上、書式ズレの問題が避けられないのも課題。これもきちんとやるのは面倒くさそうだなぁ。

いずれにしても、光明が見えたので良かった。従来はプロセスを一つずつズラす方式を頭の中でシミュレーションして破綻してたので、セル挿入機能をベースにする方針を思いついたのは大きな収穫。むしろなぜ気付かなかったのか謎だ。

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。