項目

ストップウォッチ

内容説明

VBAでミリ秒単位のストップウォッチ機能を実装する方法を示します。
引数付きでkStopwatch関数を実行するとストップウォッチがスタートし、引数無しで実行するとストップします。
引数で指定したセル・ラベル等にミリ秒単位で時間を表示します。

'標準モジュール MStopwatch
Option Explicit
Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Sub KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long)
Declare Function timeGetTime Lib "winmm.dll" () As Long
'Const dFMT = "hh:mm:ss.00" '表示フォーマット
Const dFMT = "mm:ss.00"
Dim did As Long, drg As Object, dstart As Long

'kStopwatch関数　ストップウォッチの開始/停止(トグル)
'ミリ秒単位で時間を表示します
'引数 obj:時間を表示するオブジェクト
'　　　　 無し=停止
Sub kStopwatch(Optional obj As Object)
  If obj Is Nothing Then
    pStopwatchStop
    Exit Sub
  End If
  If did <> 0 Then pStopwatchStop: Exit Sub
  Set drg = obj
  If TypeName(drg) = "Range" Then drg.NumberFormat = dFMT
  dstart = timeGetTime
  did = SetTimer(0&, 0&, 10&, AddressOf pTimerProc)
End Sub
Private Sub pStopwatchStop()
  KillTimer 0&, did
  did = 0
End Sub
Private Sub pTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
  Dim tm#
  On Error Resume Next
  If Application.Visible = False Or _
    ThisWorkbook.Parent <> "Microsoft Excel" Then pStopwatchStop: Exit Sub
  tm = (timeGetTime - dstart) / 86400000 '60*60*24*1000
  If TypeName(drg) = "Range" Then
    If Not ActiveSheet Is drg.Parent Then pStopwatchStop: Exit Sub
    drg = tm
  Else
    If VarType(drg) = vbObject Or _
      drg.Parent.Visible = False Then pStopwatchStop: Exit Sub
    drg = Application.Text(tm, dFMT)
  End If
End Sub

使用例1: セルでストップウォッチ
ワークシートにフォームのボタンを配置し test_StopwatchCell 関数を登録
クリックで測定開始、次にクリックで停止。(トグル)


'標準モジュール MStopwatch
Sub test_StopwatchCell()
  If did Then
    kStopwatch
  Else
    kStopwatch Range("a1") '表示するセル
  End If
End Sub

使用例2: ユーザーフォームのラベルでストップウォッチ
UserFormに Label1、ToggleButton1 を配置
ToggleButtonクリックで測定開始、次にクリックで停止。(トグル)


'UserFormモジュール
Option Explicit
Private Sub ToggleButton1_Click()
  If ToggleButton1.Value Then
    kStopwatch Label1 '表示するコントロール
  Else
    kStopwatch
  End If
End Sub

項目

指定した名前のシートが存在するか否かを簡潔に調べる

内容説明

指定した名前のシートが存在するかを調べたい場面はよくありますがどのようなコードを記述しますか。 方法は色々ありますが通常はコレクションのループやエラートラップを用いると思います。
Evaluateメソッドを用いて簡潔に1行のステートメントでシート存在を調べる方法を示します。 但しワークシート限定です。
同様に指定した名前のブックが開かれているかを調べる方法、及び名前が定義されているかを調べる方法も示します。

'■シート存在を調べる
Sub test_SheetExists()
  Dim st$
  st = "Sheet1" '調べるシート名
  'st = "[Book1.xls]Sheet1" '調べるシート名(ブック名を指定の場合)
  If IsError(Evaluate(st & "!a1")) Then
    MsgBox st & vbCrLf & "シートは存在しません"
  Else
    MsgBox st & vbCrLf & "シートは存在します"
  End If
End Sub

'■ブックが開かれているかを調べる
Sub test_BookOpened()
  Dim bk$, st$
  bk = "Book1.xls" '調べるブック名
  st = "Sheet1"    '調べるブックのシート名
  If IsError(Evaluate("[" & bk & "]" & st & "!a1")) = True Then
    MsgBox bk & " - " & st & vbCrLf & "開いていません"
  Else
    MsgBox bk & " - " & st & vbCrLf & "開いています"
  End If
