XML Editor
Sign up for a WebBoard account Sign Up Keyword Search Search More Options... Options
Chat Rooms Chat Help Help News News Log in to WebBoard Log in Not Logged in
Conferences Close Tree View
+ Stylus Studio Feature Requests (1192)
+ Stylus Studio Technical Forum (14621)
+ Website Feedback (249)
- XSLT Help and Discussion (7625)
-> - XSL-fo and how to line feed th... (1)
-> + Houston we have a problem (2)
-> + XSL-FO PDF generation (2)
-> + StylusStudio - pick XSLT 1.0 b... (6)
-> - Stylus Studio 2010 debugging f... (1)
-> - Drop down menu List / Option M... (1)
-> - XML transformation using Java ... (1)
-> + i can't to find XSLT editor in... (2)
-> - Copy xml input as value of an ... (1)
-> - Remove Name space from the Tab... (1)
-> - CGI formatted URL with name/va... (1)
-> - Problem with counting (1)
-> + for-each loop is only returnin... (3)
-> - sort date but some dates may b... (1)
-> - Entity Conversion (1)
-> - How can I build an xml convert... (1)
-> + Little Help (2)
-> + how do I merge nodes to one sc... (2)
-> - beginner help xslt and xpath (1)
-> - Convert XML Feed to CSV/SQL/XL... (1)
-> - Working with text node. (1)
-> - No Topic (1)
-> - API for XSLT Converter for .NE... (1)
-> - Getting started (1)
-> + saxon sql extensions - mysql a... (2)
-> - How do I copy and create new e... (1)
-> + substring-before and sums (3)
-> + Parsing special characters in ... (2)
-> + Schema - Require attribute in ... (2)
-> - Edit existing XSL files when n... (1)
-> + How can I use one single XSLT ... (2)
-> - Default selection of value in ... (1)
-> - Problem with watermark in pdf ... (1)
-> + XSLT Parameter Values dialog n... (3)
-> + Value of File Name is not acce... (10)
-> - Need help with a complex table... (1)
-> - How to replace all nordic char... (1)
-> - XSLT java heap space error wit... (1)
-> - Table Overflow to next page (1)
-> - Using XSLT 2.0 to define custo... (1)
-> - "standalone" attribute and xs... (1)
-> + Standardizing IP addresses (2)
-> + Programmatically changing page... (6)
-> + Can Stylus generate XSLT if so... (5)
-> + Extraction based on NODE Name. (2)
-> + NO XSLT:WYSIWYG (2)
-> + determine condition at run tim... (2)
-> - How to reduce top margin in ev... (1)
-> + need help on xsl looping (4)
-> - Convert Symbol to Element (1)
-> + Separator -only- between field... (3)
-> + DocBook (9)
-> + First Occurance of Alphabet (2)
-> + XSL:Key and Document (2)
-> + Excel Macro using XSLT (2)
-> + Add missing element and attrib... (2)
-> + XSL: Stop Count at First Match (2)
-> + XSD to EDI (4)
-> + How to access data from nested... (2)
-> + Simple division of XML file (2)
-> - XML to Flat File (1)
-> + Dispalying data whith xsl:for ... (3)
-> - distinct nodes - into 3 column... (1)
-> + Newbie at XML (2)
-> + XSL Not Working (3)
-> + to draw table using xsl (2)
-> + Base64 decoder (5)
-> + How to create a hidden sheet u... (3)
-> + XML Reports (2)
-> + Copying image files from one d... (2)
-> + XML conversion to RSS (2)
-> + Inserting Image (2)
-> + Xml to Pdf using Xsl (2)
-> + Using a parameter (or similar)... (2)
-> + How to avoid creating empty xm... (2)
-> + how to read txt files in xml (2)
-> + Limit records to 4 per page. P... (4)
-> + XSLT Mapping Based on JDK5 (2)
-> + XML Mappin (2)
-> + Format Datetime with xslt (3)
-> + Cell border missing (2)
-> + XSL: Key (not matches) (5)
-> + Loop through each char in stri... (2)
-> + What is the best way to sum va... (3)
-> + xslt sort help (2)
-> + getting the count (2)
-> + XSL dynamic variables (5)
-> + XSL:Key use (3)
-> + Help With Updating Attributes ... (8)
-> + GETTING COUNT AND POSITION usi... (3)
-> - Hi Everyone !! (1)
-> + Graph Traversal (Keep track of... (2)
-> + XSL IF with sum (2)
-> + Param not incrementing (2)
-> + Iterating through value tags (3)
-> + URGENT :::: Remove the name sp... (2)
-> + Pass new param values to ASP O... (2)
-> + Detect Browser Version in XSL (2)
-> + xslt result-document (2)
-> + Unique nodes based on two attr... (3)
-- Previous [181-200] [201-220] [221-240] Next
+ XQuery Help and Discussion (2015)
+ Stylus Studio FAQs (159)
+ Stylus Studio Code Samples & Utilities (364)
+ Stylus Studio Announcements (113)
Topic  
Posttop
daman 999Subject: How to get the data in the xml and output a word document?
Author: daman 999
Date: 18 Sep 2005 10:57 PM
the xml is :
"
<?xml version="1.0" encoding="UTF-8"?>
<?StartPath org::opencrx::kernel::account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3?>
<org.openmdx.base.Authority name="org:opencrx:kernel:account1" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="xri:+resource/org/opencrx/kernel/account1/xmi/account1.xsd">
<_object/>
<_content>
<provider>
<org.openmdx.base.Provider qualifiedName="CRX" _operation="null">
<_object/>
<_content>
<segment>
<org.opencrx.kernel.account1.Segment qualifiedName="Standard" _operation="null">
<_object/>
<_content>
<account>
<org.opencrx.kernel.account1.Contact id="33a18130-2681-11da-a265-4340e42a74c3">
<_object>
<education>0</education><!-- @see CodeValueContainer name="education" -->
<firstName>999</firstName>
<middleName>999</middleName>
<accessLevelUpdate>2</accessLevelUpdate><!-- @see CodeValueContainer name="accessLevel" -->
<gender>0</gender><!-- @see CodeValueContainer name="gender" -->
<owningUser>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/admin</owningUser>
<annualIncomeCurrency>0</annualIncomeCurrency><!-- @see CodeValueContainer name="currency" -->
<owner>
<_item>Standard:admin</_item>
<_item>Standard:Administrators</_item>
</owner>
<disabled>false</disabled>
<salutationCode>8</salutationCode><!-- @see CodeValueContainer name="salutationCode" -->
<accountRating>0</accountRating><!-- @see CodeValueContainer name="accountRating" -->
<preferredSpokenLanguage>75</preferredSpokenLanguage><!-- @see CodeValueContainer name="language" -->
<annualIncomeAmount>0.000000000</annualIncomeAmount>
<numberOfChildren>0</numberOfChildren>
<accessLevelBrowse>3</accessLevelBrowse><!-- @see CodeValueContainer name="accessLevel" -->
<fullName>999, 999 999</fullName>
<accessLevelDelete>2</accessLevelDelete><!-- @see CodeValueContainer name="accessLevel" -->
<modifiedBy>
<_item>admin-Standard</_item>
</modifiedBy>
<identity>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3</identity>
<accountType>0</accountType><!-- @see CodeValueContainer name="accountType" -->
<createdAt>2005-09-16T07:12:37.969Z</createdAt>
<doNotPhone>false</doNotPhone>
<doNotBulkPostalMail>false</doNotBulkPostalMail>
<doNotEMail>false</doNotEMail>
<owningGroup>
<_item>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/Administrators</_item>
</owningGroup>
<preferredWrittenLanguage>75</preferredWrittenLanguage><!-- @see CodeValueContainer name="language" -->
<createdBy>
<_item>admin-Standard</_item>
</createdBy>
<accountState>0</accountState><!-- @see CodeValueContainer name="accountState" -->
<familyStatus>0</familyStatus><!-- @see CodeValueContainer name="familyStatus" -->
<lastName>999</lastName>
<preferredContactMethod>0</preferredContactMethod><!-- @see CodeValueContainer name="contactMethod" -->
<doNotPostalMail>false</doNotPostalMail>
<doNotFax>false</doNotFax>
<modifiedAt>2005-09-16T07:33:56.467Z</modifiedAt>
</_object>
<_content>
<address>
<org.opencrx.kernel.account1.PhoneNumber id="31347170-2684-11da-8586-87c3e1604b49">
<_object>
<phoneCountryPrefix>0</phoneCountryPrefix><!-- @see CodeValueContainer name="phoneCountryPrefix" -->
<automaticParsing>false</automaticParsing>
<accessLevelUpdate>2</accessLevelUpdate><!-- @see CodeValueContainer name="accessLevel" -->
<owningUser>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/admin</owningUser>
<owner>
<_item>Standard:admin</_item>
<_item>Standard:Administrators</_item>
</owner>
<disabled>false</disabled>
<accessLevelBrowse>3</accessLevelBrowse><!-- @see CodeValueContainer name="accessLevel" -->
<accessLevelDelete>2</accessLevelDelete><!-- @see CodeValueContainer name="accessLevel" -->
<modifiedBy>
<_item>admin-Standard</_item>
</modifiedBy>
<identity>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3/address/31347170-2684-11da-8586-87c3e1604b49</identity>
<createdAt>2005-09-16T07:33:56.467Z</createdAt>
<phoneNumberFull>010-62779079</phoneNumberFull>
<isMain>false</isMain>
<owningGroup>
<_item>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/Administrators</_item>
</owningGroup>
<createdBy>
<_item>admin-Standard</_item>
</createdBy>
<modifiedAt>2005-09-16T07:33:56.467Z</modifiedAt>
</_object>
<_content>
<audit>
<org.opencrx.kernel.base.ObjectCreationAuditEntry id="3d3c6e00-2684-11da-8586-87c3e1604b49">
<_object>
<owningUser>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/admin</owningUser>
<modifiedBy>
<_item>admin-Standard</_item>
</modifiedBy>
<identity>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3/address/31347170-2684-11da-8586-87c3e1604b49/audit/3d3c6e00-2684-11da-8586-87c3e1604b49</identity>
<owner>
<_item>Standard:admin</_item>
<_item>Standard:Administrators</_item>
</owner>
<owningGroup>
<_item>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/Administrators</_item>
</owningGroup>
<createdBy>
<_item>admin-Standard</_item>
</createdBy>
<createdAt>2005-09-16T07:33:56.467Z</createdAt>
<auditee>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3/address/31347170-2684-11da-8586-87c3e1604b49</auditee>
<accessLevelBrowse>3</accessLevelBrowse><!-- @see CodeValueContainer name="accessLevel" -->
<unitOfWork>eeb5e477-2683-11da-8586-87c3e1604b49</unitOfWork>
<accessLevelUpdate>0</accessLevelUpdate><!-- @see CodeValueContainer name="accessLevel" -->
<accessLevelDelete>0</accessLevelDelete><!-- @see CodeValueContainer name="accessLevel" -->
<modifiedAt>2005-09-16T07:33:56.467Z</modifiedAt>
</_object>
<_content/>
</org.opencrx.kernel.base.ObjectCreationAuditEntry>
</audit>
</_content>
</org.opencrx.kernel.account1.PhoneNumber>
</address>
<audit>
<org.opencrx.kernel.base.ObjectCreationAuditEntry id="fd6b7bd7-2680-11da-a265-4340e42a74c3">
<_object>
<owningUser>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/admin</owningUser>
<modifiedBy>
<_item>admin-Standard</_item>
</modifiedBy>
<identity>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3/audit/fd6b7bd7-2680-11da-a265-4340e42a74c3</identity>
<owner>
<_item>Standard:admin</_item>
<_item>Standard:Administrators</_item>
</owner>
<owningGroup>
<_item>xri:@openmdx:org.opencrx.security.identity1/provider/CRX/segment/Standard/subject/Administrators</_item>
</owningGroup>
<createdBy>
<_item>admin-Standard</_item>
</createdBy>
<createdAt>2005-09-16T07:12:37.969Z</createdAt>
<auditee>xri:@openmdx:org.opencrx.kernel.account1/provider/CRX/segment/Standard/account/33a18130-2681-11da-a265-4340e42a74c3</auditee>
<accessLevelBrowse>3</accessLevelBrowse><!-- @see CodeValueContainer name="accessLevel" -->
<unitOfWork>7cfa0da6-2680-11da-a265-4340e42a74c3</unitOfWork>
<accessLevelUpdate>0</accessLevelUpdate><!-- @see CodeValueContainer name="accessLevel" -->
<accessLevelDelete>0</accessLevelDelete><!-- @see CodeValueContainer name="accessLevel" -->
<modifiedAt>2005-09-16T07:12:37.969Z</modifiedAt>
</_object>
<_content/>
</org.opencrx.kernel.base.ObjectCreationAuditEntry>
</audit>
</_content>
</org.opencrx.kernel.account1.Contact>
</account>
</_content>
</org.opencrx.kernel.account1.Segment>
</segment>
</_content>
</org.openmdx.base.Provider>
</provider>
</_content>
</org.openmdx.base.Authority>
"
Now I ave a word template file.Through the VBA code,I want to get the data from xml,and the VBA code is:
"
Option Explicit

Const objTag As String = "_object"
Const contentTag As String = "_content"
Const itemTag As String = "_item"
Const identityTag As String = "identity"
Const shortTextTag As String = "shortText"
Const longTextTag As String = "longText"
Const codeValueContainerPath As String = "org.opencrx.kernel.code1.CodeValueContainer"
Const codeValueEntryPath As String = "org.opencrx.kernel.code1.CodeValueEntry"
Const GMToffset = 60 'minutes to be added to GMT date-time

Dim doc As Word.Document 'temp doc for htmlToWord conversion
Dim locales As Variant

'----merge contact
Public Sub xmlMerge(xml As String)

Dim xmlclean, contact, locale As String
Dim usagefilter() As Variant
Dim mailingAddress, phoneNumber As Variant
Dim quit As Boolean
Dim i, localeIdx As Integer

xmlclean = convertXmlToString(xml)
locales = getLocales(xmlclean)

'qontact
contact = getObj(xmlclean, "org.opencrx.kernel.account1.Contact")
'get locale index for this letter based on writtenLanguage
Select Case Val(getTagValue(contact, "preferredWrittenLanguage"))
Case 75 'Chinese
locale = "zh_CN"
Case 110 'English
locale = "en_US"
Case 126 'French
locale = "fr_FR"
Case 138 'German
locale = "de_CH"
Case 183 'Italian
locale = "it_IT"
Case 311 'Farsi
locale = "fa_IR"
Case 328 'Russian
locale = "ru_RU"
Case 361 'Spanish
locale = "es_MX"
Case 368 'Swedish
locale = "sv_SE"
Case 392 'Turkish
locale = "tr_TR"
Case Else
locale = "en_US"
End Select
localeIdx = 0
quit = False
i = LBound(locales)
While (i <= UBound(locales)) And Not quit
If StrComp(locales(i), locale) = 0 Then
localeIdx = i
quit = True
End If
i = i + 1
Wend

Call ReplaceField("salutationCode$ShortText", getCodeValueText(xmlclean, "salutationCode", Val(getTagValue(contact, "salutationCode")), localeIdx, False), False)
Call ReplaceField("lastName", getTagValue(contact, "lastName"), False)
'primary mailing address
ReDim usagefilter(0, 1)
usagefilter(0, 0) = "usage"
usagefilter(0, 1) = "300" 'primary
mailingAddress = getObjList(getContent(xmlclean, "org.opencrx.kernel.account1.Contact"), "address", usagefilter, "postalStreet")
Call ReplaceField("postalAddressLine", getTagMultiValueAsString(getTagValue(mailingAddress(0), "postalAddressLine"), itemTag), False)
Call ReplaceField("postalStreet", getTagMultiValueAsString(getTagValue(mailingAddress(0), "postalStreet"), itemTag), False)
Call ReplaceField("postalCity", getTagValue(mailingAddress(0), "postalCity"), False)
Call ReplaceField("postalState", getTagValue(mailingAddress(0), "postalState"), False)
Call ReplaceField("postalCode", getTagValue(mailingAddress(0), "postalCode"), False)
Call ReplaceField("postalCountry$ShortText", getCodeValueText(xmlclean, "country", Val(getTagValue(mailingAddress(0), "postalCountry")), localeIdx, False), False)

ReDim usagefilter(0, 1)
usagefilter(0, 0) = "usage"
usagefilter(0, 1) = "300" 'primary
phoneNumber = getObjList(getContent(xmlclean, "org.opencrx.kernel.account1.Contact"), "address", usagefilter, "phoneNumberFull")
Call ReplaceField("primaryPhone", getTagValue(phoneNumber(0), "phoneNumberFull"), False)
End Sub

'----general purpose functions/subs to handle xml files

Private Function removeTagUnnested(ByVal xml As String, ByVal tagName As String) As String
' scans text and completely removes text between tags <_{tagName}> and </_{tagName}> (including tags)
' and returns cleaned up text
On Error GoTo LocalError
Dim posOpening, posClosing, posEmpty, n As Long
Dim quit As Boolean
Dim resultValue As String

n = -1
quit = False
While Not quit
posOpening = InStr(xml, "<" + tagName + ">")
posClosing = InStr(xml, "</" + tagName + ">")
posEmpty = InStr(xml, "<" + tagName + "/>")
If (posEmpty > 0) And ((posEmpty < posOpening) Or (posOpening = 0)) Then
'remove empty tag
xml = Left(xml, posEmpty - 1) + Right(xml, Len(xml) - posEmpty - Len(tagName) - 2)
Else
If (posOpening > 0) And (posClosing > 0) And (posOpening < posClosing) Then
'remove tag and content
xml = Left(xml, posOpening - 1) + Right(xml, Len(xml) - posClosing - Len(tagName) - 2)
Else
quit = True
End If
End If
Wend
removeTagUnnested = xml
Exit Function
LocalError:
removeTagUnnested = xml
End Function

Private Function convertXmlToString(ByVal xml As String) As String
On Error GoTo LocalError
Dim pos As Long

pos = InStr(xml, "&amp;")
While pos > 0
xml = Left(xml, pos - 1) + "&" + Right(xml, Len(xml) - pos - 4)
pos = InStr(xml, "&amp;")
Wend

pos = InStr(xml, "&lt;")
While pos > 0
xml = Left(xml, pos - 1) + "<" + Right(xml, Len(xml) - pos - 3)
pos = InStr(xml, "&lt;")
Wend

pos = InStr(xml, "&#13;")
While pos > 0
xml = Left(xml, pos - 1) + vbCr + Right(xml, Len(xml) - pos - 4)
pos = InStr(xml, "&amp;")
Wend

pos = InStr(xml, "&gt;")
While pos > 0
xml = Left(xml, pos - 1) + ">" + Right(xml, Len(xml) - pos - 3)
pos = InStr(xml, "&gt;")
Wend

pos = InStr(xml, "&quot;")
While pos > 0
xml = Left(xml, pos - 1) + """" + Right(xml, Len(xml) - pos - 5)
pos = InStr(xml, "&quot;")
Wend

pos = InStr(xml, "&apos;")
While pos > 0
xml = Left(xml, pos - 1) + "'" + Right(xml, Len(xml) - pos - 5)
pos = InStr(xml, "&apos;")
Wend

LocalError:
convertXmlToString = xml
End Function

Private Function getTagMultiValueAsList(ByVal xml As String, ByVal tagName As String) As Variant
' scans text between the tags <_{tagName}> and </_{tagName}> (or returns "" if <_{tagName}/> is found)
' and returns list of text between the tags <_item> and </_item>
On Error GoTo LocalError
Dim posOpening, posClosing, posEmpty, n As Long
Dim quit As Boolean
Dim resultValue() As String

n = -1
quit = False
While Not quit
posOpening = InStr(xml, "<" + tagName + ">")
posClosing = InStr(xml, "</" + tagName + ">")
posEmpty = InStr(xml, "<" + tagName + "/>")
If (posEmpty > 0) And ((posEmpty < posOpening) Or (posOpening = 0)) Then
'empty item found, add "" to item list
n = n + 1
ReDim Preserve resultValue(n)
resultValue(n) = ""
xml = Right(xml, Len(xml) - posEmpty - Len(tagName) - 3)
Else
If (posOpening > 0) And (posClosing > 0) And (posOpening < posClosing) Then
'item found, add it to item list
n = n + 1
ReDim Preserve resultValue(n)
resultValue(n) = getTagValue(xml, tagName)
xml = Right(xml, Len(xml) - posClosing - Len(tagName) - 2)
Else
quit = True
End If
End If
Wend
If n >= 0 Then
getTagMultiValueAsList = resultValue
Else
ReDim resultValue(0) As String
resultValue(0) = ""
getTagMultiValueAsList = resultValue
End If
Exit Function
LocalError:
ReDim resultValue(0) As String
resultValue(0) = ""
getTagMultiValueAsList = resultValue
End Function

Private Function getTagMultiValueAsString(ByVal xml As String, ByVal tagName As String) As String
' returns each item on a new line
Dim items As Variant
Dim resultValue As String
Dim i As Integer

items = getTagMultiValueAsList(xml, tagName)
resultValue = items(LBound(items))
For i = LBound(items) + 1 To UBound(items)
resultValue = resultValue & vbCr & items(i)
Next i
getTagMultiValueAsString = resultValue
End Function

Private Function getTagValue(ByVal xml As String, ByVal tagName As String) As String
' returns text between the tags <_{tagName}> and </_{tagName}> (or returns "" if <_{tagName}/> is found)
On Error GoTo LocalError
Dim resultValue As String
Dim posOpening, posClosing, posEmpty, pos, level As Long
Dim quit As Boolean

resultValue = ""
level = -1
quit = False
While Not quit
posOpening = InStr(xml, "<" + tagName + ">")
posClosing = InStr(xml, "</" + tagName + ">")
posEmpty = InStr(xml, "<" + tagName + "/>")
If (posEmpty > 0) And (Not ((posOpening > 0) And (posOpening < posEmpty))) And (Not ((posClosing > 0) And (posClosing < posEmpty))) Then
'<tagName/> found (before potentially existing <tagName> and/or </tagName>)
If level >= 0 Then
pos = posEmpty + Len(tagName) + 2
resultValue = resultValue + Left(xml, pos)
xml = Right(xml, Len(xml) - pos)
Else
quit = True
End If
Else
If (posClosing > 0) And (Not ((posOpening > 0) And (posOpening < posClosing))) Then
'</tagName> found (before potentially existing <tagName>)
If level > 0 Then
pos = posClosing + Len(tagName) + 2
resultValue = resultValue + Left(xml, pos)
xml = Right(xml, Len(xml) - pos)
level = level - 1
Else
quit = True
If level = 0 Then
resultValue = resultValue + Left(xml, posClosing - 1)
Else
'missing opening tag?
End If
End If
Else
If (posOpening > 0) Then
'<tagName> found
If level >= 0 Then
'nested opening tag
pos = posOpening + Len(tagName) + 1
resultValue = resultValue + Left(xml, pos)
xml = Right(xml, Len(xml) - pos)
Else
xml = Right(xml, Len(xml) - posOpening - Len(tagName) - 1)
End If
level = level + 1
Else
'no more valid tags
quit = True
End If
End If
End If
Wend
getTagValue = Trim(resultValue)
Exit Function
LocalError:
getTagValue = ""
End Function

Private Function getLocales(ByVal xml As String) As Variant
' returns list of locales
On Error GoTo LocalError
Dim codeTable, codeTexts As String
Dim texts As Variant
Dim quit As Boolean
Dim n As Integer
Dim resultValue() As String

codeTable = getContent(xml, codeValueContainerPath + " name=""locale")
n = -1
quit = False
While Not quit
n = n + 1
codeTexts = getObj(codeTable, codeValueEntryPath + " code=""" + Trim(str(n)))
texts = getTagMultiValueAsList(getTagValue(codeTexts, shortTextTag), itemTag)
If Len(texts(0)) > 0 Then
ReDim Preserve resultValue(n)
resultValue(n) = texts(0)
Else
quit = True
End If
Wend
getLocales = resultValue
Exit Function
LocalError:
ReDim Preserve resultValue(0)
resultValue(0) = ""
getLocales = resultValue
End Function

