水情报汛职守机来报提醒程序

最新推荐文章于 2024-04-28 15:14:54 发布

原创最新推荐文章于 2024-04-28 15:14:54 发布 · 1.2k 阅读

1 ·

CC 4.0 BY-SA版权

文章标签：

#integer #timer #function #command #string #date

个人研发同时被 2 个专栏收录

9 篇文章

订阅专栏

水文水资源

8 篇文章

订阅专栏

这是一个自动监测并提醒值班人员新报文的程序，尤其适用于没有声卡的报汛接收机。程序通过监测文件变化，结合主板声卡或播放声音文件进行报警，确保在整点20分前接收到报文。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

起因：1 需要人工校报,来报不定时,值班人员不可能24小时目光不离开计算机屏幕.
2 卡不具备报警,也没有声卡.3 而且报文必须在整点20分前发出.
功能：有新报文时报警,或者通过主板声卡或者通过声卡播放声音文件.
使用：绿色软件,直接COPY就可以使用,或者安装在报汛接收机上 ,也许没有声卡;或者安装在其他同一个网络上,通过主板声卡或者通过声卡播放声音文件来提醒值班人员.

Option Explicit
Public Const OFS_MAXPATHNAME = 128
Public Const OF_READ = &H0

Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long '注释：建立、打开或删除文件
Declare Function GetFileInformationByHandle Lib "kernel32" (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long '注释：返回文件信息
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long '注释：关闭打开的对象句柄
Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long '注释：返回当前时区信息
Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FileTime, lpSystemTime As SYSTEMTIME) As Long '注释：将64位时间转换为系统时间

Type FileTime
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Type OFSTRUCT
    cBytes As Byte
    fFixedDisk As Byte
    nErrCode As Integer
    Reserved1 As Integer
    Reserved2 As Integer
    szPathName(OFS_MAXPATHNAME) As Byte
End Type

Type BY_HANDLE_FILE_INFORMATION
    dwFileAttributes As Long
    ftCreationTime As FileTime
    ftLastAccessTime As FileTime
    ftLastWriteTime As FileTime
    dwVolumeSerialNumber As Long
    nFileSizeHigh As Long
    nFileSizeLow As Long
    nNumberOfLinks As Long
    nFileIndexHigh As Long
    nFileIndexLow As Long
End Type

Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Type TIME_ZONE_INFORMATION
    bias As Long
    StandardName(32) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type
'注释: 取得文件的创建时间?访问时间的子程序
Sub apiFileDateTime(ByVal PathName As String, dtCreate As Date, dtAccess As Date, dtWrite As Date)

Dim FileHandle As Long
Dim FileInfo As BY_HANDLE_FILE_INFORMATION
Dim lpReOpenBuff As OFSTRUCT, ft As SYSTEMTIME
Dim tZone As TIME_ZONE_INFORMATION
Dim bias As Long

FileHandle = OpenFile(PathName, lpReOpenBuff, OF_READ)

GetFileInformationByHandle FileHandle, FileInfo
CloseHandle FileHandle

GetTimeZoneInformation tZone
bias = tZone.bias

FileTimeToSystemTime FileInfo.ftCreationTime, ft
dtCreate = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + _
TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)

FileTimeToSystemTime FileInfo.ftLastAccessTime, ft
dtAccess = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + _
TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)

FileTimeToSystemTime FileInfo.ftLastWriteTime, ft
dtWrite = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + _
TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
End Sub

Public Function fileexists(fullfilename) As Boolean

' passed a filename (with path) returns
' true if the file exists, false if not.

Dim s

    s = Dir(fullfilename)

    If s = "" Then
      fileexists = False
    Else
    fileexists = True
    End If

End Function
========
源程序
=====
Option Explicit

Private Declare Function APIBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_LOOP = &H8
Const SND_ASYNC = &H1

Dim 原始文件 As String
Dim 最新文件 As String
Dim 第一次报警时间 As String
Dim 通讯报警状态 As Boolean

Private Sub Check2_Click()
    If Check2.Value = 1 Then
        Text3.Visible = True
    Else
        Text3.Visible = False
    End If
