Encapsulating functional functions in OCX can be simplified on the VB6 platform. Just paste those functions directly into the default template. In the blog post [Encapsulating the Function in “VB6 Programming IEEE Floating Point Algorithm Practice” into OCX] Encapsulating the Function in “VB6 Programming IEEE Floating Point Algorithm Practice” into OCX_Mongnewer’s blog-CSDN blog has detailed the OCX encapsulation of VB6 practice.
Below is the code of all functional functions for easy reference in later calls. CRC16 is referenced on CDSN. I can’t find which blog post it is in. If anyone knows, please tell me and I will post the source on the code.
Function MKI(ByVal iData As Integer) As String 'MKI 16bits &HFFFF -32768 to 32767 8000-7fff Dim inData As Long Dim HiByte As Long, LoByte As Long inData = Fix(iData) If inData < 0 Then inData = inData + 65536 LoByte = inData And &HFF HiByte = (inData \ 2 ^ 8) And &HFF MKI = Right$(("0" + Hex$(HiByte)), 2) + Right$(("0" + Hex$(LoByte)), 2) End Function Function MKL(ByVal lData As Long) As String 'MKL 32bits &HFFFFFFFF -2147483648 to 2147483647 80000000 to 7ffffffff 'Dim HiWord As Long, LoWord As Long 'Dim inData As Long 'LoWord = inData And &HFFFF 'HiWord = (inData \ 2 ^ 4) And &HFFFF 'MKL = Right$(("0000" + Hex$(HiWord)), 4) + Right$(("0000" + Hex$(LoWord)), 4) Dim Phi4 As Currency, Phi3 As Currency, Phi2 As Currency, Phi1 As Currency, inData As Currency inData = Fix(lData) Phi4 = inData And &HFF Phi3 = (inData \ 2 ^ 8) And &HFF Phi2 = (inData \ 2 ^ 16) And &HFF Phi1 = (inData \ 2 ^ 24) And &HFF MKL = Right$(("0" + Hex$(Phi1)), 2) + Right$(("0" + Hex$(Phi2)), 2) + Right$(("0\ " + Hex$(Phi3)), 2) + Right$(("0" + Hex$(Phi4)), 2) End Function Function MKS(ByVal sData As Single) As String '************************************************ ********************************* '* Single singn=1bit, exp= 8bits, tail=23bits, total=32bits, offset= 7F 127 * '* Double singn=1bit, exp=11bits, tail=52bits, total=64bits, offset= 3FF 1023 * '* DblEXT singn=1bit, exp=15bits, tail=64bits, total=80bits, offset=3FFF 16383 * '************************************************ ********************************* Dim inDataSingn As Byte Dim inData As Single Dim ipart As Long, npart As Byte, fpart As Single Dim tipart As Long, tnpart As Byte, tfpart As Single Dim AcuFactor As Byte, iDataExp As Integer, MoveDotPoint As Byte, ReIndex As Byte Dim TempData1(79) As Byte, TempData2(79) As Byte, TempData3(79) As Byte, TempData4(79) As Byte, TempData5(79) As Byte Dim IntiStr As String, FracStr As String Dim TempData As Integer, TempString As String Dim TempByte As Byte, OffSet As Integer, OffSetBits As Byte Dim CaseID As Integer, I As Integer Dim CRC16 As Long, CRC16Str As String OffSetBits = 8 AcuFactor = 32: OffSet = 127 inData = sData inDataSingn = 0 If inData < 0 Then inDataSingn = 1 inData = Abs(inData) 'ignore singn ipart = Int(inData): fpart = (inData - ipart) If inData = 0 Then CaseID = 0 Else 'Convert ipart, the integer part, into byte array TempData1 MSB to LSB tipart = ipart: TempString = "" For I = 1 To AcuFactor TempString = Right$(Str$(tipart And &H1), 1) + TempString tipart = tipart \ 2 ^ 1 Next I For I = 1 To AcuFactor If Mid$(TempString, I, 1) = "1" Then Exit For Mid$(TempString, I, 1) = " " Next I IntiStr = Trim(TempString) 'Convert fpart, the fraction part, into byte array TempData2 tfpart = fpart: TempString = "" For I = 1 To AcuFactor If tfpart = 0 Then Exit For tfpart = tfpart * 2 tnpart = Int(tfpart): tfpart = tfpart - tnpart TempString = TempString + Right$(Str$(tnpart And &H1), 1) Next I FracStr = TempString If ipart > 0 Then CaseID = 1 If ipart = 0 Then CaseID = 2 End If Select Case CaseID Case 0 TempByte = 0 TempString = Right$((String(AcuFactor, "0") + Hex$(TempByte)), AcuFactor / 4) MKS = TempString Case 1 'Data with integer part For I = 1 To Len(IntiStr) If Mid$(IntiStr, I, 1) = "1" Then Exit For Next I MoveDotPoint = Len(IntiStr) - I iDataExp = MoveDotPoint + OffSet 'Now Sign, Exp and Fracpart ready TempData = iDataExp TempString = "" For I = 1 To OffSetBits TempString = Right$(Str$(TempData And &H1), 1) + TempString TempData = TempData \ 2 ^ 1 Next I 'Sign and Exponent CRC16Str = Trim(Str$(inDataSingn)) + Right$(TempString, OffSetBits) 'Make full string and omit first "1" TempString = IntiStr + FracStr TempString = Right$(TempString, Len(TempString) - 1) CRC16Str = Left$((CRC16Str + TempString + String(AcuFactor, "0")), AcuFactor) TempString = "" For I = 1 To AcuFactor Step 4 TempByte = 0 TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 3, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 2, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 1, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 0, 1))) TempString = TempString + Hex$(TempByte) Next I MKS = TempString Case 2 'Data without integer part For I = 1 To Len(FracStr) If Mid$(FracStr, I, 1) = "1" Then Exit For Next I MoveDotPoint = I iDataExp = -1 * MoveDotPoint + OffSet 'Now Sign, Exp and Fracpart ready TempData = iDataExp TempString = "" For I = 1 To OffSetBits TempString = Right$(Str$(TempData And &H1), 1) + TempString TempData = TempData \ 2 ^ 1 Next I TempString = Right$(TempString, OffSetBits) 'Sign and Exponent, and FracPart CRC16Str = Trim(Str$(inDataSingn)) + Trim(TempString) + Right$(FracStr, Len(FracStr) - MoveDotPoint) TempString = "" For I = 1 To AcuFactor Step 4 TempByte = 0 TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 3, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 2, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 1, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 0, 1))) TempString = TempString + Hex$(TempByte) Next I MKS = TempString End Select End Function Function MKD(ByVal sData As Double) As String '************************************************ ********************************* '* Single singn=1bit, exp= 8bits, tail=23bits, total=32bits, offset= 7F 127 * '* Double singn=1bit, exp=11bits, tail=52bits, total=64bits, offset= 3FF 1023 * '* DblEXT singn=1bit, exp=15bits, tail=64bits, total=80bits, offset=3FFF 16383 * '************************************************ ********************************* Dim inDataSingn As Byte Dim inData As Double Dim ipart As Long, npart As Byte, fpart As Double Dim tipart As Long, tnpart As Byte, tfpart As Double Dim AcuFactor As Byte, iDataExp As Integer, MoveDotPoint As Byte, ReIndex As Byte Dim TempData1(79) As Byte, TempData2(79) As Byte, TempData3(79) As Byte, TempData4(79) As Byte, TempData5(79) As Byte Dim IntiStr As String, FracStr As String Dim TempData As Integer, TempString As String Dim TempByte As Byte, OffSet As Integer, OffSetBits As Byte Dim CaseID As Integer, I As Integer Dim CRC16 As Long, CRC16Str As String OffSetBits = 11 AcuFactor = 64: OffSet = 1023 inData = sData inDataSingn = 0 If inData < 0 Then inDataSingn = 1 inData = Abs(inData) 'ignore singn ipart = Int(inData): fpart = (inData - ipart) If inData = 0 Then CaseID = 0 Else 'Convert ipart, the integer part, into byte array TempData1 MSB to LSB tipart = ipart: TempString = "" For I = 1 To AcuFactor TempString = Right$(Str$(tipart And &H1), 1) + TempString tipart = tipart \ 2 ^ 1 Next I For I = 1 To AcuFactor If Mid$(TempString, I, 1) = "1" Then Exit For Mid$(TempString, I, 1) = " " Next I IntiStr = Trim(TempString) 'Convert fpart, the fraction part, into byte array TempData2 tfpart = fpart: TempString = "" For I = 1 To AcuFactor If tfpart = 0 Then Exit For tfpart = tfpart * 2 tnpart = Int(tfpart): tfpart = tfpart - tnpart TempString = TempString + Right$(Str$(tnpart And &H1), 1) Next I FracStr = TempString If ipart > 0 Then CaseID = 1 If ipart = 0 Then CaseID = 2 End If Select Case CaseID Case 0 TempByte = 0 TempString = Right$((String(AcuFactor, "0") + Hex$(TempByte)), AcuFactor / 4) CRC16Str = TempString Case 1 'Data with integer part For I = 1 To Len(IntiStr) If Mid$(IntiStr, I, 1) = "1" Then Exit For Next I MoveDotPoint = Len(IntiStr) - I iDataExp = MoveDotPoint + OffSet 'Now Sign, Exp and Fracpart ready TempData = iDataExp TempString = "" For I = 1 To OffSetBits TempString = Right$(Str$(TempData And &H1), 1) + TempString TempData = TempData \ 2 ^ 1 Next I 'Sign and Exponent CRC16Str = Trim(Str$(inDataSingn)) + Right$(TempString, OffSetBits) 'Make full string and omit first "1" TempString = IntiStr + FracStr TempString = Right$(TempString, Len(TempString) - 1) CRC16Str = Left$((CRC16Str + TempString + String(AcuFactor, "0")), AcuFactor) Case 2 'Data without integer part For I = 1 To Len(FracStr) If Mid$(FracStr, I, 1) = "1" Then Exit For Next I MoveDotPoint = I iDataExp = -1 * MoveDotPoint + OffSet 'Now Sign, Exp and Fracpart ready TempData = iDataExp TempString = "" For I = 1 To AcuFactor TempString = Right$(Str$(TempData And &H1), 1) + TempString TempData = TempData \ 2 ^ 1 Next I TempString = Right$(TempString, OffSetBits) 'Sign and Exponent, and FracPart CRC16Str = Trim(Str$(inDataSingn)) + Trim(TempString) + Right$(FracStr, Len(FracStr) - MoveDotPoint) End Select TempString = "" For I = 1 To AcuFactor Step 4 TempByte = 0 TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 3, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 2, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 1, 1))) TempByte = TempByte \ 2 TempByte = TempByte Or ( & amp;H8 * Val(Mid$(CRC16Str, I + 0, 1))) TempString = TempString + Hex$(TempByte) Next I MKD = TempString End Function Function CVI(ByVal iData As String) As Long 'CVI gives 16bits &HFFFF -32768 to 32767 8000-7fff Dim iReturn As Long Dim HiByte As String, LoByte As String Dim TempStr As String TempStr = Right$(Space(4) + iData, 4) HiByte = Left$(TempStr, 2) LoByte = Right$(TempStr, 2) iReturn = Val(" & amp;H" + HiByte) * 256 + Val(" & amp;H" + LoByte) CVI = iReturn End Function Function CVL(ByVal lData As String) As Long 'CVL gives 32bits &HFFFFFFFF -2147483648 to 2147483647 80000000 to 7ffffffff Dim inData As String Dim iReturn As Long Dim LoWord As Integer, HiWord As Integer inData = Right((Space(8) + lData), 8) LoWord = Val(" & amp;H" + Right$(inData, 4)) HiWord = Val(" & amp;H" + Left$(inData, 4)) iReturn = HiWord * ( & amp;HFFFF + 1) + LoWord CVL = iReturn End Function Function CVS(ByVal sData As String) As Single Dim inData As String Dim TempStr As String, TempChar As String, TempCharVal As Byte Dim SignBit As Integer, iExp As Integer, tiExp As Integer Dim I As Integer, J As Integer Dim IntiPart As String, FracPart As String Dim IntiData As Double, FracData As Double inData = Right$((String(8, "0") + sData), 8) TempStr = "" For I = 1 to 8 TempChar = Mid$(inData, 9 - I, 1) TempCharVal = Val(" & amp;H" + Right$(TempChar, 1)) For J = 1 To 4 TempStr = Trim$(Str$(TempCharVal And &H1)) + TempStr TempCharVal = TempCharVal \ 2 ^ 1 Next J Next I SignBit=1 If Left$(TempStr, 1) = "1" Then SignBit = -1 iExp = 0 For I = 2 To 9 iExp = iExp * 2^1 iExp = iExp Or Val(Mid$(TempStr, I, 1)) Next I 'positive for data greater than 1, or negative for data with only fraction part If iExp >= 127 Then 'IntiPart exists tiExp = iExp - 127 If tiExp > 0 Then IntiPart = "1" + Left$(Mid$(TempStr, 10, 23), tiExp) FracPart = Right$((Mid$(TempStr, 10, 23)), 23 - tiExp) End If If tiExp = 0 Then IntiPart = "1" + Left$(Mid$(TempStr, 10, 23), tiExp) FracPart = Right$((Mid$(TempStr, 10, 23)), 23) End If Else tiExp = iExp - 127 IntiPart = "0" FracPart = String(Abs(tiExp + 1), "0") + "1" + Mid$(TempStr, 10, 23) FracData = 0 For I = 1 To Len(FracPart) If Mid$(FracPart, I, 1) = "1" Then FracData = FracData + 2 ^ (-I) End If Next I End If IntiData = 0 For I = 1 To Len(IntiPart) IntiData = IntiData * 2^1 IntiData = IntiData Or Val(Mid$(IntiPart, I, 1)) Next I FracData = 0 For I = 1 To Len(FracPart) If Mid$(FracPart, I, 1) = "1" Then FracData = FracData + 2 ^ (-I) End If Next I CVS = SignBit * (IntiData + Val(Format$(FracData, "#.###############0"))) End Function Function CVD(ByVal sData As String) As Double Dim inData As String Dim TempStr As String, TempChar As String, TempCharVal As Byte Dim SignBit As Integer, iExp As Integer, tiExp As Integer Dim I As Integer, J As Integer Dim IntiPart As String, FracPart As String Dim IntiData As Double, FracData As Double inData = Right$((String(16, "0") + sData), 16) TempStr = "" For I = 1 To 16 TempChar = Mid$(inData, 17 - I, 1) TempCharVal = Val(" & amp;H" + Right$(TempChar, 1)) For J = 1 To 4 TempStr = Trim$(Str$(TempCharVal And &H1)) + TempStr TempCharVal = TempCharVal \ 2 ^ 1 Next J Next I SignBit=1 If Left$(TempStr, 1) = "1" Then SignBit = -1 iExp = 0 For I = 2 To 12 iExp = iExp * 2^1 iExp = iExp Or Val(Mid$(TempStr, I, 1)) Next I 'positive for data greater than 1, or negative for data with only fraction part If iExp >= 1023 Then 'IntiPart exist tiExp = iExp - 1023 If tiExp > 0 Then IntiPart = "1" + Left$(Mid$(TempStr, 13, 52), tiExp) FracPart = Right$((Mid$(TempStr, 13, 52)), 52 - tiExp) End If If tiExp = 0 Then IntiPart = "1" + Left$(Mid$(TempStr, 13, 52), tiExp) FracPart = Right$((Mid$(TempStr, 13, 52)), 52) End If Else tiExp = iExp - 1023 IntiPart = "0" FracPart = String(Abs(tiExp + 1), "0") + "1" + Mid$(TempStr, 13, 52) FracData = 0 For I = 1 To Len(FracPart) If Mid$(FracPart, I, 1) = "1" Then FracData = FracData + 2 ^ (-I) End If Next I End If IntiData = 0 For I = 1 To Len(IntiPart) IntiData = IntiData * 2^1 IntiData = IntiData Or Val(Mid$(IntiPart, I, 1)) Next I FracData = 0 For I = 1 To Len(FracPart) If Mid$(FracPart, I, 1) = "1" Then FracData = FracData + 2 ^ (-I) End If Next I CVD = SignBit * (IntiData + Val(Format$(FracData, "#.###############0"))) End Function Function CRC16(ByVal inData As String) As String Dim TestString As String Dim I As Integer, Temp As Integer Dim PP As Integer Dim CRCLo As Byte, CRCHi As Byte, TCRC As Byte DimLTable() LTable() = Array( _ " & amp;H0000", " & amp;HCC01", " & amp;HD801", " & amp;H1400", " & amp;HF001", " & amp; H3C00", " &H2800", " &HE401", _ " & amp;HA001", " & amp;H6C00", " & amp;H7800", " & amp;HB401", " & amp;H5000", " & amp; H9C01", " & amp;H8801", " & amp;H4400") TestString = inData 'TestString = "010303E80002" CRCHi = & amp;HFF: CRCLo = & amp;HFF For I = 1 To Len(TestString) / 2 PP = Val(" & amp;H" + Mid$(TestString, I * 2 - 1, 2)) Temp = (CRCLo And & amp;HF) Xor (PP And & amp;HF) CRCLo = CRCLo\ 2^4 TCRC = (CRCHi And &HF) TCRC = TCRC * 2^4: CRCLo = CRCLo Or TCRC CRCHi = CRCHi \ 2^4 CRCLo = CRCLo Xor (Val(" & amp;H" + (Right$(LTable(Temp), 2)))) CRCHi = CRCHi Xor (Val(" & amp;H" + (Mid$(LTable(Temp), 3, 2)))) Temp = (CRCLo And &HF) Xor (PP \ 2 ^ 4) CRCLo = CRCLo\ 2^4 TCRC = (CRCHi And &HF) TCRC = TCRC * 2^4: CRCLo = CRCLo Or TCRC CRCHi = CRCHi \ 2^4 CRCLo = CRCLo Xor (Val(" & amp;H" + (Right$(LTable(Temp), 2)))) CRCHi = CRCHi Xor (Val(" & amp;H" + (Mid$(LTable(Temp), 3, 2)))) Next I CRC16 = Hex$(CRCLo) + Hex$(CRCHi) End Function Function MbusVer() As Integer MbusVer=12 End Function
Change the project name and compile it. The name of this OCX is Mbus.ocx. Then use regsvr32 to register this ocx, and open VS2022 to build a new VB.NET project. Introduce Mbus, an ocx-based COM, into the project
The old routine is still Import into the program.
Add modules to the project
Module Module1 Declare Function DllRegisterServer Lib "Mbus.ocx" Alias "DllRegisterServer" () As Long Declare Function DllUnregisterServer Lib "Mbus.ocx" Alias "DllUnregisterServer" () As Long End Module
Automatically register the ocx control when the Application starts
Automatically log out the ocx control when the main form is closed
Private Sub Form1_FormClosed(sender As Object, e As FormClosedEventArgs) Handles MyBase.FormClosed Dim dReturn As Double dReturn = DllUnregisterServer() dReturn = DllUnregisterServer() dReturn = DllUnregisterServer() End Sub
Under the Command button on the form, write the calling code.
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click Dim s As New Mbus.UserControl1 TextBox1.Text = Microsoft.VisualBasic.Str(s.MbusVer() / 10) TextBox10.Text = "CRC16 = " & s.CRC16("010303E80002") TextBox2.Text = s.MKI(1123.21) 'MKI TextBox9.Text = s.CVI(TextBox2.Text) 'CVI TextBox3.Text = s.MKL(1123.21) 'MKL TextBox8.Text = s.CVL(TextBox3.Text) 'CVL TextBox4.Text = s.MKS(1123.21) 'MKS TextBox7.Text = s.CVS(TextBox4.Text) 'CVS TextBox5.Text = s.MKD(1123.21) 'MKD TextBox6.Text = s.CVD(TextBox5.Text) 'CVD End Sub
Debugged and compiled under x86 simulation, and the test passed.