Biblioteca de Codes Para VisualBasic

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

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

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

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

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

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

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

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

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

            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