Packed Data(Comp-3, etc)

[Marcos]

Does anyone know of any dll's that will convert Packed Data- comp-3 and so
forth into ascii so that it can be fed into SQL Server.

The scene:
We have some AS400 flatfiles that have data that is stored in packed comp-3
format. I need some help in converting these to readable format used by SQL
Server, VB, etc.

Any help would be much appreciated.

Thanks,

Marcos

[Larry Goldstein]

Check the class module out below.

The following sample code shows how you might use it. Here we are
converting
EBCIDIC to ASCII, then unpacking packed decimals to doubles using the
supplied method from the class.

If you need more information, send me an email. I tried to attach the .cls
as a separate file, but the newsgroup appears to block attachments.

Good luck!

Larry Goldstein
Advanswers
lgoldste@advanswers.com

Calling code...

Private Sub cmdConvert_Click()

Dim dVal As Double
Dim lErr As Long
Dim lFile As Long
Dim lFile2 As Long
Dim lRecord As Long
Dim sPCString As String * 120
Dim sMainFrameString As String * 120
Dim sTemp As String
Dim MyConversion As clsConversions

Screen.MousePointer = vbHourglass

Set MyConversion = New clsConversions

sTemp = lblRecSize
lFile = FreeFile
Open m_sFile For Random As #lFile Len = m_lSize

lFile2 = FreeFile
Open "C:\temp\test.txt" For Output As #lFile2

lstDisplay(0).Clear
lstDisplay(1).Clear

lRecord = 0

Do
lRecord = lRecord + 1
If lRecord Mod 100 = 0 Then
lblRecs = "Reading record: " & CStr(lRecord)
DoEvents
End If

Get #lFile, lRecord, sMainFrameString
lErr = Err
If lErr = 0 Then
'convert from mainframe to pc
sPCString = MyConversion.EBCDIC_To_ASCII(sMainFrameString)
If sPCString <> sMainFrameString And Left(sPCString, 1) = "1"
Then
lstDisplay(0).AddItem sMainFrameString
lstDisplay(0).ItemData(lstDisplay(0).NewIndex) = lRecord
lstDisplay(1).AddItem sPCString
lstDisplay(1).ItemData(lstDisplay(1).NewIndex) = lRecord
DoEvents
ElseIf sPCString = sMainFrameString Then
Exit Do
End If
End If

'Test with NSI Total Activity Report
If Left$(sPCString, 1) = "1" Then
dVal = MyConversion.PackedStringToDouble(Mid$(sMainFrameString,
73, 5), 10, 0)
Print #lFile2, dVal, Left$(sPCString, 30)
End If
Loop Until lErr <> 0

lblRecs = "# Records: " & CStr(lRecord - 1)
Close #lFile
Close #lFile2
Set MyConversion = Nothing

lblRecSize = sTemp
Screen.MousePointer = vbDefault
'convert from pc to mainframe
'sMainFrameString = MyConversion.ASCII_To_EBCDIC(sPCString)

End Sub


Class code...

Option Explicit

'The Conversion Class code
Private mvarEbcdic2Ascii As String
Private mvarAscii2Ebcdic As String

Private Declare Function ntohl Lib "ws2_32.dll" (ByVal l As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal l As Integer) As
Integer
Private Declare Function htonl Lib "ws2_32.dll" (ByVal l As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal l As Integer) As
Integer

'if the winsock DLL is not found the conversion functions will use these
types
Private Type LongIntegerType
i1 As Integer
i2 As Integer
End Type
Private LongIntegerRec As LongIntegerType

Private Type LongByteType
b1 As Byte
b2 As Byte
b3 As Byte
b4 As Byte
End Type

Private Type LongType
l As Long
End Type
Private LongRec As LongByteType

Private InternetLongRec As LongByteType
Private InternetLong As LongType
Private MyLong As LongType

Private Type ShortByteType
b1 As Byte
b2 As Byte
End Type
Private Type ShortType
i As Integer
End Type
Private ShortRec As ShortByteType
Private InternetShortRec As ShortByteType
Private InternetShort As ShortType
Private MyShort As ShortType

'Special Overlay data type records
Private Type DoubleLongByteType
b1 As Byte
b2 As Byte
b3 As Byte
b4 As Byte
b5 As Byte
b6 As Byte
b7 As Byte
b8 As Byte
End Type
Private Type DateTimeType
d As Date
End Type
Private Type DoubleType
d As Double
End Type
Private DoubleLongRec As DoubleLongByteType

Public Function DecLenFromParType(pLong As Long) As Integer
MyLong.l = pLong
LSet LongIntegerRec = MyLong
DecLenFromParType = LongIntegerRec.i2
End Function

Public Function DecFracFromParType(pLong As Long) As Integer
MyLong.l = pLong
LSet LongIntegerRec = MyLong
DecFracFromParType = LongIntegerRec.i1
End Function

Public Function ShortToByteArray(pShort As Integer) As Variant
Dim tArray(0 To 1) As Byte

MyShort.i = pShort

LSet ShortRec = MyShort

tArray(0) = ShortRec.b1
tArray(1) = ShortRec.b2

ShortToByteArray = tArray
End Function

Public Function LongToByteArray(pLong As Long) As Variant
Dim tArray(0 To 3) As Byte

MyLong.l = pLong

LSet LongRec = MyLong

tArray(0) = LongRec.b1
tArray(1) = LongRec.b2
tArray(2) = LongRec.b3
tArray(3) = LongRec.b4

LongToByteArray = tArray
End Function

Public Function DateTimeToByteArray(pDateTime As Date) As Variant
Dim tArray(0 To 7) As Byte
Dim tDateTimeRec As DateTimeType

tDateTimeRec.d = pDateTime

LSet DoubleLongRec = tDateTimeRec

tArray(0) = DoubleLongRec.b1
tArray(1) = DoubleLongRec.b2
tArray(2) = DoubleLongRec.b3
tArray(3) = DoubleLongRec.b4
tArray(4) = DoubleLongRec.b5
tArray(5) = DoubleLongRec.b6
tArray(6) = DoubleLongRec.b7
tArray(7) = DoubleLongRec.b8

