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
|