konto usunięte
Temat: Usprawnienie makra w WORD
Wspólnymi siłami wraz z członkami "elektrody" stworzyliśmy makro, które wstawia twardą spację a właściwie są to dwa makra, chciałbym je zitegrować w jedno, i jeżeli to możliwe usprawnić jego procedurę ?Czy mogę liczyć na Pani pomoc ?
Tekst samego marka ponizej:
Sub Wstaw_twarda_spacje()
' Wstaw_twarda_spacje Makro
' Makro wstawia twardą spację przed wszystkimi spójnikami wymienionymi w kodzie źródłowym,
' spójniki można dodać przez modyfikację kodu źródłowego makra, usuwa wpierw spację wielokrotną w dokumencie.
' Chr(32) - jest to zwykła spacja, natomiast Chr(160) jest to spacja nie rozdzielająca.
' Wyjustuj
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
' Usunięcie spacji wielokrotnej
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute
End With
While Selection.Find.Found()
Selection.Find.Execute Replace:=wdReplaceAll
Wend
' Deklaracja tablicy przyimków i zaimków, które należy poprawić wstawia twardą spację PO wyrazie
Dim a As Byte
Dim dane As New Collection
dane.Add"a"
dane.Add"i"
dane.Add"oraz"
dane.Add"albo"
dane.Add"bądź"
dane.Add"czy"
dane.Add"lub"
dane.Add"ani"
dane.Add"ni"
dane.Add"ale"
dane.Add"lecz"
dane.Add"zaś"
dane.Add"czyli"
dane.Add"przeto"
dane.Add"tedy"
dane.Add"więc"
dane.Add"zatem"
dane.Add"do"
dane.Add"za"
dane.Add"od"
dane.Add"na"
dane.Add"po"
dane.Add"o"
dane.Add"u"
dane.Add"z"
dane.Add"w"
dane.Add"bez"
dane.Add"pod"
dane.Add"nad"
dane.Add"znad"
dane.Add"poprzez"
dane.Add"sprzed"
dane.Add"zza"
dane.Add"mgr"
dane.Add"inż."
dane.Add"dr"
dane.Add"lek."
dane.Add"dent."
dane.Add"mjr"
dane.Add"gen"
dane.Add"hab."
dane.Add"prof."
dane.Add"zw."
dane.Add"ndzw."
dane.Add"lic."
dane.Add"ppor"
dane.Add"pplk"
dane.Add"ja"
dane.Add"ty"
dane.Add"my"
dane.Add"wy"
dane.Add"oni"
dane.Add"one"
dane.Add"mój"
dane.Add"twój"
dane.Add"nasz"
dane.Add"wasz"
dane.Add"ich"
dane.Add"jego"
dane.Add"jej"
dane.Add"ten"
dane.Add"ta"
dane.Add"to"
dane.Add"tamten"
dane.Add"tam"
dane.Add"tu"
dane.Add"ów"
dane.Add"tędy"
dane.Add"taki"
dane.Add"ci"
dane.Add"tamci"
dane.Add"owi"
dane.Add"razy"
dane.Add"tylko"
dane.Add"nie"
dane.Add"by"
dane.Add"niech"
dane.Add"niechaj"
dane.Add"tak"
dane.Add"bodaj"
dane.Add"oby"
dane.Add"A"
dane.Add"I"
dane.Add"Oraz"
dane.Add"Albo"
dane.Add"Bądź"
dane.Add"Czy"
dane.Add"Lub"
dane.Add"Ani"
dane.Add"Ni"
dane.Add"Ale"
dane.Add"Lecz"
dane.Add"Zaś"
dane.Add"Czyli"
dane.Add"Przeto"
dane.Add"Tedy"
dane.Add"Więc"
dane.Add"Zatem"
dane.Add"Do"
dane.Add"Za"
dane.Add"Od"
dane.Add"Na"
dane.Add"Po"
dane.Add"O"
dane.Add"U"
dane.Add"Z"
dane.Add"W"
dane.Add"Bez"
dane.Add"Pod"
dane.Add"Nad"
dane.Add"Znad"
dane.Add"Poprzez"
dane.Add"Sprzed"
dane.Add"Zza"
dane.Add"Mgr"
dane.Add"Inż."
dane.Add"Dr"
dane.Add"Lek."
dane.Add"Dent."
dane.Add"Mjr"
dane.Add"Gen"
dane.Add"Hab."
dane.Add"Prof."
dane.Add"Zw."
dane.Add"Ndzw."
dane.Add"Lic."
dane.Add"Ppor"
dane.Add"Pplk"
dane.Add"Ja"
dane.Add"Ty"
dane.Add"My"
dane.Add"Wy"
dane.Add"Oni"
dane.Add"One"
dane.Add"Mój"
dane.Add"Twój"
dane.Add"Nasz"
dane.Add"Wasz"
dane.Add"Ich"
dane.Add"Jego"
dane.Add"Jej"
dane.Add"Ten"
dane.Add"Ta"
dane.Add"To"
dane.Add"Tamten"
dane.Add"Tam"
dane.Add"Tu"
dane.Add"Ów"
dane.Add"Tędy"
dane.Add"Taki"
dane.Add"Ci"
dane.Add"Tamci"
dane.Add"Owi"
dane.Add"Razy"
dane.Add"Tylko"
dane.Add"Nie"
dane.Add"By"
dane.Add"Niech"
dane.Add"Niechaj"
dane.Add"Tak"
dane.Add"Bodaj"
dane.Add"Oby"
' Procedura wykonująca poprawkę
For a = 1 To dane.Count
With Selection.Find
.Text = dane(a)
.Replacement.Text = dane(a) & Chr$(160)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
With Selection.Find
.Text = dane(a) & Chr$(160) & Chr(32)
.Replacement.Text = dane(a) & Chr$(160)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next a
End Sub
Option Explicit
Sub Test()
Dim strListSep As String
strListSep = Application.International(wdListSeparator)
If Spaces2Space(strListSep) Then
If CyfraJednostka(strListSep) Then
If ThousandsSeparator160(strListSep) Then
MsgBox "Koniec...."
End If
End If
End If
End Sub
''---------------------------
Function CyfraJednostka(ByVal sListSep As String) As Boolean
' 160
On Error GoTo CyfraJednostka_Error
Dim arrJedn
Dim a As Long
Dim strRepla As String
arrJedn = VBA.Array("cl", "cm", "dl", "dm", "g", "hl", "sk", _
"kg", "km", "ks", "l", "m", "mg", "ml", "mm", "t", "zł", "gr")
For a = 0 To UBound(arrJedn, 1)
strRepla = "([0-9]){1" & sListSep & "}(" & arrJedn(a) & ")>"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' xxxx "([0-9]){1;}(cl)>"
.Replacement.Text = "1^s2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Next
CyfraJednostka = True
'---------------------
CyfraJednostka_Exit:
On Error Resume Next
Exit Function
CyfraJednostka_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura CyfraJednostka "
Resume CyfraJednostka_Exit
End Function
'---------------------------
Function Spaces2Space(ByVal sListSep As String) As Boolean
' spacje
On Error GoTo Spaces2Space_Error
Dim strRepla As String
strRepla = "[ ]([ ]){1" & sListSep & "}"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' **** "[ ]([ ]){1;}"
.Replacement.Text = "1"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Spaces2Space = True
'---------------------
Spaces2Space_Exit:
On Error Resume Next
Exit Function
Spaces2Space_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura Spaces2Space "
Resume Spaces2Space_Exit
End Function
'---------------------------
Function ThousandsSeparator160(ByVal sListSep As String) As Boolean
On Error GoTo ThousandsSeparator160_Error
Dim strRepla As String
strRepla = "<([0-9]{1" & sListSep & "}) ([0-9]{1" & sListSep & "})"
Selection.HomeKey wdStory
With Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = strRepla ' **** "<([0-9]{1;}) ([0-9]{1;})"
.Replacement.Text = "1^s2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
ThousandsSeparator160 = True
'---------------------
ThousandsSeparator160_Exit:
On Error Resume Next
Exit Function
ThousandsSeparator160_Error:
MsgBox "Błąd Nr: " & Err.Number & vbNewLine & _
"Opis błędu:" & Err.Description & vbNewLine & _
"Procedura ThousandsSeparator160 "
Resume ThousandsSeparator160_Exit
End Function