admin menu ≫  image  writes  admin
スポンサーサイト 
--.--.--.-- 
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
久しぶりのエクセルネタです(^^;・・・2009/08/19の記事に追記再編集 
2009.08.29.Sat 
指定された時間だけメッセージを表示するエクセルVBAのマクロです。
あちこち検索して公開されていたサンプルマクロを組合せただけですが(^^;
公開されていた方に感謝(^^

IEから開いた場合、WinOSのバージョンに依存しないメッセージが表示できるようになった(^^v
以下の仕様になっています。
?ウェブ上では、メッセージを表示しない。(問題が解決しない為)
 IEから開いた場合でもメッセージが表示できた(^^v
?OSがWin2000以下の場合は、VBスクリプト(PopUp_Msg.vbs)をThisWorkbook.Pathに出力する。
?ThisWorkbook.Pathを検索して、VBスクリプトファイルの有無を確認する。
?Shell関数でVBスクリプトを呼び出してから同期処理を行い、メッセージが消えるまでエクセル側の処理を待機させる。
?OSがWinXP以上の場合は、MessageBoxTimeoutA関数でメッセージを表示する。

主にエクセルアプリケーションの起動時、終了時に数秒間メッセージを表示したり、
時間の掛かる処理をする前後でメッセージを表示したりして使っています。
尚、VBスクリプトで表示する場合は、shell関数による呼び出しで若干時間が掛かってしまいます(^^;
Option Explicit

Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long

Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long

Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long

Declare Function MessageBoxTimeoutA Lib "user32" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageId As Long, _
ByVal dwMilliseconds As Long) As Long

Function Vbs_Msg(msg$, sec%, title$) As Boolean
'VBスクリプトとWin32 API関数を使ったメッセージ出力(2009/08/19)
Dim lngProcessID As Long 'Shell関数の戻り値
Dim lngProcess As Long 'OpenProcess関数の戻り値
Dim lngExitCode As Long '終了コード
Dim rc As Long
Dim CmdLine
If InStr(ThisWorkbook.Path, "http") <> 0 Then '?
CreateObject("WScript.Shell").Run _
"msg %username% /time:" & sec & " " & _
msg, vbHide, False '(2009/08/29)
Exit Function
End If
If InStr(Application.OperatingSystem, "5") = 0 And _
File_Search(ThisWorkbook.Path & "\", "PopUp_Msg.vbs") = False Then PopUpMsgPut '?
If File_Search(ThisWorkbook.Path & "\", "PopUp_Msg.vbs") = True Then '?
CreateObject("WScript.Shell").Popup (msg), sec, title, vbInformation 'VBAで使えない
CmdLine = "WScript.exe " & Chr(34) & ThisWorkbook.Path & "\PopUp_Msg.vbs" & Chr(34)
msg = Chr(34) & msg & Chr(34)
title = title & "(VBSメッセージ)"
CmdLine = CmdLine & " " & msg & " " & sec & " " & title
lngProcessID = Shell(CmdLine, vbNormalFocus)
lngProcess = OpenProcess(&H400&, True, lngProcessID)
Do
rc = GetExitCodeProcess(lngProcess, lngExitCode) '?
DoEvents
Loop While lngExitCode = &H103&
rc = CloseHandle(lngProcess)
Else
'?WinXp以上(この関数はWin2000以下では使えない)
On Error Resume Next '念の為
MessageBoxTimeoutA 0&, msg, title, vbInformation + vbMsgBoxSetForeground, 0, sec * 1000
End If
End Function

Function PopUpMsgPut() As Boolean
'Win2000以下のメッセージ出力用VBスクリプトファイルの出力(2009/08/19)
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim vbs_fs, vbs_f, vbs_ts, vbsFileName$
vbsFileName = ThisWorkbook.Path & "\PopUp_Msg.vbs"
Set vbs_fs = CreateObject("Scripting.FileSystemObject")
vbs_fs.CreateTextFile vbsFileName
Set vbs_f = vbs_fs.GetFile(vbsFileName)
Set vbs_ts = vbs_f.OpenAsTextStream(ForWriting, TristateUseDefault)
vbs_ts.write "Option Explicit" + vbCrLf
vbs_ts.write "Dim WSH, args" + vbCrLf
vbs_ts.write "Set WSH = CreateObject(""WScript.Shell"")" + vbCrLf
vbs_ts.write "Set args = WScript.Arguments" + vbCrLf
vbs_ts.write "WSH.Popup (args.Item(0)), args.Item(1), args.Item(2), vbInformation" + vbCrLf
vbs_ts.write "Set WSH = Nothing" + vbCrLf
vbs_ts.write "Set args = Nothing" + vbCrLf
vbs_ts.Close
End Function

Function File_Search(sFilePath$, sFileName$) As Boolean
'指定されたフォルダ内を検索し、ファイルの有無を確認して値を返す
Dim fs, Fn$, i%
Set fs = Application.FileSearch
File_Search = False
With fs
.LookIn = sFilePath
.FileName = sFileName
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fn = Mid(.FoundFiles(i), Len(sFilePath) + 1)
If Fn = sFileName Then
File_Search = True 'ファイルが見つかった
Exit Function
End If
Next i
End If
End With
End Function
関連記事
スポンサーサイト
* スポンサーサイト久しぶりのエクセルネタです(^^;・・・2009/08/19の記事に追記再編集へのコメント *
   

台風画報


ナショジオニュース

降水短時間予報

RSSフィード

月別アーカイブ

ブログ内の検索

プロフィール


  • Designed by Il mio diario
  • Powered by FC2BLOG
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。