module2.bas

This is a test ModBus comm s pragam in "STB-311".

Attribute VB_Name = "Module2"
Type Dyhgl_type
 d_Name As String * 14
 d_Address As Integer
 d_td As Integer
 d_BZ As Single
 d_wcfw As Integer
End Type

Type yxbj_type
 Name As String * 18
 shuxing As Integer
 address As Integer
 Td As Integer
 Max As Single
 Min As Single
 Bj As Boolean
End Type

Type Save_Yxbj_Name
  shi As Integer
  Fen As Integer
  miao As Integer
  Yxbj_Index As Integer
  shuxing As Integer
  yx_Value As Single
End Type

Type Dsdy
 Dsdy_Name As String * 20
 Dsdy_Add As Integer
 Dsdy_Td As Integer
End Type
Type Yuandong_zhan
 zzdz As Integer
 dddz As Integer
 TBT As Integer
End Type
 
Type DZXG
  shi As Integer
  Fen As Integer
  miao As Integer
  address As Integer
  Dingzhiming  As String * 18
  Yuanshizhi  As String * 6
  zhengdingzhi As String * 6
  caozuoren As Integer
End Type
  
Type PLC_Type
 Yx(1 To 10) As Byte
 Yc(1 To 20) As Integer
End Type
Public Jz_Num As Integer
Public PLC_N(0 To 32) As PLC_Type
Public Dsdy_P(1 To 120) As Dsdy
Public Dsdy_U(1 To 40) As Dsdy
Public DANYUAN_FSSX(1 To 3, 1 To 32) As Integer
Public DANYUAN_FSGS(1 To 3) As Integer
Public Dsdy As Boolean
Public Yd_zz As Yuandong_zhan
Public Need_hgl As Integer
Public Yxbj(0 To 512) As yxbj_type
Public yxbj_jl(0 To 500) As Save_Yxbj_Name
Public dyhgl_name(0 To 100) As Dyhgl_type
Public Yxbj_Cs As Integer
Public Yxbj_shu As Integer
Public Dyhgl(1 To 20) As Single
Public Sound_Address As Integer
Public Aqrq As Date
Public Send_Yd_string As String * 30
Public A_string(0 To 4) As String * 30 '重要遥测
Public B_string As String * 30
Public C_string As String * 30
Public D_string As String * 30
Public YKFJ_string As String * 15
Public Head_string As String * 3
Declare Function waveOutGetNumDevs Lib "winmm" () As Long
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Sub baojing(Index As Integer) '报警声音
Dim r As Integer
Dim SoundFile(1 To 3) As String
SoundFile(1) = App.Path + "\" + "diandi.wav"
SoundFile(2) = App.Path + "\" + "ringin.wav"
SoundFile(3) = App.Path + "\" + "mcitest.wav"
Const sync = 1
r = sndPlaySound(SoundFile(Index), sync)
End Sub

Sub Read_bjdz()
Dim FileName As String
Dim i As Integer
Dim J As Integer
Dim FileNum
FileName = App.Path + "\" + "BJ_sound.dat"
FileNum = FreeFile
 Open FileName For Random As FileNum Len = 2
  Get FileNum, 1, Sound_Address
 Close FileNum
End Sub

Sub read_dyhgl_name()
Dim FileName As String
Dim FileNum
Dim File_Size As Integer
FileName = App.Path + "\" + "dyhgl.dat"
FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(dyhgl_name(1))
  File_Size = LOF(FileNum) / Len(dyhgl_name(1))
  Need_hgl = File_Size
  For i = 1 To File_Size
     Get FileNum, i, dyhgl_name(i)
  Next i
Close FileNum

End Sub
Sub Read_yxbj()
Dim FileName As String
Dim FileNum
FileName = App.Path + "\" + "yxbj.dat"
FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(Yxbj(0))
 Yxbj_shu = LOF(FileNum) / Len(Yxbj(0))
  For i = 1 To Yxbj_shu
    Get FileNum, i, Yxbj(i)
    Yxbj(i).Bj = False
  Next i
Close FileNum

End Sub
Sub save_aqrq(a_year As Integer, a_month As Integer, a_day As Integer)
Dim FileName As String
Dim FileNum
On Error GoTo Err_set
FileName = App.Path + "\" + "aqrq.dat"
FileNum = FreeFile
Aqrq = CDate(Format(a_month, "00") + "/" + Format(a_day, "00") + "/" + Format(a_year, "00"))
Open FileName For Random As FileNum Len = Len(Aqrq)
  Put FileNum, 1, Aqrq
