Converting Packed Decimal to Character

[Phatbeach]

I'm trying to convert a field in a text file from Packed Decimal (COMP-3 COBOL) to Character in VB 6.

I pull a file (via ftp) from an IBM mainframe that has one field in Packed Decimal, with the other fields being Character.

Right now, I read in a line from the file as a Variant data type and write it directly to another text file, but the formatting of the new file is off. I need to read in the file, convert the one field to Character, then write to another file.

Does anyone know how this can be done? Your help would be greatly appreciated!!!

 

[CubeE101]

Are you asking how to open 2 files...
How to convert...
Or both?

to open 2 files do this

Open "TheFileToRead.txt" for Input As #1
Open "TheFileToWrite.txt" for Output As #2
Do Until EOF(1) 'Read to the end of file #1
  Line Input #1, myString 'read a line from the original file

  'do your convertions here

  Print #2, myNewString 'write the new line to the destination file
Loop
Close 'Closes ALL Files

As for the convertion I have no idea...
You might want to go a little more in detail or even paste an example. Sometimes... the BASIC things in life are the best...

or at least the most fun ;-)
-Josh Stribling

 

[JohnYingling]

You must FTP the file in Binary, no translation. If you translate then the packed data gets translated from its original form.
You also must read the file in binary, byte by byte translating the character data yourself from IBM to ASCII.

For Packed data, you must convert each "nibble" (4-bit).
Private Sub Command1_Click()
Dim byt() As Byte
ReDim byt(100) ' Byte array containing input
byt(10) = &H12 ' Set X'12345D' -12345
byt(11) = &H34
byt(12) = &H5D
Dim I As Long ' Current byte
Dim lngBin As Long ' Converted Packed
I = 10
lngBin = PKToBin(byt(), I, 3)
End Sub
Function PKToBin(byt() As Byte, ByVal lngStart As Long, ByVal lngLength As Long) As Long
Dim lngPacked As Long
Dim I As Long
Dim J As Long
I = lngStart
J = I + lngLength - 1 ' Last byte
lngPacked = 0
For I = I To J
lngPacked = 10 * lngPacked + (byt(I) And &HF0) \ 16
If I = J Then
Select Case byt(I) Mod 16
Case 11, 13 ' B, D are - (E?)
lngPacked = -lngPacked
End Select
Else
lngPacked = 10 * lngPacked + (byt(I) Mod 16)
End If
Next
PKToBin = lngPacked
End Function

http://www.VBResizer.com

Forms/Controls Resizing/Tabbing Control

http://www.VBCompare.com

Compare Code (Text)

http://www.VBSortGen.com

Generate Sort Class in VB or VBScript

 

[JohnYingling]

Forgot to convert to character. Use the Format function to deal with converting to character and dealing with where the sign goes.

http://www.VBResizer.com

Forms/Controls Resizing/Tabbing Control

http://www.VBCompare.com

Compare Code (Text)

http://www.VBSortGen.com

Generate Sort Class in VB or VBScript

 

[Phatbeach]

John,

Your advice really helps, but I'm a 2-week (in)experienced VB programmer and I'd appreciate it if you'd help me out a little bit more!

The text file I'm reading that has the Packed Decimal data also contains Character data in the same row(yes, this makes things much more exciting). I tried using what you sent me, but I must be doing something wrong.

Also, in your reply, why do you set byt(10) - byt(12) equal to the hex values? Does that handle the sign byte?

The code that I have in combination with yours is as follows. What am I doing wrong?

Open "c:\output.txt" For Output As #2

Dim I As Long       ' Current byte
Dim lngBin As Long  ' Converted Packed
Dim byt() As Byte

' The record length of the file is 300 characters,
' which must be retained in the new file
ReDim byt(300)
byt(10) = &H12    ' Set X'12345D' -12345
byt(11) = &H34
byt(12) = &H5D
    
Input #1, byt()
    Do While Not EOF(1)
        I = 10
        lngBin = PKToBin(byt(), I, 3)


' The output becomes -12345 for all rows.
' If I use bin() I get an overflow error here.
        Print #2, lngBin
        Input #1, lngBin
    Loop

Close #1
Close #2
    

Unload Form1
End Sub


