tools.vb

这个是国外大学的项目代码

                            GDATA(size) = (imgcol.G >> 2) << 4
                            GDATA(size) += imgcol.B >> 4
                            size += 1
                        Else
                            GDATA(size) = imgcol.R And &HF8
                            GDATA(size) += imgcol.G >> 5
                            size += 1
                            GDATA(size) = (imgcol.G >> 2) << 5
                            GDATA(size) += imgcol.B >> 3
                            size += 1
                        End If
                    Next
                Next
            Next
        End If
        ReDim Preserve GDATA(size - 1)
        LogN("done")
    End Sub

    Public Sub DecodeData()
        Dim pr As PRC
        Dim bmp As Drawing.Bitmap
        Dim imgcol As Drawing.Color
        Dim imgnr, imghead, imgadr, imgwidth, imgheight, wc, hc As Integer
        Dim red, grn, blu As Byte

        While IMGCOLL.Count > 0
            IMGCOLL.Remove(1)
        End While
        While PRCCOLL.Count > 0
            PRCCOLL.Remove(1)
        End While

        LogC("Decoding...  ")
        For imgnr = 1 To GDATA(0)
            imghead = imgnr << 3
            imgadr = GDATA(imghead)
            imghead += 1
            imgadr = (imgadr << 8) + GDATA(imghead)
            imghead += 1
            imgadr = (imgadr << 8) + GDATA(imghead)
            imghead += 1
            imgwidth = GDATA(imghead)
            imghead += 1
            imgwidth = (imgwidth << 8) + GDATA(imghead)
            imghead += 1
            imgheight = GDATA(imghead)
            imghead += 1
            imgheight = (imgheight << 8) + GDATA(imghead)
            imghead += 1
            bmp = New Drawing.Bitmap(imgwidth, imgheight, Imaging.PixelFormat.Format24bppRgb)
            For hc = 0 To imgheight - 1
                For wc = 0 To imgwidth - 1
                    red = GDATA(imgadr)
                    imgadr += 1
                    grn = GDATA(imgadr)
                    imgadr += 1
                    blu = GDATA(imgadr)
                    imgadr += 1
                    imgcol = Drawing.Color.FromArgb(red, grn, blu)
                    bmp.SetPixel(wc, hc, imgcol)
                Next
            Next
            IMGCOLL.Add(bmp, "Image " & imgnr)
        Next

        Dim selimg As Integer
        selimg = IMGLST.SelectedIndex

        IMGLST.Items.Clear()
        For imgnr = 0 To IMGCOLL.Count - 1
            IMGLST.Items.Add("Image " & imgnr)
        Next
        If GDATA(1) <> 0 Then
            For imgnr = 0 To GDATA(1) - 1
                pr = New PRC
                ReDim pr.alg(9)
                imghead = (imgnr << 4) Or &H80
                pr.src = IMGLST.Items.Item(GDATA(imghead) - 1)
                imghead += 1
                pr.dest = IMGLST.Items.Item(GDATA(imghead) - 1)
                imghead += 1
                For item As Integer = 0 To 9
                    pr.alg(item) = GDATA(imghead) And &H7F
                    If (GDATA(imghead) And &H80) <> 0 Then
                        pr.alg(item) = 0 - pr.alg(item)
                    End If
                    imghead += 1
                Next
                PRCCOLL.Add(pr)
            Next
        End If

        IMGLST.SelectedIndex = selimg

        selimg = PRCLST.SelectedIndex

        PRCLST.Items.Clear()
        For Each pr In PRCCOLL
            PRCLST.Items.Add(pr.src & " -> " & pr.dest)
        Next

        PRCLST.SelectedIndex = selimg

        LogN("done")
    End Sub

    Public Sub SaveData(ByVal fname As String)
        Dim filenr As Integer

        LogC("Writing to file...  ")

        filenr = FreeFile()
        FileOpen(filenr, fname, OpenMode.Binary)
        FilePut(filenr, GDATA)
        FileClose(filenr)

        LogN("done")
    End Sub

    Public Function LoadData(ByVal fname As String) As Boolean
        Dim filenr As Integer
        LogC("Reading file...  ")

        On Error GoTo failed
        ReDim GDATA(FileLen(fname) - 1)
        filenr = FreeFile()
        FileOpen(filenr, fname, OpenMode.Binary)
        FileGet(filenr, GDATA)
        FileClose(filenr)

        LogN("done")
        Return True
        Exit Function