End Sub

Private Sub Check3_Click()
If Check3.Value = 0 Then sndPlaySound vbNullString, SND_ASYNC
End Sub

Private Sub cmdClose_Click()

Unload Me

End Sub

Private Sub cmdProcess_Click()

    'If Len(frmMain.drvChoose.Drive) > 2 Then

     '   MsgBox "!", vbCritical, "Warning!!!"

    'End If
    If Timer1.Enabled Then
        Timer1.Enabled = False
        cmdProcess.Caption = "开始监视"
        drvChoose.Enabled = True
        Text2.Enabled = True
        Shape1.FillColor = &HFF&
        Shape2.FillColor = &HFF&
        Timer2.Enabled = False
        通讯报警状态 = False
        Exit Sub
    End If
    Label1.Caption = Now
    cmdProcess.Enabled = False
    Command2.Enabled = False
    drvChoose.Enabled = False
    Text2.Enabled = False
    frmMain.trvDriveView.Nodes.Clear

    trvDriveView.Nodes.Add , , "main", "该驱动器包含的目录" & frmMain.drvChoose.Drive & "/" & Text2.Text

    '获取根目录文件夹...
    trvDriveView.Nodes(1).Expanded = True
    trvDriveView.Refresh
    ShowFolderList Left(frmMain.drvChoose.Drive, 2) & "/", Text2.Text & "/"
    'ShowFolderList frmMain.drvChoose.Drive & "/", ""
    原始文件 = Text1.Text
    cmdProcess.Enabled = True
    Command2.Enabled = True
    cmdProcess.Caption = "停止监视"
    Timer1.Enabled = True
    Label5.Caption = ""
    Shape1.FillColor = &HFF0000

End Sub

Sub ShowFolderList(ByVal mvDrive As String, ByVal mvPath As String)
Dim dtCreate As Date '注释：建立时间
Dim dtAccess As Date '注释：存取日期
Dim dtWrite As Date '注释：修改时间
Dim i, j, k As Long

