定时程序

VERSION 5.00 Begin VB.Form frmTimer ClientHeight = 3090 ClientLeft = 60 ClientTop = 450 ClientWidth = 6150 Icon = "frmTimer.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 3090 ScaleWidth = 6150 StartUpPosition = 1 '所有者中心 Begin VB.Timer timerExecute Left = 120 Top = 2160 End Begin VB.CommandButton cmdHideProgram Caption = "隐于后台执行" BeginProperty Font Name = "宋体" Size = 9 Charset = 134 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 1680 TabIndex = 4 Top = 2040 Width = 3615 End Begin VB.TextBox txtParm Height = 375 Left = 2040 Locked = -1 'True TabIndex = 3 Top = 960 Width = 3135 End Begin VB.TextBox txtExeFile Height = 375 Left = 2040 Locked = -1 'True TabIndex = 0 Top = 360 Width = 3135 End Begin VB.Label Label2 Caption = "参 数" BeginProperty Font Name = "宋体" Size = 14.25 Charset = 134 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 2 Top = 1080 Width = 1935 End Begin VB.Label Label1 Caption = "可执行文件" BeginProperty Font Name = "宋体" Size = 14.25 Charset = 134 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 240 TabIndex = 1 Top = 360 Width = 1695 End End Attribute VB_Name = "frmTimer" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Public exeFilePath, parmFilePath As String Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const REG_SZ = 1 Private Const KEY_SET_VALUE = &H2 Private Sub cmdHideProgram_Click() On Error Resume Next If Len(Trim(exeFilePath)) = 0 Or Len(Trim(parmFilePath)) = 0 Then MsgBox "配置文件找不到指定的参数" Exit Sub Else Me.Visible = False End If End Sub Private Sub Form_Load() Dim fso As New FileSystemObject Dim ts As TextStream Dim iniFilePath, iniContent As String Dim objSet Dim Item Dim RunCount As Integer Dim sKeyName As String Dim sKeyValue As String Dim iRet As Long Dim hKey As Long On Error Resume Next '开机自动启动部分 sKeyName = "axzb" sKeyValue = App.Path & IIf(Len(App.Path), "/" & App.EXEName & ".exe", App.EXEName & ".exe") iRet = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE/Microsoft/Windows/CurrentVersion/Run", hKey) iRet = RegSetValueEx(hKey, sKeyName, 0&, REG_SZ, ByVal sKeyValue, Len(sKeyValue) * 2) iRet = RegCloseKey(hKey) '禁止重复运行 RunCount = 0 If LCase(Trim(App.EXEName)) <> "tasktimer" Then MsgBox "程序已经更改" End End If Set objSet = GetObject("winmgmts:").InstancesOf("Win32_Process") For Each Item In objSet If Trim(UCase(Item.Name)) = "TASKTIMER.EXE" Then RunCount = RunCount + 1 If RunCount > 1 Then MsgBox "程序已经运行" End End If End If Next If Not fso.FileExists(App.Path & "/system.ini") Then fso.CreateTextFile (App.Path & "/system.ini") Set ts = fso.OpenTextFile(App.Path & "/system.ini", ForWriting) ts.Write ("EXEFILE=" & Chr(34) & Chr(34) & Chr(13) & Chr(10) & "PARMFILE=" & Chr(34) & Chr(34)) ts.Close Set ts = Nothing End If Set ts = fso.OpenTextFile(App.Path & "/system.ini", ForReading) iniContent = ts.ReadAll ts.Close Set ts = Nothing If Len(Trim(iniContent)) = 0 Then MsgBox "配置文件为空,找不到指定的参数" timerExecute.Enabled = False End Else exeFilePath = GetValue("EXEFILE", iniContent) parmFilePath = GetValue("PARMFILE", iniContent) If Len(Trim(exeFilePath)) = 0 Then MsgBox "配置文件找不到指定的参数" timerExecute.Enabled = False End Else txtExeFile.Text = exeFilePath txtParm.Text = parmFilePath If Not fso.FileExists(exeFilePath) Then MsgBox "执行文件" timerExecute.Enabled = False End Else timerExecute.Enabled = True End If End If End If timerExecute.Interval = 1000 End Sub Private Sub timerExecute_Timer() Dim x As Long On Error Resume Next x = Shell(exeFilePath & " " & parmFilePath, vbHide) While IsRunning(x) DoEvents Wend End Sub

 

Attribute VB_Name = "Synchronous"
 Public Const SYNCHRONIZE = &H100000
 Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
 Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    
 Function IsRunning(ByVal ProgramID) As Boolean ' 传入进程标识ID
     Dim hProgram As Long '被检测的程序进程句柄
     hProgram = OpenProcess(SYNCHRONIZE, 0, ProgramID)
     If Not hProgram = 0 Then
     IsRunning = True
     Else
     IsRunning = False
     End If
     CloseHandle hProgram
End Function

 

Attribute VB_Name = "mdlString"
Function GetValue(ByVal MKey As String, ByVal iStr As String) As String
On Error GoTo er
    ar = Split(iStr, MKey)
    iStr = ar(1)
    ar = Split(iStr, Chr(34))
    GetValue = ar(1)
er:
End Function