Private Function getCodeValueText(ByVal xml As String, ByVal containerName As String, ByVal codeValue As Integer, ByVal localeId As Integer, longText As Boolean) As String
' returns shortText corresponding to the codeValue
On Error GoTo LocalError
Dim codeTable, codeTexts As String
Dim texts As Variant

codeTable = getContent(xml, codeValueContainerPath + " name=""" + containerName)
codeTexts = getObj(codeTable, codeValueEntryPath + " code=""" + Trim(str(codeValue)))
If longText Then
texts = getTagMultiValueAsList(getTagValue(codeTexts, longTextTag), itemTag)
Else
texts = getTagMultiValueAsList(getTagValue(codeTexts, shortTextTag), itemTag)
End If
If localeId < UBound(texts) Then
getCodeValueText = texts(localeId)
Else
getCodeValueText = ""
End If
Exit Function
LocalError:
getCodeValueText = ""
End Function

Private Function getObjContentWithIdentity(ByVal xml As String, ByVal identity) As String
On Error GoTo LocalError

Dim xmlSplit As Variant
Dim delimiter, content As String
Dim posStartObject, posStartContent As Long

delimiter = "<" + identityTag + ">" + identity + "</" + identityTag + ""
xmlSplit = Split(xml, delimiter)
If UBound(xmlSplit) >= 1 Then
'successfully split into at least 2 parts
posStartObject = InStrRev(xmlSplit(0), "<" + objTag + ">")
posStartContent = InStr(xmlSplit(1), "</" + objTag + ">") + Len("</" + objTag + ">") + Len(xmlSplit(0)) + Len(delimiter)
content = getTagValue(xmlSplit(1), contentTag)
If Len(content) = 0 Then
getObjContentWithIdentity = Mid(xml, posStartObject, posStartContent - posStartObject) + "<" + contentTag + "/>"
Else
getObjContentWithIdentity = Mid(xml, posStartObject, posStartContent - posStartObject) + "<" + contentTag + ">" + content + "</" + contentTag + ">"
End If
Else
getObjContentWithIdentity = ""
End If
Exit Function
LocalError:
getObjContentWithIdentity = ""
End Function

