項目

ユーザーフォームの複数コントロールのEnter・Exitイベントを纏めて処理する

内容説明

多くのコントロールのEnter・Exitイベント処理をする場合、コントロールの数だけEnter・Exitイベントプロシージャを記述していませんか？
Enter・Exitイベントを各一つのイベントプロシージャで処理するクラスを示します｡

'クラスモジュール CEnterExit
'機能:ユーザーフォームの複数コントロールのEnter・Exitイベントを纏めて処理する
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
  x As Long
  y As Long
End Type
'Enterイベントの代替
Public Event GotFocus(ByVal Control As MSForms.Control)
'Exitイベントの代替
Public Event LostFocus(ByVal Control As MSForms.Control, Cancel As Boolean)
Private WithEvents duf As MSForms.UserForm
Private dflg As Boolean, dold As MSForms.Control

'Initializeメソッド　CEnterExitクラスの開始
Public Sub Initialize(ByVal uf As MSForms.UserForm)
  If duf Is Nothing Then Set duf = uf
End Sub
Private Sub DoLoop(ByVal uf As MSForms.UserForm)
  Dim ctrl As MSForms.Control, Cancel As Boolean
  Dim ll&, tt&, ww&, hh&, ia As IAccessible, po As POINTAPI
  On Error Resume Next '念のため
  dflg = True
  Set ia = uf
  Do While dflg
    ia.accParent.accLocation ll, tt, ww, hh
    GetCursorPos po
    If po.x < ll Or po.x > ll + ww Or po.y < tt Or po.y > tt + hh Then Exit Do
    Set ctrl = ActiveControl(uf)
    If Not dold Is ctrl Then
      Cancel = False
      If Not dold Is Nothing Then RaiseEvent LostFocus(dold, Cancel)
      If Cancel Then
        dold.SetFocus
      Else
        If Not ctrl Is Nothing Then RaiseEvent GotFocus(ctrl)
        Set dold = ctrl
      End If
    End If
    DoEvents: Sleep 50
    If TypeName(uf) = "UserForm" Then Exit Do '自動で終了処理
  Loop
  dflg = False
End Sub
'ユーザーフォームのアクティブコントロールを得る
Private Function ActiveControl(ByVal fm As MSForms.UserForm) As MSForms.Control
  Dim ctrl As MSForms.Control
  Set ctrl = fm.ActiveControl
  If ctrl Is Nothing Then Exit Function
  Do
    Set ActiveControl = ctrl
    If ctrl Is Nothing Then Exit Function
    If TypeOf ctrl Is MSForms.Frame Then
      Set ctrl = ctrl.ActiveControl
    ElseIf TypeOf ctrl Is MSForms.MultiPage Then
      Set ctrl = ctrl.SelectedItem().ActiveControl
    Else
      Exit Do
    End If
  Loop
End Function
Private Sub duf_Layout()
  If dflg = False Then DoLoop duf
End Sub
Private Sub duf_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
  If dflg = False Then DoLoop duf
End Sub

'■CEnterExitクラスモジュールの使用例
'準備：ユーザーフォームに複数のコントロール(テキストボックス等)を配置
'機能：全てのコントロールの入力時のバックカラーを変更する
'ユーザーフォームモジュール
Option Explicit
Private WithEvents Control As CEnterExit

Private Sub Control_GotFocus(ByVal Control As MSForms.Control)
  'Debug.Print "Control_GotFocus  "; Control.Name, Timer
  Control.Tag = Control.BackColor
  Control.BackColor = vbMagenta
End Sub

Private Sub Control_LostFocus(ByVal Control As MSForms.Control, Cancel As Boolean)
  'Debug.Print "Control_LostFocus "; Control.Name, Timer
  Control.BackColor = Control.Tag
End Sub

Private Sub UserForm_Initialize()
  Set Control = New CEnterExit
  Control.Initialize Me
End Sub

項目

ファイルを開かずにファイルプロパティを取得する

