|
|
 top
|
  Subject: 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, "&")
While pos > 0
xml = Left(xml, pos - 1) + "&" + Right(xml, Len(xml) - pos - 4)
pos = InStr(xml, "&")
Wend
pos = InStr(xml, "<")
While pos > 0
xml = Left(xml, pos - 1) + "<" + Right(xml, Len(xml) - pos - 3)
pos = InStr(xml, "<")
Wend
pos = InStr(xml, " ")
While pos > 0
xml = Left(xml, pos - 1) + vbCr + Right(xml, Len(xml) - pos - 4)
pos = InStr(xml, "&")
Wend
pos = InStr(xml, ">")
While pos > 0
xml = Left(xml, pos - 1) + ">" + Right(xml, Len(xml) - pos - 3)
pos = InStr(xml, ">")
Wend
pos = InStr(xml, """)
While pos > 0
xml = Left(xml, pos - 1) + """" + Right(xml, Len(xml) - pos - 5)
pos = InStr(xml, """)
Wend
pos = InStr(xml, "'")
While pos > 0
xml = Left(xml, pos - 1) + "'" + Right(xml, Len(xml) - pos - 5)
pos = InStr(xml, "'")
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?
 sample-letter.doc
word template
data-0-0.xml
xml file
|
|
|
|
|
