elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Entrar al Canal Oficial Telegram de elhacker.net


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  Buscar y reemplazar series en Word ( y otros VBA)
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] Ir Abajo Respuesta Imprimir
Autor Tema: Buscar y reemplazar series en Word ( y otros VBA)  (Leído 5,949 veces)
AmadeoIsaboya

Desconectado Desconectado

Mensajes: 3


Ver Perfil
Buscar y reemplazar series en Word ( y otros VBA)
« en: 26 Agosto 2009, 17:56 pm »

Hola, un saludo a todos de un recien llegado al foro.
Quiero crear una rutina en word que me busque y reemplace series o listas predeterminadas. Me explico:
Tengo muchos E-Book, y algunos son .pdf y necesito pasarlos a Word (el convertidor de Adobe no funciona muy bien, al menos en mi caso) por lo cual lo que hago es "copiar al portapapeles" y pegar en Word. Esto incluye los números de página, que al copiar me quedan como el resto del texto, incluidos entre el mismo.
De manera que para que me quede un poco decente, tendría que empezar con el número 1 (pág 1) y reemplazarlo por un salto de línea, por un espacio, o por lo que sea recomendable en cada caso. Una vez encontrado el 1, ya no buscarlo más y pasar al 2, y así sucesivamente con todos los números de página que han quedado intercalados, recorriendo la "serie".
A veces el programa encuentra una ocurrencia que no debe ser sustituida, por ejemplo el inicio del año 2009, por lo que quiero implementar la opción de "buscar siguiente 2" hasta encontrar el que me interesa.
Otro caso es cuando un archivo ha quedado mal escaneado o convertido, a veces aparecen caracteres extraños tipo ascii. Si dispusiera de una lista de estos indeseados, podría pasársela como parámetro a la rutina de buscar y reemplazar, y en este caso sustituir todas las ocurrencias que aparezcan de cada elemento de esa lista, sin necesidad de pasarlos uno por uno al cuadro de diálogo.
Y ya para rizar el rizo, entiendo que se podría hacer una lista de equivalencias, de forma que a un determinado carácter le corresponda su reemplazo. Supongo que a todo el mundo le ha pasado bajarse un texto y encontrar que letras acentuadas aparecen como '¥', '¤', '¢' cuando deberían ser á, ú, ó (es un ejemplo).
Bueno, perdonad el "ladrillazo", pero es que me quería explicar bien. Si el tema ya ha salido y me quereis indicar la referencia, se agradecerá


En línea

ssccaann43 ©


Desconectado Desconectado

Mensajes: 792


¬¬


Ver Perfil
Re: Buscar y reemplazar series en Word ( y otros VBA)
« Respuesta #1 en: 26 Agosto 2009, 21:35 pm »

Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...

Creo que deberías meterte en las reglas del foro y leerlas.

Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.

Salu2


En línea

- Miguel Núñez
Todos tenemos derechos a ser estupidos, pero algunos abusan de ese privilegio...
"I like ^TiFa^"
MCKSys Argentina
Moderador Global
***
Desconectado Desconectado

Mensajes: 5.524


Diviértete crackeando, que para eso estamos!


Ver Perfil
Re: Buscar y reemplazar series en Word ( y otros VBA)
« Respuesta #2 en: 26 Agosto 2009, 22:04 pm »

Si los pdf's estan en TXT plano, puedes leerlos y analizarlos usando VBA.

He hecho una macro en Excel que levanta PDF's. El tema es que varia mucho la programación dependiendo de la estructura que tenga el PDF...

Es muy parecido a leer TXT's en VB.

Saludos!


En línea

MCKSys Argentina

"Si piensas que algo está bien sólo porque todo el mundo lo cree, no estás pensando."

AmadeoIsaboya

Desconectado Desconectado

Mensajes: 3


Ver Perfil
Re: Buscar y reemplazar series en Word ( y otros VBA)
« Respuesta #3 en: 26 Agosto 2009, 22:39 pm »

Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...

Creo que deberías meterte en las reglas del foro y leerlas.

Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.

Salu2
Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...

Creo que deberías meterte en las reglas del foro y leerlas.

Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.

Salu2

1) He empezado diciendo que quiero hacer una rutina para WORD (supongo que con adaptaciones me servirá para EXCEL, ACCESS, etc.) que utilizan VBA, que yo sepa es VISUAL BASIC.
2) Cuando me he registrado he leído las reglas del foro y las he aceptado. He buscado si se había publicado algo parecido y YO no lo he encontrado.
3) Por otro lado, yo no he pedido a nadie que me haga ninguna TAREA, precisamente he pedido IDEAS para hacerlo yo, y he explicado un problema que a lo mejor se le ha planteado ya a mucha otra gente, tal vez alguno ya se ha buscado la vida como voy a hacer yo.
O sea, no sé qué regla he incumplido, ya me la dirás tú si lo tienes por conveniente.
De todas maneras, gracias por tu esplendida bienvenida a mi primer post en este foro.
En línea