内容説明

Excelファイル(ブック)は開いてDocumentPropertyオブジェクトにてファイルのプロパティを取得できますが、 ここではファイルを開かずに全ての種類のファイルプロパティを取得するkFileProperty関数を示します。

'kFileProperty関数
'ファイルを開かずにファイルプロパティを取得する
'引数 FullName:ファイルのフルネーム
'　　 Item    :項目名が返るコレクション(省略可)
'戻り値 ファイルのプロパティのコレクション。keyには項目名が返る
'注）プロパティはkeyに項目名を指定して取得する事。番号はOS・Excelのバージョンにより変わる
Function kFileProperty(ByVal FullName As String, Optional Item As Collection) As Collection
  Dim ii&, jj&, itm As Object, pty As New Collection
  Set itm = CreateObject("Shell.Application").NameSpace(0).ParseName(FullName)
  If itm Is Nothing Then Beep: Exit Function
  Do
    With itm.Parent
      For jj = 0 To 10
        If .GetDetailsOf(, ii + jj) <> "" Then Exit For
      Next
      If jj = 11 Then Exit Do
      If .GetDetailsOf(, ii) <> "" Then
        pty.Add .GetDetailsOf(itm, ii), .GetDetailsOf(, ii)
        If Not Item Is Nothing Then Item.Add .GetDetailsOf(, ii)
      End If
      ii = ii + 1
    End With
  Loop
  Set kFileProperty = pty
End Function

'■kFileProperty関数の使用例1
'項目名を指定してプロパティを得る
Sub test1_kFileProperty()
  Dim fname$, pty As New Collection
  fname = "c:\ddd\eee\Book1.xls"
  Set pty = kFileProperty(fname)
  Debug.Print "作成日時", pty("作成日時")
  Debug.Print "作成者", pty("作成者")
  Debug.Print "タイトル", pty("タイトル")
  Debug.Print "表題", pty("表題")
End Sub

'■kFileProperty関数の使用例2
'全ての項目名とプロパティを得る
'(項目名が分からない場合に確認出来る)
Sub test2_kFileProperty()
  Dim nn&, fname$, pty As New Collection, itm As New Collection, na As Variant
  fname = "c:\ddd\eee\文書1.doc"
  Set pty = kFileProperty(fname, itm)
  For Each na In itm
    nn = nn + 1
    Debug.Print nn; na, "= "; pty(na)
  Next
End Sub

項目

ユーザーフォームのリストボックスでドラッグ&ドロップ

内容説明

ユーザーフォームのリストボックスでドラッグ&ドロップ機能を実装したクラスモジュールです。
MultiSelectプロパティはfmMultiSelectSingle(項目は1つだけ選択出来る)に対応。

機能
・リストボックスのアイテムをドラッグ&ドロップで位置を移動
　元位置より上のアイテムへドロップの場合はアイテムの上へ移動。
　元位置より下のアイテムへドロップの場合はアイテムの下へ移動。
・2つのリストボックス間でアイテムをドラッグ&ドロップで移動
　移動先リストボックスの最下段へ移動。

