Biblioteca de código

[ranefi]

Buscar palabras en un TextBox

Agregar dos TextBox y un CommandButton:

Código:

Private Sub Command1_Click()
            BuscarTexto
End Sub

Sub BuscarTexto()
            Dim Pos As Integer
            Dim PalabraClave As String
            Dim TipoBusqueda As Long

            PalabraClave = Text2.Text

            If Len(PalabraClave) Then
                        TipoBusqueda = vbTextCompare
                        Pos = InStr(PosIni + 1, Text1.Text, _
                                    PalabraClave, TipoBusqueda)
                        If Pos > 0 Then
                                    Text1.SelStart = Pos - 1
                                    Text1.SelLength = Len(PalabraClave)
                                    Text1.SetFocus
                        Else
                                    Text1.SetFocus
                        End If
            End If
End Sub

Sirve para buscar palabras en un cuadro de texto. Puede ser útil para un editor de texto.

[ranefi]

Ejecutar código en una determinada fecha (mejorado)

Agregar un Timer e REPLACEar el siguiente código:

Código:

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

Private Sub Timer1_Timer()
    If Month(Now) = 10 And Day(Now) = 7 Then
        MsgBox "ranefi cumple años", _
            vbCritical, "    ¿Ontá mi pastel peladete?"
        Timer1.Enabled = False
    End If
End Sub

Código mejorado por  Punk-Rock. Nos vemos pelaos.

[ranefi]

Saber cuándo un número es Par o Impar

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Private Sub Command1_Click()
            Dim PreguntaCochina As Integer
           
            PreguntaCochina = InputBox("    ¡REPLACEa un número!")
           
            If PreguntaCochina Mod 2 = 0 Then
                        MsgBox "el numero es par"
            Else
                        MsgBox "el numero es impar"
            End If
End Sub

Código proporcionado por FemBr.

[ranefi]

Barra de progreso sin control ProgressBar

Agregar un Timer y un Label:

Código:

Private Sub Form_Load()
            With Label1
                        .BackColor = vbRed
                        .Width = 0
                        .Caption = ""
            End With
            Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
            With Label1
                        If .Width < 3375 Then
                                    .Width = .Width + 100
                        Else
                                    MsgBox "como la vee cochinotes", vbCritical, "asi de facil"
                                    .Width = .Width
                                    Timer1.Enabled = False
                        End If
            End With
End Sub

Código proporcionado por el cochinote de caligastia.

[ranefi]

Cambiar el nombre de la PC

Agregar un CommandButton y un TextBox e REPLACEar el siguiente código

Código:

Private Declare Function SetComputerName Lib "kernel32" _
    Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long

Private Sub Command1_Click()
    Dim NuevoNombre As String
   
    NuevoNombre = Text1.Text
   
    SetComputerName NuevoNombre
   
    MsgBox "La PC ahora se llama " & NuevoNombre
End Sub

Es muy fácil.

[ranefi]

Restringir la lectura de archivos a otro usuario

Debes crear un archivo llamado test.txt en la unidad C: e REPLACEar el siguiente código

Código:

Private Declare Function EncryptFile Lib "ADVAPI32" Alias _
            "EncryptFileA" (ByVal lpFileName As String) As Boolean

Private Declare Function DecryptFile Lib "ADVAPI32" Alias _
            "DecryptFileA" (ByVal lpFileName As String, _
            ByVal dwReserved As Long) As Boolean

Const mFile = "c:\test.txt"

Private Sub Form_Load()
            Encrypt mFile
End Sub
Sub Encrypt(sFile As String)
            If EncryptFile(mFile) Then
                        MsgBox "El archivo ha sido encriptado. Intenta acceder al archivo desde otro usuario pa' que veas"
            End If
End Sub
Sub Decrypt(sFile As String)
            If DecryptFile(mFile, 0) = True Then
                        MsgBox "El mugroso archivo ha sido desencriptado."
            End If
End Sub

Nota: Encryptfile SÓLO FUNCIONA CON NTFS 5. Código de API Guide.

Este código no permite que otros usuarios lean un archivo que nosotros previamente creamos. Nos vemos.

[ranefi]

Establecer una combinación de teclas a un formulario

REPLACEar el siguiente código:

Código:

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Long) As Long

