Option Explicit
Private bCloseForm As Boolean
Private sDocumentStyles As String
Private sUsedDocumentStyles As String
Private sListedDocumentStyles As String
Dim sConstMsgTitle As String
Private Sub cmdAdd_Click()
Dim iCnt As Integer
On Error GoTo ErrorHandler
If lstDocStyle.Text <> "" And lstProjectStyle <> "" Then
lstMapStyle.AddItem lstDocStyle.Text & " --> " & lstProjectStyle.Text
lstDocStyle.RemoveItem (lstDocStyle.ListIndex)
For iCnt = 0 To lstDocStyle.ListCount - 1
lstDocStyle.Selected(iCnt) = False
Next iCnt
For iCnt = 0 To lstProjectStyle.ListCount - 1
lstProjectStyle.Selected(iCnt) = False
Next iCnt
End If
Exit Sub
ErrorHandler:
Err.Clear
Resume Next
End Sub
Private Sub cmdApply_Click()
Dim i As Integer
Dim sDocStyle As String
Dim sProjectStyle As String
Dim iSplitPos As Integer
Dim rngFindArea As Range
If lstMapStyle.ListCount <= 0 Then
Exit Sub
End If
Call Format2Tag
For i = 0 To lstMapStyle.ListCount - 1
iSplitPos = InStr(1, lstMapStyle.List(i), " --> ")
sDocStyle = Trim(Mid(lstMapStyle.List(i), 1, iSplitPos - 1))
If InStr(1, sDocStyle, Chr(13)) > 0 Then
sDocStyle = Trim(Replace(sDocStyle, Chr(13), ""))
End If
sProjectStyle = Trim(Mid(lstMapStyle.List(i), iSplitPos + 4, Len(lstMapStyle.List(i)) - 2))
If InStr(1, sProjectStyle, Chr(13)) > 0 Then
sProjectStyle = Trim(Replace(sProjectStyle, Chr(13), ""))
End If
If InStr(1, sDocumentStyles, "|" & sProjectStyle & "|") > 0 Then
Call ApplyProjectStyles(sDocStyle, sProjectStyle)
End If
Next i
Call Tag2Format
MsgBox "Mapped styles has been changed in the document. Please ensure", vbInformation, sConstMsgTitle
bCloseForm = True
Unload Me
Exit Sub
End Sub
Private Sub ApplyProjectStyles(sFindStyle As String, sReplaceStyle As String)
Dim rngDoc As Range
On Error GoTo ErrorHandler
If sFindStyle = sReplaceStyle Then Exit Sub
If sFindStyle = "Default Paragraph Font" Or sFindStyle = "Char Char" Or sFindStyle = "No List" Then Exit Sub
Set rngDoc = ActiveDocument.Range
With rngDoc.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Style = sFindStyle
.Execute MatchWildcards:=False
rngDoc.Select
If rngDoc = ActiveDocument.Range Then Exit Sub
End With
Set rngDoc = ActiveDocument.Range
With rngDoc.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Style = sFindStyle
.Replacement.Style = sReplaceStyle
.Execute MatchWildcards:=False, Replace:=wdReplaceAll
End With
Exit Sub
ErrorHandler:
Err.Clear
Resume Next
End Sub
Private Sub cmdClearAll_Click()
Dim iCnt As Integer
Dim DocSty As Style
Dim sCmpStr As String
If lstMapStyle.ListCount <> 0 Then
sListedDocumentStyles = ""
If lstDocStyle.ListCount > 0 Then
For iCnt = 0 To lstDocStyle.ListCount - 1
sListedDocumentStyles = sListedDocumentStyles & lstDocStyle.List(iCnt) & "|"
Next
sListedDocumentStyles = "|" & sListedDocumentStyles
End If
If lstMapStyle.ListCount > 1 Then
Do While lstMapStyle.ListCount <> 0
lstMapStyle.ListIndex = 0
sCmpStr = Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
If InStr(1, sUsedDocumentStyles, "|" & sCmpStr & "|") > 0 And InStr(1, sListedDocumentStyles, "|" & sCmpStr & "|") = 0 Then
lstDocStyle.AddItem Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
End If
lstMapStyle.RemoveItem (lstMapStyle.ListIndex)
Loop
ElseIf lstMapStyle.ListCount = 1 Then
lstMapStyle.ListIndex = 0
sCmpStr = Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
If InStr(1, sUsedDocumentStyles, "|" & sCmpStr & "|") > 0 And InStr(1, sListedDocumentStyles, "|" & sCmpStr & "|") = 0 Then
lstDocStyle.AddItem Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
End If
lstMapStyle.RemoveItem (lstMapStyle.ListIndex)
End If
End If
End Sub
Private Sub cmdRemove_Click()
Dim iCnt As Integer
Dim bStylePresent As Boolean
Dim sCmpStr As String
On Error GoTo ErrorHandler
If lstDocStyle.ListCount > 0 Then
sListedDocumentStyles = ""
If lstDocStyle.ListCount > 0 Then
For iCnt = 0 To lstDocStyle.ListCount - 1
sListedDocumentStyles = sListedDocumentStyles & lstDocStyle.List(iCnt) & "|"
Next
sListedDocumentStyles = "|" & sListedDocumentStyles
End If
End If
If lstMapStyle.ListCount > 1 Then
If lstMapStyle.Text <> "" Then
sCmpStr = Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
If InStr(1, sUsedDocumentStyles, "|" & sCmpStr & "|") > 0 And InStr(1, sUsedDocumentStyles, "|" & sCmpStr & "|") = 0 Then
lstDocStyle.AddItem Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
End If
lstMapStyle.RemoveItem (lstMapStyle.ListIndex)
For iCnt = 0 To lstProjectStyle.ListCount - 1
lstProjectStyle.Selected(iCnt) = False
Next iCnt
End If
ElseIf lstMapStyle.ListCount = 1 Then
lstMapStyle.ListIndex = 0
sCmpStr = Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
If InStr(1, sUsedDocumentStyles, "|" & sCmpStr & "|") > 0 And InStr(1, sListedDocumentStyles, "|" & sCmpStr & "|") = 0 Then
lstDocStyle.AddItem Trim(Left(lstMapStyle.List(0), InStr(1, lstMapStyle.List(0), "-") - 1))
End If
lstMapStyle.RemoveItem (lstMapStyle.ListIndex)
End If
Exit Sub
ErrorHandler:
Err.Clear
Resume Next
End Sub
Private Sub UserForm_Initialize()
Dim DocSty As Style
Dim iCnt As Integer
Dim sSql As String
Dim sMappedStyles As String
Dim aMappedStyles() As String
Dim BookCode As String
sConstMsgTitle = "StyleMapper"
On Error GoTo ErrorHandler
Call Module1.ePubStlyes
For Each DocSty In ActiveDocument.Styles
sDocumentStyles = sDocumentStyles & "|" & DocSty.NameLocal
If IsStyleUsed(DocSty.NameLocal, True) Then
If DocSty.Type <> wdStyleTypeCharacter Then
lstDocStyle.AddItem DocSty.NameLocal & " " & Chr(13)
sUsedDocumentStyles = sUsedDocumentStyles & DocSty.NameLocal & " " & Chr(13) & "|"
Else
lstDocStyle.AddItem DocSty.NameLocal
sUsedDocumentStyles = sUsedDocumentStyles & DocSty.NameLocal & "|"
End If
End If
Next DocSty
sUsedDocumentStyles = "|" & sUsedDocumentStyles
sDocumentStyles = sDocumentStyles & "|"
BookCode = ""
LoadProjectStyle
ErrorHandler:
Err.Clear
Resume Next
End Sub
''Private Sub LoadProjectStyle()
''Dim sFile As File, ReadFile As TextStream, sFilePath As String
''Dim lItemsCount As Integer
''Dim fso As FileSystemObject
''Dim sStyle As String
''
'' lItemsCount = 0
''
'' sFilePath = "D:\PUB\Styles.ini"
''
'' Set fso = New FileSystemObject
'' If fso.FileExists(sFilePath) Then
'' Set sFile = fso.GetFile(sFilePath)
'' Set ReadFile = sFile.OpenAsTextStream(ForReading)
'' Do While Not ReadFile.AtEndOfStream
'' sStyle = ReadFile.ReadLine
'' If InStr(1, sStyle, "|p") > 0 Then
'' sStyle = Trim(Left(sStyle, InStr(1, sStyle, "|p") - 1)) & " " & Chr(13)
'' frmStyleMapping.lstProjectStyle.AddItem sStyle
'' ElseIf InStr(1, sStyle, "|c") > 0 Then
'' sStyle = Trim(Left(sStyle, InStr(1, sStyle, "|c") - 1))
'' frmStyleMapping.lstProjectStyle.AddItem sStyle
'' End If
'' lItemsCount = lItemsCount + 1
'' Loop
'' Else
'' MsgBox "The " & sFilePath & " file does not exist in the specified path", vbInformation
'' Exit Sub
'' End If
''
'' If lItemsCount <= 0 Then
'' MsgBox "Please check, there is no styles present in Styles.ini file.", vbInformation
'' Exit Sub
'' End If
''
''End Sub
Private Sub LoadProjectStyle()
Dim sFile As File, ReadFile As TextStream, sFilePath As String
Dim lItemsCount As Integer
Dim fso As FileSystemObject
Dim sStyle As String
Dim sStyNam As String
Dim varRegex As New RegExp
Dim varMatch As Match
Dim varMatchs As MatchCollection
lItemsCount = 0
sFilePath = "D:\PUB\Styles.ini"
Set fso = New FileSystemObject
If fso.FileExists(sFilePath) Then
Set sFile = fso.GetFile(sFilePath)
Set ReadFile = sFile.OpenAsTextStream(ForReading)
Do While Not ReadFile.AtEndOfStream
sStyle = ReadFile.ReadLine
varRegex.Pattern = "S Name: ([^\|\n]+)\|Type\: Para"
If varRegex.Test(sStyle) = True Then
Set varMatchs = varRegex.Execute(sStyle)
Set varMatch = varMatchs(0)
sStyNam = varMatch.SubMatches(0)
sStyle = Trim(sStyNam) & " " & Chr(13)
frmStyleMapping.lstProjectStyle.AddItem sStyle
Else
varRegex.Pattern = "S Name: ([^\|\n]+)\|Type\: Char"
If varRegex.Test(sStyle) = True Then
Set varMatchs = varRegex.Execute(sStyle)
Set varMatch = varMatchs(0)
sStyNam = varMatch.SubMatches(0)
sStyle = Trim(sStyNam)
frmStyleMapping.lstProjectStyle.AddItem sStyle
End If
End If
'''' If InStr(1, sStyle, "|p") > 0 Then
'''' sStyle = Trim(Left(sStyle, InStr(1, sStyle, "|p") - 1)) & " " & Chr(13)
'''' frmStyleMapping.lstProjectStyle.AddItem sStyle
'''' ElseIf InStr(1, sStyle, "|c") > 0 Then
'''' sStyle = Trim(Left(sStyle, InStr(1, sStyle, "|c") - 1))
'''' frmStyleMapping.lstProjectStyle.AddItem sStyle
'''' End If
lItemsCount = lItemsCount + 1
Loop
Else
MsgBox "The " & sFilePath & " file does not exist in the specified path", vbInformation
Exit Sub
End If
If lItemsCount <= 0 Then
MsgBox "Please check, there is no styles present in Styles.ini file.", vbInformation
Exit Sub
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If Not bCloseForm Then
Cancel = -1
Else
'Application.Run macroname:="CancelWaitProcess"
End If
End Sub
Public Function IsStyleUsed(sStyle As String, Optional NoPrompt As Boolean) As Boolean
IsStyleUsed = False
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = sStyle
.Replacement.Text = ""
.MatchWildcards = False
.Execute
If .Found = True Then
IsStyleUsed = True
Else
IsStyleUsed = False
End If
End With
End Function
Public Sub ClearFindAndReplaceParameters()
Selection.End = 0
With Selection.Find
.ClearFormatting: .Replacement.ClearFormatting
.Text = "": .Replacement.Text = ""
.Forward = True: .Wrap = wdFindStop
.Format = False: .MatchCase = False
.MatchWholeWord = False: .MatchWildcards = False
.MatchSoundsLike = False: .MatchAllWordForms = False
End With
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = " "
.Execute
End With
Selection.End = 0
End Sub
cmdAdd
cmdRemove
cmdClearAll
cmdApply
lstDocStyle
lstICSStyle
lstMapStyle