MCKSys Argentina
Moderador Global
***
Desconectado Desconectado

Mensajes: 5.524


Diviértete crackeando, que para eso estamos!


Ver Perfil
Re: Buscar y reemplazar series en Word ( y otros VBA)
« Respuesta #4 en: 26 Agosto 2009, 22:54 pm »

Este es el código que hice (hace un tiempo ya) para "levantar" PDF's.
Está diseñado para trabajar en Excel, pero cambiando un par de cosillas, anda en Word.
Código:
Private Sub Command1_Click()
Dim Pendientes As Worksheet
Dim Linea As String
Dim strAux As String
Dim retMat() As String
Dim streams() As String
Dim IStreams As Long
Dim capturando As Boolean
Dim I As Long
Dim J As Long
Dim RowActual As Long
Dim ColActual As Long
Dim bAcu As Boolean
Dim NombreCampo As String
Dim cmdLine As String

Linea = "Está por importar datos de un PDF." + vbCrLf
Linea = Linea + "Debe tener seleccionada la celda desde la cual se insertarán las nuevas celdas importadas." + vbCrLf
Linea = Linea + "(La celda inical debe estar, preferentemente, al final de todas las anteriores)" + vbCrLf
Linea = Linea + "¿ Ha seleccionado esta celda inicial ?"
ret = MsgBox(Linea, vbQuestion + vbYesNo + vbDefaultButton1, "Atención")
If ret <> vbYes Then Exit Sub

cmdLine = Application.GetOpenFileName("Archivos PDF (*.pdf),*.pdf", 1, "Abrir PDF", , False)
If Dir(cmdLine) = "" Then Exit Sub

Set Pendientes = Worksheets("PENDIENTES2")
'Abre PDF para leer por lineas
Open cmdLine For Input Access Read As #1
IStreams = 0
capturando = False
Do While Not EOF(1)
    Line Input #1, Linea
    Linea = Trim(Linea)
    If Linea <> "" Then
        Select Case True
            Case UCase(Linea) = "STREAM"
                'comienza a capturar datos
                ReDim Preserve streams(IStreams)
                Line Input #1, Linea
                Linea = Trim(Linea)
                capturando = True
            Case UCase(Linea) = "ENDSTREAM"
                'termina de capturar stream
                IStreams = IStreams + 1
                capturando = False
        End Select
        If capturando Then
            streams(IStreams) = streams(IStreams) + Linea
        End If
    End If
Loop
Close #1

'el array streams ya contiene las lineas de informacion del PDF.
'Cada caracter de cada linea, estan en exresado en Hexa. Se utiliza la función Hexa2Ansi para convertirlas en ASCII.

'activar para insertar en 2 filas
RowActual = ActiveCell.Row - 2
'RowActual = ActiveCell.Row - 1
'ColActual = 1
For I = 0 To IStreams - 1
    Linea = Replace(streams(I), Chr(13), "")
    Linea = Replace(Linea, Chr(10), "")
    If parseTexto(Linea, retMat) > 0 Then
        'con parseTexto partimos la linea
        J = 0
        Do While J <= UBound(retMat)
            strAux = Hexa2Ansi(retMat(J))
            'Hexa2Ansi convierte cadena Hexa en ANSI
            If strAux <> "" Then
                strAux = Trim(strAux)
                If EsNuevoPedido(strAux) Then
                    'activar para insertar en 2 filas
                    RowActual = RowActual + 2
                    'RowActual = RowActual + 1
                End If
                bAcu = (strAux = "N° Orden:") Or (strAux = "Fecha Orden:") Or (strAux = "N° Cliente:")
                bAcu = bAcu Or (strAux = "Nom./Razón Soc.:") Or (strAux = "Nombre Fantasía:") Or (strAux = "Localidad:") Or (strAux = "Calle:")
                bAcu = bAcu Or (strAux = "N°:") Or (strAux = "Teléfono:") Or (strAux = "Horario de Visita:") Or (strAux = "Referencia de Domicilio:")
                bAcu = bAcu Or (strAux = "Marca y Modelo:") Or (strAux = "N° AF:") Or (strAux = "Síntoma:") Or (strAux = "Prioridad:") Or (strAux = "Reclamo:")
                bAcu = bAcu Or (strAux = "Descripción del Problema:")
                If bAcu Then
                    NombreCampo = strAux
                    J = J + 1
                    strAux = Hexa2Ansi(retMat(J))
                    If EsCampo(strAux) Or EsTitulo(strAux) Then
                        'es el siguiente campo, hay que rajar
                        GoTo FinLoop
                    Else
                        'MsgBox NombreCampo
                        'activar para insertar en 2 filas
                        ret = GetColPos(NombreCampo, ColActual)
                        'ret = GetColPos2(NombreCampo, ColActual)
                        If (ColActual = 5) And (ret = 0) Then
                            'columna de dirección (calle + alura)
                            Pendientes.Cells(RowActual, ColActual).Value = Pendientes.Cells(RowActual, ColActual).Value + " " + Trim(strAux)
                        ElseIf (ColActual = 2) And (ret = 0) Then
                            'columna de fecha
                            strAux = Replace(strAux, ".", "/")
                            strAux = Day(CDate(strAux)) & "-" & Month(CDate(strAux))
                            Pendientes.Cells(RowActual, ColActual).Value = strAux
                        ElseIf (ColActual = 3) And (ret = 0) Then
                            'numero de cliente
                            If Mid(strAux, 1, 2) = "0E" Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(" " + Mid(strAux, 3, 10))
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        ElseIf (ColActual = 9) And (ret = 0) Then
                            'Nº AF
                            If IsNumeric(strAux) Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux)
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        ElseIf (ColActual = 1) And (ret = 0) Then
                            'Nº Orden
                            If IsNumeric(strAux) Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux)
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        Else
                            'esta parte inserta en 2 filas
                            strAux = AcortarValor(UCase(Trim(strAux)))
                            If ret = 0 Then
                                Pendientes.Cells(RowActual, ColActual).Value = Trim(strAux)
                            Else
                                Pendientes.Cells(RowActual + 1, ColActual).Value = Trim(strAux)
                            End If
                            'strAux = AcortarValor(UCase(Trim(strAux)))
                            'Pendientes.Cells(RowActual, ColActual).Value = strAux
                        End If
                    End If
                End If
            Else
                MsgBox "Error en Hexa2Ansi"
                GoTo Salida
            End If
            J = J + 1