failed:
        LogN("FAILED")
        Return False
    End Function

    Public Function SendData() As Boolean
        Dim erc As Integer
        Dim buff() As Byte
        Dim bsize As Byte
        Dim tmp As Byte
        Dim cnt As Integer

        If hif = 0 Then
            SendData = False
            Exit Function
        End If

        ReDim buff(MAXBLOCK - 1)
        bsize = MAXBLOCK

        If DpcPutReg(hif, &H1, tmp, erc, 0) = False Then
            LogN("FAILED")
            Exit Function
        End If
        LogC("Sending data... ")
        For cnt = 0 To GDATA.Length - 1 Step MAXBLOCK
            If cnt + MAXBLOCK > GDATA.Length Then
                bsize = GDATA.Length - cnt
            End If
            System.Array.Copy(GDATA, cnt, buff, 0, bsize)
            If DpcPutRegRepeat(hif, &H0, buff, bsize, erc, 0) = False Then
                LogN("FAILED")
                Exit Function
            End If
        Next
        If DpcPutReg(hif, &H2, &H0, erc, 0) = False Then
            LogN("FAILED")
            Exit Function
        End If
        LogN("done")
        SendData = True
    End Function

    Public Function GetData() As Boolean
        Dim erc As Integer
        Dim cnt As Integer
        Dim buff() As Byte
        Dim bsize As Byte
        Dim tmp As Byte
        ReDim buff(MAXBLOCK - 1)
        ReDim GDATA(MAXSIZE - 1)

        bsize = MAXBLOCK
        LogC("Reeciving data... ")

        If DpcGetReg(hif, &H1, tmp, erc, 0) = False Then
            LogN("FAILED")
            Exit Function
        End If
        For cnt = 0 To MAXSIZE - 1 Step MAXBLOCK
            If cnt + MAXBLOCK > MAXSIZE Then
                bsize = MAXSIZE - cnt
            End If
            If DpcGetRegRepeat(hif, &H0, buff, bsize, erc, 0) = False Then
                LogN("FAILED")
                Exit Function
            End If
            System.Array.Copy(buff, 0, GDATA, cnt, bsize)
        Next
        If DpcGetReg(hif, &H2, &H0, erc, 0) = False Then
            LogN("FAILED")
            Exit Function
        End If
        LogN("done")
        GetData = True
    End Function

    Public Sub SendCommand(ByVal cmd As Integer, ByVal nr As Integer)
        Dim erc As Integer
        If hif = 0 Then
            Exit Sub
        End If
        If DpcPutReg(hif, cmd, nr, erc, 0) = False Then
            LogN("FAILED")
        End If
    End Sub

    Public Function CheckDataSize(Optional ByVal newbmp As Drawing.Bitmap = Nothing, _
        Optional ByVal newbmp2 As Drawing.Bitmap = Nothing, _
        Optional ByVal ignore As Integer = -1) As Boolean
        Dim bmp As Drawing.Bitmap
        Dim size As Long
        Dim item As Integer
        Dim pixelsize As Integer

        If FRMMN.cboResolution.SelectedIndex = 0 Then
            pixelsize = 3
        Else
            pixelsize = 2
        End If

        size += RAWSTART
        For item = 1 To IMGCOLL.Count
            If item <> ignore + 1 Then
                bmp = IMGCOLL.Item(item)
                size += bmp.Width * bmp.Height * pixelsize
            End If
        Next item
        If Not IsNothing(newbmp) Then
            size += newbmp.Width * newbmp.Height * pixelsize
        End If
        If Not IsNothing(newbmp2) Then
            size += newbmp2.Width * newbmp2.Height * pixelsize
        End If

        If size >= MAXSIZE Then
            CheckDataSize = True
        End If
    End Function

    Public Sub LogN(ByVal txt As String)
        FRMMN.txtLog.Text = FRMMN.txtLog.Text & txt & Chr(13) & Chr(10)
    End Sub

    Public Sub LogC(ByVal txt As String)
        FRMMN.txtLog.Text = FRMMN.txtLog.Text & txt
    End Sub

End Module