DateTimeToByteArray = tArray
End Function

Public Function ByteArrayToDateTime(pData As Variant) As Date
Dim tDateTimeRec As DateTimeType

DoubleLongRec.b1 = pData(0)
DoubleLongRec.b2 = pData(1)
DoubleLongRec.b3 = pData(2)
DoubleLongRec.b4 = pData(3)
DoubleLongRec.b5 = pData(4)
DoubleLongRec.b6 = pData(5)
DoubleLongRec.b7 = pData(6)
DoubleLongRec.b8 = pData(7)

LSet tDateTimeRec = DoubleLongRec

ByteArrayToDateTime = tDateTimeRec.d
End Function

Public Function DoubleToByteArray(pDouble As Double) As Variant
Dim tArray(0 To 7) As Byte
Dim tDoubelRec As DoubleType

tDoubelRec.d = pDouble

LSet DoubleLongRec = tDoubelRec

tArray(0) = DoubleLongRec.b1
tArray(1) = DoubleLongRec.b2
tArray(2) = DoubleLongRec.b3
tArray(3) = DoubleLongRec.b4
tArray(4) = DoubleLongRec.b5
tArray(5) = DoubleLongRec.b6
tArray(6) = DoubleLongRec.b7
tArray(7) = DoubleLongRec.b8

DoubleToByteArray = tArray
End Function

Public Function ByteArrayToDouble(pData As Variant) As Double
Dim tDoubleRec As DoubleType

DoubleLongRec.b1 = pData(0)
DoubleLongRec.b2 = pData(1)
DoubleLongRec.b3 = pData(2)
DoubleLongRec.b4 = pData(3)
DoubleLongRec.b5 = pData(4)
DoubleLongRec.b6 = pData(5)
DoubleLongRec.b7 = pData(6)
DoubleLongRec.b8 = pData(7)

LSet tDoubleRec = DoubleLongRec

ByteArrayToDouble = tDoubleRec.d
End Function

Public Function TimeStringToTime(pTimeString As String) As Date
If IsDate(pTimeString) Then
TimeStringToTime = pTimeString
End If
End Function

Public Function TimeToTimeString(pTime As Date) As String
TimeToTimeString = Format(pTime, "hh:nn:ss")
End Function

Public Function DateStringToDate(pDateString As String) As Date
If IsDate(pDateString) Then
DateStringToDate = pDateString
End If
End Function

Public Function DateToDateString(pDate As Date) As String
DateToDateString = Format(pDate, "YYYY-MM-DD")
End Function

Public Function EBCDIC_To_ASCII(pEbcdicString As String) As String
EBCDIC_To_ASCII = Translate(pEbcdicString, mvarAscii2Ebcdic)
End Function

Public Function ASCII_To_EBCDIC(pAsciiString As String) As String
ASCII_To_EBCDIC = Translate(pAsciiString, mvarEbcdic2Ascii)
End Function

Public Function NetworkShortToShort(pShort As Integer) As Integer
On Error Resume Next
NetworkShortToShort = ntohs(pShort)
If Err.Number <> 0 Then
InternetShort.i = pShort
LSet InternetShortRec = InternetShort
ShortRec.b2 = InternetShortRec.b1
ShortRec.b1 = InternetShortRec.b2
LSet MyShort = ShortRec
NetworkShortToShort = MyShort.i
End If
End Function

Public Function ShortToNetworkShort(pShort As Integer) As Integer
On Error Resume Next
ShortToNetworkShort = htons(pShort)
If Err.Number <> 0 Then
MyShort.i = pShort
LSet ShortRec = MyShort
InternetShortRec.b1 = ShortRec.b2
InternetShortRec.b2 = ShortRec.b1
LSet InternetShort = InternetShortRec
ShortToNetworkShort = InternetShort.i
End If
End Function

Public Function NetworkLongToLong(pLong As Long) As Long
On Error Resume Next
NetworkLongToLong = ntohl(pLong)
If Err.Number <> 0 Then
InternetLong.l = pLong
LSet InternetLongRec = InternetLong
LongRec.b4 = InternetLongRec.b1
LongRec.b3 = InternetLongRec.b2
LongRec.b2 = InternetLongRec.b3
LongRec.b1 = InternetLongRec.b4
LSet MyLong = LongRec
NetworkLongToLong = MyLong.l
End If
End Function

Public Function LongToNetworkLong(pLong As Long) As Long
On Error Resume Next
LongToNetworkLong = htonl(pLong)
If Err.Number <> 0 Then
MyLong.l = pLong
LSet LongRec = MyLong
InternetLongRec.b1 = LongRec.b4
InternetLongRec.b2 = LongRec.b3
InternetLongRec.b3 = LongRec.b2
InternetLongRec.b4 = LongRec.b1
LSet InternetLong = InternetLongRec
LongToNetworkLong = InternetLong.l
End If
End Function

Public Function PackedStringToDouble(pPackedString As String, pLength As
Long, pFraction As Long) As Double

'NOTELength is number of bytes packed, i.e., 2 per string character -
1
' pFraction is number of decimals

Dim tDouble As Double
Dim tDecimalStr As String
Dim tDecimalStrTest As String
Dim tLen As Long
Dim tChar As String
Dim tSignBit As Integer
Dim tDChar As String
Dim i As Long

tLen = Len(pPackedString)
tDecimalStr = ""
tSignBit = 1
For i = 1 To tLen
tChar = Mid(pPackedString, i, 1)
If i < tLen Then
tDChar = Hex(Asc(tChar))
If Len(tDChar) = 1 Then
tDChar = "0" & tDChar
End If
tDecimalStr = tDecimalStr & tDChar
Else
tDChar = Hex(Asc(tChar))
If Len(tDChar) = 1 Then
tDChar = "0" & tDChar
End If
tDecimalStr = tDecimalStr & Left(tDChar, 1)
If Right(tDChar, 1) <> "C" Then
tSignBit = -1
End If
End If
Next i