FinLoop:
        Loop
    End If
Next I
Salida:
'MsgBox "Datos cargados"
End Sub

Function AcortarValor(cadena As String) As String
Select Case Trim(cadena)
    Case "GAFA EXHIBIDORA VERT/VC / VISICOOLER"
        AcortarValor = "GAFA"
    Case "VESTFROST EXHIBIDORA/VC / VISICOOLER"
        AcortarValor = "VESTFROST"
    Case "GAFA EXHIBIDORA VERT/MV / MINI VISU"
        AcortarValor = "MV GAFA"
    Case "MINIVISU EXHIBIDORA /MV / MINI VISU"
        AcortarValor = "MV GAFA"
    Case "BEVERAGE AIR EXHIB. /VC / VISICOOLER"
        AcortarValor = "CONTOUR"
    Case "GAFA EXHIBIDORA DOBL/VD / VISICOOLER DOBL"
        AcortarValor = "GAFA 2P"
    Case "TRENTO EXHIBIDORA VE/VC / VISICOOLER"
        AcortarValor = "TRENTO"
    Case "EQUIPO GENÉRICO SIN /"
        AcortarValor = "GENERICO"
    Case "EXHIBIDORA VERTICAL /VC / VISICOOLER"
        AcortarValor = "TIPO VC"
    Case "SANTO TOME"
        AcortarValor = "STO. TOME"
    Case "SAUCE VIEJO"
        AcortarValor = "S. VIEJO"
    'Case "URGENTE"
    '    AcortarValor = "U"
    'Case "NORMAL"
    '    AcortarValor = "N"
    Case Else
        AcortarValor = cadena
End Select
End Function

Function GetColPos(Campo As String, ByRef Colu As Long) As Integer
Select Case Campo
    Case "N° Orden:"
        Colu = 1
        GetColPos = 0
    Case "Fecha Orden:"
        Colu = 2
        GetColPos = 0
    Case "N° Cliente:"
        Colu = 3
        GetColPos = 0
    Case "Nom./Razón Soc.:"
        Colu = 4
        GetColPos = 0
    Case "Nombre Fantasía:"
        Colu = 2
        GetColPos = 1
    Case "Localidad:"
        Colu = 7
        GetColPos = 0
    Case "Calle:"
        Colu = 5
        GetColPos = 0
    Case "N°:"
        Colu = 5
        GetColPos = 0
    Case "Teléfono:"
        Colu = 3
        GetColPos = 1
    Case "Horario de Visita:"
        Colu = 6
        GetColPos = 0
    Case "Referencia de Domicilio:"
        Colu = 4
        GetColPos = 1
    Case "Marca y Modelo:"
        Colu = 8
        GetColPos = 0
    Case "N° AF:"
        Colu = 9
        GetColPos = 0
    Case "Síntoma:"
        Colu = 10
        GetColPos = 0
    Case "Prioridad:"
        Colu = 5
        GetColPos = 1
    Case "Reclamo:"
        Colu = 6
        GetColPos = 1
    Case "Descripción del Problema:"
        Colu = 7
        GetColPos = 1
End Select
End Function