Close FileNum

Err_set:
 Exit Sub
End Sub
Sub read_aqrq()
Dim FileName As String
Dim FileNum
FileName = App.Path + "\" + "aqrq.dat"
FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(Aqrq)
  Get FileNum, 1, Aqrq
Close FileNum
End Sub
Sub read_dsdy()
Dim FileName As String
Dim FileNum
     FileName = App.Path + "\" + "dsdy.dat"
     FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(Dsdy_P(i))
  For i = 1 To 128
   If i <= 120 Then
     Get FileNum, i, Dsdy_P(i)
   Else
     Get FileNum, i, Dsdy_U(i - 120)
   End If
  Next i
 Close FileNum
 
     FileName = App.Path + "\" + "dsdy_qd.dat"
     FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(Dsdy)
      Get FileNum, 1, Dsdy
  Close FileNum
 
End Sub
Sub Save_Dzzd(Addr As Integer, dz_name As String, ysz As String, xgz As String, czr As Integer)
 Dim Caozuo_1 As DZXG
 Dim FileName As String
 Dim FileNum
 Dim File_num
 On Error Resume Next
 FileName = "c:\" + Format(Year(Now), "0000")
 If Dir(FileName) <> "" Then
 Else
  MkDir (FileName)
 End If
 FileName = FileName & "\" & Format(Month(Now), "00")
 If Dir(FileName) <> "" Then
 Else
 MkDir (FileName)
 End If
 FileName = FileName & "\" & Format(Day(Now), "00") & ".zd"
 FileNum = FreeFile
 Open FileName For Random As FileNum Len = Len(Caozuo_1)
 File_num = LOF(FileNum) / Len(Caozuo_1)
 Caozuo_1.address = Addr
 Caozuo_1.shi = Hour(Now)
 Caozuo_1.Fen = Minute(Now)
 Caozuo_1.miao = Second(Now)
 Caozuo_1.caozuoren = czr
 Caozuo_1.Yuanshizhi = ysz
 Caozuo_1.Dingzhiming = dz_name
 Caozuo_1.zhengdingzhi = xgz
 Put FileNum, File_num + 1, Caozuo_1
 Close FileNum
End Sub
Sub writetoprn(i As Integer, SSS As String)
On Error Resume Next
Dim FileName As String
FileName = "lpt" + Format(i, "0")
If TestPrint <> &H9000 Then Exit Sub
FileNum = FreeFile
Open FileName For Output As FileNum
  Print #FileNum, ; Chr(&H1C) + Chr(&H26) + SSS
Close (FileNum)
End Sub

Sub read_zh()
Dim FileName As String
Dim FileNum
FileName = App.Path + "\" + "ydzh.dat"
FileNum = FreeFile
Open FileName For Random As FileNum Len = Len(Yd_zz)
 Get FileNum, 1, Yd_zz
Close FileNum
End Sub
Sub Init_YD_String()
Dim Ctrl_string As String
Dim Temp_Yd_string As String * 3
Dim S() As Byte
  If Yd_zz.TBT = 1 Then
   Head_string = ChrB(&HEB) + ChrB(&H90) + ChrB(&HEB) + ChrB(&H90) + ChrB(&HEB) + ChrB(&H90)
   Else
   Head_string = ChrB(&HD7) + ChrB(&H9) + ChrB(&HD7) + ChrB(&H9) + ChrB(&HD7) + ChrB(&H9)
   End If
  
  Ctrl_string = ChrB(&H71) + ChrB(0) + ChrB(&H8) + ChrB(Yd_zz.dddz) + ChrB(Yd_zz.zzdz) + ChrB(0)
  
  For i = 1 To 4
    MidB(A_string(i), 1, 6) = Head_string
    MidB(Ctrl_string, 2, 1) = ChrB(&H61)
    S = Ctrl_string
    MidB(Ctrl_string, 6, 1) = ChrB(CRC(S))
    MidB(A_string(i), 7, 6) = Ctrl_string
    
   For J = 1 To 8
        MidB(Temp_Yd_string, 1, 1) = ChrB((i - 1) * 8 + J - 1)
        S = Temp_Yd_string
        MidB(Temp_Yd_string, 6, 1) = ChrB(CRC(S))
        MidB(A_string(i), J * 6 + 7, 6) = Temp_Yd_string
   Next J
  Next i
    MidB(D_string, 1, 6) = Head_string
    MidB(Ctrl_string, 2, 1) = ChrB(&HF4)
    S = Ctrl_string
    MidB(Ctrl_string, 6, 1) = ChrB(CRC(S))
    MidB(D_string, 7, 6) = Ctrl_string
    For i = 1 To 8
        MidB(Temp_Yd_string, 1, 1) = ChrB(&HF0 + i - 1)
        S = Temp_Yd_string
        MidB(Temp_Yd_string, 6, 1) = ChrB(CRC(S))
        MidB(D_string, i * 6 + 7, 6) = Temp_Yd_string
    Next i