Private Function getObjList(ByVal xml As String, ByVal bracketingTag As String, ByVal filterList As Variant, ByVal mustContain As String) As Variant
' returns array of objects, each represented by the text between the tags <_object> and </_object> (or returns "" if <_object/> is found)
' filter is a list of (tagName, tagValue) pairs
On Error GoTo LocalError

Dim objects() As String
Dim removedObjects() As Boolean 'true if object does not pass all filter criteria
Dim matched As Boolean
Dim resultValue(), nameValuePair(), tagValueList() As String
Dim i, n, objIndex, resultIndex As Integer
Dim tagName, tagValue, filterValue As String

If Len(bracketingTag) > 0 Then
xml = getTagValue(xml, bracketingTag)
End If
objects = getTagMultiValueAsList(xml, objTag)
ReDim removedObjects(UBound(objects) - LBound(objects))
For i = LBound(removedObjects) To UBound(removedObjects)
removedObjects(i) = False
Next
If IsArray(filterList) Then
n = LBound(filterList)
While n <= UBound(filterList)
tagName = filterList(n, 0)
filterValue = filterList(n, 1)
objIndex = 0
While objIndex <= UBound(objects)
If Not removedObjects(objIndex) Then
tagValue = getTagValue(objects(objIndex), tagName)
If InStr(tagValue, "<" + itemTag + ">") Then
'multi-valued
tagValueList = getTagMultiValueAsList(tagValue, itemTag)
matched = False
For i = LBound(tagValueList) To UBound(tagValueList)
If StrComp(tagValueList(i), filterValue) = 0 Then matched = True
Next
Else
'single-valued
matched = (StrComp(tagValue, filterValue) = 0)
End If
If Not matched Then removedObjects(objIndex) = True
End If
objIndex = objIndex + 1
Wend
n = n + 1
Wend
End If
'build result, i.e. throw out objects not passing the filter criteria
n = 0
For i = LBound(removedObjects) To UBound(removedObjects)
If Not removedObjects(i) Then
'verify whether required text is contained
If InStr(objects(i), mustContain) > 0 Then
ReDim Preserve resultValue(n)
resultValue(n) = objects(i)
n = n + 1
End If
End If
Next
If n = 0 Then
'all objects removed
ReDim resultValue(0)
resultValue(0) = ""
End If
getObjList = resultValue
Exit Function
LocalError:
getObjList = objects
End Function