Function GetColPos2(Campo As String, ByRef Colu As Long) As Integer
Select Case Campo
    Case "N° Orden:"
        Colu = 1
        GetColPos2 = 0
    Case "Fecha Orden:"
        Colu = 2
        GetColPos2 = 0
    Case "N° Cliente:"
        Colu = 3
        GetColPos2 = 0
    Case "Nom./Razón Soc.:"
        Colu = 4
        GetColPos2 = 0
    Case "Nombre Fantasía:"
        Colu = 11
        GetColPos2 = 1
    Case "Localidad:"
        Colu = 7
        GetColPos2 = 0
    Case "Calle:"
        Colu = 5
        GetColPos2 = 0
    Case "N°:"
        Colu = 5
        GetColPos2 = 0
    Case "Teléfono:"
        Colu = 12
        GetColPos2 = 1
    Case "Horario de Visita:"
        Colu = 6
        GetColPos2 = 0
    Case "Referencia de Domicilio:"
        Colu = 13
        GetColPos2 = 1
    Case "Marca y Modelo:"
        Colu = 8
        GetColPos2 = 0
    Case "N° AF:"
        Colu = 9
        GetColPos2 = 0
    Case "Síntoma:"
        Colu = 10
        GetColPos2 = 0
    Case "Prioridad:"
        Colu = 14
        GetColPos2 = 1
    Case "Reclamo:"
        Colu = 15
        GetColPos2 = 1
    Case "Descripción del Problema:"
        Colu = 16
        GetColPos2 = 1
End Select
End Function

Function Hexa2Ansi(cadena As String) As String
'Convierte una cedana Hexa en ASCII
Dim I As Long
Dim Hexa As String
Dim car As Byte
Dim retCad As String

If Len(cadena) Mod 2 <> 0 Then
    Hexa2Ansi = ""
Else
    retCad = ""
    For I = 1 To Len(cadena) Step 2
        Hexa = Mid(cadena, I, 2)
        retCad = retCad + Chr(CByte("&H" + Hexa))
    Next I
End If
Hexa2Ansi = retCad
End Function

Function parseTexto(cadena As String, mat() As String) As Long
'Divide una linea de texto (ver ejemplo) obteniendo una cadena Hexa contenida entre < y >
'Ejemplo: 542.75 Td <304536303136333833>Tj ET 0 g BT 141.75 542.75 Td <4E6F6D2E2F52617AF36E20536F632E3A>Tj ET 0 g BT 226.75 542.75 Td <41475549525245204D4152494120414C454A414E445241>Tj ET 0 g BT 453.55 542.75 Td <4E6F6D6272652046616E746173ED613A>Tj
Dim cadCopy As String
Dim Inicio As Long
Dim Fin As Long
Dim Maxi As Long


ReDim mat(0)
Maxi = -1
cadCopy = cadena
Do
    Inicio = InStr(1, cadCopy, "<") + 1
    Fin = InStr(1, cadCopy, ">")
    If Inicio > 1 Then
        Maxi = Maxi + 1
        ReDim Preserve mat(Maxi)
        mat(Maxi) = Mid(cadCopy, Inicio, (Fin - Inicio))
    End If
    cadCopy = Mid(cadCopy, Fin + 1, Len(cadCopy))
Loop Until Inicio = 1
parseTexto = Maxi
End Function

