mod.bas

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

Attribute VB_Name = "ModuleA"
Public Function Bbyte2Hex(ByVal v As Byte) As String 'v is a integer(from 0 to 15)
  Dim tmp As Byte
  tmp = v Mod 16
  If tmp < 10 Then
     Bbyte2Hex = CStr(tmp)
  Else
     Bbyte2Hex = Chr$(tmp - 10 + Asc("A"))
  End If
End Function

Public Function BHex2Dec(ByVal v As String) As Byte 'v is a ASCII ,v from "0" to "F",convert "0"~"F" to 0~15
  Dim s As String
  If Len(v) > 0 Then
         s = Mid$(v, 1, 1)
         If IsNumeric(s) Then
            BHex2Dec = Val(s)
         Else
            BHex2Dec = 10 + Asc(StrConv(s, vbUpperCase)) - Asc("A")
         End If
  End If
End Function

  Public Function LRC_String(ByVal data As String) As String
  On Error Resume Next
  Dim tmp As Byte
  Dim ret As String
  Dim i As Long, j As Long
  j = 0
  For i = 2 To Len(data) Step 2
     j = j + BHex2Dec(Mid$(data, i, 1)) * 16
     j = j + BHex2Dec(Mid$(data, i + 1, 1))
  Next
  tmp = j Mod 256
  tmp = Not tmp
  tmp = tmp + 1
  i = Int(tmp / 16)
  If i < 10 Then
    ret = i
  Else
    ret = Chr(i - 10 + Asc("A"))
  End If
  i = tmp Mod 16
  If i < 10 Then
    LRC_String = ret & CStr(i)
  Else
    LRC_String = ret & Chr(i - 10 + Asc("A"))
  End If
End Function
Public Function LRC_Byte(data() As Byte) As String
  Dim tmp As Byte
  Dim ret As String
  Dim i As Long
  tmp = 0
  For i = LBound(data) + 1 To UBound(data) Step 2
     tmp = tmp + BHex2Dec(data(i)) * 16
     tmp = tmp + BHex2Dec(data(i + 1))
  Next
  tmp = Not tmp
  tmp = tmp + 1
  i = Int(tmp / 16)
  If i < 10 Then
    ret = i
  Else
    ret = Chr(i - 10 + Asc("A"))
  End If
  i = tmp Mod 16
  If i < 10 Then
    LRC = ret & CStr(i)
  Else
    LRC = ret & Chr(i - 10 + Asc("A"))
  End If
End Function

Public Function Bin2Dec(InputData As String) As Long
Dim DecOut As Long
Dim i As Integer
Dim LenBin As Long
Dim JOne As String
LenBin = Len(InputData)
For i = 1 To LenBin
 JOne = Mid(InputData, i, 1)
   If JOne <> "0" And JOne <> "1" Then
     MsgBox "转化错误！", vbCritical
     Exit Function
   End If
Next i
DecOut = 0
For i = Len(InputData) To 1 Step -1
  If Mid(InputData, i, 1) = "1" Then
    DecOut = DecOut + 2 ^ (Len(InputData) - i)
  End If
Next i
Bin2Dec = DecOut
End Function


Public Function Dec2Bin(InputData As Long) As String
Dim BinOut As String
Dim i As Integer
Dim NewVal As Double
Dim BinTemp As String
Dim BinTemp1 As String
BinOut = ""
NewVal = InputData

DoAgain:
NewVal = (NewVal / 2)

If InStr(1, CStr(NewVal), ".") Then
  BinOut = BinOut + "1"
  NewVal = Format(NewVal, "#0")
  NewVal = (NewVal - 1)
  If NewVal < 1 Then
     GoTo DoneIt
  End If
Else
  BinOut = BinOut + "0"
   If NewVal < 1 Then
     GoTo DoneIt
   End If
End If


GoTo DoAgain

DoneIt:

BinTemp = ""
For i = Len(BinOut) To 1 Step -1
 BinTemp1 = Mid(BinOut, i, 1)
 BinTemp = BinTemp + BinTemp1
Next i