'クラスモジュール CListBoxDragDrop
Option Explicit
Private Declare Sub mouse_event Lib "user32" _
  (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, _
  ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private WithEvents ListBox1 As MSForms.ListBox
Private WithEvents ListBox2 As MSForms.ListBox
Private dlb As MSForms.ListBox

Public Sub Initialize(ByVal lb As MSForms.ListBox, Optional ByVal lb2 As MSForms.ListBox)
  Set ListBox1 = lb
  If Not lb2 Is Nothing Then Set ListBox2 = lb2
End Sub

Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  Cancel = True
End Sub
Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  pBeforeDropOrPaste ListBox1, Action, Data
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  pMouseMove ListBox1, Button
End Sub

Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  Cancel = True
End Sub
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  pBeforeDropOrPaste ListBox2, Action, Data
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  pMouseMove ListBox2, Button
End Sub

Private Sub pBeforeDropOrPaste(ByVal lb As MSForms.ListBox, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject)
  Dim idx&
  If Action = fmActionDragDrop Then
    idx = dlb.ListIndex
    If dlb Is lb Then
      lb.Value = Null 'lb.ListIndex = -1
      mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
      DoEvents
      mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
      If IsNull(lb.Value) Then lb.ListIndex = lb.ListCount - 1
      lb.AddItem Data.GetText, lb.ListIndex + IIf(idx < lb.ListIndex, 1, 0)
      dlb.RemoveItem idx + IIf(idx < lb.ListIndex, 0, 1)
    Else
      lb.AddItem Data.GetText
      dlb.RemoveItem idx
      lb.ListIndex = lb.ListCount - 1
    End If
  End If
  Data.Clear
End Sub
Private Sub pMouseMove(ByVal lb As MSForms.ListBox, ByVal Button As Integer)
  Dim Data As DataObject
  If Button = 1 And Not IsNull(lb) Then '左ボタン
    Set dlb = lb
    Set Data = New DataObject
    Data.SetText lb.Value
    Data.StartDrag
  End If
End Sub

'■使用例1　ユーザーフォームモジュール
'UserFormにListBox1を配置。
'リストボックスのアイテムをドラッグ&ドロップで位置を移動します。
Option Explicit
Dim dlistdrag As CListBoxDragDrop

Private Sub UserForm_Initialize()
  'test用リスト
  ListBox1.List = Array("Aaaa", "Bbbb", "Cccc", "Dddd", "Eeee", "Ffff")
  'CListBoxDragDropクラスの開始
  Set dlistdrag = New CListBoxDragDrop
  dlistdrag.Initialize ListBox1
End Sub

'■使用例2　ユーザーフォームモジュール
'UserFormにListBox1とListBox2を配置。
'2つのリストボックス間でアイテムをドラッグ&ドロップで移動します。
Option Explicit
Dim dlistdrag2 As CListBoxDragDrop

Private Sub UserForm_Initialize()
  Dim ii&
  For ii = 1 To 20
    ListBox1.AddItem ii * 100
  Next
  Set dlistdrag2 = New CListBoxDragDrop
  dlistdrag2.Initialize ListBox1, ListBox2
End Sub

項目

ユーザーフォームで日付を入力する

内容説明

ユーザーフォームにて日付(年月日)を入力する場合どのようにしていますか。
テキストボックスに入力した値をIsDate関数等で調べたりFormat関数で整形したり、或いは年・月・日のそれぞれのコンボボックスで入力したりと色々工夫されているのを見かけます。
しかしウインドウズにはDTPickerと言う日付及び時刻を入力する機能が備わっていて簡単にそしてスマートに入力が出来ます。
通常はDTPickerコントロール(Date and Time Picker Control(MSCOMCT2.OCX))を用いますが、ここではコントロールを用いずにクラスモジュールにて実装したCDTPickerクラスによるデモファイルを公開します。

DTPickerはコンボボックスと同じ外見で[▼]をクリックすると、カレンダーが表示され日付を選択出来ます。

DTPickerでの日付入力[kDTPicker.xls]　Version 1.00
kkDTPicker100.lzh(ソース公開)のダウンロード
提供するVBAプログラムはソース公開です。自身のプログラムへの組込みを許諾します。
但し、ソースコードのWEBや書籍などへの投稿、掲載は禁止とさせて頂きます。


注： クラス[CDTPicker]について
このクラスは拙作、カレンダーによる日付設定 [k可憐] にて用いているクラスモジュールの一つです。要望が多いためTipsとして公開致します。
カレンダーによる日付設定 [k可憐](ソース公開)

項目

水平カーソル

内容説明

アクティブセルの位置を目立たせるために水平方向のセルを色付けする手法を示します。
条件付き書式を用いる方法です。シートモジュールの SelectionChangeイベントに以下を記述します。
全てのシートを対象にするならブックモジュールやApplicationクラスのSheetSelectionChangeイベントに記述する事も出来ます。

'水平カーソル
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Const COLO = vbYellow '色指定
  Static flg As Boolean
  If flg = False Then
    With ActiveSheet.UsedRange '範囲指定 例-> Range("a2:j20")
      .FormatConditions.Delete
      .FormatConditions.Add Type:=xlExpression, Formula1:="=CELL(""row"")=ROW()"
      '.FormatConditions.Add Type:=xlExpression, Formula1:="=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())"
      .FormatConditions(1).Interior.Color = COLO
    End With
    flg = True
  End If
  Application.ScreenUpdating = True
End Sub

追記：条件付き書式を用いない方法
Excelにクロスカーソルを kクロス 1.01 のご紹介
　kクロス
kクロス(ケイクロス)はExcelにクロスカーソルを組み込む小品マクロです。 アクティブセルの水平方向と垂直方向へカーソルを表示します。

項目

2つの線分の交点を求める

内容説明

2つの線分の交点を求める kIntersectSegment関数 を示します。

'kIntersectSegment関数
'2つの線分の交点を求める
'引数　(x1,y1)(x2,y2):線分1の座標、(x3,y3)(x4,y4):線分2の座標
'戻り値 配列(0):1=線分は交差している 0=交差していない、配列(1):交点のx座標、配列(2):交点のy座標
'　　　もちろん配列数式として使える(入力はCtrl+Shift+Enterキー)
'注)引数のデータ型はDoubleとしているが整数で事足りればLongに変更の事
Function kIntersectSegment(ByVal x1#, ByVal y1#, ByVal x2#, ByVal y2#, ByVal x3#, ByVal y3#, ByVal x4#, ByVal y4#) As Variant
'Function kIntersectSegment(ByVal x1&, ByVal y1&, ByVal x2&, ByVal y2&, ByVal x3&, ByVal y3&, ByVal x4&, ByVal y4&) As Boolean
  Dim aa#, bb#, cc#, dd#, ee#, ff#, ans(0 To 2) As Variant
  kIntersectSegment = ans
  '交差しているかの判定
  If (((x1 - x2) * (y3 - y1) + (y1 - y2) * (x1 - x3)) * ((x1 - x2) * (y4 - y1) + (y1 - y2) * (x1 - x4)) > 0#) Then Exit Function
  If (((x3 - x4) * (y1 - y3) + (y3 - y4) * (x3 - x1)) * ((x3 - x4) * (y2 - y3) + (y3 - y4) * (x3 - x2)) > 0#) Then Exit Function
  If x1 = x2 Then '平行
    aa = 1: bb = 0: cc = x1
  Else
    aa = (y2 - y1) / (x2 - x1)
    bb = -1: cc = (y2 - y1) / (x2 - x1) * x1 - y1
  End If
  If x3 = x4 Then '線分2についても同様
    dd = 1: ee = 0: ff = x3
  Else
    dd = (y4 - y3) / (x4 - x3)
    ee = -1: ff = (y4 - y3) / (x4 - x3) * x3 - y3
  End If
  '解
  ans(0) = 1
  ans(1) = (cc * ee - bb * ff) / (aa * ee - bb * dd)
  ans(2) = (cc * dd - aa * ff) / (bb * dd - aa * ee)
  kIntersectSegment = ans
End Function

'kIntersectSegment関数の使用例
Sub test_kIntersectSegment()
  Dim rt As Variant
  rt = kIntersectSegment(14, 28, 26, 3, 24, 10, 6, 21)
  'rt = kIntersectSegment(14, 28, 26, 3, 22, 10, 6, 21)
  If rt(0) Then
    Debug.Print "交点="; rt(1); ","; rt(2)
  Else
    Debug.Print "交差しない"
  End If
End Sub

項目

マクロを削除して新しいブックでシートコピー

内容説明

シートモジュールにマクロが記述してあるワークシートを新しいブックでシートコピー(ActiveSheet.Copy等)したときマクロを削除する面白い方法です｡
トリッキーな手法なので少しばかり下準備も必要です｡
なお、コピー元のブックはプロジェクトの保護をしていてもOKです｡

コピー元の下準備
Option Explicit
Private WithEvents Book As Workbook
Private Sub Worksheet_Calculate()
  If Not Book Is Nothing Then Exit Sub
  Set Book = Parent
  Book.Saved = True
End Sub
'↑ここまで

プログラム本体
'kCopyDeletionMacro関数
'マクロを削除して新しいブックでシートコピー
'引数 Worksheet:コピー元のワークシート 注)コピー元シートにはコピー元の下準備のコードが必須
'　　 Filename：新しいブックのフルファイル名
'　　 Address：作業用のセルアドレス(書き込みが出来る事)
'戻り値 新しいブック(オブジェクト)
Function kCopyDeletionMacro(ByVal Ws As Worksheet, ByVal Filename As String, ByVal Address As String) As Workbook
  Application.ScreenUpdating = False
  Ws.Range(Address).Formula = "=TODAY()"
  Ws.Copy
  Ws.Range(Address).ClearContents
  With ActiveWorkbook
    Application.DisplayAlerts = False
    .SaveAs Filename
    .Close
    Application.DisplayAlerts = True
  End With
  Set kCopyDeletionMacro = Workbooks.Open(Filename)
  With kCopyDeletionMacro
    .Sheets(1).Range(Address).ClearContents
    .Save
  End With
  Application.ScreenUpdating = True
End Function

'kCopyDeletionMacro関数の使用例
Sub test_kCopyDeletionMacro()
  Dim Wb As Workbook, Ws As Worksheet, Filename As String, Address As String
  Set Ws = Sheets("Sheet1")
  Filename = "d:\eee\fff.xls"
  Address = "a1"
  Set Wb = kCopyDeletionMacro(Ws, Filename, Address)
  'Wb.Close
End Sub

項目

シートモジュールでWorkbookイベントを用いる

内容説明

ブックモジュール(ThisWorkbook)にマクロを記述せず、シートモジュールにマクロを記述してWorkbookイベントを実装する方法です。
シートモジュールにてBeforePrintやBeforeSave等の多くのWorkbookイベントが使えるようになります。

注：コピー元のシートモジュールにはいずれかのセルに以下の数式を記述の事(必須)
=TODAY()
このセルを見せたくない場合はフォント色を白にするなり行又は列を非表示にする。

'対象のシートモジュール
Option Explicit
Private WithEvents Book As Workbook
 
Private Sub Worksheet_Calculate()
  If Not Book Is Nothing Then Exit Sub
  Set Book = Parent
  Application.OnTime Now, CodeName & ".SavedProcedure"
End Sub

Private Sub SavedProcedure()
  Book.Saved = True
End Sub
'↑ここまでは該当のシートモジュールに無条件に記述の事

'↓以下Workbookイベント等を任意に使える
Private Sub Book_BeforePrint(Cancel As Boolean)
  MsgBox "BeforePrint"
End Sub
 
'Private Sub Book_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'  MsgBox "BeforeSave"
'End Sub

追記 新しいブックへコピーする場合
対象シートのCopyメソッドは次の手順で用いる(必須)

Sub test_SheetCopy()
  Dim Wb As Workbook, Ws As Worksheet, Filename As String
  Set Ws = Sheets("Sheet1") 'コピー元のシート
  Filename = "d:\eee\fff.xls" 'コピーした新しいブックのフルファイル名
  Application.DisplayAlerts = False
  Ws.Copy
  ActiveWorkbook.SaveAs Filename
  Set Wb = Workbooks.Open(Filename)
  'Wb.Close
  Application.DisplayAlerts = True
End Sub