Function EsNuevoPedido(cadena As String) As Boolean
EsNuevoPedido = (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO")
End Function

Function EsCampo(cadena As String) As Boolean
Dim bAcu As Boolean

bAcu = False
bAcu = bAcu Or (cadena = "N° Orden:")
bAcu = bAcu Or (cadena = "Fecha Orden:")
bAcu = bAcu Or (cadena = "Fecha Prev. Solución:")
bAcu = bAcu Or (cadena = "Técnico:")
bAcu = bAcu Or (cadena = "N° Cliente:")
bAcu = bAcu Or (cadena = "Nom./Razón Soc.:")
bAcu = bAcu Or (cadena = "Nombre Fantasía:")
bAcu = bAcu Or (cadena = "Contacto:")
bAcu = bAcu Or (cadena = "Provincia:")
bAcu = bAcu Or (cadena = "Localidad:")
bAcu = bAcu Or (cadena = "Barrio:")
bAcu = bAcu Or (cadena = "Calle:")
bAcu = bAcu Or (cadena = "N°:")
bAcu = bAcu Or (cadena = "Teléfono:")
bAcu = bAcu Or (cadena = "Horario de Visita:")
bAcu = bAcu Or (cadena = "Referencia de Domicilio:")
bAcu = bAcu Or (cadena = "Tipo:")
bAcu = bAcu Or (cadena = "Marca y Modelo:")
bAcu = bAcu Or (cadena = "N° AF:")
bAcu = bAcu Or (cadena = "N° E.C:")
bAcu = bAcu Or (cadena = "Observaciones:")
bAcu = bAcu Or (cadena = "Síntoma:")
bAcu = bAcu Or (cadena = "Prioridad:")
bAcu = bAcu Or (cadena = "Reclamo:")
bAcu = bAcu Or (cadena = "Descripción del Problema:")
bAcu = bAcu Or (cadena = "Fecha Visita:")
bAcu = bAcu Or (cadena = "N° A.F.:")
bAcu = bAcu Or (cadena = "Realizado Por:")
bAcu = bAcu Or (cadena = "Tipo Falla:")
bAcu = bAcu Or (cadena = "Descripción:")
EsCampo = bAcu
End Function

Function EsTitulo(cadena As String) As Boolean
Dim bAcu As Boolean

bAcu = False
bAcu = bAcu Or (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO")
bAcu = bAcu Or (cadena = "Datos Orden")
bAcu = bAcu Or (cadena = "Datos Cliente")
bAcu = bAcu Or (cadena = "Datos Equipo")
bAcu = bAcu Or (cadena = "Datos Falla")
bAcu = bAcu Or (cadena = "Datos Última Visita")
EsTitulo = bAcu
End Function

Function Str2Campo(strCampo As String) As String
Select Case strCampo
    Case "N° Orden:"
        Str2Campo = "NumOrden"
    Case "Fecha Orden:"
        Str2Campo = "FechaOrden"
    Case "N° Cliente:"
        Str2Campo = "NumCliente"
    Case "Nom./Razón Soc.:"
        Str2Campo = "Nombre"
    Case "Nombre Fantasía:"
        Str2Campo = "Fantasia"
    Case "Localidad:"
        Str2Campo = "Localidad"
    Case "Calle:"
        Str2Campo = "Calle"
    Case "N°:"
        Str2Campo = "Altura"
    Case "Teléfono:"
        Str2Campo = "Telefono"
    Case "Horario de Visita:"
        Str2Campo = "HorarioVisita"
    Case "Referencia de Domicilio:"
        Str2Campo = "RefDomicilio"
    Case "Marca y Modelo:"
        Str2Campo = "MarcaYModelo"
    Case "N° AF:"
        Str2Campo = "NumAF"
    Case "Síntoma:"
        Str2Campo = "Sintoma"
    Case "Prioridad:"
        Str2Campo = "Prioridad"
    Case "Reclamo:"
        Str2Campo = "Reclamo"
    Case "Descripción del Problema:"
        Str2Campo = "DescribeProblema"
End Select
End Function

Espero te sea útil...

Saludos!



En línea

MCKSys Argentina

"Si piensas que algo está bien sólo porque todo el mundo lo cree, no estás pensando."

AmadeoIsaboya

Desconectado Desconectado

Mensajes: 3


Ver Perfil
Re: Buscar y reemplazar series en Word ( y otros VBA)
« Respuesta #5 en: 27 Agosto 2009, 12:38 pm »

Este es el código que hice (hace un tiempo ya) para "levantar" PDF's.
Está diseñado para trabajar en Excel, pero cambiando un par de cosillas, anda en Word.
Código:
Private Sub Command1_Click()
Dim Pendientes As Worksheet
Dim Linea As String
Dim strAux As String
Dim retMat() As String
Dim streams() As String
Dim IStreams As Long
Dim capturando As Boolean
Dim I As Long
Dim J As Long
Dim RowActual As Long
Dim ColActual As Long
Dim bAcu As Boolean
Dim NombreCampo As String
Dim cmdLine As String

Linea = "Está por importar datos de un PDF." + vbCrLf
Linea = Linea + "Debe tener seleccionada la celda desde la cual se insertarán las nuevas celdas importadas." + vbCrLf
Linea = Linea + "(La celda inical debe estar, preferentemente, al final de todas las anteriores)" + vbCrLf
Linea = Linea + "¿ Ha seleccionado esta celda inicial ?"
ret = MsgBox(Linea, vbQuestion + vbYesNo + vbDefaultButton1, "Atención")
If ret <> vbYes Then Exit Sub

cmdLine = Application.GetOpenFileName("Archivos PDF (*.pdf),*.pdf", 1, "Abrir PDF", , False)
If Dir(cmdLine) = "" Then Exit Sub

Set Pendientes = Worksheets("PENDIENTES2")
'Abre PDF para leer por lineas
Open cmdLine For Input Access Read As #1
IStreams = 0
capturando = False
Do While Not EOF(1)
    Line Input #1, Linea
    Linea = Trim(Linea)
    If Linea <> "" Then
        Select Case True
            Case UCase(Linea) = "STREAM"
                'comienza a capturar datos
                ReDim Preserve streams(IStreams)
                Line Input #1, Linea
                Linea = Trim(Linea)
                capturando = True
            Case UCase(Linea) = "ENDSTREAM"
                'termina de capturar stream
                IStreams = IStreams + 1
                capturando = False
        End Select
        If capturando Then
            streams(IStreams) = streams(IStreams) + Linea
        End If
    End If
Loop
Close #1

'el array streams ya contiene las lineas de informacion del PDF.
'Cada caracter de cada linea, estan en exresado en Hexa. Se utiliza la función Hexa2Ansi para convertirlas en ASCII.

'activar para insertar en 2 filas
RowActual = ActiveCell.Row - 2
'RowActual = ActiveCell.Row - 1
'ColActual = 1
For I = 0 To IStreams - 1
    Linea = Replace(streams(I), Chr(13), "")
    Linea = Replace(Linea, Chr(10), "")
    If parseTexto(Linea, retMat) > 0 Then
        'con parseTexto partimos la linea
        J = 0
        Do While J <= UBound(retMat)
            strAux = Hexa2Ansi(retMat(J))
            'Hexa2Ansi convierte cadena Hexa en ANSI
            If strAux <> "" Then
                strAux = Trim(strAux)
                If EsNuevoPedido(strAux) Then
                    'activar para insertar en 2 filas
                    RowActual = RowActual + 2
                    'RowActual = RowActual + 1
                End If
                bAcu = (strAux = "N° Orden:") Or (strAux = "Fecha Orden:") Or (strAux = "N° Cliente:")
                bAcu = bAcu Or (strAux = "Nom./Razón Soc.:") Or (strAux = "Nombre Fantasía:") Or (strAux = "Localidad:") Or (strAux = "Calle:")
                bAcu = bAcu Or (strAux = "N°:") Or (strAux = "Teléfono:") Or (strAux = "Horario de Visita:") Or (strAux = "Referencia de Domicilio:")
                bAcu = bAcu Or (strAux = "Marca y Modelo:") Or (strAux = "N° AF:") Or (strAux = "Síntoma:") Or (strAux = "Prioridad:") Or (strAux = "Reclamo:")
                bAcu = bAcu Or (strAux = "Descripción del Problema:")
                If bAcu Then
                    NombreCampo = strAux
                    J = J + 1
                    strAux = Hexa2Ansi(retMat(J))
                    If EsCampo(strAux) Or EsTitulo(strAux) Then
                        'es el siguiente campo, hay que rajar
                        GoTo FinLoop
                    Else
                        'MsgBox NombreCampo
                        'activar para insertar en 2 filas
                        ret = GetColPos(NombreCampo, ColActual)
                        'ret = GetColPos2(NombreCampo, ColActual)
                        If (ColActual = 5) And (ret = 0) Then
                            'columna de dirección (calle + alura)
                            Pendientes.Cells(RowActual, ColActual).Value = Pendientes.Cells(RowActual, ColActual).Value + " " + Trim(strAux)
                        ElseIf (ColActual = 2) And (ret = 0) Then
                            'columna de fecha
                            strAux = Replace(strAux, ".", "/")
                            strAux = Day(CDate(strAux)) & "-" & Month(CDate(strAux))
                            Pendientes.Cells(RowActual, ColActual).Value = strAux
                        ElseIf (ColActual = 3) And (ret = 0) Then
                            'numero de cliente
                            If Mid(strAux, 1, 2) = "0E" Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(" " + Mid(strAux, 3, 10))
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        ElseIf (ColActual = 9) And (ret = 0) Then
                            'Nº AF
                            If IsNumeric(strAux) Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux)
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        ElseIf (ColActual = 1) And (ret = 0) Then
                            'Nº Orden
                            If IsNumeric(strAux) Then
                                Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux)
                            Else
                                Pendientes.Cells(RowActual, ColActual).Value = strAux
                            End If
                        Else
                            'esta parte inserta en 2 filas
                            strAux = AcortarValor(UCase(Trim(strAux)))
                            If ret = 0 Then
                                Pendientes.Cells(RowActual, ColActual).Value = Trim(strAux)
                            Else
                                Pendientes.Cells(RowActual + 1, ColActual).Value = Trim(strAux)
                            End If
                            'strAux = AcortarValor(UCase(Trim(strAux)))
                            'Pendientes.Cells(RowActual, ColActual).Value = strAux
                        End If
                    End If
                End If
            Else
                MsgBox "Error en Hexa2Ansi"
                GoTo Salida
            End If
            J = J + 1
