項目

[マクロを無効にする]で開くと使えないxlsファイル

内容説明

[マクロを無効にする]で開くと非表示になり実質使えないxlsファイルの作成方法です。
対象xlsファイルに以下マクロを組み込み、パスワード付きでプロジェクトの保護をして上書き保存して下さい。
このxlsファイルを開くときマクロを無効にするとファイルは表示されません。表示して使えるようにするには再びそのファイルを開いてマクロを有効にして下さい。

'ThisWorkbookモジュール
Option Explicit
Const dPWD = vbBack & "Invalid"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  If Saved = False Then
    Select Case MsgBox("'" & Name & "'への変更を保存しますか?", vbYesNoCancel Or vbExclamation)
    Case vbNo
      Saved = True
    Case vbYes
      Workbook_BeforeSave False, False
    Case vbCancel
      Cancel = True
    End Select
  End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim st As Object
  Set st = ActiveSheet
  Cancel = True
  With Application
    .EnableEvents = False
    If SaveAsUI Then
      If Not Application.Dialogs(xlDialogSaveAs).Show Then Exit Sub
    End If
    .ScreenUpdating = False
    IsAddin = True: Protect dPWD, , True
    Save
    Unprotect dPWD: IsAddin = False: Saved = True
    st.Select
    .ScreenUpdating = True: .EnableEvents = True
  End With
End Sub

Private Sub Workbook_Open()
  Unprotect dPWD: IsAddin = False: Saved = True
End Sub

項目

プレビューのボタンを使用不可にする

内容説明

特定のシートをプレビューする場合にプレビューのボタンを使用不可にしたい場合があります。
プレビューの[印刷][設定][余白][改ページプレビュー]等のボタンを使用不可にするkEnablePreview関数を示します。 AddressOf演算子を用いたコールバック処理を行っています。

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetDlgItem Lib "user32" _
  (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function EnableWindow Lib "user32" _
  (ByVal hWnd As Long, ByVal bEnable As Long) As Long

'コールバック処理
Sub pEnablePreviewTimer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
  Dim ii&
  hWnd = FindWindowEx(hWnd, 0, "EXCELC", vbNullString)
  If hWnd = 0 Then KillTimer 0, idEvent: Exit Sub
  '0:次ページ 1:前ページ 2:拡大 3:印刷 4:設定 5:余白 6:改ページプレビュー 7:標準 8: 閉じる 9: ヘルプ
  For ii = 3 To 7 '3:印刷〜7:標準
    EnableWindow GetDlgItem(hWnd, ii), 0 'ボタンは使用不可
  Next
End Sub

'kEnablePreview関数
'Previewの[印刷][設定][余白][改ページプレビュー]ボタンを使用不可にする
'引数 st：プレビューするシート
'戻り値 ：True=印刷した False=印刷せず閉じた
Function kEnablePreview(st As Object) As Boolean
  Call SetTimer(0, 0, 10, AddressOf pEnablePreviewTimer)
  kEnablePreview = st.PrintPreview
End Function

'kEnablePreview関数の使用例
Sub test_kEnablePreview()
  kEnablePreview ActiveSheet
'  kEnablePreview Worksheets("Sheet1")
'  kEnablePreview ActiveWindow.SelectedSheets
End Sub

追記1：コマンド操作のプレビューに対応
ユーザーのコマンド操作により印刷プレビューを実行したときに[印刷]ボタン等を使用不可にする方法を示します。

'クラスモジュール CPreview
Option Explicit
Private Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public WithEvents Preview As Application

Private Sub Preview_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean)
  Call SetTimer(0, 0, 10, AddressOf pEnablePreviewTimer)
End Sub

'標準モジュール
Dim dview As New CPreview

'クラスCPreviewの開始 印刷プレビューを実行したときに[印刷]ボタン等を使用不可に
Sub kEnablePreviewStart()
  Set dview.Preview = Application
End Sub

'クラスCPreviewの終了 [印刷プレビュー]の画面を元に戻す
Sub kEnablePreviewEnd()
  Set dview.Preview = Nothing
End Sub

追記2：PrintPreviewメソッドの引数について
プレビューの[設定]と[余白]ボタンのみをを使用不可にする場合は引数EnableChangesが利用出来ます。