'#'*****************************
'#' Begin Block Out
'#'By: Larry Goldstein
'#'On: 09/29/01
'#'*****************************
'@ 'insert the decimal place
'@ If pLength Mod 2 = 0 Then
'@ 'if the len+frac is even, we need to account for the extra leading
0 Character added
'@ tDecimalStrTest = Left(tDecimalStr, pLength - pFraction + 1) & "."
& Right(tDecimalStr, pFraction)
'@ Else
'@ tDecimalStrTest = Left(tDecimalStr, pLength - pFraction) & "." &
Right(tDecimalStr, pFraction)
'@ End If
'#'*****************************
'#' End Block Out
'#'*****************************

If pFraction > 0 Then
tDecimalStr = Left(tDecimalStr, Len(tDecimalStr) - pFraction) & "."
& Right(tDecimalStr, pFraction)
End If

On Error Resume Next
tDouble = CDbl(tDecimalStr) * tSignBit

PackedStringToDouble = tDouble
End Function

Public Function DoubleToPackedString(pDouble As Double, pLength As Long,
pFraction As Long) As String

Dim tDouble As Double
Dim tDecimalStr As String

Dim tLen As Long
Dim tChar As String
Dim tHiBits As Byte
Dim tLoBits As Byte
Dim tPChar As String
Dim i As Long
Dim tPackStr As String
Dim tSignChar As Byte

Dim tFormatStr As String

tPackStr = ""

tFormatStr = String(pLength - pFraction, "0") & "." & String(pFraction,
"0")

'format it to the size desired
tDecimalStr = Format(pDouble, tFormatStr)

'if negative remove the leading sign
If pDouble < 0 Then
tDecimalStr = Mid(tDecimalStr, 2)
End If

'remove the decimal place
tDecimalStr = Left(tDecimalStr, InStr(tDecimalStr, ".") - 1) &
Mid(tDecimalStr, InStr(tDecimalStr, ".") + 1)

'if its an even length, we need to add a leading zero to even out
'the result when adding the sign character
If Len(tDecimalStr) Mod 2 = 0 Then
'add a leading 0
tDecimalStr = "0" & tDecimalStr
End If

tLen = Len(tDecimalStr)

For i = 1 To tLen - 1
tChar = Mid(tDecimalStr, i, 1)
'even number are the "LoBits", odd are the "HiBits"
If i Mod 2 <> 0 Then
'get the value and shift it 4 bits
tHiBits = Val(tChar) * 16
Else
'get the value
tLoBits = Val(tChar)

'add them together and get the resulting character
tPChar = Chr(tHiBits + tLoBits)
tPackStr = tPackStr & tPChar
tHiBits = 0
tLoBits = 0
End If
Next i

'add the sign character
tChar = Mid(tDecimalStr, i, 1)
'get the value of the last character and shift it 4 bits
tHiBits = Val(tChar) * 16

'add the sign character
If pDouble >= 0 Then
tLoBits = 12
Else
tLoBits = 13
End If

'add them together and get the resulting character
tPChar = Chr(tHiBits + tLoBits)
tPackStr = tPackStr & tPChar

DoubleToPackedString = tPackStr

End Function

Private Sub Class_Initialize()
'build the tables just one time
mvarEbcdic2Ascii = ASCII_To_EBCDIC_Table()
mvarAscii2Ebcdic = EBCDIC_To_ASCII_Table()
End Sub

Private Function Translate(ByVal InText As String, xlatTable As String) As
String
'
' Uses a translation table to map InText from one character set to another.
'
Dim Temp As String
Dim i As Long
Temp = Space$(Len(InText))
For i = 1 To Len(InText)
Mid$(Temp, i, 1) = Mid$(xlatTable, Asc(Mid$(InText, i, 1)) + 1, 1)
Next i
Translate = Temp
End Function

Private Function ASCII_To_EBCDIC_Table() As String
'
' Returns the following table as a string for use by the Translate
' function to translate an EBCDIC string to an ASCII-ISO/ANSI string.
'
' 00 01 02 03 37 2D 2E 2F 16 05 25 0B 0C 0D 0E 0F
' 10 11 12 13 3C 3D 32 26 18 19 3F 27 1C 1D 1E 1F
' 40 5A 7F 7B 5B 6C 50 7D 4D 5D 5C 4E 6B 60 4B 61
' F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 7A 5E 4C 7E 6E 6F
' 7C C1 C2 C3 C4 C5 C6 C7 C8 C9 D1 D2 D3 D4 D5 D6
' D7 D8 D9 E2 E3 E4 E5 E6 E7 E8 E9 AD E0 BD 5F 6D
' 79 81 82 83 84 85 86 87 88 89 91 92 93 94 95 96
' 97 98 99 A2 A3 A4 A5 A6 A7 A8 A9 C0 4F D0 A1 07
' 20 21 22 23 24 15 06 17 28 29 2A 2B 2C 09 0A 1B
' 30 31 1A 33 34 35 36 08 38 39 3A 3B 04 14 3E E1
' 41 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57
' 58 59 62 63 64 65 66 67 68 69 70 71 72 73 74 75
' 76 77 78 80 8A 8B 8C 8D 8E 8F 90 9A 9B 9C 9D 9E
' 9F A0 AA AB AC 4A AE AF B0 B1 B2 B3 B4 B5 B6 B7
' B8 B9 BA BB BC 6A BE BF CA CB CC CD CE CF DA dB
' DC DD DE DF EA EB EC ED EE EF FA FB FC FD FE FF
'
ASCII_To_EBCDIC_Table = _

HexToStr("00010203372D2E2F1605250B0C0D0E0F101112133C3D322618193F271C1D1E1F")
& _

HexToStr("405A7F7B5B6C507D4D5D5C4E6B604B61F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F")
& _

HexToStr("7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D")
& _

HexToStr("79818283848586878889919293949596979899A2A3A4A5A6A7A8A9C04FD0A107")
& _

