Macro for making a XML in a command button active X

[Romano_odK]

Good afternoon,

I would prefer to have this code in a command active button but I can't get it to work. Does anyone know how to do this?


Thank you for your time,

Romano


Public Itemcode As String
Public SalesPrice As String
Public CostPrice As String
Public SupplierMain As String
Public SupplierCode As String
Public SupplierPrice As String

Public Itemrow As Integer ' Counter for actual row
Public SaveDir As String ' Header Cell (2,2)
Public ItemCurrency As String ' Header Cell (4,2)
Public ItemResource As String ' Header Cell (6,2)
Public Action As Boolean ' Flag
Private Function Conversion(ByVal InputString As String) As String

Dim ASCII As Integer
Conversion = ""
While Len(InputString) > 0
ASCII = AscW(Left(InputString, 1))

Select Case ASCII
Case 1 To 9999 '47, 58 To 64, 91 To 96, 123 To 235
Conversion = Conversion & "&#" & ASCII & ";"
Case Else
Conversion = Conversion & Left(InputString, 1)
End Select

InputString = Right(InputString, Len(InputString) - 1)
' ,"ø","ø")
Wend
End Function
Sub ConvertPurchasepriceToXML()
' ----------------------------------------------------------------------------------------
' Create output file as an object in the system with the file name as stated in the SaveDir variable
' If this file exists, it will be overwritten without questions asked
SaveDir = Worksheets("A100").Cells(3, 1)
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("" & SaveDir & "", True)
' ----------------------------------------------------------------------------------------
' Write xml header
a.writeline ("<?xml version=""1.0"" ?>")
a.writeline ("<eExact xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""eExact-Schema.xsd"">")
a.writeline ("<Items>")
' ----------------------------------------------------------------------------------------
' Step 1: initialize
' ----------------------------------------------------------------------------------------
Action = True
If Worksheets("A100").Cells(3, 2) = Empty Then
MsgBox ("Currency not filled")
Action = False
End If
If Worksheets("A100").Cells(3, 2) = Empty Then
MsgBox ("Resource not filled")
Action = False
End If

' ----------------------------------------------------------------------------------------
' Step 2: Write records for Items
' ----------------------------------------------------------------------------------------

Itemrow = 7
While Worksheets("A100").Cells(Itemrow, 1) <> Empty And Action

Itemcode = Worksheets("A100").Cells(Itemrow, 1)
' SalesPrice = Replace(Worksheets("A100").Cells(Itemrow, 3), ",", ".")
' CostPrice = Replace(Worksheets("A100").Cells(Itemrow, 6), ",", ".")
SupplierMain = Worksheets("A100").Cells(Itemrow, 27)
SupplierCode = Worksheets("A100").Cells(Itemrow, 22)
SupplierPrice = Replace(Worksheets("A100").Cells(Itemrow, 17), ",", ".")

Call WriteRecord(a)
Itemrow = Itemrow + 1
Wend
' ----------------------------------------------------------------------------------------
' Step 3: End file
' ----------------------------------------------------------------------------------------
If Action = True Then
a.writeline ("</Items>")
End If
a.writeline ("</eExact>")
a.Close
End Sub

Private Sub WriteRecord(ByVal a As Object)
a.writeline (" <Item code=""" & Itemcode & """ type=""S"">")

' a.writeline (" <Sales>")
' a.writeline (" <Price type=""S"">")
' a.writeline (" <Value>" & SalesPrice & "</Value>")
' a.writeline (" <VAT code=""" & VATCode & """/>")
' a.writeline (" </Price>")
' a.writeline (" <Unit unit=""" & SalesUnit & """/>")
' a.writeline (" </Sales>")
' a.writeline (" <Costs>")
' a.writeline (" <Price>")
' a.writeline (" <Currency code=""" & ItemCurrency & """/>")
' a.writeline (" <Value>" & CostPrice & "</Value>")
' a.writeline (" </Price>")
' a.writeline (" </Costs>")

If SupplierCode <> Empty Then
a.writeline (" <ItemAccounts>")
a.writeline (" <ItemAccount default=""" & SupplierMain & """>")
a.writeline (" <Account code="""" type=""S""><Creditor code=""" & SupplierCode & """/></Account>")
a.writeline (" <Purchase>")
a.writeline (" <Price type=""P"">")
a.writeline (" <Value>" & SupplierPrice & "</Value>")
a.writeline (" </Price>")
a.writeline (" </Purchase>")
a.writeline (" </ItemAccount>")
a.writeline (" </ItemAccounts>")
End If
'
a.writeline (" </Item>")
End Sub