| |
こんばんは。
VBSとVBAを組み合わせてみました。
>
>ブックを二つ用意します。
>
>１のブック dsptime.xls
> 機能 ユーザーフォームに時間経過を表示する機能を持つ
>
>２のブック setcell.xls
> 機能 setcell.xlsの最左端シートのＡ列に1から20000までの数値を書き込む
>
３VBSスクリプト vbstest.vbs
機能 setcell.xlsの最左端シートのＡ列に1から20000までの数値を書き込む時間を 計測し、setcell.xlsの最左端シートのセルＢ１処理時間を出力する
>
>dsptime.xls
>
>ユーザーフォーム（Userform1）を一つ用意してください。
> このUserform1には、
> Label1 開始時間の表示
> Label2 現在の時間を表示
> という二つのラベルを用意してください。
>
> ふたつのラベルには、hh:mm:ss形式で時刻を表示しますので、それに
> 足りうる幅をラベルは有します。
>
>コードです。
>
>
>Thisworkbookのモジュールに
Option Explicit
Public 時間 As Date
Sub set_proc()
Application.OnTime Now(), "thisworkbook.dspform"
End Sub
'==================================================================
Sub dspform()
UserForm1.Show
End Sub
'==================================================================
Sub unloadform()
' Userform1の消去
Unload UserForm1
End Sub
'==================================================================
Sub hideform()
' 時間表示を停止する
UserForm1.dsp = False
End Sub
'==================================================================
Sub set_tm(rng As Range)
' 開始から、停止までの時間を指定されたセルに設定する
rng.Value = 時間
End Sub
>
Userform1のモジュールは、ちょっと変更。
>'===================================================================
Option Explicit
Public dsp As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private 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 temae_set = -1
Const hyoji = &H40
Const nonesz = &H1
Const nonemv = &H2
'===================================================================
Private Sub UserForm_Activate()
Dim hwnd As Long, ret As Long
hwnd = FindWindow("ThunderDFrame", Me.Caption)
ret = SetWindowPos(hwnd, temae_set, 0, _
0, 0, 0, hyoji Or nonemv Or nonesz)
dsp = True
Label1.Caption = Format([now()], "hh:mm:ss")
Do While dsp = True
Label2.Caption = Format([now()], "hh:mm:ss")
DoEvents
Sleep 300
Loop
ThisWorkbook.時間 = CDate(Label2.Caption) - CDate(Label1.Caption)
Me.Hide
End Sub
'===================================================================
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> 1 Then
Cancel = True
End If
End Sub
>setcell.xlsのコード
標準モジュールから、Thisworkbookのモジュールに変更
'=====================================================================
Option Explicit
Sub set_cell()
Dim g0 As Long
ThisWorkbook.Activate
Worksheets(1).Activate
Range("a:a").ClearContents
For g0 = 1 To 20000
With Cells(g0, 1)
.Select
.Value = g0
End With
Next
End Sub
最後にvbstest.vbsのコード
'=====================================================================
Dim g0 ,ex,dbk,fs
set fs=createobject("scripting.filesystemobject")
with CreateObject("excel.application")
.visible=true
with .workbooks.Open(fs.GetParentFolderName(wscript.scriptfullname) & "\setcell.xls")
Set ex = CreateObject("excel.application")
Set dbk = ex.Workbooks.Open(fs.GetParentFolderName(wscript.scriptfullname) & "\dsptime.xls")
dbk.set_proc
.set_cell
.worksheets(1).Range("b1").NumberFormatLocal = "hh:mm:ss"
dbk.hideform
dbk.set_tm .worksheets(1).Range("b1")
dbk.unloadform
dbk.Close False
ex.Quit
end with
end with
set ex=nothing
set dbk=nothing
set fs=nothing
>
上記のブックとVBSスクリプトを全て同じフォルダ上に保存した後、
vbstest.vbsを実行してみてください。
尚、この投稿からコピーする場合は、VBSコードの
.visible=true
頭の空白が全角になっているので、半角に修正して保存しなければならないので
注意が必要です（全角のままだとエラーになります）
この手のことを実現するには、結構、工夫が必要ですね！！
試してみてください。
（この場合は、時間表示のユーザーフォームが非アクティブにしても
時間は、正常に取得できました）
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
