mod.bas

一个用于测试ABB变频器通讯的小工具

Attribute VB_Name = "ModuleA"
   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 GetTickCount Lib "kernel32" () As Long
   Public OpenFlag As Boolean
   Public strSetting As String
   Public MscomPort As Long
   Public ReceiveByte As Variant
   Public Function CRC16_1(data() As Byte) As String
      Dim CRC16Lo As Byte, CRC16Hi As Byte      'CRC寄存器
      Dim CL As Byte, CH As Byte                '多项式码&HA001
      Dim SaveHi As Byte, SaveLo As Byte
      Dim I As Integer
      Dim Flag As Integer
      CRC16Lo = &HFF
      CRC16Hi = &HFF
      CL = &H1
      CH = &HA0
      For I = 0 To UBound(data)
        CRC16Lo = CRC16Lo Xor data(I) '每一个数据与CRC寄存器进行异或
        For Flag = 0 To 7
          SaveHi = CRC16Hi
          SaveLo = CRC16Lo
          CRC16Hi = CRC16Hi \ 2            '高位右移一位
          CRC16Lo = CRC16Lo \ 2            '低位右移一位
          If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
            CRC16Lo = CRC16Lo Or &H80      '则低位字节右移后前面补1
          End If                           '否则自动补0
          If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
            CRC16Hi = CRC16Hi Xor CH
            CRC16Lo = CRC16Lo Xor CL
          End If
        Next Flag
      Next I
      Dim ReturnData(1) As Byte
      ReturnData(0) = CRC16Hi              'CRC高位
      ReturnData(1) = CRC16Lo              'CRC低位
      CRC16_1 = ReturnData
    End Function
  Public Function CRC16_2(data() As Byte) As String
      Dim CRC16Hi As Byte
      Dim CRC16Lo As Byte
      CRC16Hi = &HFF
      CRC16Lo = &HFF
      Dim I As Integer
      Dim iIndex As Long
      For I = 0 To UBound(data)
        iIndex = CRC16Lo Xor data(I)
        CRC16Lo = CRC16Hi Xor GetCRCLo(iIndex)        '低位处理
        CRC16Hi = GetCRCHi(iIndex)                    '高位处理
      Next I
      Dim ReturnData(1) As Byte
      ReturnData(0) = CRC16Hi        'CRC高位
      ReturnData(1) = CRC16Lo        'CRC低位
      CRC16_2 = ReturnData
    End Function

    'CRC低位字节值表
    Function GetCRCLo(Ind As Long) As Byte
      GetCRCLo = Choose(Ind + 1, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, _
      &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, _
      &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, _
      &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, _
      &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, _
      &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, _
      &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, _
      &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, _
      &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, _
      &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, _
      &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, _
      &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, _
      &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, _
      &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, _
      &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, _
      &H80, &H41, &H0, &HC1, &H81, &H40)
    End Function

    'CRC高位字节值表
    Function GetCRCHi(Ind As Long) As Byte
      GetCRCHi = Choose(Ind + 1, &H0, &HC0, &HC1, &H1, &HC3, &H3, &H2, &HC2, &HC6, &H6, &H7, &HC7, &H5, _
      &HC5, &HC4, &H4, &HCC, &HC, &HD, &HCD, &HF, &HCF, &HCE, &HE, &HA, &HCA, &HCB, &HB, &HC9, &H9, &H8, _
      &HC8, &HD8, &H18, &H19, &HD9, &H1B, &HDB, &HDA, &H1A, &H1E, &HDE, &HDF, &H1F, &HDD, &H1D, &H1C, &HDC, _
      &H14, &HD4, &HD5, &H15, &HD7, &H17, &H16, &HD6, &HD2, &H12, &H13, &HD3, &H11, &HD1, &HD0, &H10, &HF0, _
      &H30, &H31, &HF1, &H33, &HF3, &HF2, &H32, &H36, &HF6, &HF7, &H37, &HF5, &H35, &H34, &HF4, &H3C, &HFC, _
      &HFD, &H3D, &HFF, &H3F, &H3E, &HFE, &HFA, &H3A, &H3B, &HFB, &H39, &HF9, &HF8, &H38, &H28, &HE8, &HE9, _
      &H29, &HEB, &H2B, &H2A, &HEA, &HEE, &H2E, &H2F, &HEF, &H2D, &HED, &HEC, &H2C, &HE4, &H24, &H25, &HE5, _
      &H27, &HE7, &HE6, &H26, &H22, &HE2, &HE3, &H23, &HE1, &H21, &H20, &HE0, &HA0, &H60, &H61, &HA1, &H63, _
      &HA3, &HA2, &H62, &H66, &HA6, &HA7, &H67, &HA5, &H65, &H64, &HA4, &H6C, &HAC, &HAD, &H6D, &HAF, &H6F, _
      &H6E, &HAE, &HAA, &H6A, &H6B, &HAB, &H69, &HA9, &HA8, &H68, &H78, &HB8, &HB9, &H79, &HBB, &H7B, &H7A, _
      &HBA, &HBE, &H7E, &H7F, &HBF, &H7D, &HBD, &HBC, &H7C, &HB4, &H74, &H75, &HB5, &H77, &HB7, &HB6, &H76, _
      &H72, &HB2, &HB3, &H73, &HB1, &H71, &H70, &HB0, &H50, &H90, &H91, &H51, &H93, &H53, &H52, &H92, &H96, _
      &H56, &H57, &H97, &H55, &H95, &H94, &H54, &H9C, &H5C, &H5D, &H9D, &H5F, &H9F, &H9E, &H5E, &H5A, &H9A, _
      &H9B, &H5B, &H99, &H59, &H58, &H98, &H88, &H48, &H49, &H89, &H4B, &H8B, &H8A, &H4A, &H4E, &H8E, &H8F, _
      &H4F, &H8D, &H4D, &H4C, &H8C, &H44, &H84, &H85, &H45, &H87, &H47, &H46, &H86, &H82, &H42, &H43, &H83, _
      &H41, &H81, &H80, &H40)
    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 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
Public Sub TimeDelay(DT As Long)
Dim T As Long
T = GetTickCount()
Do
  DoEvents
Loop Until Abs(GetTickCount - T) >= DT
End Sub