Function PKToBin(byt() As Byte, ByVal lngStart As Long, ByVal lngLength As Long) As Long
    Dim lngPacked As Long
    Dim I As Long
    Dim J As Long
    I = lngStart
    J = I + lngLength - 1 ' Last byte
    lngPacked = 0
    For I = I To J
        lngPacked = 10 * lngPacked + (byt(I) And &HF0) \ 16
        If I = J Then
            Select Case byt(I) Mod 16
            Case 11, 13    ' B, D are - (E?)
                lngPacked = -lngPacked
            End Select
        Else
            lngPacked = 10 * lngPacked + (byt(I) Mod 16)
        End If
    Next
    PKToBin = lngPacked
End Function

 

[Phatbeach]

For some reason I left off the top of the code! It should be as follows:

Private Sub Form_Load()

Open "c:\input.txt" For Input As #1

 

[JohnYingling]

The Code that I gave you in Command1_Click was merely a "testbed" for a test of PKToBin. For your input file, how is the end of a record determined, by length? It can't be CrLF because a packed number like x'10130C' would cause a premature "end of record". You are going to have to use a BINARY OPEN and use the Get statement to read the UNTRANSALATED binary data from the file, downloaded from the mainframe. Define fixed length arrays "as Byte" for every field that you will read. You will need to use LOF(intFileNo) to know the length of the file.

Sample Open
intFileNo = FreeFile
Open wTempFile For Binary Access Read As #intFileNo


Sample byte arrays for fields.
Dim bytPriority(0) As Byte ' SDR-PRIORITY PIC 9(01).
Dim bytUsage(3) As Byte ' SDR-USAGE PIC 9(08) COMP.
Dim bytAcctStatus(0) As Byte ' SDR-ACCT-STATUS PIC X(01).
Dim bytLastModDate(3) As Byte ' SDR-LAST-MOD-DATE PIC S9(07) COMP-3.
Dim bytLastModTime(3) As Byte ' SDR-LAST-MOD-TIME PIC S9(07) COMP-3.
Dim bytLastModOper(7) As Byte ' SDR-LAST-MOD-OPER PIC X(08).
Dim bytExpirationDate(3) As Byte ' SDR-EXPIRATION-DATE PIC S9(07) COMP-3.
Dim bytNumberMessages(1) As Byte ' SDR-NUMBER-MESSAGES PIC S9(04) COMP.
Dim bytCustomerName(24) As Byte ' SDR-CUSTOMER-NAME PIC X(25).
Dim bytLengthOfSignature(1) As Byte ' SDR-LENGTH-OF-SIGNATURE PIC S9(04) COMP.


You will need to read each field individually.
Smple GETS for each field.
Get #intFileNo, , bytAcctStatus
Get #intFileNo, , bytLastModDate
Get #intFileNo, , bytAHRLocator
Get #intFileNo, , bytAHROfficer
Get #intFileNo, , bytAHRNumberSignature
Get #intFileNo, , bytAHRNextSignature
Get #intFileNo, , bytNumberMessages
wAHR.AHRBank = PDToLng(bytBank)
wAHR.AHRAppl = PDToLng(bytAppl)
wAHR.AHRAcct = PDToStr(bytAcct)
wAHR.AHRNumber = BytToLng(bytNumber)
wAHR.AHRPriority = BytEBCDICToAscii(bytPriority)
wAHR.AHRAcctStatus = BytEBCDICToAscii(bytAcctStatus)

wAHR.AHRLastModOper = BytEBCDICToAscii(bytLastModOper)
wAHR.AHROfficer = BytEBCDICToAscii(bytAHROfficer)
wAHR.AHRLocator = BytEBCDICToAscii(bytAHRLocator)
wAHR.AHRNumberMessages = BytToLng(bytNumberMessages)
wAHR.AHRMessages = ""
For I = 0 To wAHR.AHRNumberMessages - 1
Get #intFileNo, , bytMessage
wAHR.AHRMessages = wAHR.AHRMessages & _
BytEBCDICToAscii(bytMessage)
Next


Function PDToLng(pByt() As Byte) As Long

Dim I As Integer, L As Integer, lngR As Long, lngW As Long
L = UBound(pByt)

