Jump to content

LeandroA

Members
  • Content Count

    176
  • Joined

  • Last visited

  • Days Won

    4

LeandroA last won the day on November 19 2016

LeandroA had the most liked content!

2 Followers

About LeandroA

  • Rank
    Advanced Member
  • Birthday 10/07/1976

Contact Methods

  • Website URL
    www.leandroascierto.com

Profile information

  • Gender
    Hombre
  • Localización:
    Argentina

Converted

  • Campos
    ;

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

  1. hola como primer medida creo que tendrias que hacer esto en la pc que ejecute el excel https://helpx.adobe.com/la/acrobat/using/enable-pdf-thumbnail-preview-windows-explorer.html luego para extraer la imagen desde macros es un poco complicado a la hora de si se s ejecuta en un windows de 32 o 64 bits creo que la forma mas fácil y segura es si se programa en un ejecutable o una dll que exporte la miniatura a un archivo de imagen o directamente al portapapeles y luego con las macros la pegas o la lees, si te interesa alguna de estas opciones veo si puedo hacer algo, solo confirmame para no hacerlo al pepe.
  2. hola la verdad no se porque sera, no se si te lo hace con todos los archivos o con el que estas actualmente, quizas estes con un archivo de una version vieja de excel? igualmente aprovecho para hacer publicidad de mi editor con este seguramente no vas a tener ese problema Saludos y me cuentas si te sirvió.
  3. hola no estoy seguro si hacerlo con un lector no saltara dos celda, pero bien por mi parte la solucion que me viene a la cabeza es utilizar un userform con un cuadro de texto, quizas el lector arroje algún caracter especial que ayude a identificarlo de si es un tipeo o una lectora. todo esto lo puede hacer en el evento TextBox1_KeyDown en caso que no arroje ningún carácter especial, si entre el primer caracter y el ultimo caracter existe mas de un cierto tiempo es porque se ha tipeado el código a mano. cuando KeyCode = 13 (o 10 según el lector) debe volcar el contenido del textbox a la ultima celda. espero haber echo entender y espero sepa como llevar a cabo dicha solución propuesta.
  4. hola podes hacerlo asi Public Sub CambiarForma() Dim c As Comment For Each c In ActiveSheet.Comments c.Shape.AutoShapeType = 10 Next End Sub
  5. Muy bueno no sabia que los comentarios se podían tratar como shapes
  6. hola este tema ya estaba resuelto o sacan la información de un mismo lugar 'Para mostrar un UserForm sin barra de titulo necesitamos cuatro funciones API: Private Const GWL_STYLE = -16 Private Const WS_CAPTION = &HC00000 #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr #Else Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr #End If Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr #Else Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If Private Sub UserForm_Initialize() 'Este código realiza el procedimiento de ocultar la barra de título, haciendo uso de las API Dim lngWindow, lFrmHdl lFrmHdl = FindWindowA(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl)
  7. hola Josera por las dudas descomprimiste todo del archivo Libro1 + mapa.html?
  8. @bigpetroman Hola, si es cierto que cuelga el programa en x64 pero al quitar ese tercer parámetro deja de funcionar el hook, por eso no te tira mas el error, pero tampoco cambia el texto de los botones, el problema esta en la función ObjectFromPtr (ya corregido) fijate que el autor puso en win64 CopyMemory obj, lPtr, 4 y CopyMemory obj, 0&, 4 siendo que lPtr en win64 en longptr por lo tanto tienen un largo de 8 y no 4 #If Win64 Then Private Property Get ObjectFromPtr(ByVal lPtr As LongPtr) As Object Dim obj As Object CopyMemory obj, lPtr, 8 Set ObjectFromPtr = obj CopyMemory obj, 0&, 8 End Property #Else Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object Dim obj As Object CopyMemory obj, lPtr, 4 Set ObjectFromPtr = obj CopyMemory obj, 0&, 4 End Property #End If CustomMsgbox (1).xlsm
  9. hola como lo haces desde el evento exit debes cancelar la salida del foco si no se cumple la condición pero también tienes que tener en cuenta que el usuario no quiera cerrar el formulario por lo tanto debes verificar si este esta visible. Private Sub cboNitProveedor_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.Visible = False Then Exit Sub If txtProveedor = "" Then If MsgBox("El proveedor no existe en la base de datos" & vbNewLine & _ "Agreguelo a la lista con el botón " & Chr(34) & "Agregar Proveedor" & Chr(34), vbInformation + vbRetryCancel, Titulo) = vbRetry Then 'cboNitProveedor.SetFocus cboNitProveedor.SelStart = 0 cboNitProveedor.SelLength = Len(cboNitProveedor) Cancel = True End If End If End Sub
  10. hola si efectivamente el servicio no da mas de 200 registros por lo tanto las consultas no deberian ser mayor a las de un dia, para hacer la consulta de un mes usted deberia hacer un bucle desde el primer dia del mes hasta el ultimo y llamara a la funcion con las mismas fechas y su codigo. esta es la función que esta en el userform póngala en un modulo publico y como tarea cree una macro que realize el bucle antes mencionado. Public Sub Consultar(ByVal FechaInicial As String, ByVal FechaFinal As String, ByVal Codigo As String) Dim xmlhttp, HtmlDoc, Objs Dim i As Long, j As Long, sText As String Dim Mat(1 To 200, 1 To 18) If Len(Codigo) < 9 Then MsgBox "La partida debe tener 9 dígitos como mínimo" Exit Sub End If If Not IsDate(FechaInicial) Or Not IsDate(FechaFinal) Then MsgBox "Fecha invalida" Exit Sub End If FechaInicial = Replace(Format(FechaInicial, "dd/mm/yyyy"), "/", "%2F") FechaFinal = Replace(Format(FechaFinal, "dd/mm/yyyy"), "/", "%2F") Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP") Set HtmlDoc = CreateObject("htmlfile_FullWindowEmbed") xmlhttp.Open "POST", "http://www.aduanet.gob.pe/cl-ad-itestdesp/Sgboletin", False xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlhttp.send "orden=part&FecInicial=" & FechaInicial & "&FecFinal=" & FechaFinal & "&codigo=" & Codigo HtmlDoc.body.innerHTML = StrConv(xmlhttp.responseBody, vbUnicode) Set xmlhttp = Nothing If HtmlDoc.getElementsByTagName("table").Length = 0 Then MsgBox "Sin Resultados" Exit Sub End If Set Objs = HtmlDoc.getElementsByTagName("table")(0).Rows For i = 2 To Objs.Length For j = 0 To 17 Mat(i - 1, j + 1) = Objs(i - 1).Cells(j).innerText Next Next Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(Objs.Length, 18) = Mat sText = HtmlDoc.getElementsByTagName("font")(0).innerText 'Descripcion General MsgBox "Se han añadido " & Objs.Length - 1 & " resultados de" & vbCrLf & vbCrLf & sText Erase Mat Set Objs = Nothing Set HtmlDoc = Nothing Unload Me End Sub Saludos.
  11. Hola te adjunto lo que pedís, pero seguramente tendrás que hacer algún pequeño ajuste mas a tu comodidad. Saludos. Consulta.xlsm
  12. hola proba con estas declaraciones. Option Explicit 'Para mostrar un UserForm sin barra de titulo necesitamos cuatro funciones API: Private Const GWL_STYLE = -16 Private Const WS_CAPTION = &HC00000 #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr #Else Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr #End If Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr #Else Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If Private Sub UserForm_Initialize() 'Este código realiza el procedimiento de ocultar la barra de título, haciendo uso de las API Dim lngWindow, lFrmHdl lFrmHdl = FindWindowA(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) '----------------------------------------------------------------------------------------- 'Cargamos el formulario y establecemos un timer para que se cierre automáticamente Dim Contador, Maximo, Intervalo As Double ' As Integer Dim Inicio As Double Dim X Intervalo = 0.001 Maximo = 300 Me.Show For Contador = 1 To Maximo Inicio = Timer Do Until Timer - Inicio > Intervalo X = DoEvents() Loop Me.lbl_Bar.Width = Contador Me.lbl_Percent.Caption = "Cargando " & Format(Contador / Maximo, "Percent") Next Contador frm_login.Show End End Sub
  13. Hola proba esto, parece andar bien, pone el código en un modulo, seguramente se pueden quitar algunas lineas que están de mas. Option Explicit #If VBA7 Then Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr) #Else Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) #End If Private Const VK_SNAPSHOT As Long = &H2C Private Const VK_LMENU As Long = &HA4 Private Const KEYEVENTF_KEYUP As Long = &H2 Public Sub PrintActiveFrom() DoEvents keybd_event VK_LMENU, 0, 0, 0 keybd_event VK_SNAPSHOT, 0, 0, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 keybd_event VK_LMENU, 0, KEYEVENTF_KEYUP, 0 DoEvents With Workbooks.Add().ActiveSheet .PasteSpecial .Range("A1").Select With .PageSetup .PrintArea = "" .Orientation = xlLandscape .PrintTitleRows = "" .PrintTitleColumns = "" .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.75) .RightMargin = Application.InchesToPoints(0.75) .TopMargin = Application.InchesToPoints(1) .BottomMargin = Application.InchesToPoints(1) .HeaderMargin = Application.InchesToPoints(0.5) .FooterMargin = Application.InchesToPoints(0.5) .PrintHeadings = False .PrintGridlines = False .CenterHorizontally = True .CenterVertically = True .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With .PrintOut Copies:=1 End With ActiveWorkbook.Close False End Sub
  14. LeandroA

    timeout

    Hola con la propiedad SetTimeouts podes darle el tiempo que quieras. S Sub web() Set httpRequest = CreateObject("WinHttp.winHttpRequest.5.1") With httpRequest .Option(4) = &H100 .Open "GET", "http:......." .SetTimeouts 5000, 5000, 5000, 5000 .send If .Status = 200 Then MsgBox .responseBody End If End With End Sub
×
×
  • Create New...

Important Information

Privacy Policy