'[設定][余白]ボタンを使用不可でプレビュー
  '例1
  ActiveWindow.SelectedSheets.PrintPreview EnableChanges:=False
  '例2
  Worksheets("Sheet2").PrintPreview False

項目

Officeクリップボードオブジェクトをマクロで貼り付ける

内容説明

Officeクリップボーは複数のオブジェクトを管理しています。
マクロにて任意のn番目のクリップボードオブジェクトを貼り付ける方法です。
注)このTipsはExcel2000限定です。

'kClipboardPaste関数
'n番目のクリップボードオブジェクトを貼り付け
'貼り付け先はSelectionです ActiveCell等
'nch&　：n番目
'戻り値：クリップボードのCaption
'　="":貼り付け出来ない <>"":貼り付け成功
Function kClipboardPaste(nch As Long) As String
  With CommandBars("Clipboard Paste Menu")
    If nch > kClipboardCount Or nch < 1 Then Exit Function
    With .Controls(nch)
      kClipboardPaste = .Caption
      .Execute '貼り付け
    End With
  End With
End Function

'kClipboardCount関数 値の入っているクリップボードの数を得る
'戻り値：値の入っているクリップボードの数
Function kClipboardCount() As Long
  With CommandBars("Clipboard Paste Menu")
    For kClipboardCount = 0 To .Controls.Count - 1
      If .Controls(kClipboardCount + 1).Caption = "空" Then Exit For
    Next
  End With
End Function

'Selection位置へｎ番目のクリップボードを貼り付ける例
Sub test1_kClipboardPaste()
  Dim rt$, nn&
  nn = 1
  rt = kClipboardPaste(nn)
  If rt <> "" Then MsgBox _
    nn & "番目のクリップボード(" & rt & ")を貼り付けました"
End Sub

'全てのクリップボードを貼り付ける例
'(クリップボードの形式が複数ある場合に対応)
Sub test2_kClipboardPaste()
  Dim ii&, rg As Range
  Set rg = ActiveWindow.RangeSelection
  For ii = 1 To kClipboardCount
    rg.Offset(ii - 1).Activate
    kClipboardPaste ii
  Next
  rg.Activate
End Sub

'Officeクリップボードのクリア
  'Officeクリップボードを全てクリア
  With CommandBars("Clipboard").Controls("クリップボードのクリア(&L)")
    If .Enabled Then .Execute
  End With

項目

ダイアログを指定時間で自動的に閉じる

内容説明

InputBox、MsgBox、GetOpenFilename、組み込みダイアログボックス等を表示した場合に、指定時間が経過したら自動的に閉じるkTimeOutDialog関数を示します。
時間経過により閉じた場合はデフォルト(或はキャンセル)キーが押されたと認識します。

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Const WM_CLOSE = &H10
Const WM_COMMAND = &H111
Private Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetLastActivePopup Lib "user32" (ByVal hWnd As Long) As Long
Dim dsec&, dbutton&

'kTimeOutDialog関数
'ダイアログを指定時間で閉じる
'引数
'　msec: 指定時間(ミリ秒)
'　button:省略可能。MsgBox関数でButtonsにvbAbortRetryIgnore及びvbYesNoを指定した場合に必要
'　　　　タイムアウト時にMsgBox関数の戻値にする値を設定。vbAbortやvbYesなど...
'例)kTimeOutDialogの次行に目的のダイアログ表示を記述の事(必須)
'  kTimeOutDialog　5
'  MsgBox "prompt"
Sub kTimeOutDialog(ByVal msec&, Optional ByVal button As VbMsgBoxResult)
  dsec = msec: dbutton = button
  SetTimer 0, 0, 0, AddressOf pTimeOutDialogProc
End Sub
Private Function pTimeOutDialogProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
  Dim wnd&
  KillTimer 0, idEvent
  wnd = FindWindow("XLMAIN", Application.Caption) 'Application.hWnd
  hWnd = GetLastActivePopup(wnd)
  If hWnd <> wnd Then SetTimer hWnd, 1, dsec, AddressOf pTimeOutDialogProc2
