Biblioteca de Codes Para VisualBasic

Bueno Aqui Empesare a Poner Varios Codes, que he ido recopilando y sacado de una web de un amigo ( El me Autorizo)

Me Gustaria Que Ustedes Tambien Postearan Sus Codes, Pero Solo Codes nada de Preguntas asi para mantener el Orden del Topic y no desvirtuar el Tema

Mostrar palabra que se encuentra debajo del cursor

Agregar 1 control Label y 1 RichTextBox y poner el siguiente código

Insertar CODE, HTML o PHP:

Option Explicit

Private Const EM_CHARFROMPOS& = &HD7
Private Type POINTAPI
    X As Long
    Y As Long
End Type

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


Public Function RichWordOver(rch As RichTextBox, X As Single, Y As Single) As String
    Dim pt As POINTAPI
    
    Dim pos As Integer
    Dim start_pos As Integer
    Dim end_pos As Integer
    
    Dim ch As String
    Dim txt As String
    
    Dim txtlen As Integer


    pt.X = X \ Screen.TwipsPerPixelX
    pt.Y = Y \ Screen.TwipsPerPixelY


    pos = SendMessage(rch.hWnd, EM_CHARFROMPOS, 0&, pt)
    If pos <= 0 Then Exit Function

    txt = rch.Text
    For start_pos = pos To 1 Step -1
        ch = Mid$(rch.Text, start_pos, 1)

        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next start_pos
    start_pos = start_pos + 1


    txtlen = Len(txt)
    For end_pos = pos To txtlen
        ch = Mid$(txt, end_pos, 1)

        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next end_pos
    end_pos = end_pos - 1

    If start_pos <= end_pos Then _
        RichWordOver = Mid$(txt, start_pos, _
            end_pos - start_pos + 1)
End Function

Private Sub Form_Load()
    RichTextBox1.Text = "Que rica esta tu hermanita, que " & _
        "esta en mi casita, se esta cayendo de buena " & _
        vbCrLf & vbCrLf & "porque ya esta madurita.. " & _
            "Jojojo"
End Sub

Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim txt As String

    txt = RichWordOver(RichTextBox1, X, Y)
    
    If Label1.Caption <> txt Then
        Label1.Caption = txt
    End If
End Sub

Formulario que explota e implota (animación de inicio)

Agregar 1 control CommandButton y poner el siguiente código

En el Formulario

Insertar CODE, HTML o PHP:

Private Sub Command1_Click()
    Call ImplodeForm(Me, 2, 500, 1)
    
    End
    
    Set Form1 = Nothing
End Sub

Private Sub Form_Load()
    Call ExplodeForm(Me, 500)
    Command1.Caption = "Dame un cochino clic"
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call ImplodeForm(Me, 2, 500, 1)
End Sub

En el Modulo

Insertar CODE, HTML o PHP:

Option Explicit


#If Win16 Then
    Type RECT
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
    End Type
#Else
    Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
#End If


#If Win16 Then
    Declare Sub GetWindowRect Lib "User" _
        (ByVal hwnd As Integer, lpRect As RECT)
    
    Declare Function GetDC Lib "User" _
        (ByVal hwnd As Integer) As Integer
    
    Declare Function ReleaseDC Lib "User" _
        (ByVal hwnd As Integer, _
        ByVal hdc As Integer) As Integer
    
    Declare Sub SetBkColor Lib "GDI" _
        (ByVal hdc As Integer, ByVal crColor As Long)
    
    Declare Sub Rectangle Lib "GDI" _
        (ByVal hdc As Integer, ByVal X1 As Integer, _
        ByVal Y1 As Integer, ByVal X2 As Integer, _
        ByVal Y2 As Integer)
    
    Declare Function CreateSolidBrush Lib "GDI" _
        (ByVal crColor As Long) As Integer
    
    Declare Function SelectObject Lib "GDI" _
        (ByVal hdc As Integer, _
        ByVal hObject As Integer) As Integer
    
    Declare Sub DeleteObject Lib "GDI" _
        (ByVal hObject As Integer)
