Moderatori: Anthony47, Flash30005
Sub DeleteNonBlack()
Dim Wrd As Range
Dim wdcolor As String
Const HexadecimalPrefix As String = "color:#"
Const HexadecimalSuffix As String = ";"
For Each Wrd In ActiveDocument.Words
If Wrd.Font.Color <> wdColorBlack And Wrd.Font.Color <> wdColorAutomatic Then
wdcolor = Hex(Wrd.Font.Color)
Wrd = "<span style=""" & HexadecimalPrefix & wdcolor & HexadecimalSuffix & """>" & Wrd & "</span>"
Wrd.Font.Color = wdColorAutomatic
End If
Next Wrd
End Sub
Sub Parole3()
Dim parola As Range
Dim strParola As String
Dim voceIndice As String
Dim voceIndiceTrovata As Boolean
Dim numeroPagina As String
Dim MnumPag As Integer
Dim NpCol As String
For Each parola In ThisDocument.Words
If parola.Font.ColorIndex > 1 Then
strParola = CStr(parola)
strParola = Replace(strParola, Chr(13), "")
If Trim(strParola) <> "" Then
If voceIndiceTrovata = False Then
parola.Select
numeroPagina = Selection.Information(wdActiveEndPageNumber)
If MnumPag <> numeroPagina Then
MsgBox numeroPagina
If NpCol = "" Then
NpCol = numeroPagina
Else
NpCol = NpCol & "," & numeroPagina
End If
End If
MnumPag = numeroPagina
End If
End If
voceIndiceTrovata = True
Else
If voceIndiceTrovata = True And Trim(voceIndice) <> "" Then
' MsgBox numeroPagina
End If
voceIndice = ""
voceIndiceTrovata = False
End If
Next parola
MsgBox NpCol
End Sub
Option Base 1
Sub PagineAColoriParagrafo()
msg = " Si sta per avviare la ricerca di fogli a colori e b/n " & vbCrLf
msg = msg & " sul documento " & ActiveDocument.Name & vbCrLf
msg = msg & " il file sara' salvato all'inizio e poi Chiuso " & vbCrLf
msg = msg & " per confermare premi SI, oppure NO"
scelta = MsgBox(Prompt:=msg, Buttons:=vbYesNo)
If scelta = 7 Then Exit Sub
'Ini = Timer
ActiveDocument.Save
Dim Parola, PParola
Dim strParola As String
Dim voceIndice As String
Dim voceIndiceTrovata As Boolean
Dim numeroPagina As String
Dim MnumPag As Integer, JJ As Long
Dim NpCol As String, NpBN As String
Dim PagImm As String
Dim InS
Dim VettC(1000) As Integer
Perc = ActiveDocument.Path & "/"
NumPag = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
Application.ScreenUpdating = False
'Controlla nelText
For Each Parola In ActiveDocument.Paragraphs '.Words
JJ = JJ + 1
Parola.Range.Select
If Selection.Font.ColorIndex > 1 And VettC(Selection.Information(wdActiveEndPageNumber)) = 0 Then
strParola = CStr(Parola)
strParola = Replace(strParola, Chr(13), "")
If Trim(strParola) <> "" Then
wUnits = Selection.Move(Unit:=wdCharacter, Count:=1)
For Each PParola In ActiveDocument.Paragraphs(JJ).Range.Words
PParola.Select
numeroPagina = Selection.Information(wdActiveEndPageNumber)
If PParola.Font.ColorIndex > 1 Then VettC(numeroPagina) = numeroPagina
Next PParola
End If
End If
DoEvents
Next Parola
'Controlla nelle footnotes:
JJ = 0
If ActiveDocument.Footnotes.Count > 0 Then
For Each Parola In ActiveDocument.StoryRanges(wdFootnotesStory).Paragraphs '.Words
JJ = JJ + 1
Parola.Range.Select
If Selection.Font.ColorIndex > 1 And VettC(Selection.Information(wdActiveEndPageNumber)) = 0 Then
strParola = CStr(Parola)
strParola = Replace(strParola, Chr(13), "")
If Trim(strParola) <> "" Then
For Each PParola In ActiveDocument.StoryRanges(wdFootnotesStory).Paragraphs(JJ).Range.Words
PParola.Select
numeroPagina = Selection.Information(wdActiveEndPageNumber)
If Selection.Font.ColorIndex > 1 Then VettC(numeroPagina) = numeroPagina
Next PParola
End If
End If
DoEvents
Next Parola
End If
'Controlla Shapes 6 InLineShapes
For Each InS In ActiveDocument.InlineShapes
InS.Select
numeroPagina = Selection.Information(wdActiveEndPageNumber)
VettC(numeroPagina) = numeroPagina
Next InS
'
For Each InS In ActiveDocument.Shapes
InS.Select
numeroPagina = Selection.Information(wdActiveEndPageNumber)
VettC(numeroPagina) = numeroPagina
Next InS
NumPag = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
For PCol = 1 To NumPag
If VettC(PCol) <> 0 Then
NpCol = NpCol & "," & VettC(PCol)
Else
NpBN = NpBN & "," & PCol
End If
Next PCol
NpCol = Right(NpCol, Len(NpCol) - 1)
NpBN = Right(NpBN, Len(NpBN) - 1)
Application.ScreenUpdating = True
Open Perc & "PagStampa.txt" For Output As #1
Print #1, "Col - " & NpCol
Print #1, "B/n - " & NpBN
Close #1
'Stampa B/n stampante default
'Application.PrintOut FileName:=Perc & ActiveDocument.Name, Pages:=NpBN, Range:=wdPrintRangeOfPages
'Stampa Colore
'StDef = Shell("C:\PrintCol.bat") ' imposta la stampante a colori come default
'Application.PrintOut FileName:=Perc & ActiveDocument.Name, Pages:=NpCol, Range:=wdPrintRangeOfPages
'StDef = Shell("C:\PrintDefault.bat") ' reimposta la stamapnte B/n come default
'Fine = Timer - Ini
'MsgBox Fine
ActiveDocument.Close savechanges:=False
End Sub
RUNDLL32 PRINTUI.DLL,PrintUIEntry /y /n "HP LaserJet xxxxxxxxxxx"
Torna a Applicazioni Office Windows
Formattzione valori con simbolo triangolini colorati Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 11 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
sal vare doc in word in PDF editabile Autore: danibi60 |
Forum: Applicazioni Office Windows Risposte: 2 |
Disattivazione funzione " Telemetria " in W 10 Autore: mastino46 |
Forum: Software Windows Risposte: 5 |
Visitano il forum: Nessuno e 37 ospiti