For I = 0 To L - 1
lngR = lngR * 100 + (pByt(I) \ 16) * 10 + (pByt(I) And &HF)
Next
lngR = lngR * 10 + (pByt(I) \ 16)
lngW = pByt(I) And &HF
If lngW = 11 Or lngW = 13 Or lngW = 14 Then
lngR = -lngR
End If
PDToLng = lngR
End Function


Function BytToLng(pByt() As Byte) As Long
Dim L As Integer, lngR As Long
L = UBound(pByt)
lngR = pByt(0) * 256 + pByt(1)
If L > 1 Then
lngR = lngR * 65536 + pByt(2) * 256 + pByt(3)
End If
BytToLng = lngR
End Function

Function PDToStr(pByt() As Byte) As String
Dim L As Integer, I As Integer, J As Integer

J = UBound(pByt)
L = (UBound(pByt) + 1) * 2 - 1
PDToStr = Space$(L)
For I = 0 To J
Mid$(PDToStr, 2 * I + 1, 1) = ChrW(pByt(I) \ 16 + 48)
Next
For I = 0 To J - 1
Mid$(PDToStr, 2 * I + 2, 1) = ChrW((pByt(I) And &HF) + 48)
Next

End Function

Function BytEBCDICToAscii(pByt() As Byte) As String
Static bytASCII(255) As Byte
Dim intEB As Integer, intAscii As Integer
' Check last byte for 0; allows for re-entrancy
If bytASCII(&HFF) = 0 Then
bytASCII(&H40) = 32
bytASCII(&H5A) = 33 ' !
bytASCII(&H7F) = 34 ' "
bytASCII(&H7B) = 35 ' #
bytASCII(&H5B) = 36 ' $
bytASCII(&H6C) = 37 ' %
bytASCII(&H50) = 38 ' &
bytASCII(&H7D) = 39 ' '
bytASCII(&H4D) = 40 ' (
bytASCII(&H5D) = 41 ' )
bytASCII(&H5C) = 42 ' *
bytASCII(&H4E) = 43 ' +
bytASCII(&H6B) = 44 ' ,
bytASCII(&H60) = 45 ' -
bytASCII(&H4B) = 46 ' .
bytASCII(&H61) = 47 ' /
intAscii = 48
For intEB = &HF0 To &HF9
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
bytASCII(&H7A) = 58 ' :
bytASCII(&H5E) = 59 ' ;
bytASCII(&H4C) = 60 ' <
bytASCII(&H7E) = 61 ' =
bytASCII(&H6E) = 62 ' >
bytASCII(&H6F) = 63 ' ?
bytASCII(&H7C) = 64 ' @
intAscii = 65
For intEB = &HC1 To &HC9
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
For intEB = &HD1 To &HD9
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
For intEB = &HE2 To &HE9
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
bytASCII(&HAD) = 91 ' [
bytASCII(&HE0) = 92 ' bytASCII(&HBD) = 93 ' ]
' bytASCII(&Hxx) = 94 ' ^
bytASCII(&H6D) = 95 ' _'
bytASCII(&H79) = 96 ' `
intAscii = 97
For intEB = &H81 To &H89
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
For intEB = &H91 To &H99
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
For intEB = &HA2 To &HA9
bytASCII(intEB) = intAscii
intAscii = intAscii + 1
Next
bytASCII(&HC0) = 123 ' {
bytASCII(&H4F) = 124 ' `|
bytASCII(&HD0) = 125 ' }
bytASCII(&HA1) = 126 ' ~
bytASCII(&HFF) = 255
End If
Dim I As Integer, J As Integer, K As Integer
J = UBound(pByt)
BytEBCDICToAscii = Space$(J + 1)
For I = 0 To J
K = I + 1
Mid$(BytEBCDICToAscii, K, 1) = ChrW(bytASCII(pByt(I)))
Next
End Function

http://www.VBResizer.com

Forms/Controls Resizing/Tabbing Control

http://www.VBCompare.com

Compare Code (Text)

http://www.VBSortGen.com

Generate Sort Class in VB or VBScript

 

[Phatbeach]

Thanks for you're help, John, I'll keep on tweaking it to see if I can get it to work. By the way, tell your employer that you deserve a raise!!!