Embedded Files
Posted on 22 March 2011 at 06.17 PM, Kuala Lumpur, Malaysia
Sometimes, in the real world we have a situation where we need to create an XML file manually to be fed into PI interface. One instance would be when the partner system is NOT able to generate a return XML file due to system limitation. The exception is reported back through phone call or email.
Obviously, it may be a breeze for the developer to use XML editor or any other programming tool to create the XML, but may NOT be the case for the user. In this case, Excel Macro VBA comes in handy for the user.
Obviously the magic is done through VBA macro which is triggered when the user click on the button. Following is the sample VBA macro to generate a pain002 XML required to update SAP bank status monitor:
Rem Attribute VB_Name = "XL_to_XML"
Sub Button1_Click()
' create an XML file from an Excel table
Dim MyRow As Integer, MyCol As Integer, Temp As String, YesNo As Variant, DefFolder As String
Dim XMLFileName As String, XMLRecSetName As String, MyLF As String, RTC1 As Integer
Dim Datum As String, Time As String, DateTime As String
Dim RangeOne As String, RangeTwo As String, Tt As String, FldName(99) As String
Dim Status As String
Datum = Format(Now, "YYYY-MM-DD")
Time = Format(Now, "HH:MM:SS")
DateTime = Datum & "T" & Time
MyLF = Chr(10) & Chr(13) ' a line feed command
DefFolder = "C:\Documents and Settings\rchang\Desktop\Pain002\XML\" 'change this to the location of saved XML files
XMLFileName = Range("B1").Value
If Right(XMLFileName, 4) <> ".xml" Then
XMLFileName = "pain002_" & XMLFileName & ".xml"
End If
XMLRecSetName = "PaymentOrderNotification"
RangeOne = "A2:B2"
MyRow = MyRng(RangeOne, 1)
For MyCol = MyRng(RangeOne, 3) To MyRng(RangeOne, 4)
If Len(Cells(MyRow, MyCol).Value) = 0 Then
MsgBox "Error: names range contains blank cell" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "XML Pain002"
Exit Sub
End If
FldName(MyCol - MyRng(RangeOne, 3)) = FillSpaces(Cells(MyRow, MyCol).Value)
Next MyCol
RangeTwo = InputBox("Enter the range of cells containing the data table:", "XML Pain002", "A3:B4")
Select Case True
Case StrPtr(RangeTwo) = 0
Exit Sub
End Select
If MyRng(RangeOne, 4) - MyRng(RangeOne, 3) <> MyRng(RangeTwo, 4) - MyRng(RangeTwo, 3) Then
MsgBox "Error: number of field names <> data columns" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "XML Pain002"
Exit Sub
End If
RTC1 = MyRng(RangeTwo, 3)
If InStr(1, XMLFileName, ":\") = 0 Then
XMLFileName = DefFolder & XMLFileName
End If
Open XMLFileName For Output As #1
Rem Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<ns1:CollectivePaymentOrderNotification_async xmlns:ns1=""http://sap.com/xi/SAPGlobal20/Global"">"
Print #1, "<MessageHeader>"
Print #1, "<ID>CITIBANK/20120219-PSR/170</ID>"
Print #1, "<CreationDateTime>" & DateTime & "</CreationDateTime>"
Print #1, "</MessageHeader>"
Print #1, "<CollectivePaymentOrderNotification>"
Print #1, "<ID>" & Range("B1").Value & "</ID>"
Print #1, "<ExecutionStatusCode>ZBPP</ExecutionStatusCode>"
Print #1, "<ExecutionStatusNote>pain.001.001.02</ExecutionStatusNote>"
For MyRow = MyRng(RangeTwo, 1) To MyRng(RangeTwo, 2)
Print #1, "<" & XMLRecSetName & ">"
For MyCol = RTC1 To MyRng(RangeTwo, 4)
' the next line uses the FormChk function to format dates and numbers
Print #1, "<" & FldName(MyCol - RTC1) & ">" & Cells(MyRow, MyCol).Value & "</" & FldName(MyCol - RTC1) & ">"
Status = Cells(MyRow, MyCol).Value
Next MyCol
Print #1, "<ExecutionStatusNote>pain.001.001.02</ExecutionStatusNote>"
Print #1, "<RejectionReason>"
Print #1, "<Code>NARR</Code>"
If Status = "ACSP" Then
Print #1, "<Note>/00000000/CB Accepted</Note>"
Else
Print #1, "<Note>/00000000/CB Rejected</Note>"
End If
Print #1, "</RejectionReason>"
Print #1, "</" & XMLRecSetName & ">"
Next MyRow
Print #1, "</CollectivePaymentOrderNotification>"
Print #1, "</ns1:CollectivePaymentOrderNotification_async>"
Close #1
MsgBox XMLFileName & " created." & MyLF & "Process finished", vbOKOnly + vbInformation, "MakeXML CiM"
Debug.Print XMLFileName & " saved"
End Sub
Function MyRng(MyRangeAsText As String, MyItem As Integer) As Integer
' analyse a range, where MyItem represents 1=TR, 2=BR, 3=LHC, 4=RHC
Dim UserRange As Range
Set UserRange = Range(MyRangeAsText)
Select Case MyItem
Case 1
MyRng = UserRange.Row
Case 2
MyRng = UserRange.Row + UserRange.Rows.Count - 1
Case 3
MyRng = UserRange.Column
Case 4
MyRng = UserRange.Columns(UserRange.Columns.Count).Column
End Select
Exit Function
End Function
Function FillSpaces(AnyStr As String) As String
' remove any spaces and replace with underscore character
Dim MyPos As Integer
MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "_"
MyPos = InStr(1, AnyStr, " ")
Loop
Rem FillSpaces = LCase(AnyStr)
FillSpaces = AnyStr
End Function
Function FormChk(RowNum As Integer, ColNum As Integer) As String
' formats numeric and date cell values to comma 000's and DD MMM YY
FormChk = Cells(RowNum, ColNum).Value
If IsNumeric(Cells(RowNum, ColNum).Value) Then
FormChk = Format(Cells(RowNum, ColNum).Value, "#,##0 ;(#,##0)")
End If
If IsDate(Cells(RowNum, ColNum).Value) Then
FormChk = Format(Cells(RowNum, ColNum).Value, "dd mmm yy")
End If
End Function
Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)
MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
Mid(AnyStr, MyPos, 1) = "+"
MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function
Life is beautiful! Let's make it meaningful and colorful!
Page updated
Google Sites
Report abuse