FinLoop:
        Loop
    End If
Next I
Salida:
'MsgBox "Datos cargados"
End Sub

Function AcortarValor(cadena As String) As String
Select Case Trim(cadena)
    Case "GAFA EXHIBIDORA VERT/VC / VISICOOLER"
        AcortarValor = "GAFA"
    Case "VESTFROST EXHIBIDORA/VC / VISICOOLER"
        AcortarValor = "VESTFROST"
    Case "GAFA EXHIBIDORA VERT/MV / MINI VISU"
        AcortarValor = "MV GAFA"
    Case "MINIVISU EXHIBIDORA /MV / MINI VISU"
        AcortarValor = "MV GAFA"
    Case "BEVERAGE AIR EXHIB. /VC / VISICOOLER"
        AcortarValor = "CONTOUR"
    Case "GAFA EXHIBIDORA DOBL/VD / VISICOOLER DOBL"
        AcortarValor = "GAFA 2P"
    Case "TRENTO EXHIBIDORA VE/VC / VISICOOLER"
        AcortarValor = "TRENTO"
    Case "EQUIPO GENÉRICO SIN /"
        AcortarValor = "GENERICO"
    Case "EXHIBIDORA VERTICAL /VC / VISICOOLER"
        AcortarValor = "TIPO VC"
    Case "SANTO TOME"
        AcortarValor = "STO. TOME"
    Case "SAUCE VIEJO"
        AcortarValor = "S. VIEJO"
    'Case "URGENTE"
    '    AcortarValor = "U"
    'Case "NORMAL"
    '    AcortarValor = "N"
    Case Else
        AcortarValor = cadena