End Sub

'■名前が定義されているかを調べる
Sub test_NameExists()
  Dim na$
  na = "nnn" '調べる名前
  If IsError(Evaluate(na)) Then
    MsgBox na & vbCrLf & "名前は定義されていません"
  Else
    MsgBox na & vbCrLf & "名前は定義されています" & vbCrLf & " " & Range(na).Address(False, False, , True)
  End If
End Sub

'■図形が存在するかを調べる1
'Me、ActiveSheet、Applicationオブジェクトでの調査
Sub test1_ShapeExists()
  Dim na$
  na = "Rectangle 1"
  If IsObject(Evaluate(na)) Then
    Debug.Print "存在しています"
  Else
    Debug.Print "存在しません"
  End If
End Sub

'■図形が存在するかを調べる2
'Sheetsオブジェクトを指定しての調査
Sub test2_ShapeExists()
  Dim na$, st As Object
  Set st = Workbooks("Book1.xls").Sheets("Sheet1")
  na = "Rectangle 1"
  If IsObject(st.Evaluate(na)) Then
    Debug.Print "存在しています"
  Else
    Debug.Print "存在しません"
  End If
End Sub

参考)Evaluateメソッドのヘルプより
Evaluate メソッド
使用する名前を、オブジェクトまたは値に変換します。
構文
expression.Evaluate(Name)
expression　Application オブジェクトでは省略可能です。Chart オブジェクト、および Worksheet オブジェクトでは必ず指定します。対象となる Application、Chart、Worksheet オブジェクトへのいずれかを表すオブジェクト式を指定します。
Name　　　　必ず指定します。文字列型 (String) の値を使用します。Excel の名前付け規則に従って、対象オブジェクトの名前を指定します。

項目

ファイルのプロパティダイアログを表示する

内容説明

ファイル名を指定してファイルのプロパティダイアログを表示する方法です。
このプロパティダイアログはエクスプローラ等の右クリック-[プロパティ]で表示されるものです。
Excelの[ファイル]-[プロパティ]と比べ、改訂番号や属性などの詳細情報を設定出来ます。

'標準モジュール
Option Explicit
Option Private Module
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (lpExecInfo As SHELLEXECUTEINFO) As Long
Type SHELLEXECUTEINFO
  cbSize As Long
  fMask As Long
  hWnd As Long
  lpVerb As String
  lpFile As String
  lpParameters As String
  lpDirectory As String
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type
Const SEE_MASK_NOCLOSEPROCESS = &H40
Const SEE_MASK_INVOKEIDLIST = &HC
Const SEE_MASK_FLAG_NO_UI = &H400

'kFileProperty関数
'ファイル名を指定してファイルのプロパティダイアログを表示する
'引数 fn ：ファイルのフルパス
'     wnd：ウインドウハンドル 省略->Excel
Sub kFileProperty(ByVal fn As String, Optional ByVal wnd As Long = -1)
  Dim se As SHELLEXECUTEINFO
  If wnd = -1 Then wnd = FindWindow("XLMAIN", Application.Caption)
  With se
    .cbSize = LenB(se)
    .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
    .hWnd = wnd
    .lpVerb = "PROPERTIES"
    .lpFile = fn
  End With
  Call ShellExecuteEX(se)
End Sub

Sub test_kFileProperty() 'kFileProperty関数のテスト
  Call kFileProperty("c:\ddd\eee\fff.xls")
End Sub

項目

インターネットへの接続を調べる

内容説明

インターネット(プロバイダサーバー)へ接続されているかどうかを調べる関数を示します。

'インターネットへの接続を調べる
'戻り値 True:接続されている　False:接続されていない
Function kConnectionCheckInternet() As Boolean
  With CreateObject("InternetExplorer.Application")
    .Visible = False
    .navigate "http://www2.aqua-r.tepm.jp/~kmado/"
    While .Busy: Wend
    'While .readyState <> READYSTATE_COMPLETE:  Wend '参照設定Microsoft Internet Controls
    While .readyState <> 4:  Wend
    If .document.Title = "サーバーが見つかりません" Then Exit Function
    kConnectionCheckInternet = True
  End With
