module1.bas

多达5路DTu的信息接收客户端

Public Sub SaveSetup()
On Error GoTo Errs
    Dim x, y, z As Integer
    Dim sTemp As String
    
    Open App.Path & "\" & "SimId.Dtu" For Output As #1
        For x = 1 To 5
            Print #1, CStr(x) & "=" & sDianId(x, 2)
        Next
    Close #1
    
    Open App.Path & "\" & "ModTd.Dtu" For Output As #2
        '一号
        sTemp = ""
        For x = 1 To 6
            If SerMod(1, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '二号
        sTemp = ""
        For x = 1 To 6
            If SerMod(2, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '三号
        sTemp = ""
        For x = 1 To 6
            If SerMod(3, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '四号
        sTemp = ""
        For x = 1 To 6
            If SerMod(4, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '五号
        sTemp = ""
        For x = 1 To 6
            If SerMod(5, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '一号
        sTemp = ""
        For x = 0 To 7
            If SerTongDao(1, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '二号
        sTemp = ""
        For x = 0 To 7
            If SerTongDao(2, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '三号
        sTemp = ""
        For x = 0 To 7
            If SerTongDao(3, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '四号
        sTemp = ""
        For x = 0 To 7
            If SerTongDao(4, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        '五号
        sTemp = ""
        For x = 0 To 7
            If SerTongDao(5, x) Then sTemp = sTemp & "," & CStr(x)
        Next
        If sTemp = "" Then
            Print #2,
        Else
            Print #2, Mid(sTemp, 2, Len(sTemp) - 1)
        End If
        
        Print #2, CStr(CInt(isSort))
    Close #2
    
    Open App.Path & "\" & "Setup.Dtu" For Output As #3
        Print #3, CStr(iTimer)
        Print #3, CStr(iWaitTime)
        Print #3, sXinTiao
        Print #3, CStr(iXinTiao)
        Print #3, CStr(CInt(isReCommand))
        Print #3, RemoteUrl
        Print #3, CStr(RemoteTime)
        Print #3, CStr(CInt(isUseRemote))
        Print #3, CStr(CInt(isUseClose))
        Print #3, CStr(iCloseTime)
    Close #3
    Exit Sub
Errs:
    Call ShowError(App.Title, "SaveSetup", ERR.Number, ERR.Description)
End Sub

'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
   Dim Obj As Control
   FormOldWidth = FormName.ScaleWidth
   FormOldHeight = FormName.ScaleHeight
   On Error Resume Next
   For Each Obj In FormName
     Obj.Tag = Obj.Left & " " & Obj.Top & " " _
           & Obj.Width & " " & Obj.Height & " "
   Next Obj
   On Error GoTo 0
End Sub

'按比例改变表单内各元件的大小，在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
   Dim Pos(4) As Double
   Dim I As Long, TempPos As Long, StartPos As Long
   Dim Obj As Control
   Dim ScaleX As Double, ScaleY As Double

   ScaleX = FormName.ScaleWidth / FormOldWidth
   '保存窗体宽度缩放比例
   ScaleY = FormName.ScaleHeight / FormOldHeight
   '保存窗体高度缩放比例
   On Error Resume Next
   For Each Obj In FormName
     StartPos = 1
     For I = 0 To 4
     '读取控件的原始位置与大小

       TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
       If TempPos > 0 Then
         Pos(I) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
         StartPos = TempPos + 1
       Else
         Pos(I) = 0
       End If
       '根据控件的原始位置及窗体改变大小的比例对控件重新定位与改变大小
       Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, _
               Pos(2) * ScaleX, Pos(3) * ScaleY
     Next I
   Next Obj
   On Error GoTo 0
End Sub

Public Sub ShowError(strModule As String, strProcedure As String, _
lngErrorNumber As Long, strErrorDescription As String, _
Optional blnLogFile As Boolean = False)

'Call ShowError(Me.Name, "frmMain_Click", Err.Number, Err.Description)
    On Error GoTo PROC_ERR
    Dim strMessage As String
    Dim strCaption As String
    Dim intLogFile As Integer
    
    If blnLogFile Then
        intLogFile = FreeFile
    
        Open g_strErrorLogFileName For Append As #intLogFile
            Print #intLogFile, "*** Error Encountered " & VBA.Now & "***"
            Print #intLogFile, "错误号: " & lngErrorNumb
            Print #intLogFile, "详细信息: " & strErrorDescripti
            Print #intLogFile, "模块: " & strModu
            Print #intLogFile, "位置: " & strProcedu
            Print #intLogFile, ""
        Close #intLogFile
    End If
    
    strMessage = "错 误 号: " & lngErrorNumber & vbNewLine & _
                "详细信息: " & strErrorDescription & vbNewLine & vbNewLine & _
                "模    块: " & strModule & vbNewLine & _
                "位    置: " & strProcedure & vbNewLine & vbNewLine & _
                "    程序发生了异常错误，我们对此给您带来的" & vbNewLine & _
                "不便表示歉意请参考用户手册或帮助文件，查对" & vbNewLine & _
                "以上的错误号与错误信息寻找解决方案，如没有" & vbNewLine & _
                "相关信息或无法解决请联系我们的客服人员与技。" & vbNewLine & _
                "术支持" & vbNewLine & vbNewLine & "    感谢您对我们的支持！"
                    
    strCaption = "意外中断! 程序版本: " & _
                Str$(App.Major) & "." & Str$(App.Minor) & "." & _
                Format(App.Revision, "0000")
                
    MsgBox strMessage, vbCritical, strCaption: End
PROC_EXIT:
    Exit Sub
PROC_ERR:
    Resume Next
End Sub