Private Function getObj(ByVal xml As String, ByVal objPath As String) As String
' returns text between the tags <_object> and </_object> (or returns "" if <_object/> is found) of object with path objPath
On Error GoTo LocalError
Dim pos As Long
getObj = ""
pos = InStr(xml, objPath)
If (pos > 0) Then
getObj = getTagValue(Right(xml, Len(xml) - pos - Len(objPath) + 1), objTag)
End If
Exit Function
LocalError:
getObj = ""
End Function

Private Function getContent(ByVal xml As String, ByVal objPath As String) As String
' gets text between the tags <_content> and </_content> (or returns "" if <_content/> is found) of object with path objPath
Dim pos As Long
getContent = ""
pos = InStr(xml, objPath)
If (pos > 0) Then
getContent = getTagValue(Right(xml, Len(xml) - pos - Len(objPath) + 1), contentTag)
End If
Exit Function
LocalError:
getContent = ""
End Function

Private Sub ReplaceField(ByVal placeholdername As String, ByVal value As String, isDate As Boolean)
Dim replacementStr As String

If Len(value) > 250 Then
' note that the replacement.text must not be longer than 255 chars
value = Left(value, 250)
End If
If isDate Then
'2003-07-23T00:00:00.000Z (see http://www.w3.org/TR/xmlschema-2/#dateTime)
replacementStr = "ungültiges Datum (" + value + ")"
On Error GoTo Continue
Dim d As Date
Dim mth$(12)
mth$(1) = "Januar": mth$(2) = "Februar": mth$(3) = "März"
mth$(4) = "April": mth$(5) = "Mai": mth$(6) = "Juni"
mth$(7) = "Juli": mth$(8) = "August": mth$(9) = "September"
mth$(10) = "Oktober": mth$(11) = "November": mth$(12) = "Dezember"
d = DateSerial(Val(Mid(value, 1, 4)), Val(Mid(value, 6, 2)), Val(Mid(value, 9, 2))) + TimeSerial(Val(Mid(value, 12, 2)), Val(Mid(value, 15, 2)) + GMToffset, Val(Mid(value, 18, 2)))
'force German date regardless of local language
replacementStr = Format(d, "dd") + ". " + mth$(Format(d, "m")) + " " + Format(d, "yyyy")
'use local language
'.Replacement.Text = Format(d, "dd-MMMM-yyyy")
Continue:
Else
replacementStr = value
End If