Private Declare Function DefWindowProc Lib "user32" _
    Alias "DefWindowProcA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Const WM_SETHOTKEY = &H32
Const WM_SHOWWINDOW = &H18
Const HK_SHIFTA = &H141 'Shift + A
Const HK_SHIFTB = &H142 'Shift + B
Const HK_CONTROLA = &H241 'Control + A
Const HK_ALTZ = &H45A 'Alt + Z

Private Sub Form_Load()
    Me.WindowState = vbMinimized
   
    erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)

    If erg& <> 1 Then
        MsgBox "Necesitas otra mugre combinación de teclas", vbOKOnly, "Error"
    End If

    erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, 0, 0)
End Sub

NOTA: El valor de la combinación de teclas debe ser declarada en formato lowbyte/highbyte (se puede interpretar como ByteInferior/ByteSuperior). Esto es como Número hexadécimal: Los últimos dos carácteres específican el lowbyte (ejemplillo: 41 = a), el primero es highbyte (ejemplillo: 01 = 1 = Shift)

El formulario aparecerá minimizado y tendrás que presionar ALT + Z para maximizarlo. Código de API Guide. Nos vemos.

[ranefi]

Extraer iconos de archivos y dibujarlos en un PictureBox

Agregar un CommandButton y un PictureBox e REPLACEar el siguiente código:

Código:

Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE

Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" _
    Alias "ExtractAssociatedIconA" (ByVal hInst As Long, _
    ByVal lpIconPath As String, lpiIcon As Long) As Long

Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, _
    ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, _
    ByVal cxWidth As Long, ByVal cyWidth As Long, _
    ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, _
    ByVal diFlags As Long) As Long

Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Sub Command1_Click()
    Dim mIcon As Long

    mIcon = ExtractAssociatedIcon(App.hInstance, "C:\Autoexec.bat", 2)

    DrawIconEx Picture1.hdc, 0, 0, mIcon, 0, 0, 0, 0, DI_NORMAL

    DestroyIcon mIcon
End Sub

Obviamente se podrán extraer los iconos de diferentes archivos y además dibujarlos en controles diferentes (que soporten esta propiedad) al PictureBox. Nos vemos. Código de API Guide.

[ranefi]

Conocer los tamaños de papel soportados por la impresora

REPLACEar el siguiente código:

Código:

Const DC_PAPERS = 2

Private Declare Function DeviceCapabilities Lib "winspool.drv" _
    Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
    ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
    lpDevMode As Any) As Long

Private Sub Form_Load()
    Dim Ret As Long, PaperSizes() As Integer
   
    Ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, _
        ByVal 0&, ByVal 0&)
   
    ReDim PaperSizes(1 To Ret) As Integer
   
    Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, _
        PaperSizes(1), ByVal 0&)
   
    Me.AutoRedraw = True
    Me.Print "Tamaños de papel soportados:"
   
    Dim Cnt As Long
    For Cnt = 1 To Ret
        Me.Print Str$(PaperSizes(Cnt))
    Next
End Sub

No estoy muy seguro si este código funciona con otro tipo de puertos de impresora. Código de API Guide. Nos vemos.

[ranefi]

Registrar/Desregistrar Controles (OCX) y/o Librerías (DLLs)

Agreagar dos CommandButton e insertar el siguiente código:

En un módulo:

Código:

Declare Function DllRegisterServer Lib "mswinsck.ocx" () As Long
Declare Function DllUnregisterServer Lib "mswinsck.ocx" () As Long

En un formulario:

Código:

Const ERROR_SUCCESS = &H0

Private Sub Command1_Click()
            If DllRegisterServer = ERROR_SUCCESS Then
                        MsgBox "Registro exitoso"
            Else
                        MsgBox "Error al registrar"
            End If
End Sub

Private Sub Command2_Click()
            If DllUnregisterServer = ERROR_SUCCESS Then
                        MsgBox "Desregistro exitoso"
            Else
                        MsgBox "Error al desregistrar"
            End If
End Sub

Creo que ya saben para qué podría servir, jejeje. Código de API Guide. Nos vemos.

[ranefi]

Descargar un archivo de Internet

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Private Declare Function DoFileDownload Lib "shdocvw.dll" _
            (ByVal lpszFile As String) As Long