End Select
End Function

Function GetColPos(Campo As String, ByRef Colu As Long) As Integer
Select Case Campo
    Case "N° Orden:"
        Colu = 1
        GetColPos = 0
    Case "Fecha Orden:"
        Colu = 2
        GetColPos = 0
    Case "N° Cliente:"
        Colu = 3
        GetColPos = 0
    Case "Nom./Razón Soc.:"
        Colu = 4
        GetColPos = 0
    Case "Nombre Fantasía:"
        Colu = 2
        GetColPos = 1
    Case "Localidad:"
        Colu = 7
        GetColPos = 0
    Case "Calle:"
        Colu = 5
        GetColPos = 0
    Case "N°:"
        Colu = 5
        GetColPos = 0
    Case "Teléfono:"
        Colu = 3
        GetColPos = 1
    Case "Horario de Visita:"
        Colu = 6
        GetColPos = 0
    Case "Referencia de Domicilio:"
        Colu = 4
        GetColPos = 1
    Case "Marca y Modelo:"
        Colu = 8
        GetColPos = 0
    Case "N° AF:"
        Colu = 9
        GetColPos = 0
    Case "Síntoma:"
        Colu = 10
        GetColPos = 0
    Case "Prioridad:"
        Colu = 5
        GetColPos = 1
    Case "Reclamo:"
        Colu = 6
        GetColPos = 1
    Case "Descripción del Problema:"
        Colu = 7
        GetColPos = 1
End Select
End Function

Function GetColPos2(Campo As String, ByRef Colu As Long) As Integer
Select Case Campo
    Case "N° Orden:"
        Colu = 1
        GetColPos2 = 0
    Case "Fecha Orden:"
        Colu = 2
        GetColPos2 = 0
    Case "N° Cliente:"
        Colu = 3
        GetColPos2 = 0
    Case "Nom./Razón Soc.:"
        Colu = 4
        GetColPos2 = 0
    Case "Nombre Fantasía:"
        Colu = 11
        GetColPos2 = 1
    Case "Localidad:"
        Colu = 7
        GetColPos2 = 0
    Case "Calle:"
        Colu = 5
        GetColPos2 = 0
    Case "N°:"
        Colu = 5
        GetColPos2 = 0
    Case "Teléfono:"
        Colu = 12
        GetColPos2 = 1
    Case "Horario de Visita:"
        Colu = 6
        GetColPos2 = 0
    Case "Referencia de Domicilio:"
        Colu = 13
        GetColPos2 = 1
    Case "Marca y Modelo:"
        Colu = 8
        GetColPos2 = 0
    Case "N° AF:"
        Colu = 9
        GetColPos2 = 0
    Case "Síntoma:"
        Colu = 10
        GetColPos2 = 0
    Case "Prioridad:"
        Colu = 14
        GetColPos2 = 1
    Case "Reclamo:"
        Colu = 15
        GetColPos2 = 1
    Case "Descripción del Problema:"
        Colu = 16
        GetColPos2 = 1
End Select
End Function

Function Hexa2Ansi(cadena As String) As String
'Convierte una cedana Hexa en ASCII
Dim I As Long
Dim Hexa As String
Dim car As Byte
Dim retCad As String

If Len(cadena) Mod 2 <> 0 Then
    Hexa2Ansi = ""
Else
    retCad = ""
    For I = 1 To Len(cadena) Step 2
        Hexa = Mid(cadena, I, 2)
        retCad = retCad + Chr(CByte("&H" + Hexa))
    Next I
End If
Hexa2Ansi = retCad
End Function

Function parseTexto(cadena As String, mat() As String) As Long
'Divide una linea de texto (ver ejemplo) obteniendo una cadena Hexa contenida entre < y >
'Ejemplo: 542.75 Td <304536303136333833>Tj ET 0 g BT 141.75 542.75 Td <4E6F6D2E2F52617AF36E20536F632E3A>Tj ET 0 g BT 226.75 542.75 Td <41475549525245204D4152494120414C454A414E445241>Tj ET 0 g BT 453.55 542.75 Td <4E6F6D6272652046616E746173ED613A>Tj
Dim cadCopy As String
Dim Inicio As Long
Dim Fin As Long
Dim Maxi As Long