End Function

Sub test_kConnectionCheckInternet() 'kConnectionCheckInternet関数のテスト
  Dim rt As Boolean
  rt = kConnectionCheckInternet
  MsgBox IIf(rt, "接続済み", "未接続"), , "インターネットへの接続確認"
End Sub

項目

使用出来るファイル名であるかを調べる

内容説明

新規保存や名前を付けて保存あるいはファイル名変更等で、ファイル名(又はフォルダ名)がWindowsで使用出来る文字列であるかを調べる関数を示します。
次の文字は、ファイル名に使用できません。
\ / : * ? " < > |
ファイル名はスペースも含めて最大215文字です。但し215文字のファイル名はお勧めしません。ほとんどのプログラムは長すぎるファイル名を解釈できません。

Windows Script(Microsoft VBScript Regular Expression x.x)の正規表現を用いてシンプルに記述した、ファイル名に不正な文字が含まれていないかを調べるkBadFilename関数です。

'kBadFilename関数 ファイル名が正しいか調べる
'構文 rt=kBadFilename(fn)
'引数   fn:調べるファイル名
'戻り値 rt: rt="" 正しいファイル名 rt<>"" 不正なファイル名(使えない文字が戻る)
Function kBadFilename(fn As String) As String
  Dim ele As Object
  With CreateObject("VBScript.RegExp")
    .Pattern = "[\\/:*?""<>|]" '検索する正規表現パターン
    .Global = True
    For Each ele In .Execute(fn)
      kBadFilename = kBadFilename & ele
    Next
  End With
End Function

'kBadFilename関数の使用例
Sub test_kBadFilename()
  Dim fname As String, rt As String
  Const TIT = "ファイル名"
  fname = "asd?zxc|*123.xls"
  rt = kBadFilename(fname)
  If rt = "" Then
    MsgBox fname & " は正しいファイル名です", , TIT
  Else
    MsgBox "ファイル名には次の文字は使えません" & vbCrLf & "\/:*?""<>|" & vbCrLf & _
      fname & " は不正なファイル名です" & vbCrLf & rt & " が含まれています", , TIT
  End If
End Sub

追記1)Like演算子による簡易判定
'不正ファイル名の簡易判定 但し不正文字の特定はしていない
  Dim file$
  file = "abc?" 'ファイル名
  If file Like "*[\/:*?""<>|]*" Then
    MsgBox file & " は不正なファイル名です"
  End If

追記2)ファイル名に使えない文字は入力させない
'UserFormのTextBoxで制御する例 txtFile <- UserFormのテキストボックス 
Private Sub txtFile_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
  If Chr(KeyAscii) Like "[\/:*?""<>|]" Then KeyAscii = 0
End Sub

項目

テキストエディターのフルパス名を取得する

内容説明

txtファイル等に関連付けされているテキストエディター(メモ帳など)等のフルパス名を取得する方法を示します。
拡張子に関連付けされているアプリケーションのフルパスを取得するkGetExe関数

'モジュールレベル
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

'kGetExecutable関数　拡張子に関連付けされているアプリケーションのフルパスを取得する
'引数 ext：拡張子 省略値はtxt
'戻り値　：拡張子に関連付けされているアプリケーションのフルパス ""=エラー
Function kGetExecutable$(Optional ext$ = "txt")
  Dim buf As String * 260, tmp$, ff%
  tmp = Environ("temp") & "\" & Format(Now, "yymmddhhmmss") & "." & ext
  ff = FreeFile
  Open tmp For Output As ff: Close ff
  If Not FindExecutable(tmp, tmp, buf) < 32 Then _
    kGetExecutable = Left(buf, InStr(buf, Chr(0)) - 1)
  Kill tmp
End Function

使用例) kGetExecutable関数でテキストエディターのフルパス名を取得する

