Biblioteca de código

[ranefi]

Barra de Progreso en el reloj de la barra de tareas

1.- Establecer la propiedad BorderStyle del formulario a 0 - None
2.- Agregar un control Timer y un control PictureBox e REPLACEar el siguiente código:

Código:

Dim CurrentPercent As Integer

Private Type RECT
            Left As Long
            Top As Long
            Right As Long
            Bottom As Long
End Type

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
            (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private 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

Private Declare Function GetWindowRect Lib "user32" _
            (ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Function SetParent Lib "user32" _
            (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long


Private Sub Form_Load()
            Timer1.Interval = 100
           
            With Picture1
                        .Top = 16
                        .Left = 0
                        .Width = 1
                        .Height = 17
            End With
           
            MsgBox ("Mira al cochino de tu reloj en la barra de tareas")
           
            Dim hWnd As Long, rctemp As RECT
           
            hWnd = FindWindow("Shell_TrayWnd", vbNullString)
            hWnd = FindWindowEx(hWnd, 0, "TrayNotifyWnd", vbNullString)

            GetWindowRect hWnd, rctemp
           
            With Me
                        .Top = 0
                        .Left = 0
                        .Height = Me.Height * (rctemp.Bottom - rctemp.Top) / Me.ScaleHeight
                        .Width = Me.Width * (rctemp.Right - rctemp.Left) / Me.ScaleWidth
            End With
           
            Timer1.Enabled = True
           
            SetParent Me.hWnd, hWnd
           
            Picture1.Height = Me.ScaleHeight
            Picture1.Width = Me.ScaleWidth
End Sub

Private Sub Form_DblClick()
            Unload Me
End Sub

Private Sub Picture1_Click()
            Unload Me
End Sub

Private Sub Form_Resize()
            Picture1.Top = _
                        (Me.ScaleHeight - Picture1.Height) / 2
End Sub

Public Function UpdateProgress(pb As Control, ByVal Percent)
            Dim Num$
           
            If Not pb.AutoRedraw Then
                        pb.AutoRedraw = -1
            End If
           
            pb.Cls
            pb.ScaleWidth = 100
            pb.DrawMode = 10

            Num$ = Format$(Percent, "###") + "%"

            pb.CurrentX = 50 - pb.TextWidth(Num$) / 2
            pb.CurrentY = (pb.ScaleHeight - pb.TextHeight(Num$)) / 2
           
            pb.Print Num$
            pb.Line (0, 0)-(Percent, pb.ScaleHeight), , BF
            pb.Refresh
End Function

Private Sub Timer1_Timer()
            CurrentPercent = CurrentPercent + 1
           
            If CurrentPercent < 101 Then
                        UpdateProgress Picture1, CurrentPercent
            Else
                        Timer1.Enabled = False
                        CurrentPercent = 0
            End If
End Sub

Es divertido éste código; no recuerdo donde lo encontré. Nos vemos.

[ranefi]

Cerrar el Explorador de Internet

Agregar un CommandButton en el formulario e REPLACEar lo siguiente:

En el formulario:

Código:

Private Sub Command1_Click()
            Dim winHwnd As Long
            Dim RetVal As Long

            winHwnd = FindWindow("IEFrame", vbNullString)

            If winHwnd <> 0 Then
                        RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
                        If RetVal = 0 Then
                                    MsgBox "Error, enviando cochino mensaje"
                        End If
            Else
                        MsgBox "El maldito Internet Explorer no está abierto"
            End If
End Sub

En el módulo:

Código:

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long

Public Const WM_CLOSE = &H10

Este código nos podría servir para crear un Bloqueador de ventanas emergentes (Popup Blocker). Sólo estructuren bien la idea y verán. Nos vemos.

[ranefi]

InputBox que sólo admita números

Introducir un CommandButton e REPLACEar el siguiente código:

Código:

Private Sub Command1_Click()
            Dim Numero As String
           
            Do
                        Numero = InputBox("Introduce un cochino número", _
                                    "Cochino número")
            Loop Until IsNumeric(Numero)
           
            MsgBox "El cochino número es ", _
                        vbInformation, "He aquí tu cochinada " & Numero
End Sub

Puede ser muy útil cuando deseas mostrar únicamente un InputBox al cual sólo se le deban introducir números. Nos vemos.

[ranefi]

Mostrar y Ocultar cursor del ratón

Agregar dos CommandButton e REPLACEar el siguiente código:

En un módulo

Código:

Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

En un formulario

Código:

Private Sub Command1_Click()
            Dim ResultadoCochino As String

            ResultadoCochino = ShowCursor(False)
End Sub

Private Sub Command2_Click()
            Dim ResultadoCochino As String

            ResultadoCochino = ShowCursor(True)
End Sub

Esto puede ser útil para tus cochinos troyanos, mañosón. See ya.

[ranefi]

Cambiar el papel tápiz del escritorio de Windows

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Private Declare Function SystemParametersInfo Lib "user32" _
            Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _
            ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1


Private Sub Command1_Click()
            SystemParametersInfo SPI_SETDESKWALLPAPER, 0, _
                        "C:\Windows\pompas.bmp", SPIF_UPDATEINIFILE
End Sub

Obviamente deberemos cambiar la ruta en donde dice "C:\Window\pompas.bmp" por la ruta y la imagen bmp que queramos usar. Nos vemos.

[ranefi]

Eliminar documentos recientes

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Private Declare Function SHAddToRecentDocs Lib "Shell32" _
            (ByVal lflags As Long, ByVal lPv As Long) As Long

Private Sub Command1_Click()
            SHAddToRecentDocs 0, 0
End Sub

Muy útil, pero no creo que lo necesiten si desean crear un virus      xD

[ranefi]

Conocer unidad del disco duro local

REPLACEar el siguiente código en la ventana de vista código:

Código:

Private Declare Function GetDriveType Lib "Kernel32" _
            Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Function BuscarDiscoDuro() As String
            Dim Unidad As Integer
           
            Const Disco_Duro = 3
           
            BuscarDiscoDuro = "No hay disco duro instalado"
           
            For Unidad = 65 To 90
                        If GetDriveType(Chr(Unidad) & ":\") = Disco_Duro Then
                                   
                                    BuscarDiscoDuro = Chr(Unidad) & ":\"
                                    Exit For
                        End If
            Next Unidad
End Function

Private Sub Form_Load()
            Me.Caption = BuscarDiscoDuro
End Sub

Se puede combinar con la API que nos dice el número de serie del disco duro.

[ranefi]

Establecer una conexión con Oracle con ADO

Agregar un CommandButton e REPLACEar lo siguiente:

Código:

Public adoCochinaConexionn As New ADODB.Connection
Public adoMugrosoRecordset As New ADODB.Recordset

Private Sub Command1_Click()
                 adoCochinaConexion.ConnectionString = "Provider=MSDAORA;Password=ranefi;User ID=jiman;Data Source=database"
                 adoCochinaConexion.Open
End Sub

Se establece la conexión a Oracle con Ado, esto claro, asumiendo que se conoce el usuario, contraseña y la base de datos. En caso de que no exista contraseña, ésta pues, se puede omitir.

Si algo no está correcto, por favor, envíenme un mensaje privado indicando el código incorrecto y el por qué. Gracias.

[ranefi]

Vaciar la papelera de reciclaje

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Const SHERB_NOCONFIRMATION = &H1
Const SHERB_NOPROGRESSUI = &H2
Const SHERB_NOSOUND = &H4

Private Type ULARGE_INTEGER
      LowPart As Long
      HighPart As Long
End Type

Private Type SHQUERYRBINFO
      cbSize As Long
      i64Size As ULARGE_INTEGER
      i64NumItems As ULARGE_INTEGER
End Type

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" _
            Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, _
            ByVal pszRootPath As String, ByVal dwFlags As Long) As Long

Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long

Private Declare Function SHQueryRecycleBin Lib "shell32.dll" _
            Alias "SHQueryRecycleBinA" (ByVal pszRootPath As String, _
            pSHQueryRBInfo As SHQUERYRBINFO) As Long


Private Sub Command1_Click()
            SHEmptyRecycleBin Me.hwnd, vbNullString, 1
            SHUpdateRecycleBinIcon
            End
End Sub

Si deseamos que nos aparezca un cuadro de diálogo pregúntandonos si deseamos vaciar la papelera de reciclaje deberemos de cambiar el 1 de SHEmptyRecycle Bin Me.hwnd, vbNullString, 1 por 0, debe quedar así: SHEmptyRecycle Bin Me.hwnd, vbNullString, 0

Nos vemos.

[ranefi]

Crear una conexión a una base de datos de Access 2000 en tiempo de ejecución (conexión con ADO)

Agregar un TextBox llamado Text1, copiarlo y pegarlo 2 veces; deberán quedar así:

Text1(0)
Text2(1)
Text3(2)

Ya hecho eso, tendrán que crear una base de datos llamada ranefi con una tabla llamada Datos y con los siguientes campos:

Nombre
Edad
Direccion

Y llenar un par de registros.

En Visual Basic, ir al menú Proyecto-->Referencias

Y seleccionar la casilla de Microsoft ActiveX Data Objects 2.0 Library

Ahora introducir el siguiente código:

Código:

            Public BaseDatos As String
            Public Tabla As String
            Public Campo1 As String
            Public Campo2 As String
            Public Campo3 As String
           
            Public Conex As ADODB.Connection
            Public Rst As ADODB.Recordset
           
           

Sub Conexion()
            BaseDatos = App.Path & "\ranefi.mdb"
            Tabla = "Datos"
            Campo1 = "Nombre"
            Campo2 = "Edad"
            Campo3 = "Direccion"
           
            Set Cnn = New ADODB.Connection
            Set Rst = New ADODB.Recordset
           
            Cnn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & BaseDatos
           
            Rst.Open "SELECT * FROM " & Tabla & " ORDER BY " & Campo1, _
                        Cnn, adOpenDynamic, adLockOptimistic
           
            Dim CuadrosTexto As TextBox
           
            For Each CuadrosTexto In Me.Text1
                        Set CuadrosTexto.DataSource = Rst
            Next
           
            Text1(0).DataField = Campo1
            Text1(1).DataField = Campo2
            Text1(2).DataField = Campo3
End Sub

Private Sub Form_Load()
            Conexion
End Sub

Más adelante publicaré el código para los botones de desplazamiento y modificación de registros. Nos vemos.

[ranefi]

Botones de desplazamiento (continuación de conexión con ADO)

Agregar 4 CommandButton e insertar el siguiente código:

Código:

Private Sub Command1_Click()
            PrimerRegistro
End Sub

Private Sub Command2_Click()
            RegistroAnterior
End Sub

Private Sub Command3_Click()
            RegistroSiguiente
End Sub

Private Sub Command4_Click()
            UltimoRegistro
End Sub



Public Sub PrimerRegistro()
            Rst.MoveFirst
End Sub

Public Sub RegistroAnterior()
            Rst.MovePrevious
                        With Rst
                                    If .BOF Then
                                                .MoveFirst
                                    End If
                        End With
End Sub

Public Sub RegistroSiguiente()
            Rst.MoveNext
                        With Rst
                                    If .EOF Then
                                                .MoveLast
                                    End If
                        End With
End Sub

Public Sub UltimoRegistro()
            Rst.MoveLast
End Sub

Les recuerdo que este código es tomando en cuenta el anterior mensaje (Crear una conexión a una base de datos de Access 2000 en tiempo de ejecución)


Más o menos debe quedar así:



Eso es todo.

[ranefi]

Botones para edición de registros (continuación de conexión con ADO)

Agregar 6 CommandButton al proyecto previamente guardado.

El formulario debe quedar así:



Insertar el siguiente código

Código:

Private Sub Command10_Click()
            End
End Sub

Private Sub Command5_Click()
            Rst.AddNew
End Sub

Private Sub Command6_Click()
            Rst.Update
End Sub

Private Sub Command7_Click()
            Rst.CancelUpdate
End Sub

Private Sub Command8_Click()
            Dim Pregunta As String
                        With Rst
                                    If .RecordCount = .BOF = True And .EOF = True Then
                                                MsgBox "No hay registros que eliminar", vbExclamation, "    ¡Aviso!"
                                    Else
                                                Pregunta = MsgBox("    ¿Desea eliminar este registro?", _
                                                            vbQuestion + vbYesNo + vbDefaultButton2, "    ¡Aviso!")
                                                If Pregunta = vbYes Then
                                                            .Delete
                                                            .UpdateBatch adAffectAllChapters
                                                            .MoveLast
                                                            If .EOF Then .MoveLast
                                                            If .BOF Then GoTo ups
                                                End If
                                    End If
                        End With
End Sub

Private Sub Command9_Click()
            Dim Criterio As String
            Dim Busqueda As String
           
            Busqueda = InputBox("Introduce nombre a buscar", _
                        "Búsqueda por Nombre")
           
                        With Rst
                                    Criterio = "Nombre LIKE '*" & Busqueda & "*'"
                                    If Busqueda = "" Then
                                                Exit Sub
                                    Else
                                                .MoveNext
                                                If Not .EOF Then
                                                            .Find Criterio
                                                End If
                                                If Not .EOF Then
                                                            .Find Criterio
                                                Else
                                                            .MoveFirst
                                                            .Find Criterio
                                                            If .EOF Then
                                                                        .MoveLast
                                                                        MsgBox "Dato no encontrado", _
                                                                                    vbInformation, "    ¡Aviso!"
                                                            End If
                                                End If
                                    End If
                        End With
End Sub

Les recuerdo una vez más, éste código sólo funcionará si se han seguido los mensajes anteriores. Nos vemos.

[ranefi]

Texto en 3D

Agregar un Timer e insertar el siguiente código:

Código:

Private Sub Form_Load()
    Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
    Dim I As Integer
    Dim X As Integer
    Dim Y As Integer

    Me.ForeColor = &H0
   
    X = Me.CurrentX
    Y = Me.CurrentY

    Me.FontSize = 18

    For I = 1 To 3
        Print "Extraído de www.elguruprogramador.com"
        X = X + 1
        Y = Y + 1
        Me.CurrentX = X
        Me.CurrentY = Y
    Next I
    Me.ForeColor = &HFFFFFF
    Print "Extraído de www.elguruprogramador.com"
    Exit Sub
End Sub

Pueden quitar el código que no necesiten y ya dependerá de ustedes el uso que le encuentren. Nos vemos.

[ranefi]

Texto en 3D (mejorado)

Miren mis muchachuelas este código pondrá un texto en su maldito formulario

Nerds recargados agreguen un maldito CommandButton de mier~~ e REPLACEen este maldito código:

Código:

Private Sub Command1_Click()
            Dim I As Integer
            Dim X As Integer
            Dim Y As Integer

            Me.ForeColor = &H0
           
            X = Me.CurrentX
            Y = Me.CurrentY

            Me.FontSize = 25

            For I = 1 To 70
                        Print "CALIGASTIA ES MUY GUAPO"
                        X = X + 1
                        Y = Y + 1
                       
                        Me.CurrentX = X
                        Me.CurrentY = Y
            Next I

            Me.ForeColor = &HFFFFFF
           
            Print "CALIGASTIA ES MUY GUAPO"
End Sub

Explicación y modificación de código del maldito de caligastia, jejejeje, merci mi amigo caligastia. Nos vemos.

[ranefi]

Ejecutar código en determinada fecha

Agregar un Timer e REPLACEar el siguiente código:

Código:

Private Sub Form_Load()
            Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
            Me.Caption = Format(Date, "dd mm yyyy")
           
            If Me.Caption = "07 10 2006" Then
                        MsgBox "ranefi cumple años", _
                                    vbCritical, "    ¿Ontá mi pastel peladete?"
                        Timer1.Enabled = False
            End If
End Sub

    ¿Para qué les podría ser útil ésta cochinadota? Jejejeje.