'ensure every occurrence of the placeholder is replaced
'source: http://word.mvps.org/FAQs/MacrosVBA/FindReplaceAllWithVBA.htm
Dim myStoryRange As Range

For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
.Text = "? + placeholdername + "?
.Replacement.Text = replacementStr
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Do While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
With myStoryRange.Find
.Text = "? + placeholdername + "?
.Replacement.Text = replacementStr
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Loop
Next myStoryRange

' the following code is faster but acts on the main document ONLY!
'Selection.Find.ClearFormatting
'Selection.Find.Replacement.ClearFormatting
'With Selection.Find
' .Text = "? + placeholdername + "?
' .Replacement.Text = value
' .Forward = True
' .Wrap = wdFindContinue
' .Format = False
' .MatchCase = False
' .MatchWholeWord = False
' .MatchWildcards = False
' .MatchSoundsLike = False
' .MatchAllWordForms = False
'End With
'Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Private Sub DeleteFieldAndPlaceCaret(placeholdername As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "? + placeholdername + "?
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete
End Sub

Private Sub DeleteTagAndPlaceCaret(tag As String)
Selection.HomeKey Unit:=wdStory

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "? + tag + "?
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceOne

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "?" + tag + "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceOne

Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub

'----general purpose subs to convert html range to word range [formatting!]