Sub test_kGetExecutable()
  MsgBox kGetExecutable
End Sub

項目

UserFormのウィンドウスタイルを変更する

内容説明

UserFormのウィンドウスタイル(属性)を変更する方法を示します。

その1)ユーザーフォームに最大化最小化ボタンを付け、又サイズ変更可能にする

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" _
  (ByVal pacc As Object, phwnd As Long) As Long
Const WS_MAXIMIZEBOX = &H10000
Const WS_MINIMIZEBOX = &H20000
Const WS_THICKFRAME = &H40000 'サイズ変更
Const GWL_STYLE = (-16)

'ユーザーフォームに最大化最小化ボタンを付け、又サイズ変更可能にする
Sub kUformMaxMin(uf As UserForm)
  Dim hwnd&
  'hwnd = FindWindow(IIf(Application.Version < 9, "ThunderXFrame", "ThunderDFrame"), uf.Caption)
  WindowFromObject uf, hwnd 'Windows2000以降
  SetWindowLong hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX Or WS_THICKFRAME
  DrawMenuBar hwnd
End Sub

'ユーザーフォームモジュール
Private Sub UserForm_Initialize()
  Call kUformMaxMin(Me)
End Sub

Private Sub UserForm_Resize() 'サイズ変更がされた
  If Height < InsideHeight Then Exit Sub '最小化された
  '各コントロールの位置やサイズを調整するコードを記述
  '
End Sub