End Sub
Sub set_yaoxin()
Dim i As Integer
Dim A As Integer
Dim b As Integer
Dim C As Integer
Dim d As Integer
Dim T As Long
Dim yx_string As String * 64
For i = 1 To yx_shu
 '取遥信
 ''b = yx_dian(I).danyuanhao '单元号
 ''C = yx_dian(I).Leixing '类型
 ''a = yx_dian(I).xuhao   '序号
 ''d = yx_dian(I).Weihao  '位置
 ''If C = 1 Then '直接遥信
  ''   If ((2 ^ (d - 1)) And (&HFF - Asc(yx_b(b)))) <> 0 Then
    ''   yx_flag(I) = 1
     '' Else
      '' yx_flag(I) = 0
    '' End If
 '' Else  '报警遥信
   ''  T = Asc(Mid(bj_w(b), 1, 1)) + 0.1 * Asc(Mid(bj_w(b), 2, 1)) * 10 * 256
    '' If ((2 ^ (d - 1)) And T) <> 0 Then
     ''  yx_flag(I) = 1
     '' Else
      '' yx_flag(I) = 0
     ''End If
     
'' End If
'' M = (a - 1) \ 8 + 1 '字节号
 ''N = (a - 1) Mod 8 '位号
 ''If yx_flag(I) = 1 Then
  ''   Mid(yx_string, M, 1) = Chr(Asc(Mid(yx_string, M, 1)) Or (2 ^ N))
  ''Else
   ''  Mid(yx_string, M, 1) = Chr(Asc(Mid(yx_string, M, 1)) And (&HFF - (2 ^ N)))
  ''End If
 '' Next I
 ''For I = 1 To 16
 '' Mid(Yuandong_string(I + 2), 2, 1) = Mid(yx_string, 4 * I - 3, 1)
 '' Mid(Yuandong_string(I + 2), 3, 1) = Mid(yx_string, 4 * I - 2, 1)
  ''Mid(Yuandong_string(I + 2), 4, 1) = Mid(yx_string, 4 * I - 1, 1)
  ''Mid(Yuandong_string(I + 2), 5, 1) = Mid(yx_string, 4 * I, 1)
  ''Mid(Yuandong_string(I + 2), 6, 1) = Chr(Crc(Yuandong_string(I + 2)))
 Next i
 End Sub

Public Function CRC(S() As Byte) As Integer
Dim SSS As String
Dim AL As Integer
AL = 0
If UBound(S) < 4 Then Exit Function
For i = 0 To UBound(S) - 1
SSS = SSS + ChrB(S(i))
 AL = AL Xor AscB(MidB(SSS, i + 1, 1))
 For J = 1 To 8
 AL = AL * 2
  If AL > &HFF Then AL = AL Xor &H107
 Next J
 Next i
CRC = AL Xor &HFF
End Function
Function CRC16(data() As Byte) As String
      Dim CRC16Lo As Byte, CRC16Hi As Byte      'CRC寄存器
      Dim CL As Byte, CH As Byte                '多项式码&HA001
      Dim SaveHi As Byte, SaveLo As Byte
      Dim i As Integer
      Dim Flag As Integer
      CRC16Lo = &HFF
      CRC16Hi = &HFF
      CL = &H1
      CH = &HA0
      For i = 0 To UBound(data)
        CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
        For Flag = 0 To 7
          SaveHi = CRC16Hi
          SaveLo = CRC16Lo
          CRC16Hi = CRC16Hi \ 2            '高位右移一位
          CRC16Lo = CRC16Lo \ 2            '低位右移一位
          If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
            CRC16Lo = CRC16Lo Or &H80      '则低位字节右移后前面补1
          End If                           '否则自动补0
          If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
            CRC16Hi = CRC16Hi Xor CH
            CRC16Lo = CRC16Lo Xor CL
          End If
        Next Flag
      Next i
      Dim ReturnData(1) As Byte