hola amigos se bien que muchos de ustedes realizan sus
programas solos, yo no soy un excelente programador pero
trato de aprender lo mas que puedo encontre este codigo en
la red y al tratar de usarlo desde asp me marca algunos
errores, yo lo use en VB6 y no me dio problemas pero desde
el asp no puedo, quisiera saber si alguno de ustedes me
puede decir donde encontrar informacion para arreglarlo o
ayudarme a hacerlo. les mando mi codigo aqui abajo del
mensaje a ver que pueden hacer gracias.
<% on error resume next
if session("admin") <> 1 or session("gerencia") <> 1 then
else
if session(usuario)<> 1 then
Response.Redirect
("sinderechos.html")
else
end if
end if%>
<html>
<head>
<SCRIPT LANGUAGE=VBScript>
public function imprime()
dim con,rec,rec1,rec2,sql,sql1,sql2,text1
text1= document.impresion.select1.value
sql = "Select
apaterno,amaterno,nombre,area from personal where
NoSocio='" & Text1 & "'"
sql1 = "Select funcion from gerencias
where NoSocio= '" & Text1 & "'"
sql2 = "Select
num_curso,nom_curso,fch_curso,ins_curso from expediente
where NoSocio='" & Text1 & "'"
set con = Server.CreateObject
("ADODB.Connection")
con.open "Provider=SQLOLEDB.1;Persist Security
Info=False;User ID=sa;Initial Catalog=capacitacion;Data
Source=EMP-SV-MAJORCRU"
Set rec = CreateObject
("ADODB.Recordset")
Set rec1 = CreateObject
("ADODB.Recordset")
Set rec2 = CreateObject
("ADODB.Recordset")
rec.Open sql,con,2,3
rec1.Open sql1,con,2,3
rec2.Open sql2,con,2,3
If rec.EOF=False then
Call(FillTemplates)
else
msgbox "No Hay Datos para
mostrar",vbokonly,"Expedientes Electronicos"
end if
end function
' If the same variable name is used more than once in the
template, this
' array saves the application performing the same work
again to get that
' data. It simply lifts it from this array.
Public Sub FillTemplates()
Dim WordApp, WordDoc
Dim a , c , grid
Set WordApp = CreateObject("Word.Application")
Set WordDoc = CreateObject("Word.Document")
Dim i ,j ,uno
Dim NewResult
uno= rec.fields(0)
ReDim UsedVariables(0)
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(App.Path
& "\template.doc")
WordApp.Visible = True
a=0
' For each section (header and footer)
For i = 1 To WordDoc.Sections.Count
' Headers
Debug.Print "Fields in Header:" & WordDoc.Sections
(i).Headers(wdHeaderFooterPrimary).Range.Fields.Count
For j = 1 To WordDoc.Sections(i).Headers
(wdHeaderFooterPrimary).Range.Fields.Count
If WordDoc.Sections(i).Headers
(wdHeaderFooterPrimary).Range.Fields(j).Type =
wdFieldDocVariable then
' Get the text for the field from the user
NewResult = GetNewResult(WordDoc.Sections
(i).Headers(wdHeaderFooterPrimary).Range.Fields(j),
WordDoc)
'Insert New Text into the field
If NewResult <> "" then
WordDoc.Sections(i).Headers
(wdHeaderFooterPrimary).Range.Fields(j).Result.Text =
NewResult
end if
end if
Next
'Footers
Debug.Print "Fields in Footer:" & WordDoc.Sections
(i).Footers(wdHeaderFooterPrimary).Range.Fields.Count
For j = 1 To WordDoc.Sections(i).Footers
(wdHeaderFooterPrimary).Range.Fields.Count
If WordDoc.Sections(i).Footers
(wdHeaderFooterPrimary).Range.Fields(j).Type =
wdFieldDocVariable then
' Get the text for the field from the user
NewResult = GetNewResult(WordDoc.Sections
(i).Footers(wdHeaderFooterPrimary).Range.Fields(j),
WordDoc)
'Insert New Text into the field
If NewResult <> "" then
WordDoc.Sections(i).Footers
(wdHeaderFooterPrimary).Range.Fields(j).Result.Text =
NewResult
end if
end if
Next
Next
' In main body
Debug.Print "Fields in main body: " &
WordDoc.Fields.Count
For i = 1 To WordDoc.Fields.Count
If WordDoc.Fields(i).Type = wdFieldDocVariable then
' Get the text for the field from the user
NewResult = GetNewResult(WordDoc.Fields(i),
WordDoc)
'Insert New Text into the field
If NewResult <> "" then
WordDoc.Fields(i).Result.Text = NewResult
end if
end if
Next
' lock the document to stop changes
WordDoc.Protect wdAllowOnlyComments, , "spawn2099"
WordDoc.SaveAs "c:\expediente.doc"
wordDoc.PrintPreview
SetAttr "c:\expediente.doc", vbSystem + vbHidden
WordDoc.Close
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
MsgBox "Finished!"
Exit Sub
End Sub
Private Function GetNewResult(wField as Variant ,WordDoc
as Variant) as string
Dim StopPos
Dim Variable
Dim UsedVariable
Dim VariableValue
dim wRange as Word.Range
dim wField as Word.Field
dim WordDoc as Word.Document
Debug.Print wField.Code
' These three lines strip down the field code to find
' out it's name
StopPos = InStrRev(wField.Code, "\*")
Variable = Left(wField.Code, StopPos - 3)
Variable = Right(Variable, Len(Variable) - 14)
' Check this field hasn't already appeared in this
' document.
If CheckUsedVariable(Variable) Then
VariableValue = GetVariableValue(Variable)
Else
Select Case UCase(Variable)
' I don't simply want to insert a string -
' I wish to insert a table at the Product
Field.
Case "NO"
' Get the range (location) of the product
field
Set wRange = wField.Code
' Delete the field, as any text will be
inserted into the
' {} of the existing field.
wField.Delete
' Enter our table information including
headers.
' Ideally, I would get this data from an
ADO recordset
' using GetString().
With wRange
cadena = ""
cadenax = ""
cadenax = "No." & vbTab & "NOMBRE DEL
CURSO" & vbTab & "FECHA" & vbTab & "INSTRUCTOR" & vbCrLf
.FormattedText.Font.NameBi
= "Times New Roman"
.FormattedText.Font.Size = "12"
grid = 1
While grid < 31
While rec2.EOF = False
cadena = rec2.Fields(0) & vbTab &
rec2.Fields(1) & vbTab & _
rec2.Fields(2) & vbTab &
rec2.Fields(3) & vbCrLf
cadenax = cadenax & cadena
rec2.MoveNext
grid = grid + 1
Wend
cadena = " " & vbTab & " " & vbTab
& _
" " & vbTab & " " & vbCrLf
cadenax = cadenax & cadena
grid = grid + 1
Wend
Dim ancho, ancho1, ancho2
.FormattedText.Font.Name = "Times New
Roman"
.FormattedText.Font.Size = "8"
.Text = cadenax
' Once the data is there, we can convert
it to a table
.ConvertToTable vbTab, , , ,
wdTableFormatGrid1
.Columns(1).AutoFit
.Columns(2).Width = 250
.Columns(3).Width = 60
.Columns(4).Width = 138
.Cells.Height = 10
End With
' Send back blank string as field does not
exist anymore
VariableValue = ""
Case Else
' Get the value of the field from the user
If a < 4 Then
VariableValue = rec.Fields(a)
a = a + 1
Else
If c < 1 Then
VariableValue = rec.Fields(3)
c = c + 1
Else
VariableValue = rec1.Fields(0)
End If
End If
AddNewVariable Variable, VariableValue
End Select
End If
GetNewResult = VariableValue
End Function
Private Function GetVariableValue(Variable As String)as
string
Dim i As Integer
For i = 0 To UBound(UsedVariables)
If Left(UsedVariables(i), Len(Variable)) =
Variable Then
GetVariableValue = Right(UsedVariables(i), Len
(UsedVariables(i)) - Len(Variable))
Exit For
End If
Next
End Function
Private Sub AddNewVariable(Variable As String, TheValue As
String)
Dim ArraySize As Integer
ArraySize = UBound(UsedVariables)
ReDim Preserve UsedVariables(ArraySize + 1)
UsedVariables(ArraySize) = TheValue
End Sub
Private Function CheckUsedVariable(Variable As String)as
boolean
Dim i As Integer
For i = 0 To UBound(UsedVariables)
If Left(UsedVariables(i), Len(Variable)) =
Variable Then
CheckUsedVariable = True
Exit For
End If
Next
End Function
</script>
</head>
<body>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<FORM action="enviar.asp" id="impresion" method="post"
name="impresion">
<div align="center">
<SELECT id=select1 name=lista style="FONT-SIZE: xx-
small;HEIGHT: 22px; WIDTH: 250px" disabled>
<option value="<%=Request.QueryString("text1")%>"
selected><%=Request.QueryString("text1")%></option>
</select>
<INPUT id=submit1 name=submit1 type=button
value="Aceptar" onclick="vbscript: imprime()">
</div>
</form>
</body>
</html>
Últimos mensajes - Powered by IBM
Palabras claves
Hacer una pregunta
Siga el debate
Tengo una respuesta
Lunes 23 de diciembre - 05:45
Registrar
Leer las respuestas