その2)ユーザーフォームを最大化表示にする

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" _
  (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const SW_SHOWMAXIMIZED = 3
Const SC_MOVE = &HF010&

'アクティブウインドウを最大化表示にする
Sub kShowMaximized()
  Dim hwnd&
  hwnd = GetActiveWindow
  'hwnd = FindWindow("XLMAIN", Application.Caption)
  ShowWindow hwnd, SW_SHOWMAXIMIZED
  DeleteMenu GetSystemMenu(hwnd, 0&), SC_MOVE, 0&
  DrawMenuBar hwnd
End Sub

'ユーザーフォームモジュール
Private Sub UserForm_Activate()
  kShowMaximized
End Sub

追記：高度なウィンドウスタイル
Excelウインドウ左上のアイコンを変更、UserFormのタイトルバーにアイコンを設定する等については ソフトウェア<Our Software>
エクセルVBAテクニック集 kVBA1
クラス編については
エクセルVBAテクニック集 kVBA4
をご参照下さい。

項目

ネットワークにも対応したChDir

内容説明

カレントドライブとフォルダを変更するにはChDriveステートメントとChDirステートメントを使い、次のように設定出来ます。

　Dim pathn$
  pathn = "c:\ddd\eee"
  ChDrive pathn
  ChDir pathn

しかし、変更するフォルダがネットワークの場合、ChDriveステートメントは使えません。(ネットワークドライブの割り当てがされていない場合)
WindowsAPIのSetCurrentDirectory関数を用いると簡単にカレントドライブとフォルダの変更が出来ます。

'モジュールレベルで宣言
Private Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" _
  (ByVal lpPathName As String) As Long

'カレントドライブとフォルダの変更例
Sub test_SetCurrentDirectory()
  Dim pathn$, file
  pathn = "\\host\dat\aaa"
  SetCurrentDirectory (pathn)
  file = Application.GetOpenFilename("Excel ﾌﾞｯｸ(*.xls),*.xls")
  If file = False Then Exit Sub
  MsgBox file
  'Workbooks.Open file
End Sub

追記：WSH(Windows Scripting Host)のCurrentDirectoryプロパティを用いる方法
　CreateObject("WScript.Shell").CurrentDirectory = "\\aaa\bbb\ccc"

項目

ファイルをごみ箱にいれる

内容説明

VBAにてファイルをごみ箱に入れる方法です。

'標準モジュール
Option Explicit
Option Private Module
Type SHFILEOPSTRUCT
  hwnd As Long
  wFunc As Long
  pfrom As String
  pto As String
  fflags As Integer
  fAnyOperationsAborted As Boolean
  hNameMappings As Long
  lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32" Alias "SHFileOperationA" _
  (lpFileOp As SHFILEOPSTRUCT) As Long
Const FO_DELETE = &H3 '削除
Const FOF_ALLOWUNDO = &H40 '元に戻す
Const FOF_NOCONFIRMATION = &H10 '確認なし
Const FOF_NOERRORUI = &H400&    'エラーのダイアログを表示しない
Const FOF_MULTIDESTFILES = &H1& '複数ファイル削除指定
'複数のファイル,フォルダを処理する場合はNULL文字で区切る

'kFileOperationDel関数 ファイルをごみ箱へ入れる
'引数 fname：ごみ箱へ入れるファイル名
'     fflags：省略(確認無し) True:確認有り
'戻り値 0：成功
Function kFileOperationDel(fname As String, Optional fflags As Boolean = False) As Long
  Dim fo As SHFILEOPSTRUCT
  fo.pfrom = fname
  fo.wFunc = FO_DELETE
  fo.fflags = FOF_ALLOWUNDO Or FOF_NOERRORUI Or IIf(fflags, 0, FOF_NOCONFIRMATION)
  kFileOperationDel = SHFileOperation(fo) 'rt=0 成功
End Function

'kFileOperationDel関数の使用例
Sub test_kFileOperationDel()
  Dim ret&
  ret = kFileOperationDel("D:\Users\ddd.txt")
  If ret Then MsgBox "Err=" & ret
End Sub

項目

各種フォルダを取得する

内容説明

WINDOWSのフォルダ、テンポラリ−フォルダ、Excel関連のフォルダ等の取得メモです。

Environ("windir") 'Windowsフォルダ
Environ("temp")   'Tempフォルダ

ActiveWorkbook.Name　   'ActiveWorkbookのブック名 
ActiveWorkbook.FullName 'ActiveWorkbookのフルパス名 
ActiveWorkbook.Path     'ActiveWorkbookの絶対パス 
Application.Path        'Excelの絶対パス 
Application.AltStartupPath  '代替起動フォルダの名前 
Application.DefaultFilePath 'カレントフォルダ名 
Application.LibraryPath     '[Library]フォルダのパス名 
Application.NetworkTemplatesPath 'テンプレートのネットワークパス名 
Application.PathSeparator   'パスセパレータ \ 
Application.StartupPath     'Excelの起動フォルダの絶対パス名 
Application.TemplatesPath   'テンプレートのローカルパス名 
CurDir [(drive)]  '指定したドライブの現在のパス 引数driveは省略可能
Application.UserLibraryPath 'ユーザー単位のCOMアドインのパス名(Excel2000以降) 

'WINDOWSのSYSTEMフォルダの取得
'モジュ−ルレベルで宣言 
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _ 
　(ByVal lpBuffer As String, ByVal nSize As Long) As Long 
'kGetSysDir関数 WINDOWSのSYSTEMフォルダ取得
Function kGetSysDir$()
  Dim sdir As String
  sdir = Space(260)
  kGetSysDir = Left(sdir, GetSystemDirectory(sdir, Len(sdir)))
End Function
'kGetSysDir関数の使用例
Sub test_kGetSysDir()
  Debug.Print kGetSysDir
End Sub

WHSの利用
'デスクトップのフォルダ
CreateObject("WScript.Shell").SpecialFolders("Desktop")
'マイドキュメントのフォルダ
CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
'使用できる特殊フォルダ名
"AllUsersDesktop"
"AllUsersStartMenu"
"AllUsersPrograms"
"AllUsersStartup"
"AppData"
"Desktop"
"Favorites"
"Fonts"
"MyDocuments"
"NetHood"
"PrintHood"
"Programs"
"Recent"
"SendTo"
"StartMenu"
"Startup"
"Templates"

追記：フォルダ選択のダイアログボックス
フォルダを選択するダイアログの表示については ソフトウェア<Our Software> エクセルVBAテクニック集 kVBA1をご参照下さい。
初期フォルダやダイアログタイトルを任意に設定出来ます。