Private Sub htmlToWord(htmlRange As Word.Range)
'remove all paragraphs marks (inserted by word during paste operation to replace <LF> or <CR><LF>
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'remove all manual line breaks
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "^l"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert <u>...</u> to underlined text
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
htmlRange.Find.Replacement.Font.Underline = wdUnderlineSingle
With htmlRange.Find
.Text = "(\<u\>)(*)(\</u\>)"
.Replacement.Text = "\2"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert <b>...</b> to bold text
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
htmlRange.Find.Replacement.Font.Bold = True
With htmlRange.Find
.Text = "(\<b\>)(*)(\</b\>)"
.Replacement.Text = "\2"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert <i>...</i> to italic text
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
htmlRange.Find.Replacement.Font.Italic = True
With htmlRange.Find
.Text = "(\<i\>)(*)(\</i\>)"
.Replacement.Text = "\2"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert white space to a single blank (hence don't format with white space!)
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "^w"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert <br /> to <br>
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "<br />"
.Replacement.Text = "<br>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'remove blank before <br>
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "^w<br>)"
.Replacement.Text = "<br>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert <br> to line breaks
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "(\<br\>)"
.Replacement.Text = "^l"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'remove blank before <p>
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "( )(\<p\>)"
.Replacement.Text = "\2"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'remove <p>
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "(\<p\>)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'remove </p> followed by paragraphs mark (i.e. fix end of document issue)
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "</p>^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
htmlRange.Find.Execute Replace:=wdReplaceAll

'convert </p> to paragraphs
htmlRange.Find.ClearFormatting
htmlRange.Find.Replacement.ClearFormatting
With htmlRange.Find
.Text = "(*)(\</p\>)"
.Replacement.Text = "\1^p"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
htmlRange.Find.Execute Replace:=wdReplaceAll
End Sub

"
But I can only get the 'fistname'and "the lastname",I can't get the "postcode" and "phonefullnumber".How I can do to work it out?


Unknownsample-letter.doc
word template

Unknowndata-0-0.xml
xml file

   
Download A Free Trial of Stylus Studio 6 XML Professional Edition Today! Powered by Stylus Studio, the world's leading XML IDE for XML, XSLT, XQuery, XML Schema, DTD, XPath, WSDL, XHTML, SQL/XML, and XML Mapping!  
go

Log In Options

Site Map | Privacy Policy | Terms of Use | Trademarks
Stylus Scoop XML Newsletter:
W3C Member
Stylus Studio® and DataDirect XQuery ™are from DataDirect Technologies, is a registered trademark of Progress Software Corporation, in the U.S. and other countries. © 2004-2016 All Rights Reserved.