信息(简).frm

我们公司生产线大屏幕的程序．是用visual basic语言编写的．

        tcpClient.Connect ip_adr, PORT
    
    End If
    
        
    If show_current < 2 * show_max - 1 Then
       show_current = show_current + 1
    Else
       show_current = 0
    End If
End Sub

Private Sub sendbmp(ByVal fileName As String, ByVal pingnumber As Long)
    Const VALUE As Byte = 128
    Dim i, j, k
    Dim mychar As String
    Dim d As Integer
    Dim colorcount As Integer
    Dim bytes As Integer
    Dim linebytes As Long
    Dim width As Integer
    Dim height As Long
    Dim fileoffset As Long
    Dim fileHeader As BITMAPFILEHEADER
    Dim infoHeader As BITMAPINFOHEADER
    Dim pixel(1500, 300) As Byte
       
    On Error GoTo ErrorHandler   ' 打开错误处理程序。
    Open fileName For Binary Access Read As #1
    On Error GoTo 0   ' 关闭错误陷阱。
    Get #1, , fileHeader.bftype
    Get #1, , fileHeader.bfsize
    Get #1, , fileHeader.bfreserved1
    Get #1, , fileHeader.bfreserved2
    Get #1, , fileHeader.bfoffbits
 
    
    Get #1, , infoHeader.bisize
    Get #1, , infoHeader.biwidth
    Get #1, , infoHeader.biheight
    Get #1, , infoHeader.biplanes
    Get #1, , infoHeader.bibitcount
    Get #1, , infoHeader.bicompress
    Get #1, , infoHeader.bisizeimage
    Get #1, , infoHeader.bixpeispermeter
    Get #1, , infoHeader.biypeispermeter
    Get #1, , infoHeader.bicirused
    Get #1, , infoHeader.bicirimprotant
    
        
    If infoHeader.bicompress <> 0 Then
        MsgBox "only supports non_compressed BMP file"
        Close #1
        Exit Sub
    End If
    If infoHeader.bibitcount <> 24 And infoHeader.bibitcount <> 1 Then
        MsgBox "only support 单色 or 24Bit BMP file"
        Close #1
        Exit Sub
    End If
    width = infoHeader.biwidth
    height = infoHeader.biheight
    bytes = (width * infoHeader.bibitcount + 7) \ 8
    linebytes = ((bytes + 3) \ 4) * 4
    
    
    ReDim outbytes(3)
    outbytes(0) = Asc("B")
    outbytes(1) = Asc("M")
    outbytes(2) = Asc("P")
    outbytes(3) = pingnumber
    string_s = False
    On Error Resume Next
    If tcpClient.State <> sckClosed Then _
    tcpClient.Close
    tcpClient.Connect ip_adr, PORT
    Do Until tcpClient.State = sckClosed
    DoEvents
    Loop
    
    Picture1.Picture = LoadPicture(fileName)
    Picture1.Visible = True
    If infoHeader.bibitcount = 1 Then
        Dim temp As Byte
       
        ReDim outbytes(linebytes - 1)
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        Get #1, , temp
        For j = height - 1 To 0 Step -1
            For i = 0 To linebytes - 1
                Get #1, , pixel(i, j)
            Next i
        Next j
        For j = 0 To height - 1
            For i = 0 To linebytes - 1
                outbytes(i) = pixel(i, j)
            Next i
            Picture1.height = (1 + j) * Screen.TwipsPerPixelX
            Picture1.width = width * Screen.TwipsPerPixelY
            
            string_s = False
            On Error Resume Next
            If tcpClient.State <> sckClosed Then _
            tcpClient.Close
            tcpClient.Connect ip_adr, PORT
            Do Until tcpClient.State = sckClosed
            DoEvents
            Loop
       
        Next j
    Else
        For j = height - 1 To 0 Step -1
            For i = 0 To linebytes - 1
                Get #1, , pixel(i, j)
            Next i
        Next j
    
        infoHeader.bibitcount = 1
        bytes = (width * infoHeader.bibitcount + 7) \ 8
        linebytes = ((bytes + 3) \ 4) * 4
        infoHeader.bisizeimage = linebytes * height
        ReDim outbytes(linebytes - 1)
        
        For j = 0 To height - 1
            For i = 0 To linebytes - 1
                outbytes(i) = 0
                For k = 0 To 7
                    If pixel((8 * i + k) * 3, j) > 128 Then
                        outbytes(i) = outbytes(i) Or 2 ^ (7 - k)
                    End If
                Next k
            Next i
        
            Picture1.height = (1 + j) * Screen.TwipsPerPixelX
            Picture1.width = width * Screen.TwipsPerPixelY
            string_s = False
            On Error Resume Next
            If tcpClient.State <> sckClosed Then _
            tcpClient.Close
            tcpClient.Connect ip_adr, PORT
            Do Until tcpClient.State = sckClosed
            DoEvents
            Loop
            
        Next j
    
    End If

    Close #1

    'Picture1.height = 0
    'Picture1.width = 0
    Exit Sub      ' 退出程序，以避免进入错误处理程序。
