' </> --------------------------------------------------------------------- </>
' </> ---&--- </> </> ---&---- </>
' </> ---&--- </> Convierte Documento a PDF </> ---&---- </>
' </> ---&--- </> </> ---&---- </>
' </> --------------------------------------------------------------------- </>
' '
' Programado por..... Antonio Masana '
' Fecha finalizado... Enero - 2010 '
' '
' Revisado... 15/06/2011 '
' '
' </> --------------------------------------------------------------------- </>
Sub DocToPdf_V2()
'
' ------------------------------------------------------'
' ---------- Convierte un documento a PDF ----------'
' ------------------------------------------------------'
' Divide un documento en subdocumentos y los convierte '
' a PDF '
' La cabecera ha de tener tres lineas para la conversion'
' '
' IDXCLIENTE: <miembro> '
' IDXPERIODO: <fecha> '
' IDXCONCEPTO: <texto> '
' '
' Estos tres datos definen el nombre del fichero PDF '
' ------------------------------------------------------'
Dim n_Cuenta As Integer, _
c_Direc_1 As String, _
c_Direc_2 As String
Dim c_Clie As String, _
c_Fech As String, _
c_Conc As String
' </> ---&--- </> Textos
Salida = "W:\Liquidaciones Mensuales\clientes": Crear_Dir = vbYes
Texto_0 = "Convertir DOC a PDF"
Texto_1 = "¿ Desea realizar la conversión a PDF ?"
Texto_2 = "Destino de los ficheros PDF"
Texto_3 = "Este documento no contiene información para convertir a PDF"
Texto_4 = "Conversión de ficheros Word a Pdf completada."
' </> ---&--- </> Pide confirmacion
If MsgBox(Texto_1, vbOKCancel + vbQuestion, Texto_0) <> vbOK Then
MsgBox "Macro cancelado", vbCritical, c_Texto_0
Exit Sub
End If
' </> ---&--- </> Pide la ruta de Destino de los PDF
Dir_Salida = InputBox(Texto_2, Texto_0, Salida)
If Len(Dir_Salida) = 0 Then
MsgBox "Macro cancelado", vbCritical, c_Texto_0
Exit Sub
End If
If Dir_Salida <> Salida Then
If Dir(Dir_Salida, vbDirectory) = "" Then
MsgBox "No exite este diectorio " & Dir_Salida, vbCritical, c_Texto_0
Exit Sub
Else
Crear_Dir = MsgBox("Crear un directorio para cada cliente en " & _ vbCrLf & _
vbCrLf & Dir_Salida, vbQuestion + vbYesNo, Texto_0)
End If
End If
' </> ---&--- </> Ajustes especiales
Application.EnableCancelKey = xlDisabled ' --- Esc o Cntl+Break
Application.ScreenUpdating = False ' --- Refresco de pantalla
' </> ---&--- </> Seleccionar texto
Selection.WholeStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1
contador = 0
n_Cuenta = 0
' </> ---&--- </> Cuenta el numero de documentos a crear
With Selection.Find
.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Text = "IDXCLIENTE"
.Execute
Do While .Found = True
n_Cuenta = n_Cuenta + 1
.Execute
Loop
End With
' </> ---&--- </> No esta el texto IDXCLIENTE
If n_Cuenta = 0 Then
MsgBox Texto_3, vbCritical, Texto_0
Exit Sub
End If
' </> ---&--- </> Crea los PDF
For x = 1 To n_Cuenta
' </> ---&--- </> Identificacion CLIENTE
With Selection.Find
.Text = "IDXCLIENTE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
c_Cliente = Selection.Text
' </> ---&--- </> Identificacion PERIODO
With Selection.Find
.Text = "IDXPERIODO"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
c_Periodo = Selection.Text
' </> ---&--- </> Identificacion CONCEPTO
With Selection.Find
.Text = "IDXCONCEPTO"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
c_Concept = Selection.Text
' </> ---&--- </> Copia paginas cliente
Set mirange = Selection.Range
mirange.Start = Selection.Range.End
If x = n_Cuenta Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Else
With Selection.Find
.Text = "IDXCLIENTE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
c_Cliente2 = Selection.Text
mirange.End = Selection.Start
Selection.Start = mirange.Start
Selection.End = mirange.End
End If
Selection.Copy
' </> ---&--- </> Crea un nuevo Documento
Documents.Add Template:="Doc2Pdf", _
NewTemplate:=False, _
DocumentType:=0
Selection.Paste
Selection.WholeStory
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^b"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' </> ---&--- </> Crea la ruta de Salida
c_Clie = Trim(Mid(c_Cliente, 1, Len(c_Cliente) - 1))
c_Fech = Trim(Mid(c_Periodo, 1, Len(c_Periodo) - 1))
c_Conc = Trim(Mid(c_Concept, 1, Len(c_Concept) - 1))
c_Direc_2 = Dir_Salida
If Crear_Dir = vbYes Then
c_Direc_1 = Dir_Salida & "\" & c_Clie
c_Direc_2 = Dir_Salida & "\" & c_Clie & "\" & c_Fech
If Dir(c_Direc_1, vbDirectory) = "" Then MkDir c_Direc_1
If Dir(c_Direc_2, vbDirectory) = "" Then MkDir c_Direc_2
End If
' </> ---&--- </> Para el nombre del PDF
c_Titulo = c_Direc_2 & "\" & c_Clie & c_Fech & c_Conc
' </> ---&--- </> Graba como PDF
ActiveDocument.ExportAsFixedFormat OutputFileName:=c_Titulo, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
From:=1, _
To:=1, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
' </> ---&--- </> Cierra el Documento Nuevo convertido a PDF
Application.ActiveWindow.Close 0
Next
Selection.HomeKey Unit:=wdStory
a = MsgBox(Texto_4, vbInformation, Texto_0)
End Sub
' </> -------------------------------------------------------------------- </>
' </> ---&--- </> </> ---&--- </>
' </> ---&--- </> F I N D E L A S M A C R O S </> ---&--- </>
' </> ---&--- </> </> ---&--- </>
' </> -------------------------------------------------------------------- </>