HexToStr("202122232415061728292A2B2C090A1B30311A333435360838393A3B04143EE1")
& _

HexToStr("4142434445464748495152535455565758596263646566676869707172737475")
& _

HexToStr("767778808A8B8C8D8E8F909A9B9C9D9E9FA0AAABAC4AAEAFB0B1B2B3B4B5B6B7")
& _

HexToStr("B8B9BABBBC6ABEBFCACBCCCDCECFDADBDCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF")

End Function

Private Function EBCDIC_To_ASCII_Table() As String
'
' Returns the following table as a string for use by the Translate
' function to traslate an EBCDIC string to an ASCII-ISO/ANSI string.
'
' 00 01 02 03 9C 09 86 7F 97 8D 8E 0B 0C 0D 0E 0F ....o.?-�Z.....
' 10 11 12 13 9D 85 08 87 18 19 92 8F 1C 1D 1E 1F ....�..?..'�....
' 80 81 82 83 84 0A 17 1B 88 89 8A 8B 8C 05 06 07 ?�,f"...^?S<O...
' 90 91 16 93 94 95 96 04 98 99 9A 9B 14 15 9E 1A �'."".-.~Ts>..z.
' 20 A0 A1 A2 A3 A4 A5 A6 A7 A8 D5 2E 3C 28 2B 7C . ¡¢£¤¥¦§...<(+|
' 26 A9 AA AB AC AD AE AF B0 B1 21 24 2A 29 3B 5E &©ª«¬*®¯°±!$*);^
' 2D 2F B2 B3 B4 B5 B6 B7 B8 B9 E5 2C 25 5F 3E 3F -/²³´µ¶·¸¹.,%_>?
' BA BB BC BD BE BF C0 C1 C2 60 3A 23 40 27 3D 22 º»¼½¾¿...`:#@'="
' C3 61 62 63 64 65 66 67 68 69 C4 C5 C6 C7 C8 C9 .abcdefghi......
' CA 6A 6B 6C 6D 6E 6F 70 71 72 CB CC CD CE CF D0 .jklmnopqr......
' D1 7E 73 74 75 76 77 78 79 7A D2 D3 D4 5B D6 D7 .~stuvwxyz...[..
' D8 D9 DA DB DC DD DE DF E0 E1 E2 E3 E4 5D E6 E7 .............]..
' 7B 41 42 43 44 45 46 47 48 49 E8 E9 EA EB EC ED {ABCDEFGHI......
' 7D 4A 4B 4C 4D 4E 4F 50 51 52 EE EF F0 F1 F2 F3 }JKLMNOPQR......
' 5C 9F 53 54 55 56 57 58 59 5A F4 F5 F6 F7 F8 F9 \.STUVWXYZ......
' 30 31 32 33 34 35 36 37 38 39 FA FB FC FD FE FF 0123456789......
'
EBCDIC_To_ASCII_Table = _

HexToStr("000102039C09867F978D8E0B0C0D0E0F101112139D8508871819928F1C1D1E1F")
& _

HexToStr("80818283840A171B88898A8B8C050607909116939495960498999A9B14159E1A")
& _

HexToStr("20A0A1A2A3A4A5A6A7A8D52E3C282B7C26A9AAABACADAEAFB0B121242A293B5E")
& _

HexToStr("2D2FB2B3B4B5B6B7B8B9E52C255F3E3FBABBBCBDBEBFC0C1C2603A2340273D22")
& _

HexToStr("C3616263646566676869C4C5C6C7C8C9CA6A6B6C6D6E6F707172CBCCCDCECFD0")
& _

HexToStr("D17E737475767778797AD2D3D45BD6D7D8D9DADBDCDDDEDFE0E1E2E3E45DE6E7")
& _

HexToStr("7B414243444546474849E8E9EAEBECED7D4A4B4C4D4E4F505152EEEFF0F1F2F3")
& _

HexToStr("5C9F535455565758595AF4F5F6F7F8F930313233343536373839FAFBFCFDFEFF")
End Function

Private Function HexToStr(ByVal HexStr As String) As String
Dim Temp As String
Dim i As Long
Temp = Space$(Len(HexStr) \ 2)
For i = 1 To Len(HexStr) \ 2
Mid$(Temp, i, 1) = Chr$(Val("&H" & Mid$(HexStr, i * 2 - 1, 2)))
Next i
HexToStr = Temp
End Function









"Marcos" <newcastleluvr@yahoo.com> wrote in message
news:3c029081$1@147.208.176.211...
>
> Does anyone know of any dll's that will convert Packed Data- comp-3 and so
> forth into ascii so that it can be fed into SQL Server.
>
> The scene:
> We have some AS400 flatfiles that have data that is stored in packed
comp-3
> format. I need some help in converting these to readable format used by
SQL
> Server, VB, etc.
>
> Any help would be much appreciated.
>
> Thanks,
>
> Marcos
>

[Marcos]

Thanks so much. I'll try it out this afternoon and let you know how it turns
out. It looks good so far.

Marcos