#Else
    Declare Function GetWindowRect Lib "user32" _
        (ByVal hwnd As Long, lpRect As RECT) As Long
    
    Declare Function GetDC Lib "user32" _
        (ByVal hwnd As Long) As Long
    
    Declare Function ReleaseDC Lib "user32" _
        (ByVal hwnd As Long, ByVal hdc As Long) As Long
    
    Declare Function SetBkColor Lib "gdi32" _
        (ByVal hdc As Long, ByVal crColor As Long) _
        As Long
    
    Declare Function Rectangle Lib "gdi32" _
        (ByVal hdc As Long, ByVal X1 As Long, _
        ByVal Y1 As Long, ByVal X2 As Long, _
        ByVal Y2 As Long) As Long
    
    Declare Function CreateSolidBrush Lib "gdi32" _
        (ByVal crColor As Long) As Long
    
    Declare Function SelectObject Lib "user32" _
        (ByVal hdc As Long, _
        ByVal hObject As Long) As Long
    
    Declare Function DeleteObject Lib "gdi32" _
        (ByVal hObject As Long) As Long
#End If


Sub ExplodeForm(f As Form, Movement As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
    Dim TheScreen As Long
    Dim Brush As Long
    
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
    
    For i = 1 To Movement
        Cx = formWidth * (i / Movement)
        Cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - Cx) / 2
        Y = myRect.Top + (formHeight - Cy) / 2
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy
    Next i
    
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub


Public Sub ImplodeForm(f As Form, Direction As Integer, Movement As Integer, ModalState As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
    Dim TheScreen As Long
    Dim Brush As Long
    
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
    
        For i = Movement To 1 Step -1
        Cx = formWidth * (i / Movement)
        Cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - Cx) / 2
        Y = myRect.Top + (formHeight - Cy) / 2
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy
    Next i
    
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub

Abrir y Cerrar unidad de CD
Agregar un 2 CommandButton y introducir lo siguiente:

En el Formulario

Insertar CODE, HTML o PHP:

Private Sub Command1_Click()
            mciSendString "set CDAudio door open", "", 127, 0
End Sub

Private Sub Command2_Click()
            mciSendString "set CDAudio door closed", "", 127, 0
End Sub

En el Modulo

Insertar CODE, HTML o PHP:

Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
            (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
            ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Con este Code Podras Abrir una Unidad Predeterminada de CD


Bloquear Ratón y Teclado durante 10 segundos

Agregar un Timer y un CommandButton e introducir lo siguiente:

En el Formulario:

Insertar CODE, HTML o PHP:

Private Sub Command1_Click()
            BlockInput True
            ShowCursor False
End Sub

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

Private Sub Timer1_Timer()
            BlockInput False
            ShowCursor True
End Sub

En el Modulo:

Insertar CODE, HTML o PHP:

Public Declare Function BlockInput Lib "user32" _
            (ByVal fBlock As Long) As Long

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

Con esto Bloquearas el Teclado y el Mouse por 10 Seg. ideal para hacer bromas ^^



Cerrar el Explorador de Internet

Agregar un CommandButton en el formulario y introducir lo siguiente:

En el Formulario:

Insertar CODE, HTML o PHP:

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 mensaje"
                        End If
            Else
                        MsgBox "El Internet Explorer no est&#225; abierto, Avispate"
            End If
End Sub

En el Modulo:

Insertar CODE, HTML o PHP:

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

Cambiar el fondo de escritorio de Windows

Agregar un CommandButton y poner el siguiente código:

En el Formulario:

Insertar CODE, HTML o PHP:

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, _
                        "[COLOR=Red]C:\Windows\wallpaper.bpm[/COLOR]", SPIF_UPDATEINIFILE
End Sub

Por Supuesto que la Imagen que queremos poner como fondo de escritorio en este ejemplo este en el directorio "C:\Windows\wallpaper.bpm"
puedes cambiarlo por la ruta que tu quieras


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

En el Formulario:

Insertar CODE, HTML o PHP:

            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 & "\midb.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

Este Code me sirvio a mi para hacer un programa para un Doctor $$

 

uhh hace caleta que no entraba jaja, voi a revivir este post