modmain.bas

回流焊监控系统-DCS,VB编写,对PLC进行通讯采集和控制,界面直观,操作方便,可以作为同类软件系统提供示范

Attribute VB_Name = "modMain"
Option Explicit
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002

Type FORMBACKCOLOR
    colorBackDlg As Long
    colorFont As Long
    colorBackMain As Long
    colorBackCurve As Long
End Type
Type CTLINFORMATION
    name As String
    lenth As Long
    id As Long
    reg As Boolean
End Type
Type OPTIONTYPE
  sOptionName As String
  sOption As String
  bOption(0 To 22) As Boolean
End Type
Type CURVEPROP
  Xmax As Long
  Ymax As Long
  Color(0 To 2) As Long
  point(0 To 2, 0 To 2000) As Single
End Type

Type MoveBlock
   Index As Long
   startT As Single
   iCurentLeft As Long
End Type

Public iWarnUU() As Single
Public iWarnUL() As Single
Public iWarnDU() As Single
Public iWarnDL() As Single

Public bTimeEnd As Boolean
Public bAdjustVisible As Boolean
Public colorSet As FORMBACKCOLOR
Public ctlInfo() As CTLINFORMATION
Public LoginSucceeded As Boolean
Public mPassword As String

Public iOptionCount As Integer
Public iCurrentOption As Integer
Public oOption() As OPTIONTYPE
Public sCurrentPrgFile As String
Public iCurrentWidth As Long
Public iniFile As String
Public bWarnInfo(0 To 9) As Boolean
Public sWarnInfo(0 To 9) As String
Public sMaxTemp As Single
Public curvep As CURVEPROP
Public SafeTemp As Single
Public Ack As Boolean
Public MoveB() As Boolean 'MoveBlock

Sub Main()
    Dim i As Boolean

    If App.PrevInstance Then
         MsgBox ("程序已经运行，不能再次装载。"), vbExclamation
         End
    End If
    frmSplash.Show
    Delay 0.05
    iniFile = App.Path + "\paraset.ini"
    InitInifile iniFile
    With colorSet
     .colorBackDlg = Val(ReadInIFiles("Color", "BkDlg", "-2147483633", iniFile))  ' &H8000000F
     .colorBackMain = Val(ReadInIFiles("Color", "MainDlg", "-2147483633 ", iniFile))  ' &H8000000F
     .colorFont = Val(ReadInIFiles("Color", "Font", "0 ", iniFile))
     .colorBackCurve = Val(ReadInIFiles("Color", "BkCurve", "0 ", iniFile))
    End With
    mPassword = ReadInIFiles("Password", "pass", "", iniFile)
    sCurrentPrgFile = ReadInIFiles("Public", "PrgFile", App.Path + "\default.par", iniFile)
    sMaxTemp = Val(ReadInIFiles("Para", "1", "300", iniFile))
    If sMaxTemp < 1 Then
      sMaxTemp = 300
    End If
    Delay 0.05
    Call InitCtrl
    Call InitOption
    Call InitInfo
    Call InitCurve
    ReDim MoveB(0 To 0)
    LoginSucceeded = False
    bAdjustVisible = False
    SafeTemp = Val(ReadInIFiles("Para", CStr(9), "200.0", iniFile))
'    mPassword = ""
'    frmLogin.Show 1
'    If LoginSucceeded Then
'     Debug.Print Hex2Bin("004")
       frmMain.Show
'    End If
End Sub


Private Sub InitCurve()
 With curvep
    .Xmax = Val(ReadInIFiles("Curve", "X", "300", iniFile))
    .Ymax = Val(ReadInIFiles("Curve", "Y", "300", iniFile))
    .Color(0) = Val(ReadInIFiles("Curve", "Color0", "255", iniFile))
    .Color(1) = Val(ReadInIFiles("Curve", "Color1", "65280", iniFile))
    .Color(2) = Val(ReadInIFiles("Curve", "Color2", "65535", iniFile))
 End With
End Sub

Private Sub InitInfo()
  Dim i As Long
  sWarnInfo(0) = "出板检测报警！"
  sWarnInfo(1) = "紧急输入报警！"
  sWarnInfo(2) = "风机过载报警！"
  sWarnInfo(3) = "缺相报警！"
  sWarnInfo(4) = "机盖上限报警！"
  sWarnInfo(5) = "机盖下限报警！"
  sWarnInfo(6) = "运输过载报警！"
  sWarnInfo(7) = "导轨正极限报警！"
  sWarnInfo(8) = "导轨原点报警！"
End Sub

Private Sub InitCtrl()
  ReDim ctlInfo(0 To 4)
  ctlInfo(0).name = "switch.ocx"
  ctlInfo(1).name = "tdplc.ocx"
  ctlInfo(2).name = "classXP.dll"
  ctlInfo(3).name = "vbwProgressBar.ocx"
  ctlInfo(4).name = "plcpublic.dll"
  
  ctlInfo(0).lenth = 28672
  ctlInfo(1).lenth = 61440
  ctlInfo(2).lenth = 69632
  ctlInfo(3).lenth = 28672
  ctlInfo(4).lenth = 49152
  
  ctlInfo(0).id = 101
  ctlInfo(1).id = 102
  ctlInfo(2).id = 103
  ctlInfo(3).id = 104
  ctlInfo(4).id = 105
  
  ctlInfo(0).reg = True
  ctlInfo(1).reg = True
  ctlInfo(2).reg = False
  ctlInfo(3).reg = True
  ctlInfo(4).reg = True

  Call AutoReg
End Sub

