[dario29]

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

[lucasiramos]

Ustedes diran "¡Qué fácil! Usamos la propiedad RecordCount del Recordset" ..... Si y no. La propiedad RecordCount funciona bien si antes nos movemos hasta el último registro, sino, en algunos casos funciona y en otros no. Pero si nuestro recordset no tiene registros, no puede ejecutar el RS.MoveLast, ya que no tiene registros, y el programa da un error. Entonces podemos hacer lo siguiente:

If RS.EOF = True And RS.BOF = True Then
MsgBox "Nuestro Recordset no tiene registros"
else
RS.MoveLast
MsgBox "Nuestro Recordset tiene " & CStr(RS.RecordCount) & " registros
End If

Si el Recordset no tiene registros, tanto la propiedad EOF como la BOF tiene valor verdadero.
Espero que les sirva. Saludos . Lucas

[GeoAvila]

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

[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

[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

[stock]

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:

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

y para usarlas nomas asi:

Código:

'PARA REINICIAR EL SISTEMA
Call ReiniciarPc

'PARA APAGAR EL ORDENADOR
Call ApagarPc

[GeoAvila]

Pregunta:
¿Como Impedir que se cierre un Form?

Respuesta :
En el evento QueryUnload del formulario colocar un codigo como el siguiente:

Código:

 Private EnabledClose As Boolean 
Private Sub Form_Unload(Cancel As Integer)
If Not EnabledClose Then
	Cancel = -1
End If
End Sub
'Suponiendo que se cierra con un Botón
Private Sub Command1_Click()
EnabledClose = True
Unload Me
End Sub ' ejemplo mas exacto por david el grande..
 

Esto no impide que se haga Unload Me controlado por un boton o lo que sea.

[GeoAvila]

pregunta:
¿como reemplazar determinado caracter en vb?

respuesta

Código:

text1=replace(text1," ","0")

[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.

Un ejemplo:
Crea un nuevo proyecto, añade un label y un textbox.
Selecciona el label, en la propiedad Index, escribe CERO, de esta forma tendrás un array creado.
Haz lo mismo con el TextBox.

Ahora escribe esto en el evento Load de formulario, se crearán nuevos controles.
Es importante notar que los nuevos controles creados tienen la propiedad Visible a FALSE, por tanto no serán visibles salvo que se cambie el estado a TRUE.

Veamos el código de ejemplo que permitirá crear controles, posicionarlos debajo de los anteriores y si se pulsa en el botón cmdElimir, eliminará el último que se haya creado...

Código:

'
'Ejemplo de creación de controles en tiempo de ejecución
Option Explicit
 
'Llevará la cuenta de los controles creados
Private numControles As Long
 
 
Private Sub cmdCrear_Click()
    'Crear un nuevo control de cada tipo
 
    'numControles está declarada a nivel de módulo
    numControles = numControles + 1
    'Crear los controles
    Load Label1(numControles)
    Load Text1(numControles)
 
    'Posicionarlos y hacerlos visibles
    With Label1(numControles)
        .Visible = True
        .Top = Label1(numControles - 1).Top + .Height + 120
        .Caption = "Label1(" & numControles & ")"
    End With
    With Text1(numControles)
        .Visible = True
        .Top = Text1(numControles - 1).Top + .Height + 60
        .Text = "Text1(" & numControles & ")"
    End With
End Sub
 
 
Private Sub cmdEliminar_Click()
    'Eliminar un elemento de cada control anteriormente creado
 
    'El control CERO no se puede eliminar
    If numControles > 0 Then
        'Descargarlos de la memoria
        Unload Label1(numControles)
        Unload Text1(numControles)
        numControles = numControles - 1
    End If
End Sub
 
 
Private Sub Form_Load()
  'Por defecto creamos un control de cada array:
    'un Label y un Textbox
 
    cmdCrear_Click
End Sub
 

[GeoAvila]

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

[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

[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
 

[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.

[lic_dahool]

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

[GeoAvila]

¿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

[vbx3m]

Código:

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

Solo debes tener en cuenta el nombre de la caja de texto y el del formulario, en gmail sería :

Código:

Webbrowser1.Document.Forms(0).email.Value = "[email protected]" 'por ejemplo...

Eso lo sabes viendo su codigo... Simple, no?...

[VisualGuallabo]

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

[vbx3m]

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

...

[vbx3m]

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

...

[vbx3m]

Código:

Dim ret As String
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & ("ruta archivo"))

...

[vbx3m]

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)

...

[vbx3m]

Con esto puedes ocultar y/o mostrar los iconos que se encuentran al aldo del reloj del taskbar.

En un módulo:

Código:

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

En el form:

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

...

[GeoAvila]

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

[vbx3m]

Agregas un modulo de clase y lo llamas clsmouse y copias:

Código:

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

Agregas otro y lo llamas clsmouseposition y pegas:

Código:

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

y en el form pones:

Código:

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

Espero les sirva...

[vbx3m]

En un modulo:

Código:

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

Y en el Form:

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

[vbx3m]

¡OJO! Este codigo funciona solo si el BorderStyle del form es 0...

En un modulo:

Código:

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

En el form:

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

[VisualGuallabo]

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

[VisualGuallabo]

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

[VisualGuallabo]

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"

[VisualGuallabo]

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----