BinOut = BinTemp
Dec2Bin = BinOut
eds:
End Function
Function Hex2Bin(InputData As String) As String
   Dim ret As String, Rec As String, tmp As String
   Dim i As Long
   ret = ""
   Rec = StrConv(InputData, vbUpperCase)
   For i = 1 To Len(Rec)
     Select Case (Mid(Rec, i, 1))
        Case "0"
          tmp = "0000"
        Case "1"
          tmp = "0001"
        Case "2"
          tmp = "0010"
        Case "3"
           tmp = "0011"
        Case "4"
          tmp = "0100"
        Case "5"
           tmp = "0101"
        Case "6"
          tmp = "0110"
        Case "7"
          tmp = "0111"
        Case "8"
          tmp = "1000"
        Case "9"
          tmp = "1001"
        Case "A"
          tmp = "1010"
        Case "B"
          tmp = "1011"
        Case "C"
          tmp = "1100"
        Case "D"
          tmp = "1101"
        Case "E"
          tmp = "1110"
        Case "F"
          tmp = "1111"
      End Select
      ret = ret & tmp
   Next
   Hex2Bin = ret
End Function


Function Bin2Hex(InputData As String) As String
''
''  Converts Binary to hex
''
Dim i As Integer
Dim LenBin As Integer
Dim JOne As String
Dim NumBlocks As Integer
Dim FullBin As String
Dim HexOut As String
Dim TempBinBlock As String
Dim TempHex As String

LenBin = Len(InputData)

''
''  Make sure that it is a Binary Number
''
For i = 1 To LenBin
 JOne = Mid(InputData, i, 1)
   If JOne <> "0" And JOne <> "1" Then
     MsgBox "NOT A BINARY NUMBER", vbCritical
     Exit Function
   End If
Next i

''  Set the Variable to the Binary
''
FullBin = InputData

''
''  If the value is less than 4 in length, build it up.
''
If LenBin < 4 Then
 If LenBin = 3 Then
  FullBin = "0" + FullBin
 ElseIf LenBin = 2 Then
  FullBin = "00" + FullBin
 ElseIf LenBin = 1 Then
  FullBin = "000" + FullBin
 ElseIf LenBin = 0 Then
   MsgBox "Nothing Given..", vbCritical
   Exit Function
 End If
  NumBlocks = 1
  GoTo DoBlocks
End If


If LenBin = 4 Then
  NumBlocks = 1
  GoTo DoBlocks
End If



If LenBin > 4 Then

Dim TempHold As Currency
Dim TempDiv As Currency
Dim AfterDot As Integer
Dim Pos As Integer

TempHold = Len(InputData)
TempDiv = (TempHold / 4)

''
''  Works by seeing whats after the deciomal place
''
Pos = InStr(1, CStr(TempDiv), ".")

If Pos = 0 Then
 '' Divided by 4 perfectly
 NumBlocks = TempDiv
 GoTo DoBlocks
End If

AfterDot = Mid(CStr(TempDiv), (Pos + 1))

If AfterDot = 25 Then
  FullBin = "000" + FullBin
  NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 5 Then
  FullBin = "00" + FullBin
  NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 75 Then
  FullBin = "0" + FullBin
  NumBlocks = (Len(FullBin) / 4)
Else
  MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation
  Exit Function
End If


  GoTo DoBlocks
End If


''
''  The rest will process the now built up number
''
DoBlocks:

HexOut = ""

For i = 1 To Len(FullBin) Step 4
  TempBinBlock = Mid(FullBin, i, 4)
If TempBinBlock = "0000" Then
  HexOut = HexOut + "0"
ElseIf TempBinBlock = "0001" Then
  HexOut = HexOut + "1"
ElseIf TempBinBlock = "0010" Then
  HexOut = HexOut + "2"
ElseIf TempBinBlock = "0011" Then
  HexOut = HexOut + "3"
ElseIf TempBinBlock = "0100" Then
  HexOut = HexOut + "4"
ElseIf TempBinBlock = "0101" Then
  HexOut = HexOut + "5"
ElseIf TempBinBlock = "0110" Then
  HexOut = HexOut + "6"
ElseIf TempBinBlock = "0111" Then
  HexOut = HexOut + "7"
ElseIf TempBinBlock = "1000" Then
  HexOut = HexOut + "8"
ElseIf TempBinBlock = "1001" Then
  HexOut = HexOut + "9"
ElseIf TempBinBlock = "1010" Then
  HexOut = HexOut + "A"
ElseIf TempBinBlock = "1011" Then
  HexOut = HexOut + "B"
ElseIf TempBinBlock = "1100" Then
  HexOut = HexOut + "C"
ElseIf TempBinBlock = "1101" Then
  HexOut = HexOut + "D"
ElseIf TempBinBlock = "1110" Then
  HexOut = HexOut + "E"
ElseIf TempBinBlock = "1111" Then
  HexOut = HexOut + "F"
End If

Next i


Bin2Hex = HexOut

eds:
End Function