"Larry Goldstein" <lgoldste@advanswers.com> wrote:
>Check the class module out below.
>
>The following sample code shows how you might use it. Here we are
>converting
>EBCIDIC to ASCII, then unpacking packed decimals to doubles using the
>supplied method from the class.
>
>If you need more information, send me an email. I tried to attach the .cls
>as a separate file, but the newsgroup appears to block attachments.
>
>Good luck!
>
>Larry Goldstein
>Advanswers
>lgoldste@advanswers.com
>
>Calling code...
>
>Private Sub cmdConvert_Click()
>
> Dim dVal As Double
> Dim lErr As Long
> Dim lFile As Long
> Dim lFile2 As Long
> Dim lRecord As Long
> Dim sPCString As String * 120
> Dim sMainFrameString As String * 120
> Dim sTemp As String
> Dim MyConversion As clsConversions
>
> Screen.MousePointer = vbHourglass
>
> Set MyConversion = New clsConversions
>
> sTemp = lblRecSize
> lFile = FreeFile
> Open m_sFile For Random As #lFile Len = m_lSize
>
> lFile2 = FreeFile
> Open "C:\temp\test.txt" For Output As #lFile2
>
> lstDisplay(0).Clear
> lstDisplay(1).Clear
>
> lRecord = 0
>
> Do
> lRecord = lRecord + 1
> If lRecord Mod 100 = 0 Then
> lblRecs = "Reading record: " & CStr(lRecord)
> DoEvents
> End If
>
> Get #lFile, lRecord, sMainFrameString
> lErr = Err
> If lErr = 0 Then
> 'convert from mainframe to pc
> sPCString = MyConversion.EBCDIC_To_ASCII(sMainFrameString)
> If sPCString <> sMainFrameString And Left(sPCString, 1) = "1"
>Then
> lstDisplay(0).AddItem sMainFrameString
> lstDisplay(0).ItemData(lstDisplay(0).NewIndex) = lRecord
> lstDisplay(1).AddItem sPCString
> lstDisplay(1).ItemData(lstDisplay(1).NewIndex) = lRecord
> DoEvents
> ElseIf sPCString = sMainFrameString Then
> Exit Do
> End If
> End If
>
> 'Test with NSI Total Activity Report
> If Left$(sPCString, 1) = "1" Then
> dVal = MyConversion.PackedStringToDouble(Mid$(sMainFrameString,
>73, 5), 10, 0)
> Print #lFile2, dVal, Left$(sPCString, 30)
> End If
> Loop Until lErr <> 0
>
> lblRecs = "# Records: " & CStr(lRecord - 1)
> Close #lFile
> Close #lFile2
> Set MyConversion = Nothing
>
> lblRecSize = sTemp
> Screen.MousePointer = vbDefault
> 'convert from pc to mainframe
> 'sMainFrameString = MyConversion.ASCII_To_EBCDIC(sPCString)
>
>End Sub
>
>
>Class code...
>
>Option Explicit
>
>'The Conversion Class code
>Private mvarEbcdic2Ascii As String
>Private mvarAscii2Ebcdic As String
>
>Private Declare Function ntohl Lib "ws2_32.dll" (ByVal l As Long) As Long
>Private Declare Function ntohs Lib "ws2_32.dll" (ByVal l As Integer) As
>Integer
>Private Declare Function htonl Lib "ws2_32.dll" (ByVal l As Long) As Long
>Private Declare Function htons Lib "ws2_32.dll" (ByVal l As Integer) As
>Integer
>
>'if the winsock DLL is not found the conversion functions will use these
>types
>Private Type LongIntegerType
> i1 As Integer
> i2 As Integer
>End Type
>Private LongIntegerRec As LongIntegerType
>
>Private Type LongByteType
> b1 As Byte
> b2 As Byte
> b3 As Byte
> b4 As Byte
>End Type
>
>Private Type LongType
> l As Long
>End Type
>Private LongRec As LongByteType
>
>Private InternetLongRec As LongByteType
>Private InternetLong As LongType
>Private MyLong As LongType
>
>Private Type ShortByteType
> b1 As Byte
> b2 As Byte
>End Type
>Private Type ShortType
> i As Integer
>End Type
>Private ShortRec As ShortByteType
>Private InternetShortRec As ShortByteType
>Private InternetShort As ShortType
>Private MyShort As ShortType
>
>'Special Overlay data type records
>Private Type DoubleLongByteType
> b1 As Byte
> b2 As Byte
> b3 As Byte
> b4 As Byte
> b5 As Byte
> b6 As Byte
> b7 As Byte
> b8 As Byte
>End Type
>Private Type DateTimeType
> d As Date
>End Type
>Private Type DoubleType
> d As Double
>End Type
>Private DoubleLongRec As DoubleLongByteType
>
>Public Function DecLenFromParType(pLong As Long) As Integer
> MyLong.l = pLong
> LSet LongIntegerRec = MyLong
> DecLenFromParType = LongIntegerRec.i2
>End Function
>
>Public Function DecFracFromParType(pLong As Long) As Integer
> MyLong.l = pLong
> LSet LongIntegerRec = MyLong
> DecFracFromParType = LongIntegerRec.i1
>End Function
>
>Public Function ShortToByteArray(pShort As Integer) As Variant
> Dim tArray(0 To 1) As Byte
>
> MyShort.i = pShort
>
> LSet ShortRec = MyShort
>
> tArray(0) = ShortRec.b1
> tArray(1) = ShortRec.b2
>
> ShortToByteArray = tArray
>End Function
>
>Public Function LongToByteArray(pLong As Long) As Variant
> Dim tArray(0 To 3) As Byte
>
> MyLong.l = pLong
>
> LSet LongRec = MyLong
>
> tArray(0) = LongRec.b1
> tArray(1) = LongRec.b2
> tArray(2) = LongRec.b3
> tArray(3) = LongRec.b4
>
> LongToByteArray = tArray
>End Function
>
>Public Function DateTimeToByteArray(pDateTime As Date) As Variant
> Dim tArray(0 To 7) As Byte
> Dim tDateTimeRec As DateTimeType
>
> tDateTimeRec.d = pDateTime
>
> LSet DoubleLongRec = tDateTimeRec
>
> tArray(0) = DoubleLongRec.b1
> tArray(1) = DoubleLongRec.b2
> tArray(2) = DoubleLongRec.b3
> tArray(3) = DoubleLongRec.b4
> tArray(4) = DoubleLongRec.b5
> tArray(5) = DoubleLongRec.b6
> tArray(6) = DoubleLongRec.b7
> tArray(7) = DoubleLongRec.b8
>
> DateTimeToByteArray = tArray
>End Function
>
>Public Function ByteArrayToDateTime(pData As Variant) As Date
> Dim tDateTimeRec As DateTimeType
>
> DoubleLongRec.b1 = pData(0)
> DoubleLongRec.b2 = pData(1)
> DoubleLongRec.b3 = pData(2)
> DoubleLongRec.b4 = pData(3)
> DoubleLongRec.b5 = pData(4)
> DoubleLongRec.b6 = pData(5)
> DoubleLongRec.b7 = pData(6)
> DoubleLongRec.b8 = pData(7)
>
> LSet tDateTimeRec = DoubleLongRec
>
> ByteArrayToDateTime = tDateTimeRec.d
>End Function
>
>Public Function DoubleToByteArray(pDouble As Double) As Variant
> Dim tArray(0 To 7) As Byte
> Dim tDoubelRec As DoubleType
>
> tDoubelRec.d = pDouble
>
> LSet DoubleLongRec = tDoubelRec
>
> tArray(0) = DoubleLongRec.b1
> tArray(1) = DoubleLongRec.b2
> tArray(2) = DoubleLongRec.b3
> tArray(3) = DoubleLongRec.b4
> tArray(4) = DoubleLongRec.b5
> tArray(5) = DoubleLongRec.b6
> tArray(6) = DoubleLongRec.b7
> tArray(7) = DoubleLongRec.b8
>
> DoubleToByteArray = tArray
>End Function
>
>Public Function ByteArrayToDouble(pData As Variant) As Double
> Dim tDoubleRec As DoubleType
>
> DoubleLongRec.b1 = pData(0)
> DoubleLongRec.b2 = pData(1)
> DoubleLongRec.b3 = pData(2)
> DoubleLongRec.b4 = pData(3)
> DoubleLongRec.b5 = pData(4)
> DoubleLongRec.b6 = pData(5)
> DoubleLongRec.b7 = pData(6)
> DoubleLongRec.b8 = pData(7)
>
> LSet tDoubleRec = DoubleLongRec
>
> ByteArrayToDouble = tDoubleRec.d
>End Function
>
>Public Function TimeStringToTime(pTimeString As String) As Date
> If IsDate(pTimeString) Then
> TimeStringToTime = pTimeString
> End If
>End Function
>
>Public Function TimeToTimeString(pTime As Date) As String
> TimeToTimeString = Format(pTime, "hh:nn:ss")
>End Function
>
>Public Function DateStringToDate(pDateString As String) As Date
> If IsDate(pDateString) Then
> DateStringToDate = pDateString
> End If
>End Function
>
>Public Function DateToDateString(pDate As Date) As String
> DateToDateString = Format(pDate, "YYYY-MM-DD")
>End Function
>
>Public Function EBCDIC_To_ASCII(pEbcdicString As String) As String
> EBCDIC_To_ASCII = Translate(pEbcdicString, mvarAscii2Ebcdic)
>End Function
>
>Public Function ASCII_To_EBCDIC(pAsciiString As String) As String
> ASCII_To_EBCDIC = Translate(pAsciiString, mvarEbcdic2Ascii)
>End Function
>
>Public Function NetworkShortToShort(pShort As Integer) As Integer
> On Error Resume Next
> NetworkShortToShort = ntohs(pShort)
> If Err.Number <> 0 Then
> InternetShort.i = pShort
> LSet InternetShortRec = InternetShort
> ShortRec.b2 = InternetShortRec.b1
> ShortRec.b1 = InternetShortRec.b2
> LSet MyShort = ShortRec
> NetworkShortToShort = MyShort.i
> End If
>End Function
>
>Public Function ShortToNetworkShort(pShort As Integer) As Integer
> On Error Resume Next
> ShortToNetworkShort = htons(pShort)
> If Err.Number <> 0 Then
> MyShort.i = pShort
> LSet ShortRec = MyShort
> InternetShortRec.b1 = ShortRec.b2
> InternetShortRec.b2 = ShortRec.b1
> LSet InternetShort = InternetShortRec
> ShortToNetworkShort = InternetShort.i
> End If
>End Function
>
>Public Function NetworkLongToLong(pLong As Long) As Long
> On Error Resume Next
> NetworkLongToLong = ntohl(pLong)
> If Err.Number <> 0 Then
> InternetLong.l = pLong
> LSet InternetLongRec = InternetLong
> LongRec.b4 = InternetLongRec.b1
> LongRec.b3 = InternetLongRec.b2
> LongRec.b2 = InternetLongRec.b3
> LongRec.b1 = InternetLongRec.b4
> LSet MyLong = LongRec
> NetworkLongToLong = MyLong.l
> End If
>End Function
>
>Public Function LongToNetworkLong(pLong As Long) As Long
> On Error Resume Next
> LongToNetworkLong = htonl(pLong)
> If Err.Number <> 0 Then
> MyLong.l = pLong
> LSet LongRec = MyLong
> InternetLongRec.b1 = LongRec.b4
> InternetLongRec.b2 = LongRec.b3
> InternetLongRec.b3 = LongRec.b2
> InternetLongRec.b4 = LongRec.b1
> LSet InternetLong = InternetLongRec
> LongToNetworkLong = InternetLong.l
> End If
>End Function
>
>Public Function PackedStringToDouble(pPackedString As String, pLength As
>Long, pFraction As Long) As Double
>
> 'NOTELength is number of bytes packed, i.e., 2 per string character
-
>1
> ' pFraction is number of decimals
>
> Dim tDouble As Double
> Dim tDecimalStr As String
> Dim tDecimalStrTest As String
> Dim tLen As Long
> Dim tChar As String
> Dim tSignBit As Integer
> Dim tDChar As String
> Dim i As Long
>
> tLen = Len(pPackedString)
> tDecimalStr = ""
> tSignBit = 1
> For i = 1 To tLen
> tChar = Mid(pPackedString, i, 1)
> If i < tLen Then
> tDChar = Hex(Asc(tChar))
> If Len(tDChar) = 1 Then
> tDChar = "0" & tDChar
> End If
> tDecimalStr = tDecimalStr & tDChar
> Else
> tDChar = Hex(Asc(tChar))
> If Len(tDChar) = 1 Then
> tDChar = "0" & tDChar
> End If
> tDecimalStr = tDecimalStr & Left(tDChar, 1)
> If Right(tDChar, 1) <> "C" Then
> tSignBit = -1
> End If
> End If
> Next i
>
>'#'*****************************
>'#' Begin Block Out
>'#'By: Larry Goldstein
>'#'On: 09/29/01
>'#'*****************************
>'@ 'insert the decimal place
>'@ If pLength Mod 2 = 0 Then
>'@ 'if the len+frac is even, we need to account for the extra leading
>0 Character added
>'@ tDecimalStrTest = Left(tDecimalStr, pLength - pFraction + 1) &
"."
>& Right(tDecimalStr, pFraction)
>'@ Else
>'@ tDecimalStrTest = Left(tDecimalStr, pLength - pFraction) & "."
&
>Right(tDecimalStr, pFraction)
>'@ End If
>'#'*****************************
>'#' End Block Out
>'#'*****************************
>
> If pFraction > 0 Then
> tDecimalStr = Left(tDecimalStr, Len(tDecimalStr) - pFraction) &
"."
>& Right(tDecimalStr, pFraction)
> End If
>
> On Error Resume Next
> tDouble = CDbl(tDecimalStr) * tSignBit
>
> PackedStringToDouble = tDouble
>End Function
>
>Public Function DoubleToPackedString(pDouble As Double, pLength As Long,
>pFraction As Long) As String
>
> Dim tDouble As Double
> Dim tDecimalStr As String
>
> Dim tLen As Long
> Dim tChar As String
> Dim tHiBits As Byte
> Dim tLoBits As Byte
> Dim tPChar As String
> Dim i As Long
> Dim tPackStr As String
> Dim tSignChar As Byte
>
> Dim tFormatStr As String
>
> tPackStr = ""
>
> tFormatStr = String(pLength - pFraction, "0") & "." & String(pFraction,
>"0")
>
> 'format it to the size desired
> tDecimalStr = Format(pDouble, tFormatStr)
>
> 'if negative remove the leading sign
> If pDouble < 0 Then
> tDecimalStr = Mid(tDecimalStr, 2)
> End If
>
> 'remove the decimal place
> tDecimalStr = Left(tDecimalStr, InStr(tDecimalStr, ".") - 1) &
>Mid(tDecimalStr, InStr(tDecimalStr, ".") + 1)
>
> 'if its an even length, we need to add a leading zero to even out
> 'the result when adding the sign character
> If Len(tDecimalStr) Mod 2 = 0 Then
> 'add a leading 0
> tDecimalStr = "0" & tDecimalStr
> End If
>
> tLen = Len(tDecimalStr)
>
> For i = 1 To tLen - 1
> tChar = Mid(tDecimalStr, i, 1)
> 'even number are the "LoBits", odd are the "HiBits"
> If i Mod 2 <> 0 Then
> 'get the value and shift it 4 bits
> tHiBits = Val(tChar) * 16
> Else
> 'get the value
> tLoBits = Val(tChar)
>
> 'add them together and get the resulting character
> tPChar = Chr(tHiBits + tLoBits)
> tPackStr = tPackStr & tPChar
> tHiBits = 0
> tLoBits = 0
> End If
> Next i
>
> 'add the sign character
> tChar = Mid(tDecimalStr, i, 1)
> 'get the value of the last character and shift it 4 bits
> tHiBits = Val(tChar) * 16
>
> 'add the sign character
> If pDouble >= 0 Then
> tLoBits = 12
> Else
> tLoBits = 13
> End If
>
> 'add them together and get the resulting character
> tPChar = Chr(tHiBits + tLoBits)
> tPackStr = tPackStr & tPChar
>
> DoubleToPackedString = tPackStr
>
>End Function
>
>Private Sub Class_Initialize()
> 'build the tables just one time
> mvarEbcdic2Ascii = ASCII_To_EBCDIC_Table()
> mvarAscii2Ebcdic = EBCDIC_To_ASCII_Table()
>End Sub
>
>Private Function Translate(ByVal InText As String, xlatTable As String)
As
>String
>'
>' Uses a translation table to map InText from one character set to another.
>'
> Dim Temp As String
> Dim i As Long
> Temp = Space$(Len(InText))
> For i = 1 To Len(InText)
> Mid$(Temp, i, 1) = Mid$(xlatTable, Asc(Mid$(InText, i, 1)) + 1,
1)
> Next i
> Translate = Temp
>End Function
>
>Private Function ASCII_To_EBCDIC_Table() As String
>'
>' Returns the following table as a string for use by the Translate
>' function to translate an EBCDIC string to an ASCII-ISO/ANSI string.
>'
>' 00 01 02 03 37 2D 2E 2F 16 05 25 0B 0C 0D 0E 0F
>' 10 11 12 13 3C 3D 32 26 18 19 3F 27 1C 1D 1E 1F
>' 40 5A 7F 7B 5B 6C 50 7D 4D 5D 5C 4E 6B 60 4B 61
>' F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 7A 5E 4C 7E 6E 6F
>' 7C C1 C2 C3 C4 C5 C6 C7 C8 C9 D1 D2 D3 D4 D5 D6
>' D7 D8 D9 E2 E3 E4 E5 E6 E7 E8 E9 AD E0 BD 5F 6D
>' 79 81 82 83 84 85 86 87 88 89 91 92 93 94 95 96
>' 97 98 99 A2 A3 A4 A5 A6 A7 A8 A9 C0 4F D0 A1 07
>' 20 21 22 23 24 15 06 17 28 29 2A 2B 2C 09 0A 1B
>' 30 31 1A 33 34 35 36 08 38 39 3A 3B 04 14 3E E1
>' 41 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57
>' 58 59 62 63 64 65 66 67 68 69 70 71 72 73 74 75
>' 76 77 78 80 8A 8B 8C 8D 8E 8F 90 9A 9B 9C 9D 9E
>' 9F A0 AA AB AC 4A AE AF B0 B1 B2 B3 B4 B5 B6 B7
>' B8 B9 BA BB BC 6A BE BF CA CB CC CD CE CF DA dB
>' DC DD DE DF EA EB EC ED EE EF FA FB FC FD FE FF
>'
> ASCII_To_EBCDIC_Table = _
>
>HexToStr("00010203372D2E2F1605250B0C0D0E0F101112133C3D322618193F271C1D1E1F")
>& _
>
>HexToStr("405A7F7B5B6C507D4D5D5C4E6B604B61F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F")
>& _
>
>HexToStr("7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D")
>& _
>
>HexToStr("79818283848586878889919293949596979899A2A3A4A5A6A7A8A9C04FD0A107")
>& _
>
>HexToStr("202122232415061728292A2B2C090A1B30311A333435360838393A3B04143EE1")
>& _
>
>HexToStr("4142434445464748495152535455565758596263646566676869707172737475")
>& _
>
>HexToStr("767778808A8B8C8D8E8F909A9B9C9D9E9FA0AAABAC4AAEAFB0B1B2B3B4B5B6B7")
>& _
>
>HexToStr("B8B9BABBBC6ABEBFCACBCCCDCECFDADBDCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF")
>
>End Function
>
>Private Function EBCDIC_To_ASCII_Table() As String
>'
>' Returns the following table as a string for use by the Translate
>' function to traslate an EBCDIC string to an ASCII-ISO/ANSI string.
>'
>' 00 01 02 03 9C 09 86 7F 97 8D 8E 0B 0C 0D 0E 0F ....o.?-�Z.....
>' 10 11 12 13 9D 85 08 87 18 19 92 8F 1C 1D 1E 1F ....�..?..'�....
>' 80 81 82 83 84 0A 17 1B 88 89 8A 8B 8C 05 06 07 ?�,f"...^?S<O...
>' 90 91 16 93 94 95 96 04 98 99 9A 9B 14 15 9E 1A �'."".-.~Ts>..z.
>' 20 A0 A1 A2 A3 A4 A5 A6 A7 A8 D5 2E 3C 28 2B 7C . ¡¢£¤¥¦§...<(+|
>' 26 A9 AA AB AC AD AE AF B0 B1 21 24 2A 29 3B 5E &©ª«¬*®¯°±!$*);^
>' 2D 2F B2 B3 B4 B5 B6 B7 B8 B9 E5 2C 25 5F 3E 3F -/²³´µ¶·¸¹.,%_>?
>' BA BB BC BD BE BF C0 C1 C2 60 3A 23 40 27 3D 22 º»¼½¾¿...`:#@'="
>' C3 61 62 63 64 65 66 67 68 69 C4 C5 C6 C7 C8 C9 .abcdefghi......
>' CA 6A 6B 6C 6D 6E 6F 70 71 72 CB CC CD CE CF D0 .jklmnopqr......
>' D1 7E 73 74 75 76 77 78 79 7A D2 D3 D4 5B D6 D7 .~stuvwxyz...[..
>' D8 D9 DA DB DC DD DE DF E0 E1 E2 E3 E4 5D E6 E7 .............]..
>' 7B 41 42 43 44 45 46 47 48 49 E8 E9 EA EB EC ED {ABCDEFGHI......
>' 7D 4A 4B 4C 4D 4E 4F 50 51 52 EE EF F0 F1 F2 F3 }JKLMNOPQR......
>' 5C 9F 53 54 55 56 57 58 59 5A F4 F5 F6 F7 F8 F9 \.STUVWXYZ......
>' 30 31 32 33 34 35 36 37 38 39 FA FB FC FD FE FF 0123456789......
>'
> EBCDIC_To_ASCII_Table = _
>
>HexToStr("000102039C09867F978D8E0B0C0D0E0F101112139D8508871819928F1C1D1E1F")
>& _
>
>HexToStr("80818283840A171B88898A8B8C050607909116939495960498999A9B14159E1A")
>& _
>
>HexToStr("20A0A1A2A3A4A5A6A7A8D52E3C282B7C26A9AAABACADAEAFB0B121242A293B5E")
>& _
>
>HexToStr("2D2FB2B3B4B5B6B7B8B9E52C255F3E3FBABBBCBDBEBFC0C1C2603A2340273D22")
>& _
>
>HexToStr("C3616263646566676869C4C5C6C7C8C9CA6A6B6C6D6E6F707172CBCCCDCECFD0")
>& _
>
>HexToStr("D17E737475767778797AD2D3D45BD6D7D8D9DADBDCDDDEDFE0E1E2E3E45DE6E7")
>& _
>
>HexToStr("7B414243444546474849E8E9EAEBECED7D4A4B4C4D4E4F505152EEEFF0F1F2F3")
>& _
>
>HexToStr("5C9F535455565758595AF4F5F6F7F8F930313233343536373839FAFBFCFDFEFF")
>End Function
>
>Private Function HexToStr(ByVal HexStr As String) As String
> Dim Temp As String
> Dim i As Long
> Temp = Space$(Len(HexStr) \ 2)
> For i = 1 To Len(HexStr) \ 2
> Mid$(Temp, i, 1) = Chr$(Val("&H" & Mid$(HexStr, i * 2 - 1, 2)))
> Next i
> HexToStr = Temp
>End Function
>
>
>
>
>
>
>
>
>
>"Marcos" <newcastleluvr@yahoo.com> wrote in message
>news:3c029081$1@147.208.176.211...
>>
>> Does anyone know of any dll's that will convert Packed Data- comp-3 and
so
>> forth into ascii so that it can be fed into SQL Server.
>>
>> The scene:
>> We have some AS400 flatfiles that have data that is stored in packed
>comp-3
>> format. I need some help in converting these to readable format used by
>SQL
>> Server, VB, etc.
>>
>> Any help would be much appreciated.
>>
>> Thanks,
>>
>> Marcos
>>
>
>
>
>
>
>

[APanda]

Looking for sample code in VB which will convert (HH:MM:SS) and (DDD/MM/YY) to packed PIC S9(07) comp-3 format, as i need to post
this converted value from Visual Basic to a VSAM file

Any help would be much appreciated.

Thanks,
AP