Private Sub AutoReg()
Dim Ocx() As Byte, Counter As Long, i As Long
Dim OldName
Dim Result As Double
Dim Fs As Object
On Error Resume Next
    Set Fs = CreateObject("Scripting.FileSystemObject")
    For i = 0 To UBound(ctlInfo)
        OldName = Fs.GetSpecialFolder(1) & "\" & ctlInfo(i).name
        If Dir(OldName) = "" Then
            Ocx = LoadResData(ctlInfo(i).id, "CUSTOM")
            Open OldName For Binary As #1
            For Counter = 0 To ctlInfo(i).lenth - 1
              Put #1, , Ocx(Counter)
            Next Counter
            Close #1
            If ctlInfo(i).reg Then
                Result = Shell("RegSvr32 /s " + ctlInfo(i).name)
                If Result = 0 Then
                    MsgBox OldName & "注册失败！", vbOKOnly + vbExclamation, "警告"
                End If
            End If
        Else
            If FileLen(OldName) <> ctlInfo(i).lenth Then
                Name (OldName) As (OldName & "." & Format(Date, "yyyymmdd") & second(Time))
                Ocx = LoadResData(ctlInfo(i).id, "CUSTOM")
                Open OldName For Binary As #1
                For Counter = 0 To ctlInfo(i).lenth - 1
                  Put #1, , Ocx(Counter)
                Next Counter
                Close #1
                If ctlInfo(i).reg Then Result = Shell("RegSvr32 /s " + ctlInfo(i).name)
            End If
        End If
        
        frmSplash.ProgressBar1.Value = frmSplash.ProgressBar1.Value + (i + 1) * 130
        Delay 0.05
    Next
    Set Fs = Nothing
End Sub

Private Sub InitOption()
  Dim i As Integer, j As Integer
  On Error GoTo Errhandle
  iOptionCount = Val(ReadInIFiles("Option", "OptionCount", "6", iniFile))
  ReDim oOption(0 To iOptionCount - 1)
  For i = 0 To iOptionCount - 1
     oOption(i).sOption = ReadInIFiles("Option", CStr(i), "00000000000000000000000", iniFile)
     oOption(i).sOptionName = ReadInIFiles("Option", "Name" & CStr(i), "U" & i + 5 & "D" & i + 5, iniFile)
     For j = 0 To 22
       oOption(i).bOption(j) = -Val(Mid$(oOption(i).sOption, j + 1, 1))
     Next
  Next
  iCurrentOption = Val(ReadInIFiles("Option", "currentID", "0", iniFile))
  If iCurrentOption > iOptionCount - 1 Then
    iCurrentOption = 0
  End If

  Exit Sub
Errhandle:
  MsgBox Err.description
  Err.Clear
End Sub

Public Sub SetDlgBackColor(frm As Form)
  On Error Resume Next
    Dim ctl As Control
    Dim obj As Object
    Dim fnt As Object
    Dim nVal As Integer
    frm.BackColor = colorSet.colorBackDlg
    '设置控件的标题，对菜单项使用 caption 属性并对所有其他控件使用 Tag 属性
    For Each ctl In frm.Controls
        Select Case (TypeName(ctl))
          Case "Label"
            ctl.BackStyle = 0
            ctl.ForeColor = colorSet.colorFont
            ctl.BackColor = colorSet.colorBackDlg
          Case "TextBox"
          Case "ComboBox"
          Case "CommandButton"
          Case Else
            ctl.BackStyle = 0
            ctl.BackColor = colorSet.colorBackDlg
            ctl.ForeColor = colorSet.colorFont
        End Select
    Next
End Sub

Public Function ReadInIFiles(Mainkey As String, Subkey As String, DefaultKey As String, filename As String) As String
    Dim Success As Long
    Dim ReadBack As String
    Const Falseread = "信息文件不存在或被破坏!"
    ReadBack = String(150, 0)
    Success = GetPrivateProfileString(Mainkey, Subkey, DefaultKey, ReadBack, 150, filename)
    ReadInIFiles = Left(ReadBack, Success)
    If Success = 0 Then
       If Subkey <> "pass" Then
       MsgBox Falseread, vbCritical, "错误提示"
       End If
       ReadInIFiles = DefaultKey
    End If
End Function

Public Sub ParseStringToStr(StringToParse As String, ByRef Str_Array() As String, Optional Delimiter As String = "@")
    Dim l As Long
    Dim lngStartPos As Long
    Dim lngNextPos  As Long
    Dim strTemp     As String
    On Error Resume Next
    '初始化起始位置
    lngStartPos = 1
    Do
        ReDim Preserve Str_Array(l)
        lngNextPos = InStr(lngStartPos, StringToParse, Delimiter)
        If lngNextPos = 0 Then
            strTemp = Mid$(StringToParse, lngStartPos, Len(StringToParse) - lngNextPos + 1)
        Else
            strTemp = Mid$(StringToParse, lngStartPos, lngNextPos - lngStartPos)
        End If
        Str_Array(l) = strTemp
        lngStartPos = lngNextPos + 1
        l = l + 1
    Loop Until lngNextPos = 0
End Sub
Private Sub InitInifile(filename As String)
On Error Resume Next
Dim Fs As Object
Dim a
Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs.FileExists(filename) Then
    Set a = Fs.CreateTextFile(filename, True)
    a.WriteLine ("[Public]")
    a.Close
End If
End Sub

Public Sub Delay(ByVal second As Single)
 Dim ss As Single
 ss = Timer + second
 Do
   DoEvents
   Sleep (20)
 Loop Until (ss < Timer)
End Sub