aQUI TENGO UN PROGRAMITA QUE NO ME FUNCIONA , NO SE PORKE PUEDE SER, PODEIS MIRAR A VER QUE LE PASA PORFAVOOOORR, FUNCIONABA CUANDO ESTA EN EKIPOS CON WINDOWS NT, PERO CON WINDOWS XP NO VA, PORKE PUEDE SER.
Private Sub CommandButton1_Click()
'
' Macro creada el 04/12/03 por jvalls
'
'-----------------------------------------------------------------------
'Path de los ficheros
Dim pbop, pdirectorio, ptemporales As String
Dim guardar As String
'pbop = "T:\" '<- Directorio de donde se coge el fichero que saca la aplicación
'pdirectorio = "c:\usuarios\copia\" '<- Directorio donde estan los documentos
'ptemporales = "C:\usuarios\boptemp\" '<- OJO, Si se cambia, se tiene que cambiar el origen de datos de los documentos
'guardar = "A:\sdgcs.doc" '<- Nombre y path del fichero a guardar
pbop = "c:\usuarios\" '<- Directorio de donde se coge el fichero que saca la aplicación
pdirectorio = "c:\usuarios\copia\" '<- Directorio donde estan los documentos
ptemporales = "C:\usuarios\boptemp\" '<- OJO, Si se cambia, se tiene que cambiar el origen de datos de los documentos
guardar = "C:\sdgcs.doc" '<- Nombre y path del fichero a guardar
'-----------------------------------------------------------------------
On Error Resume Next
MkDir ptemporales 'Carpeta temporal
Dim tipoescrito, cabecera, lista, anupueblo, listapueblo As String
If Formulario.OptionButton1.Value = True Then 'Elegir tipo de escrito
tipoescrito = "pr1112b.doc"
cabecera = "anunciob.doc"
lista = "id.doc"
'lista = "pr1110x.doc"
anupueblo = "anun1112b.doc"
listapueblo = "pr1112l.doc"
Else
If Formulario.OptionButton2.Value = True Then
tipoescrito = "pr1112.doc"
cabecera = "anuncio.doc"
'lista = "pr1110x.doc"
lista = "id.doc"
anupueblo = "anun1112.doc"
listapueblo = "pr1112l.doc"
Else
If Formulario.OptionButton3.Value = True Then
tipoescrito = "pr1112c.doc"
cabecera = "anuncioc.doc"
'lista = "pr1110x.doc"
lista = "id.doc"
anupueblo = "anun1112c.doc"
listapueblo = "pr1112l.doc"
Else
'lista = "recursol.doc"
lista = "id.doc"
cabecera = "anurecu.doc"
tipoescrito = "alzada12.doc"
anupueblo = "anrecu12.doc"
listapueblo = "alza12l.doc"
End If
End If
End If
Formulario.OptionButton1.Enabled = False
Formulario.OptionButton2.Enabled = False
Formulario.OptionButton3.Enabled = False
Formulario.OptionButton4.Enabled = False
Formulario.CommandButton1.Enabled = False
Formulario.Tcargo.Enabled = False
Formulario.Tnombre.Enabled = False
Dim MyMerge As Word.MailMerge
Dim wrd As Object
Set wrd = CreateObject("Word.Application")
wrd.Visible = False
MsgBox wrd.ActiveDocument.Name
wrd.Documents.Open FileName:=pdirectorio & lista
' sssa = Openfile.lista
Set MyMerge = wrd.ActiveDocument.MailMerge
' sss = sssa.ActiveDocument.Subdocuments.Count
If Application.Documents.Count >= 1 Then
MsgBox ActiveDocument.Name
End If
With MyMerge
.Destination = wdSendToNewDocument
.Execute
End With
'----Fusionar escrito
wrd.Selection.InsertFile FileName:=pdirectorio & cabecera, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
'--------------------
Dim fecha As String
fecha = Format(Date, "d") & " de " & Format(Date, "MMMM") & " de " & Format(Date, "yyyy")
Set nou = wrd.ActiveDocument.Paragraphs '-------Añadir fecha y firma
With nou
.Add.Range.InsertAfter "Castellón de la Plana, " & fecha & Chr(11) & _
Tcargo.Value & "," & Chr(11) & Chr(11) & _
Chr(11) & Chr(11) & Chr(11) & Chr(11) & _
"Fdo.:" & Tnombre.Value
.Add.Alignment = wdAlignParagraphCenter
End With
Dim paranada 'variable para recoger el resultado de msgbox
paranada = MsgBox("Introduzca un disquete para guardar la información.", vbOKOnly, "Atención")
wrd.ActiveDocument.SaveAs FileName:=guardar 'Guardar lista
wrd.Options.PrintBackground = False
wrd.ActiveDocument.PrintOut copies:=1 'Imprimir en impresora predeterminada
'Esperar a que imprima
Do While wrd.BackgroundPrintingStatus <> 0
DoEvents
Loop
wrd.ActiveDocument.Close savechanges:=0
'///////////////////////////////////////////
wrd.Quit savechanges:=False
'///////////////////////////////////////////
'---FIN PR1110--------------------------------------------------------
'---PR1112------------------------------------------------------------
Set wrd = CreateObject("Word.Application")
wrd.Visible = False
wrd.Documents.Open(pbop & "bop.dat.doc").Tables(1).Sort ExcludeHeader:=True, FieldNumber:=35
Dim muni As String
Dim i As Integer
muni = ""
i = wrd.ActiveDocument.Tables(1).Rows.Count
While (i > 0)
If (wrd.ActiveDocument.Tables(1).Rows(i).Cells(35) = muni) Then
wrd.ActiveDocument.Tables(1).Rows(i).Delete
Else
muni = wrd.ActiveDocument.Tables(1).Rows(i).Cells(35)
End If
i = i - 1
Wend
wrd.ActiveDocument.SaveAs (ptemporales & "boppue.dat.doc")
wrd.ActiveDocument.Close
wrd.Documents.Open FileName:=pdirectorio & tipoescrito
Set nou = wrd.ActiveDocument.Paragraphs '-------Añadir firma
With nou
.Add.Range.InsertAfter Tcargo.Value & "," & Chr(11) & Chr(11) & _
Chr(11) & Chr(11) & Chr(11) & Chr(11) & _
"Fdo.:" & Tnombre.Value
.Add.Alignment = wdAlignParagraphCenter
End With
Set MyMerge = wrd.ActiveDocument.MailMerge
With MyMerge
.Destination = wdSendToNewDocument
.Execute
End With
wrd.Options.PrintBackground = False
wrd.ActiveDocument.PrintOut copies:=1
'Esperar a que imprima
Do While wrd.BackgroundPrintingStatus <> 0
DoEvents
Loop
wrd.ActiveDocument.Close savechanges:=0
'///////////////////////////////////////////
wrd.Quit savechanges:=False
'///////////////////////////////////////////
'------FIN pr1112-------------------------------------------------------
'------Lista pr1112-----------------------------------------------------
Set wrd = CreateObject("Word.Application")
wrd.Visible = False
wrd.Documents.Open (ptemporales & "boppue.dat.doc")
npu = wrd.ActiveDocument.Tables(1).Rows.Count
ReDim pueblos(npu) As String
i = 1
While (i <= wrd.ActiveDocument.Tables(1).Rows.Count)
pueblos(i) = wrd.ActiveDocument.Tables(1).Rows(i).Cells(35)
i = i + 1
Wend
wrd.ActiveDocument.Close
wrd.Documents.Open (pbop & "bop.dat.doc")
Dim j, filas As Integer
j = wrd.ActiveDocument.Tables(1).Rows.Count
filas = wrd.ActiveDocument.Tables(1).Rows.Count
i = 2 'No coger la cabecera
While (i <= npu)
wrd.Quit savechanges:=False
Set wrd = CreateObject("Word.Application")
wrd.Visible = False
wrd.Documents.Open (pbop & "bop.dat.doc")
While (j > 1)
If (wrd.ActiveDocument.Tables(1).Rows(j).Cells(35) <> pueblos(i)) Then
wrd.ActiveDocument.Tables(1).Rows(j).Delete
End If
j = j - 1
Wend
wrd.Documents.Open (pdirectorio & "pueblo.doc")
wrd.ActiveDocument.Tables(1).Rows(2).Cells(1) = pueblos(i)
wrd.ActiveDocument.SaveAs (ptemporales & "pueblo.dat.doc")
wrd.ActiveDocument.Close
wrd.ActiveDocument.SaveAs (ptemporales & "lista.dat.doc")
wrd.ActiveDocument.Close
wrd.Documents.Open (pdirectorio & anupueblo)
Set MyMerge = wrd.ActiveDocument.MailMerge
With MyMerge
.Destination = wdSendToNewDocument
.Execute
End With
wrd.ActiveDocument.SaveAs (ptemporales & "anun1112.dat.doc")
wrd.ActiveDocument.Close
wrd.Documents.Open FileName:=pdirectorio & listapueblo
Set MyMerge = wrd.ActiveDocument.MailMerge
With MyMerge
.Destination = wdSendToNewDocument
.Execute
End With
wrd.Selection.InsertFile FileName:=ptemporales & "ANUN1112.dat.doc", Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Set nou = wrd.ActiveDocument.Paragraphs '-------Añadir fecha y firma
With nou
.Add.Range.InsertAfter "Castellón de la Plana, " & fecha & Chr(11) & _
Tcargo.Value & "," & Chr(11) & Chr(11) & _
Chr(11) & Chr(11) & Chr(11) & Chr(11) & _
"Fdo.:" & Tnombre.Value
.Add.Alignment = wdAlignParagraphCenter
End With
wrd.Options.PrintBackground = False
wrd.ActiveDocument.PrintOut copies:=1
'Esperar a que imprima
Do While wrd.BackgroundPrintingStatus <> 0
DoEvents
Loop
wrd.ActiveDocument.Close savechanges:=0
j = filas
i = i + 1
Wend
While (wrd.Documents.Count <> 0)
wrd.ActiveDocument.Close savechanges:=False
Wend
'//////////////////////////////
wrd.Quit savechanges:=False
'//////////////////////////////
'Kill ptemporales & "*.*"
'RmDir ptemporales
Application.Quit savechanges:=False
End Sub