Esta funcion verifica si el texto ingresado es numero, yo lo utilizo cuando pierde el foco el textbox.
espero te sirva Dario.
Private Sub Text1_LostFocus()
If Not IsNumeric(Me.Text1.Text) Then
MsgBox ("Ingrese solo numeros")
End If
End Sub
| |||
Otra Forma Para Ingresar Solo Numeros Esta funcion verifica si el texto ingresado es numero, yo lo utilizo cuando pierde el foco el textbox. espero te sirva Dario. Private Sub Text1_LostFocus() If Not IsNumeric(Me.Text1.Text) Then MsgBox ("Ingrese solo numeros") End If End Sub |
| ||||
Imprimir un RichTextBox tal y como se ve: Imprimir un RichTextBox con su formato original. Private Sub Command1_Click() On Error GoTo ErrorDeImpresion Printer.Print "" RichTextBox1.SelPrint Printer.hDC Printer.EndDoc Exit Sub ErrorDeImpresion: Exit Sub End Sub Otra forma: En el Formulario [Form1 por defecto] :Private Sub Form_Load() Dim LineWidth As Long Me.Caption = "Rich Text Box Ejemplo de Impresion" Command1.Move 10, 10, 600, 380 Command1.Caption = "&Imprimir" RichTextBox1.SelFontName = "Verdana, Tahoma, Arial" RichTextBox1.SelFontSize = 10 LineWidth = WYSIWYG_RTF(RichTextBox1, 1440, 1440) Me.Width = LineWidth + 200End Sub Private Sub Form_Resize() RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600End Sub Private Sub Command1_Click() PrintRTF RichTextBox1, 1440, 1440, 1440, 1440End Sub Crear un módulo y escribir: Private Type Rect Left As Long Top As Long Right As Long Bottom As Long End Type Private Type CharRange cpMin As Long cpMax As Long End Type Private Type FormatRange hdc As Long hdcTarget As Long rc As Rect rcPage As Rect chrg As CharRange End Type Private Const WM_USER As Long = &H400 Private Const EM_FORMATRANGE As Long = WM_USER + 57 Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72 Private Const PHYSICALOFFSETX As Long = 112 Private Const PHYSICALOFFSETY As Long = 113 Private Declare Function GetDeviceCaps Lib "gdi32" ( _ ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _ (ByVal lpDriverName As String, ByVal lpDeviceName As String, _ ByVal lpOutput As Long, ByVal lpInitData As Long) As Long Public Function WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, _ RightMarginWidth As Long) As Long Dim LeftOffset As Long, LeftMargin As Long, RightMargin As Long Dim LineWidth As Long Dim PrinterhDC As Long Dim r As Long Printer.Print Space(1) Printer.ScaleMode = vbTwips LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _ PHYSICALOFFSETX), vbPixels, vbTwips) LeftMargin = LeftMarginWidth - LeftOffset RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset LineWidth = RightMargin - LeftMargin PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0) r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _ ByVal LineWidth) Printer.KillDoc WYSIWYG_RTF = LineWidth End Function Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _ TopMarginHeight, RightMarginWidth, BottomMarginHeight) Dim LeftOffset As Long, TopOffset As Long Dim LeftMargin As Long, TopMargin As Long Dim RightMargin As Long, BottomMargin As Long Dim fr As FormatRange Dim rcDrawTo As Rect Dim rcPage As Rect Dim TextLength As Long Dim NextCharPosition As Long Dim r As Long Printer.Print Space(1) Printer.ScaleMode = vbTwips LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _ PHYSICALOFFSETX), vbPixels, vbTwips) TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _ PHYSICALOFFSETY), vbPixels, vbTwips) LeftMargin = LeftMarginWidth - LeftOffset TopMargin = TopMarginHeight - TopOffset RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset rcPage.Left = 0 rcPage.Top = 0 rcPage.Right = Printer.ScaleWidth rcPage.Bottom = Printer.ScaleHeight rcDrawTo.Left = LeftMargin rcDrawTo.Top = TopMargin rcDrawTo.Right = RightMargin rcDrawTo.Bottom = BottomMargin fr.hdc = Printer.hdc fr.hdcTarget = Printer.hdc fr.rc = rcDrawTo fr.rcPage = rcPage fr.chrg.cpMin = 0 fr.chrg.cpMax = -1 TextLength = Len(RTF.Text) Do NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr) If NextCharPosition >= TextLength Then Exit Do fr.chrg.cpMin = NextCharPosition Printer.NewPage Printer.Print Space(1) fr.hDC = Printer.hDC fr.hDCTarget = Printer.hDC Loop Printer.EndDoc r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0)) End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
Pregunta: ¿Cómo usar un Array? Respuesta : Un array permite referirse a una serie de elementos del mismo tipo por un mismo nombre y referenciar un único elemento de la serie utilizando un índice. Visual Basic, igual que sus predecesores, permite definir arrays de variables de una o más dimensiones y de cualquier tipo de datos (tipos fundamentales y tipos definidos por el usuario), e introduce una nueva clase de arrays de controles, necesarios para escribir menús, para crear nuevos controles en tiempo de ejecución o para hacer que una serie de controles tengan asociado un mismo procedimiento para cada tipo de suceso. Arrays de variables Los arrays discutidos en este apartado permiten referirse a una serie de variables por un mismo nombre y acceder individualmente a cada una de ellas utilizando un índice (variables subindicadas). Este tipo de arrays tiene que declararse en el código y pueden tener una o más dimensiones. Arrays estáticos Para declarar un array estático (array con un número fijo de elementos), Visual Basic hace tres consideraciones importantes: Para declarar un array global, hágalo en la sección de declaraciones de un módulo utilizando la sentencia Public. Para declarar un array a nivel de un módulo, hágalo en la sección de declaraciones del módulo utilizando la sentencia Public o Dim. Para declarar un array local a un procedimiento, utilice la sentencia Dim o Static dentro del propio procedimiento. A diferencia de otras versiones de Basic, Visual Basic no permite declarar implícitamente un array. Un array tiene que ser declarado explícitamente, y los índices del mismo deben estar en el rango (-2.147.483.648 a 2.147.483.647). A continuación se muestran algunos ejemplos: Dim Array_A(19) As String Este ejemplo declara un array de una dimensión, Array_A, con veinte elementos, Array_A(0), Array_A(1),..., Array_A(19), cada uno de los cuales permite almacenar una cadena de caracteres de longitud variable. Dim Array_B(3, 1 To 6) As Integer Este ejemplo declara un array de dos dimensiones, Array_B, con 4x6 elementos, Array_B(0,1),..., Array_B(3,6), de tipo entero. Static Array_C(1 To 5, 1 To 5) As Integer Este ejemplo declara un array de dos dimensiones, Array_C, con 5x5 elementos, Array_C(1,1),..., Array_C(5,5), de tipo entero. Public Array_D(1 To 12) As String *60 Este ejemplo declara un array de una dimensión, Array_D, con doce elementos, Array_D(1),..., Array_D(12), cada uno de los cuales permite almacenar una cadena de caracteres de longitud fija (60 caracteres). Arrays Dinámicos Cuando las dimensiones de un array no son siempre las mismas, la mejor forma de especificarlas es mediante variables. Un array declarado de esta forma es un array dinámico. El espacio necesario para un array estático se asigna al iniciarse el programa y permanecerá fijo. El espacio para un array dinámico será asignado en cualquier momento durante la ejecución. Para crear un array dinámico. Declare el array en la sección de declaraciones de un módulo con una sentencia Public si lo quiere global con Private o Dim si lo quiere s nivel del módulo, o en un procedimiento con Static o Dim si lo quiere local. Para especificar que el array va a ser dinámico deje la lista de dimensiones vacía. Por ejemplo: Dim Array_A() Asigne el número actual de elementos con la sentencia ReDim. ReDim Array_A(N+1) La sentencia ReDim puede aparecer solamente en un procedimiento y permite cambiar el número de elementos del array, no el número de dimensiones. Por ejemplo, si declaramos el array_A a nivel de un módulo. Private Array_A() as Integer Para asignarle espacio al array utilizamos: ReDim Array_A(5) Cada vez que se ejecuta la sentencia ReDim, todos los valores almacenados en el array se pierden. Cuando le interese cambiar el tamaño del array conservando los valores del array, ejecute ReDim con la palabra clave Preserve. Por ejemplo, supongamos un Array_A de dos dimensiones. La sentencia será: ReDim Preserve Array_A(8) Esto es un Array, espero nos sirva la explicación
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
Pregunta : ¿Como restar fechas u Horas? Respuesta : Dos ejemplos de cómo restar fechas y horas. Para saber los segundos entre dos horas o los días entre dos fechas. Crea un form con los siguientes controles, dejale los nombre por defecto. 4 TextBox 2 Labels 2 Commands Distribuyelos para que los dos primeros TextoBoxes estén con el primer label y command, lo mismo con el resto. Añade lo siguiente al form y pulsa F5 'Ejemplo de prueba para restar fechas y horas
Código:
Option Explicit Private Sub Command1_Click() Dim t0 As Variant, t1 As Variant 'Text1 Tendrá una fecha anterior 'Text2 tendrá la nueva fecha t0 = DateValue(Text1) t1 = DateValue(Text2) Label1 = t1 - t0 End Sub Private Sub Command2_Click() Dim t0 As Variant, t1 As Variant 'Text3 Tendrá una hora anterior Text4 = Format(Now, "hh:mm:ss") t0 = Format(Text3, "hh:mm:ss") t1 = Format(Text4, "hh:mm:ss") Label2 = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss") End Sub Private Sub Form_Load() 'Para probar la diferencia de fechas Text1 = DateValue(Now) Text2 = DateValue(Now + 10) ' 'Para probar la diferencia de horas Text3 = Format(Now, "hh:mm:ss") Text4 = Format(Now, "hh:mm:ss") Command1_Click Command2_Click End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
![]() Pregunta: Como apagar, reiniciar o salir del sistema? Respuesta: usa la API ExitWindowsEx Copia todo este codigo en un modulo, despues en tu formulario, o donde lo necesites unicamente llama a las funciones necesarias:
Código:
y para usarlas nomas asi:Option Explicit Public Const TOKEN_ADJUST_PRIVILEGES As Long = &H20 Public Const TOKEN_QUERY As Long = &H8 Public Const SE_PRIVILEGE_ENABLED As Long = &H2 Public Const EWX_LOGOFF As Long = &H0 Public Const EWX_SHUTDOWN As Long = &H1 Public Const EWX_REBOOT As Long = &H2 Public Const EWX_FORCE As Long = &H4 Public Const EWX_POWEROFF As Long = &H8 Public Const EWX_FORCEIFHUNG As Long = &H10 '2000/XP only Public Const VER_PLATFORM_WIN32_NT As Long = 2 Public uflags As Long Public success As Long 'TIPO DE DATOS PARA LAS APIS Public Type OSVERSIONINFO OSVSize As Long dwVerMajor As Long dwVerMinor As Long dwBuildNumber As Long PlatformID As Long szCSDVersion As String * 128 End Type Public Type LUID dwLowPart As Long dwHighPart As Long End Type Public Type LUID_AND_ATTRIBUTES udtLUID As LUID dwAttributes As Long End Type Public Type TOKEN_PRIVILEGES PrivilegeCount As Long laa As LUID_AND_ATTRIBUTES End Type 'DECLARACION DE LAS APIS A USAR Public Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long Public Declare Function GetCurrentProcess Lib "kernel32" () As Long Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As Any, ReturnLength As Long) As Long Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long 'FUNCION PARA SABER QUE SISTEMA OPERATIVO CORRE 'returns True if running Windows NT, 'Windows 2000, Windows XP, or .net server Public Function IsWinNTPlus() As Boolean #If Win32 Then Dim OSV As OSVERSIONINFO OSV.OSVSize = Len(OSV) If GetVersionEx(OSV) = 1 Then IsWinNTPlus = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And (OSV.dwVerMajor >= 4) End If #End If End Function 'FUNCION PARA DAR LOS PERMISOS NECESARIOS Public Function EnableShutdownPrivledges() As Boolean Dim hProcessHandle As Long Dim hTokenHandle As Long Dim lpv_la As LUID Dim token As TOKEN_PRIVILEGES hProcessHandle = GetCurrentProcess() If hProcessHandle <> 0 Then 'open the access token associated 'with the current process. hTokenHandle 'returns a handle identifying the 'newly-opened access token If OpenProcessToken(hProcessHandle, _ (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), _ hTokenHandle) <> 0 Then 'obtain the locally unique identifier '(LUID) used on the specified system 'to locally represent the specified 'privilege name. Passing vbNullString 'causes the api to attempt to find 'the privilege name on the local system. If LookupPrivilegeValue(vbNullString, _ "SeShutdownPrivilege", _ lpv_la) <> 0 Then 'TOKEN_PRIVILEGES contains info about 'a set of privileges for an access token. 'Prepare the TOKEN_PRIVILEGES structure 'by enabling one privilege. With token .PrivilegeCount = 1 .laa.udtLUID = lpv_la .laa.dwAttributes = SE_PRIVILEGE_ENABLED End With 'Enable the shutdown privilege in 'the access token of this process. 'hTokenHandle: access token containing the ' privileges to be modified 'DisableAllPrivileges: if True the function ' disables all privileges and ignores the ' NewState parameter. If FALSE, the ' function modifies privileges based on ' the information pointed to by NewState. 'token: TOKEN_PRIVILEGES structure specifying ' an array of privileges and their attributes. ' 'Since were just adjusting to shut down, 'BufferLength, PreviousState and ReturnLength 'can be passed as null. If AdjustTokenPrivileges(hTokenHandle, _ False, _ token, _ ByVal 0&, _ ByVal 0&, _ ByVal 0&) <> 0 Then 'success, so return True EnableShutdownPrivledges = True End If 'AdjustTokenPrivileges End If 'LookupPrivilegeValue End If 'OpenProcessToken End If 'hProcessHandle End Function 'FUNCION PARA REINICIAR EL SISTEMA Public Sub ReiniciarPc() uflags = EWX_REBOOT Or EWX_FORCE If IsWinNTPlus() Then success = EnableShutdownPrivledges() If success Then Call ExitWindowsEx(uflags, 0&) Else '9x system, so just do it Call ExitWindowsEx(uflags, 0&) End If End Sub 'FUNCIONA PARA APAGAR EL SISTEMA Public Sub ApagarPc() uflags = EWX_POWEROFF Or EWX_FORCE If IsWinNTPlus() Then success = EnableShutdownPrivledges() If success Then Call ExitWindowsEx(uflags, 0&) 'Shell "shutdown -r -t 0" Else '9x system, so just do it Call ExitWindowsEx(uflags, 0&) End If End Sub 'FUNCION PARA SALIR DEL SISTEMA Public Sub SalirSistema() uflags = EWX_LOGOFF Or EWX_FORCE If IsWinNTPlus() Then success = EnableShutdownPrivledges() If success Then Call ExitWindowsEx(uflags, 0&) 'Shell "shutdown -r -t 0" Else '9x system, so just do it Call ExitWindowsEx(uflags, 0&) End If End Sub
Código:
'PARA REINICIAR EL SISTEMA Call ReiniciarPc 'PARA APAGAR EL ORDENADOR Call ApagarPc
__________________ Curso de Angular JS - Haremos una app de principio a fin |
| ||||
Pregunta: ¿Como Impedir que se cierre un Form? Respuesta : En el evento QueryUnload del formulario colocar un codigo como el siguiente:
Código:
Esto no impide que se haga Unload Me controlado por un boton o lo que sea.
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila Última edición por GeoAvila; 22/08/2005 a las 15:09 |
| ||||
pregunta: ¿como reemplazar determinado caracter en vb? respuesta
Código:
text1=replace(text1," ","0")
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
¿Cómo crear controles en tiempo de ejecución? Pregunta: La pregunta es la siguiente: No sabemos como crear textbox y listbox (o algo semejante para almacenar texto) en tiempo de ejecución (objeto) sin que tenga límite en cuanto al número de objetos, es decir, en este caso de textbox y listbox que se puedan crear. Respuesta: Para crear controles en tiempo de ejecución, con el VB6 hay otras posibilidades, debes tener esos controles en un array, como mínimo deberás tener uno, a partir de ahí, simplemente usando LOAD nombreControl(numeroDeElemento), tendrás nuevos controles.
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila Última edición por GeoAvila; 18/11/2005 a las 13:54 |
| ||||
Pregunta: Como cambiar de color una columna de MSFlexgrid? Respuesta: rutina que le permite cambiar el color de las columnas de un MsFlexGrid Hay que pasarle el nombre del MSFLEXGRID y el valor RGB de color esta rutinas se tiene que colocar en un BAS
Código:
Public Sub MSFlexGridColors(ColorGrid As MSFlexGrid, R As Integer, G As Integer, B As Integer) For j = 0 To ColorGrid.Cols - 1 For i = 1 To ColorGrid.Rows - 1 If i / 2 <> Int(i / 2) Then ColorGrid.Col = j ColorGrid.Row = i ColorGrid.CellBackColor = RGB(R, G, B) End If Next i Next j End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
pregunta: ¿Como impedir cambiar el tamaño de una ventana redimensionable? respuesta: Seguramente te preguntarás ¿que utilidad puede tener esto? Si a la ventana se le puede cambiar el tamaño, ¿por qué no permitir que se cambie? La respuesta, para mí, es sencilla, pero la dejo para que pienses un poco cual sería el motivo... Bueno, ahí va: en algunas ocasiones me gusta que los bordes de la ventana se vean de forma "normal", es decir como si se pudiese cambiar el tamaño, pero no me gusta que lo puedan cambiar, así que lo que he hecho en estas ocasiones es simplemente conservar el tamaño inicial de la ventana (el que tiene al cargarse) y cuando el usuario decide cambiarle el tamaño, no permitirselo y volver al que tenía inicialemente. Aquí tienes todo el código necesario:
Código:
Código:
'-------------------------------------------------------------- 'Prueba para no cambiar el tamaño de una ventana con 'bordes dimensionables '-------------------------------------------------------------- Option Explicit 'Tamaño inicial del Form Dim iH As Integer Dim iW As Integer Private Sub Form_Load() 'Guardar el tamaño inicial iH = Height iW = Width End Sub Private Sub Form_Resize() 'Sólo comprobar si el estado es Normal If WindowState = vbNormal Then 'Si se cambia la altura If Height <> iH Then Height = iH End If 'Si se cambia el ancho If Width <> iW Then Width = iW End If End If End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
Pregunta : ¿Como esperar X segundos? Respuesta : Una forma de esperar un número determinado de segundos.
Código:
'Si se quiere usar de forma GLOBAL, insertarlo en un Módulo BAS y declararlo como público
Código:
Private Sub Wait(ByVal nSec As Integer) 'Esperar un número de segundos Dim t1 As Date, t2 As Date t1 = Second(Now) t2 = t1 + nSec Do DoEvents Loop While t2 > Second(Now) End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
Pregunta: ¿Cómo detectar errores en Visual Basic? Respuesta: Cuando quieras que el Visual Basic "ignore" los errores que se produzcan en tu aplicación o en parte de ella, usa: On Error Resume Next Esto hará que si se produce un error, se continúe ejecutando el código como si nada hubiese ocurrido. Por supuesto que la recomendación es que compruebes si se ha producido un error, ya que no es bueno dejar que los errores ocurran sin más. Para ello tendrás que chequear el valor de la propiedad Number del objeto Err, (que al ser la propiedad por defecto no es necesario especificarla), si ese valor es cero quiere decir que no se ha producido un error; veamos un ejemplo:
Código:
On
Código:
Local Error Resume Next ' Error 13 producirá un error de tipos (Type Mismatch) Error 13 If Err.Number Then MsgBox "Se ha producido el siguiente error:" & vbCrLf & _ Err.Number & ", " & Err.Description End If Pero si haces esto, procura hacer un poco de limpieza... ya que, si desde este procedimiento llamas a otros procedimientos que a su vez tienen la instrucción On Error Resume Next y no has "limpiado" el valor del número del error... cualquier comprobación que hagas de ese valor dará como resultado que se muestre el mensaje. Veamos un par de ejemplos: Para crear el programa de pueba, crea un nuevo proyecto, añade tresd botones (Command1, Command2 y Command3), y pega este código:
Código:
Private Sub Command1_Click()
Código:
' Ejemplo para detectar errores en Visual Basic Dim i As Integer On Local Error Resume Next i = MsgBox("Pulsa SI para producir un error en este evento," & vbCrLf & _ "pulsa en NO para llamar al procedimiento Command2_Click" & vbCrLf & _ "pulsa en Cancelar para llamar al procedimiento Command3_Click", vbYesNoCancel) If i = vbYes Then ' Error 13 producirá un error de tipos (Type Mismatch) Error 13 ElseIf i = vbNo Then ' El error producido en el procedimiento Command2 está controlado, ' por tanto no se mostrará el mensaje del final Command2_Click Else ' Esto producirá un error en Command3, pero se detectará aquí Command3_Click End If If Err Then MsgBox "Se ha producido el siguiente error:" & vbCrLf & _ Err.Number & ", " & Err.Description, , "En Command1_Click" End If End Sub Private Sub Command2_Click() On Local Error Resume Next ' Error 76, (Path not found) Error 76 If Err Then ' Este error está comprobado dentro de este procedimiento, por tanto no mostrará nada End If ' Limpiamos el valor del error Err = 0 End Sub Private Sub Command3_Click() ' Este procedimiento produce un error número 5 Error 5 ' Este mensaje NUNCA se mostrará MsgBox "El valor de Err.Number es: " & Err.Number & vbCrLf & _ "Aquí no se notará que se ha producido un error..." & vbCrLf, , "En Command3_Click" End Sub Veamos que es lo que hace este código y porqué. Cuando pulses en el Command1 te mostrará un mensaje pidiendote que selecciones el tipo de prueba que quieres hacer, para probar cada una de ellas, tendrás que pulsar varias veces en ese botón, una para cada una de las tres posibilidades. Si pulsas en "SI", el error se producirá en este mismo evento y el mensaje del final nos indicará que se ha producido el error número 13. Cuando pulses en "NO", se llamará al procedimiento Command2_Click en el que se produce un error 76, pero que el propio procedimiento se encarga de gestionar y "limpiar", por tanto, no ocurrirá, al menos aparentemente, nada. Por último, al pulsar en "Cancelar", se llama al procedimiento Command3_Click, el cual produce el error 5, pero no detecta los errores; pero como el Visual Basic "sabe" que aún hay una rutina "interceptadora" de errores en funcionamiento, la del Command1, deja de ejecutar el código erróneo y vuelve a la siguiente instrucción que haya en el procedimiento Command1... Después de estas tres pruebas, pulsa en el Command2. Nada ocurre, ya que el código detecta los posibles errores. Cuando pulses en el Command3, verás que el Visual Basic se detiene mostrandonos una ventana de error, esto ocurre porque no hay ninguna rutina de detección de errores en funcionamiento y cuando no la hay... el Visual Basic nos muestra la suya propia y detiene el programa. Ahora cambia el código del Command3_Click por este otro:
Código:
Código:
' Private Sub Command3_Click() On Local Error Resume Next ' Este procedimiento produce un error número 5 Error 5 ' Ahora si que se mostrará este mensaje MsgBox "El valor de Err.Number es: " & Err.Number & vbCrLf & _ "Aquí no se notará que se ha producido un error..." & vbCrLf, , "En Command3_Click" End Sub Como verás, al no "limpiar" el valor de la propiedad Err.Number, el valor se mantiene; y a pesar de que se haya detectado el error en ese evento, al volver de nuevo al código del Command1, se mostrará el mensaje de que hay error... y además el mensaje que tenemos en el evento Command2_Click, el cual antes no se mostraba. Resumiendo: Si detectas los errores con Resume Next, acostumbrate a dejar el valor de Err.Number a cero antes de que acabe y/o antes de salir del procedimiento. Recuerda que para salir de un procedimiento puedes usar Exit Sub, Exit Function o Exit Property. También debes saber que, cuando acaba un procedimiento, la rutina que gestiona los errores también acaba, pero, como has podido comprobar, el valor del error permanece asignado.
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila Última edición por GeoAvila; 22/01/2005 a las 11:34 |
| ||||
Cita:
Iniciado por GeoAvila Pregunta : ¿Como esperar X segundos? Respuesta : Una forma de esperar un número determinado de segundos.
Código:
'Si se quiere usar de forma GLOBAL, insertarlo en un Módulo BAS y declararlo como público
Código:
Private Sub Wait(ByVal nSec As Integer) 'Esperar un número de segundos Dim t1 As Date, t2 As Date t1 = Second(Now) t2 = t1 + nSec Do DoEvents Loop While t2 > Second(Now) End Sub
Código:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Esperar 5000 milisegundos Sleep 5000
__________________ La población, sin embargo, sigue aumentando. COLE Laurent Gasser Tienes alguna duda :pensando: ? >>> www.google.com :aplauso: <<< |
| ||||
¿Como leer caracter por caracter de una cadena string? Respuesta:
Código:
Private Sub Command1_Click() Dim Contador As Integer Texto = "Uno_a_UNo" ' cadena string For Contador = 1 To Len(Texto) MsgBox Mid(Texto, Contador, 1) Next Contador End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
login en mail
Código:
Solo debes tener en cuenta el nombre de la caja de texto y el del formulario, en gmail sería :Private Sub Form_Activate() Webbrowser1.Navigate "http://login.passport.net/uilogin.srf?id=2" 'Este es hotmail debes poner la dirección exacta End Sub Private Sub Command1_Click() Do Until Webbrowser1.ReadyState = READYSTATE_COMPLETE DoEvents Loop On Error Resume Next Webbrowser1.Document.Form1.login.Value = "[email protected]" Webbrowser1.Document.Form1.passwd.Value = "password" Webbrowser1.Document.Form1.submit End Sub
Código:
Eso lo sabes viendo su codigo... Simple, no?... Webbrowser1.Document.Forms(0).email.Value = "[email protected]" 'por ejemplo... ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:21 |
| ||||
Ejecutar Cualquier tipo de Archivos Esta es una función que nos permite ejecutar Cualquier Archivo siempre y cuando existe un programa para abrir dicho archivo. Ademas ejecuta los .exe y abre directorios o unidades. Ejemplo Ponemos Direccion="D:/" ABRIRA UNA BENTANA con el contenido de D Ponemos Direccion="D:/PEPE" ABRIRA UNA BENTANA con el contenido de pepe Ponemos Direccion="D:/PEPE/doci.doc" ABRIRA doci.doc sin existe un programa para abrirlo como es elWord. Escriba este codigo en el formulario en General: Public Sub EjecutarArchivos(Direccion As String) On Error GoTo error ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & (Direccion), 1) Exit Sub error: MsgBox Err.Description, vbExclamation, "Error de Ejecución" End Sub para ejecutar solo tenemos que poner La función ejemplo EjecutarArchivos "c:\nota.txt" "No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende" Yosvanis Cruz Alias VisualGuallabo Ycruz ![]() Última edición por VisualGuallabo; 25/03/2005 a las 14:48 |
| ||||
Detener Apagado de Windows... En un módulo:
Código:
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Type POINTAPI x As Long y As Long End Type Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Public Const GWL_WNDPROC = -4 Public Const WM_QUERYENDSESSION = &H11 Global Const WM_CANCELMODE = &H1F Public SDAttempted As Long Global lpPrevWndProc As Long Global gHW As Long Public Sub Hook() lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub Unhook() Dim temp As Long temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc) End Sub Function WindowProc(ByVal hw As Long, ByVal uMsg As _ Long, ByVal wParam As Long, ByVal lParam As Long) As _ Long Dim a As Long If uMsg = WM_QUERYENDSESSION Then SDAttempted = SDAttempted + 1 WindowProc = CallWindowProc(lpPrevWndProc, hw, _ WM_CANCELMODE, wParam, wParam) Exit Function End If WindowProc = CallWindowProc(lpPrevWndProc, hw, _ uMsg, wParam, lParam) End Function en el form Load o Activate:
Código:
... SDAttempted = 0 gHW = Me.hwnd Hook ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:22 |
| ||||
Ordenar Datagrid haciendo click en la cabecera
Código:
... Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer) With Adodc1.Recordset If (.Sort = .Fields(ColIndex).[Nombre] & " Asc") Then .Sort = .Fields(ColIndex).[Nombre] & " Desc" Else .Sort = .Fields(ColIndex).[Nombre] & " Asc" End If End With End Sub ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:22 |
| ||||
Ejecutar cualquier programa
Código:
... Dim ret As String ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & ("ruta archivo")) ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:22 |
| ||||
Ejecutar una direccion url en el navegador
Código:
... Option Explicit Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Const SW_NORMAL = 1 Dim X X = ShellExecute(Me.hwnd, "Open", "http://www.url.com", &O0, &O0, SW_NORMAL) ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:24 |
| ||||
Control total del taskbar Con esto puedes ocultar y/o mostrar los iconos que se encuentran al aldo del reloj del taskbar. En un módulo:
Código:
En el form:Public isvisible As Integer Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Const HWND_TOPMOST = -1 Private Const HWND_NOTOPMOST = -2 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOSIZE = &H1 Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Public Function HideTaskBarIcons() Dim FindClass As Long, Handle As Long FindClass& = FindWindow("Shell_TrayWnd", "") Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString) ShowWindow Handle&, 0 End Function Public Function ShowTaskBarIcons() Dim FindClass As Long, Handle As Long FindClass& = FindWindow("Shell_TrayWnd", "") Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString) ShowWindow Handle&, 1 End Function Public Function HideTaskBarClock() Dim FindClass As Long, FindParent As Long, Handle As Long FindClass& = FindWindow("Shell_TrayWnd", vbNullString) FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString) Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString) ShowWindow Handle&, 0 End Function Public Function ShowTaskBarClock() Dim FindClass As Long, FindParent As Long, Handle As Long FindClass& = FindWindow("Shell_TrayWnd", vbNullString) FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString) Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString) ShowWindow Handle&, 1 End Function Public Function HideDesktop() ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0 End Function Public Function ShowDesktop() ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5 End Function Public Function HideStartButton() Dim Handle As Long, FindClass As Long FindClass& = FindWindow("Shell_TrayWnd", "") Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString) ShowWindow Handle&, 0 End Function Public Function ShowStartButton() Dim Handle As Long, FindClass As Long FindClass& = FindWindow("Shell_TrayWnd", "") Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString) ShowWindow Handle&, 1 End Function Public Function HideTaskBar() Dim Handle As Long Handle& = FindWindow("Shell_TrayWnd", vbNullString) ShowWindow Handle&, 0 End Function Public Function ShowTaskBar() Dim Handle As Long Handle& = FindWindow("Shell_TrayWnd", vbNullString) ShowWindow Handle&, 1 End Function Public Sub MakeNormal(hwnd As Long) SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS End Sub Public Sub MakeTopMost(hwnd As Long) SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS End Sub
Código:
... Dim ico As Integer Dim clo As Integer Dim stb As Integer Dim tsk As Integer Dim dsk As Integer Private Sub Command1_Click() If isvisible = 1 Then If ico = 0 Then ShowTaskBarIcons ico = 1 ElseIf ico = 1 Then HideTaskBarIcons ico = 0 End If ElseIf isvisible = 0 Then End If End Sub Private Sub Command2_Click() If isvisible = 1 Then If clo = 0 Then ShowTaskBarClock clo = 1 ElseIf clo = 1 Then HideTaskBarClock clo = 0 End If ElseIf isvisible = 0 Then End If End Sub Private Sub Command3_Click() If isvisible = 1 Then If stb = 0 Then ShowStartButton stb = 1 ElseIf stb = 1 Then HideStartButton stb = 0 End If ElseIf isvisible = 0 Then End If End Sub Private Sub Command4_Click() If isvisible = 1 Then If tsk = 0 Then ShowTaskBar tsk = 1 ElseIf tsk = 1 Then HideTaskBar tsk = 0 End If ElseIf isvisible = 0 Then End If End Sub Private Sub Command5_Click() If isvisible = 1 Then If dsk = 0 Then ShowDesktop dsk = 1 ElseIf dsk = 1 Then HideDesktop dsk = 0 End If ElseIf isvisible = 0 Then End If End Sub Private Sub Command6_Click() If isvisible = 1 Then ShowTaskBarIcons ShowTaskBarClock ShowDesktop ShowStartButton ShowTaskBar ico = 1 clo = 1 stb = 1 tsk = 1 dsk = 1 ElseIf isvisible = 0 Then End If End Sub Private Sub Form_Load() MakeTopMost Me.hwnd isvisible = 1 ico = 1 clo = 1 stb = 1 tsk = 1 dsk = 1 End Sub ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:25 Razón: Error en una sentencia |
| ||||
¿como posicionar el cursor con vb6? Repuesta: bueno buscando por alli econtre esto..
Código:
Option Explicit Private Declare Function SetCursorPos Lib "user32" _ (ByVal x As Long, ByVal y As Long) As Long Private Sub Command1_Click() Dim a As Long, b As Long, c As Long SetCursorPos 256, 256 a = 2 b = 5 c = a + b SetCursorPos 512, 512 End Sub
__________________ * Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ Sitio http://www.geoavila.com twitter: @GeoAvila |
| ||||
Autoclick Agregas un modulo de clase y lo llamas clsmouse y copias:
Código:
Agregas otro y lo llamas clsmouseposition y pegas:Option Explicit Public Event PositionChanged() Public Event SytemClick(ByVal Button As MouseButtonConstants) Private Const VK_RBUTTON As Long = &H2 Private Const VK_MBUTTON As Long = &H4 Private Const VK_LBUTTON As Long = &H1 Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2 Private Const MOUSEEVENTF_LEFTUP As Long = &H4 Private Const MOUSEEVENTF_MIDDLEDOWN As Long = &H20 Private Const MOUSEEVENTF_MIDDLEUP As Long = &H40 Private Const MOUSEEVENTF_RIGHTDOWN As Long = &H8 Private Const MOUSEEVENTF_RIGHTUP As Long = &H10 Private Type POINTAPI X As Long Y As Long End Type Private m_WatchPosition As Boolean Private m_WatchSystemClicks As Boolean Private m_Position As New clsmouseposition Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, _ ByVal dx As Long, _ ByVal dy As Long, _ ByVal cButtons As Long, _ ByVal dwExtraInfo As Long) Public Sub Click(Optional MouseButton As MouseButtonConstants = vbLeftButton) If (MouseButton = vbLeftButton) Then Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0&, 0&, 0&, 0&) Call mouse_event(MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, 0&) ElseIf (MouseButton = vbMiddleButton) Then Call mouse_event(MOUSEEVENTF_MIDDLEDOWN, 0&, 0&, 0&, 0&) Call mouse_event(MOUSEEVENTF_MIDDLEUP, 0&, 0&, 0&, 0&) ElseIf (MouseButton = vbRightButton) Then Call mouse_event(MOUSEEVENTF_RIGHTDOWN, 0&, 0&, 0&, 0&) Call mouse_event(MOUSEEVENTF_RIGHTUP, 0&, 0&, 0&, 0&) End If End Sub Private Function CompKey(KCode As Long) As Boolean Dim Result As Long Result = GetAsyncKeyState(KCode) If Result = -32767 Then CompKey = True Else CompKey = False End If End Function Public Property Get Position() As clsmouseposition Set Position = m_Position End Property Public Property Let TimerEvent(ByVal Dummmy As Boolean) Dim CurPos As POINTAPI Dim Value As MouseButtonConstants Static First As Boolean Static mx As Long Static my As Long If m_WatchPosition Then Call GetCursorPos(CurPos) If First Then If CurPos.X <> mx Or CurPos.Y <> my Then RaiseEvent PositionChanged End If End If mx = CurPos.X my = CurPos.Y End If If m_WatchSystemClicks Then If CompKey(VK_LBUTTON) Then Value = vbLeftButton End If If CompKey(VK_RBUTTON) Then Value = Value Or vbRightButton End If If CompKey(VK_MBUTTON) Then Value = Value Or vbMiddleButton End If If Value <> 0 Then RaiseEvent SytemClick(Value) End If End If First = True End Property
Código:
y en el form pones:Option Explicit Private Type POINTAPI X As Long Y As Long End Type Private m_x As Long Private m_y As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, _ ByVal Y As Long) As Long Private Sub GetPosition() Dim P As POINTAPI Call GetCursorPos(P) m_y = P.Y m_x = P.X End Sub Public Property Get X() As Long Call GetPosition X = m_x End Property Public Property Let X(lngValue As Long) Call SetCursorPos(lngValue, m_y) m_x = lngValue End Property Public Property Get Y() As Long Call GetPosition Y = m_y End Property Public Property Let Y(lngValue As Long) Call SetCursorPos(m_x, lngValue) m_y = lngValue End Property
Código:
Espero les sirva... Option Explicit Private WithEvents Mouse As clsmouse Private Sub Command1_Click() With Mouse .Position.X = coodenada .Position.Y = coordenada .Click (vbLeftButton) End With 'Si quieres pones x=100 y y=100, pones el Startupposition en center screen y que tu form no ocupe la pantalla completa hazlo pequeño para que veas que pasa End Sub Private Sub Form_Load() Set Mouse = New clsmouse End Sub ![]()
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:26 |
| ||||
Colocar el icono de la aplicacion en el systray En un modulo:
Código:
Y en el Form:Public nid As NOTIFYICONDATA Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean Public Const WM_CHAR = &H102 Public Const WM_SETTEXT = &HC Public Const WM_USER = &H400 Public Const WM_KEYDOWN = &H100 Public Const WM_KEYUP = &H101 Public Const WM_LBUTTONDOWN = &H201 Public Const WM_CLOSE = &H10 Public Const WM_COMMAND = &H111 Public Const WM_CLEAR = &H303 Public Const WM_DESTROY = &H2 Public Const WM_GETTEXT = &HD Public Const WM_GETTEXTLENGTH = &HE Public Type NOTIFYICONDATA cbSize As Long hwnd As Long uId As Long uFlags As Long uCallBackMessage As Long hIcon As Long szTip As String * 64 End Type Public Const NIM_ADD = &H0 Public Const NIM_MODIFY = &H1 Public Const NIM_DELETE = &H2 Public Const NIF_MESSAGE = &H1 Public Const NIF_ICON = &H2 Public Const NIF_TIP = &H4 Public Const WM_MOUSEMOVE = &H200 Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long Sub InitializeTrayIcon() With nid .cbSize = Len(nid) .hwnd = frmMain.hwnd 'nombre del form que estara minimizado .uId = vbNull .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE .uCallBackMessage = WM_MOUSEMOVE .hIcon = frmMain.Icon 'nombre del formulario que contiene el icono End With Shell_NotifyIcon NIM_ADD, nid End Sub
Código:
Private Sub Form_Load() InitializeTrayIcon End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim Result As Long Dim msg As Long If Me.ScaleMode = vbPixels Then msg = X Else msg = X / Screen.TwipsPerPixelX End If Select Case msg Case 517 Me.PopupMenu MNU Case 514 Result = SetForegroundWindow(Me.hwnd) Me.Show End Select End Sub Private Sub Form_Terminate() Shell_NotifyIcon NIM_DELETE, nid End Sub Private Sub Form_Unload(Cancel As Integer) Shell_NotifyIcon NIM_DELETE, nid End Sub
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:27 |
| ||||
Formulario transparente con controles visibles ¡OJO! Este codigo funciona solo si el BorderStyle del form es 0... En un modulo:
Código:
En el form:Option Explicit Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Const RGN_XOR = 3 Public Sub MakeTransparent(TransForm As Form) Dim ErrorTest As Double On Error Resume Next Dim Regn As Long Dim TmpRegn As Long Dim TmpControl As Control Dim LinePoints(4) As POINTAPI TransForm.ScaleMode = 3 If TransForm.BorderStyle <> 0 Then MsgBox "Change the borderstyle to 0!", vbCritical, "ACK!": End Regn = CreateRectRgn(0, 0, 0, 0) For Each TmpControl In TransForm If TypeOf TmpControl Is Line Then If Abs((TmpControl.Y1 - TmpControl.Y2) / (TmpControl.X1 - TmpControl.X2)) > 1 Then LinePoints(0).X = TmpControl.X1 - 1 LinePoints(0).Y = TmpControl.Y1 LinePoints(1).X = TmpControl.X2 - 1 LinePoints(1).Y = TmpControl.Y2 LinePoints(2).X = TmpControl.X2 + 1 LinePoints(2).Y = TmpControl.Y2 LinePoints(3).X = TmpControl.X1 + 1 LinePoints(3).Y = TmpControl.Y1 Else LinePoints(0).X = TmpControl.X1 LinePoints(0).Y = TmpControl.Y1 - 1 LinePoints(1).X = TmpControl.X2 LinePoints(1).Y = TmpControl.Y2 - 1 LinePoints(2).X = TmpControl.X2 LinePoints(2).Y = TmpControl.Y2 + 1 LinePoints(3).X = TmpControl.X1 LinePoints(3).Y = TmpControl.Y1 + 1 End If TmpRegn = CreatePolygonRgn(LinePoints(0), 4, 1) ElseIf TypeOf TmpControl Is Shape Then If TmpControl.Shape = 0 Then TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height) ElseIf TmpControl.Shape = 1 Then If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width) Else TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height) End If ElseIf TmpControl.Shape = 2 Then TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + TmpControl.Height + 0.5) ElseIf TmpControl.Shape = 3 Then If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 0.5) Else TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 0.5, TmpControl.Top + TmpControl.Height + 0.5) End If ElseIf TmpControl.Shape = 4 Then If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Width / 4, TmpControl.Width / 4) End If ElseIf TmpControl.Shape = 5 Then If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 1, TmpControl.Width / 4, TmpControl.Width / 4) End If End If If TmpControl.BackStyle = 0 Then CombineRgn Regn, Regn, TmpRegn, RGN_XOR If TmpControl.Shape = 0 Then TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + TmpControl.Height - 1) ElseIf TmpControl.Shape = 1 Then If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 1) Else TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 1, TmpControl.Top + TmpControl.Height - 1) End If ElseIf TmpControl.Shape = 2 Then TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + TmpControl.Height - 0.5) ElseIf TmpControl.Shape = 3 Then If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 0.5) Else TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 0.5, TmpControl.Top + TmpControl.Height - 0.5) End If ElseIf TmpControl.Shape = 4 Then If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Width / 4, TmpControl.Width / 4) End If ElseIf TmpControl.Shape = 5 Then If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width, TmpControl.Width / 4, TmpControl.Width / 4) End If End If End If Else TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height) End If ErrorTest = 0 ErrorTest = TmpControl.Width If ErrorTest <> 0 Or TypeOf TmpControl Is Line Then CombineRgn Regn, Regn, TmpRegn, RGN_XOR End If Next TmpControl SetWindowRgn TransForm.hwnd, Regn, True End Sub
Código:
Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Const WM_SYSCOMMAND = &H112 Private Sub Form_Load() MakeTransparent frmTrans End Sub
__________________ ホルヘ・ラファエル・マルティネス・レオン Última edición por vbx3m; 10/05/2006 a las 12:28 |
| ||||
![]() Esto es a pura API de Windows usaremos la función GetKeyState de la libreria user32. Si queremos detectar la o las teclas presionadas tenemos que llamar a la función pasándole como parámetro el código ASCII de la o las teclas que queremos analizar. Si la tecla está pulsada, la función devuelve –127 o –128. (Se van alternando los valores a cada pulsación completa.) Cuando no está apretada, la función devuelve 0 o 1. Resumiendo, la tecla está pulsada si la función devuelve un número menor de 0. Para ver una demostración de esta función, podemos crear un Label y un Timer con el Interval bajo (para que continuamente se produzca el Timer1_Timer). Añadir este código: Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Private Sub Timer1_Timer() If GetKeyState(32) < 0 And GetKeyState(vbKeyUp) < 0 Then Label1.Caption = "Estás pulsando espacio y arriba a la vez." Else Label1.Caption = "No" End If End Sub Al ejecutar el programa, el texto del Label será No; pero al apretar Espacio y Flecha Arriba a la vez, el texto cambiará hasta que dejen de pulsarse estas teclas. Recuerden poner intervalo al timer y enable=True
__________________ "No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende" Yosvanis Cruz Alias VisualGuallabo Ycruz |
| ||||
![]() Colocaremos en el formulario un ListBox de nombre List1. Y luego copiar este codigo... Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVallProcessID As Long) As Long Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long) Private Type PROCESSENTRY32 dwSize As Long cntUsage As Long th32ProcessID As Long th32DefaultHeapID As Long th32ModuleID As Long cntThreads As Long th32ParentProcessID As Long pcPriClassBase As Long dwFlags As Long szExeFile As String * 260 End Type Private Sub Form_Load() Dim hSnapShot As Long Dim uProceso As PROCESSENTRY32 Dim res As Long hSnapShot = CreateToolhelpSnapshot(2&, 0&) If hSnapShot <> 0 Then uProceso.dwSize = Len(uProceso) res = ProcessFirst(hSnapShot, uProceso) Do While res List1.AddItem Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1) res = ProcessNext(hSnapShot, uProceso) Loop Call CloseHandle(hSnapShot) End If End Sub
__________________ "No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende" Yosvanis Cruz Alias VisualGuallabo Ycruz |
| ||||
Bloquear la PC. Eso es una Bicoca, Aqui tienen el codigo en una sola linea. Para todos mis amigos programadores de Visual Basic. Shell "rundll32.exe user32.dll LockWorkStation"
__________________ "No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende" Yosvanis Cruz Alias VisualGuallabo Ycruz |
| ||||
Abrir la caja de dialogo de Abrir con selección multiple de archivos(API) Esto es a pura API adios comandialogo. para que control si tenemos la API. ¿Verdad? En un modulo: ' Modulo para Abrir la caja de dialogo de Abrir ' archivos donde podra aser selección multiple 'Ejemplo de Yosvanis Cruz Alias VisualGuallabo 'Alguna sugerencia responder ' a [email protected] estare agradesido 'Con este codigo puede aser los cambios que quiera Option Explicit Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Public Const OFN_READONLY = &H1 Public Const OFN_OVERWRITEPROMPT = &H2 Public Const OFN_HIDEREADONLY = &H4 Public Const OFN_NOCHANGEDIR = &H8 Public Const OFN_SHOWHELP = &H10 Public Const OFN_ENABLEHOOK = &H20 Public Const OFN_ENABLETEMPLATE = &H40 Public Const OFN_ENABLETEMPLATEHANDLE = &H80 Public Const OFN_NOVALIDATE = &H100 Public Const OFN_ALLOWMULTISELECT = &H200 Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Const OFN_PATHMUSTEXIST = &H800 Public Const OFN_FILEMUSTEXIST = &H1000 Public Const OFN_CREATEPROMPT = &H2000 Public Const OFN_SHAREAWARE = &H4000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOTESTFILECREATE = &H10000 Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules Public Const OFN_EXPLORER = &H80000 ' new look commdlg Public Const OFN_NODEREFERENCELINKS = &H100000 Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules Public Const OFN_SHAREFALLTHROUGH = 2 Public Const OFN_SHARENOWARN = 1 Public Const OFN_SHAREWARN = 0 Public Total_de_Archivos As Integer Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Public Lista_Archivos(1 To 20000) As String Function CountFilesInList(ByVal FileList As String) As Integer ' Cuenta archivos. Los regresos resultan como el entero Dim iCount As Integer Dim iPos As Integer iCount = 0 For iPos = 1 To Len(FileList) If Mid$(FileList, iPos, 1) = Chr$(0) Then iCount = iCount + 1 Next If iCount = 0 Then iCount = 1 CountFilesInList = iCount End Function Function GetFileFromList(ByVal FileList As String, FileNumber As Integer) As String ' Obtiene el nombre de archivo de FileNumber de FileList Dim iPos As Integer Dim iCount As Integer Dim iFileNumberStart As Integer Dim iFileNumberLen As Integer Dim sPath As String If InStr(FileList, Chr(0)) = 0 Then GetFileFromList = FileList Else iCount = 0 sPath = Left(FileList, InStr(FileList, Chr(0)) - 1) If Right(sPath, 1) <> "\" Then sPath = sPath + "\" FileList = FileList + Chr(0) For iPos = 1 To Len(FileList) If Mid$(FileList, iPos, 1) = Chr(0) Then iCount = iCount + 1 Select Case iCount Case FileNumber iFileNumberStart = iPos + 1 Case FileNumber + 1 iFileNumberLen = iPos - iFileNumberStart Exit For End Select End If Next GetFileFromList = sPath + Mid(FileList, iFileNumberStart, iFileNumberLen) End If End Function Function OpenDialog(Filter As String, Title As String, InitDir As String) As String Dim ofn As OPENFILENAME Dim A As Long ofn.lStructSize = Len(ofn) ofn.hInstance = App.hInstance If Right$(Filter, 1) <> "|" Then Filter = Filter + "|" For A = 1 To Len(Filter) If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0) Next ofn.lpstrFilter = Filter ofn.lpstrFile = Space$(254) ofn.nMaxFile = 20000 ofn.lpstrFileTitle = Space$(254) ofn.nMaxFileTitle = 255 ofn.lpstrInitialDir = InitDir ofn.lpstrTitle = Title ofn.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST Or OFN_EXPLORER Or OFN_ALLOWMULTISELECT A = GetOpenFileName(ofn) ' Variable del contador Dim i As Integer ' Pasa a través de todos los archivos seleccionados For i = 1 To CountFilesInList(ofn.lpstrFile) ' Compruebe el tamaño del archivo On Error GoTo cont Select Case FileLen(GetFileFromList(ofn.lpstrFile, i)) Case Is > 0 ' Ahora agréga el archivo a la lista Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i) Total_de_Archivos = Total_de_Archivos + 1 Case Else ' Si el tamaño del archivo es 0 (el cero) - pregunta si desea agregar a la lista If MsgBox("El Archivo " & GetFileFromList(ofn.lpstrFile, i) & " tiene 0bytes de tamaño" _ & vbCr & "¿Está seguro usted que quiere agregarlo?", vbYesNo, "Alerta") = vbYes Then Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i) Total_de_Archivos = Total_de_Archivos + 1 End If End Select Next i cont: If (A) Then If Total_de_Archivos = 0 Then Total_de_Archivos = Total_de_Archivos + 1 Lista_Archivos(i) = ofn.lpstrFile End If End Function ******************en el Form ************************ Debera agregar un Listbox de nombre List1 Private Sub Form_Load() OpenDialog "*.*", "Abrir Archivo", "" For A = 1 To Total_de_Archivos If Lista_Archivos(A) <> "" Then List1.AddItem Lista_Archivos(A) Next A me.Caption = Total_de_Archivos End Sub ------Este codigo me llebo trabajo espero que les sea de gran utilidad---- ![]() ![]()
__________________ "No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende" Yosvanis Cruz Alias VisualGuallabo Ycruz |