Private Sub Command1_Click()
            DoFileDownload _
            StrConv("http://mx.geocities.com/posotroranefi/msnmsgr.zip", vbUnicode)
End Sub

Deben tener Internet Explorer funcionando correctamente, de lo contrario aparecerá un error y se cerrará Visual Basic sin guardar cambios. Código de API Guide. Nos vemos.

[ranefi]

Inicio animado de formulario

REPLACEar el siguiente código:

Código:

Const IDANI_OPEN = &H1
Const IDANI_CLOSE = &H2
Const IDANI_CAPTION = &H3

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

Private Declare Function SetRect Lib "User32" (lpRect As RECT, _
            ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
            ByVal Y2 As Long) As Long

Private Declare Function DrawAnimatedRects Lib "User32" _
            (ByVal hWnd As Long, ByVal idAni As Long, lprcFrom As RECT, _
            lprcTo As RECT) As Long

Private Sub Form_Load()
            Dim rSource As RECT, rDest As RECT, ScreenWidth As Long, _
                        ScreenHeight As Long
                       
            ScreenWidth = Screen.Width / Screen.TwipsPerPixelX
            ScreenHeight = Screen.Height / Screen.TwipsPerPixelY

            SetRect rSource, ScreenWidth, ScreenHeight, ScreenWidth, _
                        ScreenHeight
            SetRect rDest, 0, 0, 200, 200
           
            DrawAnimatedRects Me.hWnd, IDANI_CLOSE Or IDANI_CAPTION, _
                        rSource, rDest
           
            Me.Move 0, 0, 200 * Screen.TwipsPerPixelX, 200 * _
                        Screen.TwipsPerPixelY
End Sub

Esto es solo para que sea vea más presentable nuestra aplicación (Pa' impresionar a las morras, jejejeje). Código de API Guide. Nos vemos.

[ranefi]

Crear formularios y moverlos de forma aleatoria

REPLACEar el siguiente código:

Código:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim frmFormulariosCochinos As Form1
   
    Randomize Timer
   
    Me.Top = Int(Rnd * 8000) - 100
    Me.Left = Int(Rnd * 14000) - 1000
   
    Set frmFormulariosCochinos = New Form1
   
    frmFormulariosCochinos.Visible = True
End Sub

Jajajaja, es gracioso este cochino código. Inspirado por MeGo85. Nos vemos.

[ranefi]

Abrir un documento de Word previamente guardado

Agregar un CommandButton e REPLACEar el siguiente código:

Código:

Private Sub Command1_Click()
On Error GoTo ups
    Dim CochinoWord As Object
   
    Set CochinoWord = CreateObject("Word.Basic")
   
    CochinoWord.ChDefaultDir "C:\", 0
    CochinoWord.FileOpen Name:="CochinoDocumento.doc"
    CochinoWord.AppShow
    CochinoWord.AppMaximize
    Exit Sub
ups:
    MsgBox "    ¡Ups! Un error cochino ocurrió", _
        vbCritical, "Error cochinooooo"
    End
End Sub

Se asume que existe un documento de Word llamado CochinoDocumen to.doc ubicado en la unidad C. Nos vemos.

[ranefi]

Matar un proceso

Agregar un CommandButton e insertar el siguiente código:

Código:

Private Sub Command1_Click()
    KillProcess ("msnmsgr.exe")
End Sub

Public Sub KillProcess(ByVal processName As String)
On Error GoTo ErrHandler
    Dim oWMI
    Dim ret
    Dim sService
    Dim oWMIServices
    Dim oWMIService
    Dim oServices
    Dim oService
    Dim servicename

    Set oWMI = GetObject("winmgmts:")
    Set oServices = oWMI.InstancesOf("win32_process")

    For Each oService In oServices
        servicename = _
            LCase(Trim(CStr(oService.Name) & ""))

        If InStr(1, servicename, _
            LCase(processName), vbTextCompare) > 0 Then
            ret = oService.Terminate
        End If
    Next

    Set oServices = Nothing
    Set oWMI = Nothing
    Exit Sub
ErrHandler:
    Err.Clear
End Sub

Con este código finalizaremos el proceso del Messenger; pueden cambiar "msnmsgr.exe" por "winword". "winword" cerrará a Microsoft Word. Nos vemos.