Jump to content

ikanni

Members
  • Posts

    340
  • Joined

  • Last visited

  • Days Won

    9
  • Country

    Spain

ikanni last won the day on November 16 2020

ikanni had the most liked content!

2 Followers

Profile information

  • Localización:
    Tafalla

Converted

  • Campos
    ;

Recent Profile Visitors

2,464 profile views

ikanni's Achievements

  1. Hola, Te dejo una función que cambia el tamaño de una imagen. Úsalo cómo necesites. Uso el objeto Windows Image Acquisition (WIA). Además sin perder nada de calidad. Cualquier duda pregunta. Sub Llamamos() RutaOriginal = "C:\...\..\img1.xxx" RutaFinal= "C:\...\..\img1.xxx" Call WIA_CambiaTamano(RutaOriginal, RutaFinal, 400, 300) end sub Function WIA_CambiaTamano(RutaImgOriginal As String, RutaImgConvertida As String, _ AnchoMax As Long, AltoMax As Long) On Error GoTo error_Handler Dim oWIA As Object Dim oIP As Object Set oWIA = CreateObject("WIA.ImageFile") Set oIP = CreateObject("WIA.ImageProcess") With oIP .Filters.Add oIP.FilterInfos("Scale").FilterID .Filters(1).Properties("MaximumWidth") = AnchoMax .Filters(1).Properties("MaximumHeight") = AltoMax End With oWIA.LoadFile RutaImgOriginal Set oWIA = oIP.Apply(oWIA) oWIA.SaveFile RutaImgConvertida Error_Handler_Exit: On Error Resume Next If Not oIP Is Nothing Then Set oIP = Nothing If Not oWIA Is Nothing Then Set oWIA = Nothing Exit Function error_Handler: MsgBox "Ha ocurrido un error" & vbCrLf & vbCrLf & _ "Error Número: " & Err.Number & vbCrLf & _ "Error Dónde: WIA_CambiaTamano" & vbCrLf & _ "Error Descripción: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Linea No: " & Erl) _ , vbOKOnly + vbCritical, "Vaya!" Resume Error_Handler_Exit End Function
  2. Hola, Aquí hay algo https://vba846.wordpress.com/2019/11/24/automatizacion-word-excel/
  3. Hola Benito, Pega este codigo en en el modulo de la hoja. Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$2" Then [B3] = "": [B3] = BuscaNombre(CLng(Target)) Application.EnableEvents = True End Sub Function BuscaNombre(ID As Long) As String On Error GoTo Ctrl_Err Dim miConexion As New ADODB.Connection Dim RS As New ADODB.Recordset Dim CadenaSql As String With miConexion If .State = 1 Then .Close ' access2010 .Provider = "Microsoft.ACE.OLEDB.12.0" 'Ruta BBDD .ConnectionString = Application.ActiveWorkbook.path & "\BBDD.accdb" .Open End With CadenaSql = "SELECT tb_cliente.nombre FROM tb_cliente" & _ " WHERE (((tb_cliente.Id_Cliente)=" & ID & "));" With RS If .State = 1 Then .Close .CursorLocation = 3 .Open CadenaSql, miConexion, 3, 1 BuscaNombre = !nombre End With RS.Close salir: Set RS = Nothing miConexion.Close: Set miConexion = Nothing Exit Function Ctrl_Err: If Err.Number = 3021 Then MsgBox "No existe este registro" Else MsgBox "Algo no ha funcionado" End If GoTo salir End Function Lo hago con un ADO. COn conexion a Access 2010 si tuvieras otro habrá que cambiar la cadena de conexión. Ha considerar: tu tenias activada la Referencia Microsoft Active Data Object LIbrary 2.8, desactivala y activa una mayor, con ADO nunca se sabe. En mi caso con Excel 2010 : Microsoft Active Data Object LIbrary 6.1. Ah se me olvidaba, He visto en la tabla de access que la indexacion está hecha con el Numero de cliente y no con el ID, yo le pondria el ID. Y he supuesto que buscas con el ID, sino tedrás que cambiar la cadena SQL.
  4. Hola, Sería mas o menos así ... MyArray=(1,2,3) for x=1 to 3 if tipo=MyArray(x) then Msgbox "Encontrado": Exit function/Sub ' o lo que sea next x .....
  5. Hola Pirtrafilla, Preguntas : ¿Los PDF están todo en una carpeta? Si la respuesta es NO, ¿Cómo estan distribuidos los ficheros? Un mapita de como estan los pdf vendría bien para poder abordar una solución.
  6. Hola benjarc, No he trbajado con formularios de word y no tengo ninguno para trabajar. Pero la solución a tu problema yo lo plantearía de la siguiente manera. El formulario Word tendrá un botón o algo parecido para grabar los datos que envías al propio documento. En ese momento sería automatizar el ingreso de los datos en otra aplicación como Excel o Access. Y ¿Cómo? Pues seguro que hay un momtón de ejemplos en el foro que te ayudan a construir algo. Por darte una idea yo si sería a Access lo haría con una consulta de actualizacion usando ADO. Y con Excel dependería la cantidad de campos que tenga el registro, con muchos lo haría con un recordset, insertando directamente la fila y con pocos pues igual lo hacía directamente en la hoja. Esa es más o menos la teoría, claro con un ejemplo se podría afinar más. Un saludo
  7. Te dejo el formulario apañado. Saludos Gestor Documental (v.prueba)(3).xlsm
  8. Hola Pirtrafilla, A ver si te vale el apaño. Hecho por fuerza bruta😃 Gestor Documental (v.prueba)(2).xlsm
  9. Hola Piltrafilla, Te he hecho un apaño, ya que yo cambiaría todo🙄, pero no hay tiempo. Te busca en todas las subcarpetas que haya en la carpeta seleccionada y la ruta se ve tambien en el listbox. Espero te sirva. Gestor Documental (v.prueba).xlsm
  10. Hola joseppp, No está nada claro lo que pides, pero bueno hqciendo un esfuerzo por entenderte, mira a ver sí es esto lo que buscas. Dale el botoncito rojo y te creará los cuadrantes individualizados para enviarlos pero cuando termine se queda como estaba. Espartano pero efectivo siempre y cuando no se han miles de correos 😉 . Prueba1(1).xlsm
  11. Hola Vladimir, Aquí una manera de hacer lo demandas. Sub ColoreaAlterno() Dim strCad As String, varVal As Long, miColor As Long, d As Range Set d = Hoja1.Range("A2:A" & Hoja1.Range("A" & Rows.Count).End(xlUp).Row) miColor = vbYellow varVal = [a2].Value For Each celda In d If celda = varVal Then celda.Interior.Color = miColor Else varVal = celda miColor = IIf(miColor = vbGreen, vbYellow, vbGreen) celda.Interior.Color = miColor End If Next celda End Sub End Sub
  12. Hola Joselica, ibas bien encaminada. Cambia en tu procedimiento 'StarBlink' la parte que esta por esta With rRange If .Interior.ColorIndex = 3 Then .Interior.ColorIndex = xlNone .Font.Color = vbBlack Else .Interior.ColorIndex = 3 .Font.Color = vbWhite End If End With SAludos
  13. Hola Joselica, El criterio del filtro avanzado no lo has creado bien, es mas sencillo. Cambia este procedimiento por el tuyo Private Sub TextBox1_Change() criteriofiltro = "*" & Hoja1.TextBox1.Text & "*" If TextBox1.Text <> "" Then Hoja1.Range("B7").AutoFilter Field:=2, Criteria1:=criteriofiltro Else Hoja1.ListObjects("Table1").Range.AutoFilter Field:=2 End If End Sub
×
×
  • Create New...

Important Information

Privacy Policy