ErrorHandler:           ' 错误处理程序。
   Select Case Err.Number   ' 检查错误代号。
      Case 53   ' 发生“文件打不开”的错误。
      MsgBox "*.bmp open error."
'      Err.Clear   ' 清除 Err 对象字段。
       Case Else
        ' 处理其他错误状态 . . .
   End Select
End Sub

Public Sub 读设置()
    Dim i
    Open "setfile1" For Random As #1
    Get #1, , show_max
    MSFlexGrid1.Rows = show_max + 1
    For i = 0 To show_max - 1
        Get #1, , myshowmode(i).fileName
        Get #1, , myshowmode(i).pausetime
        Get #1, , myshowmode(i).dsmode
        Get #1, , myshowmode(i).dsclock
    MSFlexGrid1.TextMatrix(i + 1, 0) = myshowmode(i).fileName
    MSFlexGrid1.TextMatrix(i + 1, 1) = myshowmode(i).pausetime
    MSFlexGrid1.TextMatrix(i + 1, 2) = myshowmode(i).dsmode
    MSFlexGrid1.TextMatrix(i + 1, 3) = myshowmode(i).dsclock
    Next i
    Get #1, , ip_adr
   Text1.Text = MSFlexGrid1.Text
   Text2.Text = ip_adr
    Close #1
End Sub

Public Sub 写设置()
    Dim i
    'MSFlexGrid1.TextArray(1 * MSFlexGrid1.Cols + 1) = "文件名"
    MSFlexGrid1.Text = Text1.Text
    While MSFlexGrid1.TextMatrix(MSFlexGrid1.Rows - 1, 0) = ""
        MSFlexGrid1.Rows = MSFlexGrid1.Rows - 1
    Wend
    show_max = MSFlexGrid1.Rows - 1
    Open "setfile1" For Random As #1
    Put #1, , show_max
    For i = 0 To show_max - 1
        myshowmode(i).fileName = MSFlexGrid1.TextMatrix(i + 1, 0)
        If Val(MSFlexGrid1.TextMatrix(i + 1, 1)) > 18 Then
            myshowmode(i).pausetime = 18
        ElseIf Val(MSFlexGrid1.TextMatrix(i + 1, 1)) < 0 Then
            myshowmode(i).pausetime = 0
        Else
            myshowmode(i).pausetime = Val(MSFlexGrid1.TextMatrix(i + 1, 1))
        End If
            MSFlexGrid1.TextMatrix(i + 1, 1) = myshowmode(i).pausetime
        If Val(MSFlexGrid1.TextMatrix(i + 1, 2)) > 8 Then
            myshowmode(i).dsmode = 8
        ElseIf Val(MSFlexGrid1.TextMatrix(i + 1, 2)) < 1 Then
            myshowmode(i).dsmode = 1
        Else
            myshowmode(i).dsmode = Val(MSFlexGrid1.TextMatrix(i + 1, 2))
        End If
            MSFlexGrid1.TextMatrix(i + 1, 2) = myshowmode(i).dsmode
        If Val(MSFlexGrid1.TextMatrix(i + 1, 3)) <> 0 Then
            myshowmode(i).dsclock = 1
          Else
            myshowmode(i).dsclock = 0
        End If
            MSFlexGrid1.TextMatrix(i + 1, 3) = myshowmode(i).dsclock
        Put #1, , myshowmode(i).fileName
        Put #1, , myshowmode(i).pausetime
        Put #1, , myshowmode(i).dsmode
        Put #1, , myshowmode(i).dsclock
    Next i
    Put #1, , ip_adr
    Close #1
    Text1.Text = MSFlexGrid1.Text
End Sub
Private Sub 读数据()
    On Error Resume Next
    Open App.Path & "\data.txt" For Input As #1   ' 打开输入文件。
    njh = readone
    nwc = readone
    yjh = readone
    ywc = readone
    rjh = readone
    rwc = readone
    jp = readone
    If Not EOF(1) Then  ' 循环至文件尾。
        Input #1, error_inf ' 数据读入
    End If
    Close #1
    End Sub
Private Function readone()
    Dim Datastring, tmp
    If Not EOF(1) Then  ' 循环至文件尾。
asd:
        Input #1, Datastring  ' 数据读入
        On Error Resume Next
        tmp = CLng(Datastring)
        If Err.Number = 13 Then GoTo asd
        On Error GoTo 0
        If tmp < 100000 Then
            Datastring = " " & Datastring
        End If
        If tmp < 10000 Then
            Datastring = " " & Datastring
        End If
        If tmp < 1000 Then
            Datastring = " " & Datastring
        End If
        If tmp < 100 Then
            Datastring = " " & Datastring
        End If
         If tmp < 10 Then
            Datastring = " " & Datastring
        End If
       readone = Datastring
    End If
End Function
Private Sub tcpClient_Close()
    Print "close"
    tcpClient.Close
End Sub

Private Sub tcpClient_Connect()
    If string_s Then
        tcpClient.SendData OutString
    Else
        tcpClient.SendData outbytes
    End If
End Sub

Private Sub tcpClient_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    Print Description
End Sub

Private Sub tcpClient_SendComplete()
    tcpClient.Close
End Sub