Text1.Text = ""

    If Right(mvPath, 10) <> "|NONE|HERE" Then

        Dim fs, f, f1, f2, fc, s
        Dim mvFound As Boolean

        mvFound = False
        Set fs = CreateObject("Scripting.FileSystemObject")
        If mvPath = "main" Then
            mvPath = ""
        End If
        Set f = fs.GetFolder(mvDrive & mvPath)
        Set fc = f.Files

        For Each f2 In fc

            mvFound = True
            If mvPath = "" Then
                apiFileDateTime mvDrive & mvPath & f2.Name, dtCreate, dtAccess, dtWrite
                Debug.Print Now - dtWrite
                trvDriveView.Nodes.Add "main", tvwChild, f2.Name, f2.Name & " (" & Format((f2.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite + 148093.034444444
                Text1.Text = Text1.Text & f2.Name & " (" & Format((f2.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite & vbNewLine
                'TextBox txtFrequency (try 1000 for starters)

            Else
            apiFileDateTime mvDrive & mvPath & f2.Name, dtCreate, dtAccess, dtWrite
                Debug.Print Now - dtWrite
                trvDriveView.Nodes.Add "main", tvwChild, f2.Name, f2.Name & " (" & Format((f2.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite + 148093.034444444
                Text1.Text = Text1.Text & f2.Name & " (" & Format((f2.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite & vbNewLine
                'trvDriveView.Nodes.Add mvPath, tvwChild, mvPath & "/" & f2.Name, f2.Name & " (" & Format((f2.Size / 1024) / 1024, "#0.00") & " MB)"
            End If
            trvDriveView.Refresh
        Next
    If Check4.Value = 1 Then
        Set fc = f.SubFolders
        For Each f1 In fc

            mvFound = True
            If mvPath = "" Then
                apiFileDateTime mvDrive & mvPath & f1.Name, dtCreate, dtAccess, dtWrite
                Debug.Print Now - dtWrite
                trvDriveView.Nodes.Add "main", tvwChild, f1.Name, f1.Name & " (" & Format((f1.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite
                Text1.Text = Text1.Text & f1.Name & " (" & Format((f1.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite & vbNewLine
                'TextBox txtFrequency (try 1000 for starters)

            Else
                apiFileDateTime mvDrive & mvPath & f1.Name, dtCreate, dtAccess, dtWrite
                Debug.Print Now - dtWrite
                trvDriveView.Nodes.Add "main", tvwChild, f1.Name, f1.Name & " (" & Format((f1.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite
                Text1.Text = Text1.Text & f1.Name & " (" & Format((f1.Size / 1024) / 1024, "#0.00") & " MB)" & dtWrite & vbNewLine
                'trvDriveView.Nodes.Add mvPath, tvwChild, mvPath & "/" & f1.Name, f1.Name & " (" & Format((f1.Size / 1024) / 1024, "#0.00") & " MB)"
            End If
            trvDriveView.Refresh

        Next

        If mvFound = False Then

            If mvPath = "" Then
                trvDriveView.Nodes.Add "main", tvwChild, "|NONE|HERE", "当前路径没有文件夹!"
            Else
                trvDriveView.Nodes.Add mvPath, tvwChild, mvPath & "/|NONE|HERE", "当前路径没有文件夹!"
            End If

        End If
    End If          '包含子目录否
    End If
End Sub

Private Sub Command1_Click()
Dim dtCreate As Date '注释：建立时间
Dim dtAccess As Date '注释：存取日期
Dim dtWrite As Date '注释：修改时间

apiFileDateTime "d:/生产计划需求.doc", dtCreate, dtAccess, dtWrite
Debug.Print dtCreate
Debug.Print dtAccess
Debug.Print dtWrite

End Sub

Private Sub Command2_Click()
    'If Len(frmMain.drvChoose.Drive) > 2 Then

     '   MsgBox "!", vbCritical, "Warning!!!"

    'End If
    Label2.Caption = Now
    cmdProcess.Enabled = False
    Command2.Enabled = False
    frmMain.trvDriveView.Nodes.Clear

    trvDriveView.Nodes.Add , , "main", "该驱动器包含的目录" & frmMain.drvChoose.Drive & "/" & Text2.Text

    '获取根目录文件夹...
    trvDriveView.Nodes(1).Expanded = True
    trvDriveView.Refresh
    ShowFolderList Left(frmMain.drvChoose.Drive, 2) & "/", Text2.Text & "/"
    最新文件 = Text1.Text
    If 最新文件 <> 原始文件 Then
        '发声音报警
        If (通讯报警状态) Then
            'Label5.Caption = Now()
        Else
            Label5.Caption = Now()
            通讯报警状态 = True
            Timer2.Enabled = True
        End If
        Shape2.FillColor = &HFFFF&
    End If
    cmdProcess.Enabled = True
    Command2.Enabled = True

End Sub

Private Sub drvChoose_Change()
Text2.Text = ""
End Sub

Private Sub Form_Load()

    Timer1.Enabled = False
    Shape1.FillColor = &HFF&
    Shape2.FillColor = &HFFFFFF
    If Check2.Value = 1 Then
        Text3.Visible = True
    Else
        Text3.Visible = False
    End If

End Sub

Private Sub Timer1_Timer()

    Command2_Click

End Sub

Private Sub Timer2_Timer()
If 通讯报警状态 And Check1.Value = 1 Then 发声音报警
If 通讯报警状态 And Check3.Value = 1 Then sndPlaySound App.Path & "/Windows XP 叮当声.wav", SND_ASYNC Or SND_LOOP ' App.Path & "/Windows XP 叮当声.wav" 'playsound App.Path & "/Windows XP 叮当声.wav"

End Sub

Private Sub trvDriveView_NodeClick(ByVal Node As MSComctlLib.Node)

ShowFolderList Left(frmMain.drvChoose.Drive, 2) & "/", Node.Key

End Sub

Private Sub 发声音报警()
    Dim frequency As Long
    Dim N, j, k As Integer

    For N = 1 To 8
        APIBeep frequency + N * 200, 100
    Next N

End Sub