End Function
Private Function pTimeOutDialogProc2(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
  KillTimer hWnd, 1
  SendMessage hWnd, WM_CLOSE, 0, 0
  If dbutton Then SendMessage hWnd, WM_COMMAND, dbutton, 0
End Function

'kTimeOutDialog関数の使用例1(InputBox関数)
Sub test1_kTimeOutDialog()
  Dim inp$
  kTimeOutDialog 10000 '10秒
  inp = InputBox("Message", "Title", "Default")
  '
End Sub

'kTimeOutDialog関数の使用例2(MsgBox関数)
Sub test2_kTimeOutDialog()
  Dim rt&
  kTimeOutDialog 5000 '5秒
  rt = MsgBox("Prompt", vbOKCancel, "Title")
  'kTimeOutDialog 5000, vbYes
  'rt = MsgBox("5秒で閉じます", vbYesNo)
  '
End Sub

'kTimeOutDialog関数の使用例3(GetOpenFilenameメソッド)
Sub test3_kTimeOutDialog()
  Dim file
  kTimeOutDialog 20000 '20秒
  file = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")
  '
End Sub

追記： MsgBox関数の代わりにWSH(Windows Scripting Host)のPopupメソッドを用いる機能を2つ示します。
構文
MsgBox(prompt[, buttons] [, title] [, helpfile, context])
Popup (strText, [intSecondsToWait], [strTitle], [intType])
　(指定時間で閉じたときは-1が返る)

追記1：指定時間(秒)で自動的に閉じるメッセージボックス
'注)メッセージボックスがアクティブ状態の時しかカウントされない。正確な時間が必要なら上記kTimeOutDialog関数の使用例2 を用いる事
Sub test1_Popup()
  Dim rt&, sec&
  sec = 5
  rt = CreateObject("Wscript.Shell").Popup("5秒後自動的に閉じます", sec, "メッセージボックス", vbYesNo Or vbSystemModal)
  If rt = -1 Then Debug.Print "指定時間" & sec; "秒で自動的に閉じました"
End Sub

追記2：メッセージボックス表示中にセル・シートの選択やスクロールを行う
'注)セルへの入力はダブルクリックして編集状態にして行えます。但し、必ず編集状態を終了してメッセージボックスを閉じる事。
Sub test2_Popup()
  Dim rt&
  AppActivate Application.Caption '念のため
  rt = CreateObject("Wscript.Shell").Popup("セルの選択やスクロールが出来ます", , "メッセージボックス", vbOKCancel Or vbSystemModal)
End Sub

項目

ダイアログを指定位置へ表示する

内容説明

MsgBox、GetOpenFilename、組み込みダイアログボックス等を表示する場合、表示位置を指定する事は出来ません。
通常以前に表示されていた位置へ表示されます。
何かの事情により、ダイアログを指定位置へ表示したい場合に用いる事ができるkSetDialogPos関数を示します。

'標準モジュール
Option Explicit
Option Private Module
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function SetWindowPos Lib "user32" _
  (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const SWP_NOSIZE = &H1
Declare Function SetTimer Lib "user32" _
  (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" _
  (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Dim dx&, dy&

'kSetDialogPos関数　ダイアログを指定位置へ表示
'xx:x座標　yy:y座標
'例)kSetDialogPosの次行に目的のダイアログ表示を記述の事(必須)
'  kSetDialogPos　xx, yy
'  MsgBox "mmmmm"
Sub kSetDialogPos(xx&, yy&)
  dx = xx: dy = yy
  SetTimer 0, 0, 0, AddressOf pDialogPosProc
End Sub
Private Function pDialogPosProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
  KillTimer 0, idEvent
  hwnd = GetActiveWindow
  SetWindowPos hwnd, 0&, dx, dy, 0, 0, SWP_NOSIZE
End Function

'■kSetDialogPos関数の使用例1
Sub test1_kSetDialogPos() 
  kSetDialogPos 200, 200
  MsgBox "test_kSetDialogPos"
  '
End Sub

'■kSetDialogPos関数の使用例2
Sub test2_kSetDialogPos() 
  Dim ret As Boolean
  kSetDialogPos 100, 100
  ret = Application.Dialogs(xlDialogOpen).Show
  '
End Sub

追記：高度なMsgBoxのカスタマイズ
エクセルテクニック集[kVBA1]
[kVBA1]拡張メッセージボックスをご参照下さい。
(外観のカスタマイズ、表示位置、タイトルバーにアイコン設定)

項目

UserFormから組込みのダイアログを表示するとモードレスもどきになる

内容説明

モーダルのユーザーフォームからCommandButton等で組込みのダイアログを表示するとモードレスもどきの状態になります。
(セル選択やスクロールが出来るようになる)
この状態を防ぐ方法です。
WindowsAPIのEnableWindow関数でExcelウィンドウを使用不可にしています。

'UserFormモジュール
Private Declare Function EnableWindow Lib "user32" _
  (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub CommandButton1_Click()
  Dim file
  file = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")
  '組み込みダイアログの使用後に次の一行を挿入
  EnableWindow FindWindow("XLMAIN", Application.Caption), 0&
  If file = False Then Exit Sub
  '
  '
End Sub

追記1：APIを使わない方法

'UserFormモジュール
Private Sub CommandButton1_Click()
  Dim file As Variant
  Hide '組み込みダイアログの使用前に非表示にする
  file = Application.GetSaveAsFilename(fileFilter:="テキスト ファイル (*.txt), *.txt")
  Show '表示に戻す
  If file = False Then Exit Sub
  '
  '
End Sub

追記2：モーダルでシートをスクロールする
モーダルのユーザーフォームでモードレスもどきにする方法です。セルやシートの選択・編集、スクロールが出来るようにします。
但し、コマンドバーの利用、セルへの入力等は一部制限があります。 (セルの入力はダブルクリックして編集状態にして行えます。右クリックショートカットメニュー等は使えます)
また、ShowメソッドはUserFormが閉じられない限り完了しません。(モーダルの動作通り)

'UserFormモジュール
Private Declare Function EnableWindow Lib "user32" _
  (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub UserForm_Activate()
  EnableWindow FindWindow("XLMAIN", Application.Caption), 1&
End Sub

注）エクセル2002以降ではhWndプロパティが追加されているので
FindWindow("XLMAIN", Application.Caption)
は
Application.hWnd
と記述出来ますが、Excel97/2000の環境で使われる可能性のある場合は用いる事は出来ません。

項目

ユーザーフォームコントロールの見落としやすいプロパティ

内容説明

ユーザーフォームのコントロールには多くのプロパティがあります。
多いだけに見落としがちな必須プロパティのメモです。


TextBox
Locked プロパティ
　コントロールを編集可能にするかどうかを設定します。
　Trueにすると表示されたまま編集ができないようにします。
　カット&コピーなどのショートカットキーは使えます。 
PasswordChar プロパティ　
　実際に入力された文字の代わりにプレースホルダ文字を表示します。
　プレースホルダ：
　セキュリティ上の理由から他の文字の代わりに使われる文字。
　例えばユーザーがパスワードを入力すると
　入力された文字の代わりにアスタリスク(*)が表示されます。
EnterKeyBehavior プロパティ　
　Trueにすると[Enter]キーで改行します。
　但し、MultiLineプロパティがTrueの場合に限り適用されます。
TabKeyBehavior プロパティ　
　Trueにすると[Tab]キーが入力出来ます。
　但し、MultiLineプロパティがTrueの場合に限り適用されます。
SelectionMargin プロパティ　
　文字列の左側の余白部分をクリックするだけで、
　その行の文字列を選択できるようにするかどうかを設定します。
　Falseにすると左端の隙間を無くし文字列を表示できます。
　(TextBox、ComboBox)
ShowDropButtonWhen プロパティ　(TextBoxでは非表示メンバ)
　右端の下向き矢印(DropButton)の表示を制御します。
　定数　　　　　　　　　　  値 内容 
　fmShowDropButtonWhenNever　0 DropButtonはどの状況下でも表示しません。 
　fmShowDropButtonWhenFocus　1 コントロールにフォーカスがあるときにDropButtonを表示します。 
　fmShowDropButtonWhenAlways 2 DropButtonを常に表示します。 
　TextBoxにもDropButtonを表示する事が出来ます。
　(TextBox、ComboBox)

ComboBox
Style プロパティ
　fmStyleDropDownList 2 にするとリストから値を選択しなければなりません。 
　任意の文字は入力出来なくなります。 
ListWidth プロパティ
　リスト部分の幅を設定します。
　リスト幅をComboBox幅と同じにしてスクロールバーを出さいようにするには
　ListWidthとColumnWidthsプロパティをWidthプロパティと同じにします。

ListBox
ColumnCount プロパティ
　列の数を設定します。
　列の幅を設定するときは ColumnWidthsプロパティを使います。
　ColumnWidthsに0を設定すると列を非表示にすることができます。
ListStyle プロパティ　
　fmListStyleOption 1 にすると複数の選択ができるオプションボタン
　又はチェック ボックスを表示します 。
MultiSelect プロパティ　
　複数選択を許可するかどうかを設定します。
　'選択されている項目を調べるにはSelected プロパティを使います。
  For ii = 0 To Me.ListBox1.ListCount - 1
    If ListBox1.Selected(ii) = True Then
      Debug.Print ListBox1.List(ii)
    End If
  Next　　　

CommandButton
TakeFocusOnClick プロパティ
　Falseにするとクリックされてもフォーカスを取得しません。
　フォーカスは元のコントロールに留まります。 

MultiPage
Style プロパティ　
　Tabsのスタイルを設定します。
　fmTabStyleButtons 1 タブ バーにボタンを表示します 
　fmTabStyleNone　　2 タブ バーを表示しません
　各種ウイザードはfmTabStyleNoneが用いられます。
Value プロパティ　
　現在アクティブなページを表す整数値を表します。
　取得、設定が出来ます。1ページ目は0です。
　MultiPage1.Value = 1 '2ページ目に切り替え

Image　
Enabled プロパティ
　フォーカスを取得できるかどうか、及びイベントに応答するかどうかを設定します。
　Trueのままだと不都合が発生する可能性大です。
　イベントを用いなければFalseにしておくのが必須です。
　イベントを用いる場合はRepaintメソッドでの再描画が必須です。
　RepaintがないとWindows再描画がされるまで固まってしまいます。　
　Private Sub Image1_Click()　
  　Image1.Picture = LoadPicture("xxx.png")
  　Me.Repaint 'お呪いのRepaintメソッドが必須
　End Sub  　

項目

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

内容説明

多くのコントロールに同じような処理をする場合、コントロールの数だけイベントプロシージャを記述していませんか？
クラスを用いてイベントを一つのイベントプロシージャで処理するサンプルを示します。

'■簡易版(そのユーザーフォームのみで処理する)
'全てのTextBoxで右クリックする場合の例
'UserForm1 モジュール
Option Explicit
Public WithEvents TextBox As MSForms.TextBox
Dim dbox As New Collection

Private Sub TextBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then '右クリック
    With TextBox
      MsgBox .Name & "=" & .Value, , .Parent.Name
    End With
  End If
End Sub

Private Sub UserForm_Initialize()
  'UserForm1 は実際のユーザーフォーム名(オブジェクト名)に変更の事。必須
  Dim uf As UserForm1, tb As Object '←
  If Not Me Is UserForm1 Then Exit Sub '←
  For Each tb In Controls
    If TypeOf tb Is MSForms.TextBox Then
      Set uf = New UserForm1 '←
      Set uf.TextBox = tb
      dbox.Add uf
    End If
  Next
  '以降他のInitialize処理を記述
End Sub

'■汎用版(高度な汎用クラスを用いて処理する)
'CForms クラスモジュール
'複数コントロールを1つのイベントプロシージャで処理する汎用クラス
'注) 一部のコントロールとイベントのみ実装。必要により追加要
Option Explicit
Public WithEvents CommandButtons As MSForms.CommandButton
Public WithEvents TextBoxs As MSForms.TextBox
Public WithEvents ComboBoxs As MSForms.ComboBox
Public WithEvents Labels As MSForms.Label
Public WithEvents CheckBoxs As MSForms.CheckBox
Public WithEvents OptionButtons As MSForms.OptionButton
Public Event Click(ByVal Control As MSForms.Control)
Public Event Change(ByVal Control As MSForms.Control)
Public Event KeyDown(ByVal Control As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Public Event KeyPress(ByVal Control As MSForms.Control, ByVal KeyAscii As MSForms.ReturnInteger)
Public Event KeyUp(ByVal Control As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Public Event MouseDown(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Public Event MouseMove(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Public Event MouseUp(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Private dmng As CForms
Private dctl As Collection

Sub AddEvent(ByVal Form As MSForms.UserForm)
  Dim cf As CForms, ctl As Object
  On Error Resume Next
  Set dctl = New Collection
  For Each ctl In Form.Controls
    If Not (TypeOf ctl Is MSForms.Frame Or TypeOf ctl Is MSForms.MultiPage) Then
      Set cf = New CForms
      Set cf.Manager = Me
      If TypeOf ctl Is MSForms.Label Then
        Set cf.Labels = ctl
      ElseIf TypeOf ctl Is MSForms.CommandButton Then
        Set cf.CommandButtons = ctl
      ElseIf TypeOf ctl Is MSForms.TextBox Then
        Set cf.TextBoxs = ctl
      ElseIf TypeOf ctl Is MSForms.ComboBox Then
        Set cf.ComboBoxs = ctl
      ElseIf TypeOf ctl Is MSForms.CheckBox Then
        Set cf.CheckBoxs = ctl
      ElseIf TypeOf ctl Is MSForms.OptionButton Then
        Set cf.OptionButtons = ctl
      Else
        Set cf = Nothing
      End If
      If Not cf Is Nothing Then dctl.Add cf
    End If
  Next
End Sub

Public Sub RemoveEvent()
  Dim cf As CForms
  If dctl Is Nothing Then Exit Sub
  For Each cf In dctl
    Set cf.Manager = Nothing
  Next
  Set dctl = Nothing
End Sub

Private Sub Class_Terminate()
  RemoveEvent
End Sub
Friend Property Set Manager(ByVal obj As CForms)
  Set dmng = obj
End Property

Friend Sub RaiseClick(ByVal Control As MSForms.Control)
  RaiseEvent Click(Control)
End Sub
Friend Sub RaiseChange(ByVal Control As MSForms.Control)
  RaiseEvent Change(Control)
End Sub
Friend Sub RaiseKeyDown(ByVal Control As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  RaiseEvent KeyDown(Control, KeyCode, Shift)
End Sub
Friend Sub RaiseKeyUp(ByVal Control As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  RaiseEvent KeyUp(Control, KeyCode, Shift)
End Sub
Friend Sub RaiseKeyPress(ByVal Control As MSForms.Control, ByVal KeyAscii As MSForms.ReturnInteger)
  RaiseEvent KeyPress(Control, KeyAscii)
End Sub
Friend Sub RaiseMouseDown(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  RaiseEvent MouseDown(Control, Button, Shift, X, Y)
End Sub
Friend Sub RaiseMouseMove(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  RaiseEvent MouseMove(Control, Button, Shift, X, Y)
End Sub
Friend Sub RaiseMouseUp(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  RaiseEvent MouseUp(Control, Button, Shift, X, Y)
End Sub

Private Sub CheckBoxs_Click()
  dmng.RaiseClick CheckBoxs
End Sub
Private Sub CheckBoxs_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyDown CheckBoxs, KeyCode, Shift
End Sub
Private Sub CheckBoxs_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyUp CheckBoxs, KeyCode, Shift
End Sub
Private Sub OptionButtons_Click()
  dmng.RaiseClick OptionButtons
End Sub
Private Sub OptionButtons_Change()
  dmng.RaiseChange OptionButtons
End Sub
Private Sub OptionButtons_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyDown OptionButtons, KeyCode, Shift
End Sub
Private Sub ComboBoxs_Change()
  dmng.RaiseChange ComboBoxs
End Sub
Private Sub ComboBoxs_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyDown ComboBoxs, KeyCode, Shift
End Sub
Private Sub ComboBoxs_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyUp ComboBoxs, KeyCode, Shift
End Sub
Private Sub ComboBoxs_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  dmng.RaiseMouseDown ComboBoxs, Button, Shift, X, Y
End Sub
Private Sub ComboBoxs_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  dmng.RaiseMouseUp ComboBoxs, Button, Shift, X, Y
End Sub
Private Sub CommandButtons_Click()
  dmng.RaiseClick CommandButtons
End Sub
Private Sub CommandButtons_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyDown CommandButtons, KeyCode, Shift
End Sub
Private Sub CommandButtons_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyUp CommandButtons, KeyCode, Shift
End Sub
Private Sub Labels_Click()
  dmng.RaiseClick Labels
End Sub
Private Sub Labels_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  dmng.RaiseMouseDown Labels, Button, Shift, X, Y
End Sub
Private Sub TextBoxs_Change()
  dmng.RaiseChange TextBoxs
End Sub
Private Sub TextBoxs_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyDown TextBoxs, KeyCode, Shift
End Sub
Private Sub TextBoxs_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  dmng.RaiseKeyUp TextBoxs, KeyCode, Shift
End Sub
Private Sub TextBoxs_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  dmng.RaiseMouseDown TextBoxs, Button, Shift, X, Y
End Sub
Private Sub TextBoxs_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  dmng.RaiseMouseUp TextBoxs, Button, Shift, X, Y
End Sub
'↑ここまで CForms クラスモジュール

'ユーザーフォーム汎用クラスCFormsの使用例
'UsetForm モジュール
'複数のCommandButton、TextBox、ComboBox、Label、CheckBox等を適宜配置してお試し下さい
Option Explicit
Dim WithEvents Controls As CForms

Private Sub Controls_Change(ByVal Control As MSForms.Control)
  Debug.Print "Controls_Change "; Control.Value
End Sub
Private Sub Controls_Click(ByVal Control As MSForms.Control)
  Debug.Print "Controls_Click "; Control, Control.Caption, Control.Name, Control.Parent.Name
End Sub
Private Sub Controls_KeyUp(ByVal Control As MSForms.Control, ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Debug.Print "Controls_KeyUp "; Control; KeyCode; Shift
End Sub
Private Sub Controls_MouseUp(ByVal Control As MSForms.Control, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Debug.Print "Controls_MouseUp "; Control; Button; Shift; X; Y
End Sub

Private Sub UserForm_Initialize()
  Set Controls = New CForms
  Controls.AddEvent Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Controls.RemoveEvent
End Sub

項目

指定したプリンターで印刷する

内容説明

特定の印刷をActivePrinter以外のプリンター[LBP-880 (xxx.xxx)]で行うサンプルです。
複数の端末に[LBP-880 (xxx.xxx)]は登録してありますがActivePrinter名は
LBP-880 (xxx.xxx) on Ne01:
LBP-880 (xxx.xxx) on Ne03:
など、ポート番号は端末により不定です。
Application.ActivePrinter = "LBP-880 (xxx.xxx) on Ne01:"
などと指定すると端末によってはエラーになります。
次のようにPrintOutメソッドの引数ActivePrinterにはポート番号無しのプリンター名が指定出来ます。

Sub test_E00M082()
  Dim tmp$, prn$
  prn = "LBP-880 (xxx.xxx)" 'プリンター名(ポート番号無し)
  tmp = Application.ActivePrinter
  ActiveSheet.PrintOut ActivePrinter:=prn 
  Application.ActivePrinter = tmp 'ActivePrinterを戻す
End Sub

項目

最新のExcelファイルを探す

内容説明

指定したフォルダのなかで最新更新のExcelファイルをフルパスで返す関数です。

'kNewestFile関数 最新のExcelファイルを探す
'引数 folder$：探すフォルダ名
'戻り値：最新Excelファイルのフルパス名
Function kNewestFile(ByVal folder$) As String
  Dim dt As Date, fn$, ff$
  If Right(folder, 1) = "\" Then folder = Left(folder, Len(folder) - 1)
  ff = Dir(folder & "\*.xls")
  Do While ff <> ""
    If dt < FileDateTime(folder & "\" & ff) Then fn = ff: dt = FileDateTime(folder & "\" & ff)
    ff = Dir
  Loop
  If fn <> "" Then kNewestFile = folder & "\" & fn
End Function

'kNewestFile関数の使用例
Sub test_kNewestFile()
  MsgBox kNewestFile("C:\Documents and Settings\user\My Documents"), , "最新ファイル"
End Sub