ReDim mat(0)
Maxi = -1
cadCopy = cadena
Do
    Inicio = InStr(1, cadCopy, "<") + 1
    Fin = InStr(1, cadCopy, ">")
    If Inicio > 1 Then
        Maxi = Maxi + 1
        ReDim Preserve mat(Maxi)
        mat(Maxi) = Mid(cadCopy, Inicio, (Fin - Inicio))
    End If
    cadCopy = Mid(cadCopy, Fin + 1, Len(cadCopy))
Loop Until Inicio = 1
parseTexto = Maxi
End Function

Function EsNuevoPedido(cadena As String) As Boolean
EsNuevoPedido = (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO")
End Function

Function EsCampo(cadena As String) As Boolean
Dim bAcu As Boolean

bAcu = False
bAcu = bAcu Or (cadena = "N° Orden:")
bAcu = bAcu Or (cadena = "Fecha Orden:")
bAcu = bAcu Or (cadena = "Fecha Prev. Solución:")
bAcu = bAcu Or (cadena = "Técnico:")
bAcu = bAcu Or (cadena = "N° Cliente:")
bAcu = bAcu Or (cadena = "Nom./Razón Soc.:")
bAcu = bAcu Or (cadena = "Nombre Fantasía:")
bAcu = bAcu Or (cadena = "Contacto:")
bAcu = bAcu Or (cadena = "Provincia:")
bAcu = bAcu Or (cadena = "Localidad:")
bAcu = bAcu Or (cadena = "Barrio:")
bAcu = bAcu Or (cadena = "Calle:")
bAcu = bAcu Or (cadena = "N°:")
bAcu = bAcu Or (cadena = "Teléfono:")
bAcu = bAcu Or (cadena = "Horario de Visita:")
bAcu = bAcu Or (cadena = "Referencia de Domicilio:")
bAcu = bAcu Or (cadena = "Tipo:")
bAcu = bAcu Or (cadena = "Marca y Modelo:")
bAcu = bAcu Or (cadena = "N° AF:")
bAcu = bAcu Or (cadena = "N° E.C:")
bAcu = bAcu Or (cadena = "Observaciones:")
bAcu = bAcu Or (cadena = "Síntoma:")
bAcu = bAcu Or (cadena = "Prioridad:")
bAcu = bAcu Or (cadena = "Reclamo:")
bAcu = bAcu Or (cadena = "Descripción del Problema:")
bAcu = bAcu Or (cadena = "Fecha Visita:")
bAcu = bAcu Or (cadena = "N° A.F.:")
bAcu = bAcu Or (cadena = "Realizado Por:")
bAcu = bAcu Or (cadena = "Tipo Falla:")
bAcu = bAcu Or (cadena = "Descripción:")
EsCampo = bAcu
End Function

Function EsTitulo(cadena As String) As Boolean
Dim bAcu As Boolean

bAcu = False
bAcu = bAcu Or (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO")
bAcu = bAcu Or (cadena = "Datos Orden")
bAcu = bAcu Or (cadena = "Datos Cliente")
bAcu = bAcu Or (cadena = "Datos Equipo")
bAcu = bAcu Or (cadena = "Datos Falla")
bAcu = bAcu Or (cadena = "Datos Última Visita")
EsTitulo = bAcu
End Function

Function Str2Campo(strCampo As String) As String
Select Case strCampo
    Case "N° Orden:"
        Str2Campo = "NumOrden"
    Case "Fecha Orden:"
        Str2Campo = "FechaOrden"
    Case "N° Cliente:"
        Str2Campo = "NumCliente"
    Case "Nom./Razón Soc.:"
        Str2Campo = "Nombre"
    Case "Nombre Fantasía:"
        Str2Campo = "Fantasia"
    Case "Localidad:"
        Str2Campo = "Localidad"
    Case "Calle:"
        Str2Campo = "Calle"
    Case "N°:"
        Str2Campo = "Altura"
    Case "Teléfono:"
        Str2Campo = "Telefono"
    Case "Horario de Visita:"
        Str2Campo = "HorarioVisita"
    Case "Referencia de Domicilio:"
        Str2Campo = "RefDomicilio"
    Case "Marca y Modelo:"
        Str2Campo = "MarcaYModelo"
    Case "N° AF:"
        Str2Campo = "NumAF"
    Case "Síntoma:"
        Str2Campo = "Sintoma"
    Case "Prioridad:"
        Str2Campo = "Prioridad"
    Case "Reclamo:"
        Str2Campo = "Reclamo"
    Case "Descripción del Problema:"
        Str2Campo = "DescribeProblema"
End Select
End Function

Espero te sea útil...

Saludos!




Muchas gracias por tu aporte y por tu pronta respuesta.
En línea

Páginas: [1] Ir Arriba Respuesta Imprimir 

Ir a:  

WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines