Biblioteca de código

[ranefi]

Utilizar el control CommonDialog con colores (propiedad ShowColor)

Agregar 2 CommandButton, 1 TextBox y 1 CommonDialog e REPLACEar el siguiente código

NOTA: El control CommonDialog se agrega presionando CTRL + T y seleccionando el control llamado Microsoft Common Dialog Control 6.0

Código:

Private Sub Command1_Click()
            With CommonDialog1
                        .Flags = 2
                        .ShowColor
                        Text1.BackColor = .Color
            End With
End Sub

Private Sub Command2_Click()
            With CommonDialog1
                        .Flags = 2
                        .ShowColor
                        Text1.ForeColor = .Color
            End With
End Sub

Esto cambia el color de fondo y de fuente de un control TextBox. Nos vemos.

[ranefi]

Cambiar el formato de una fuente con el control CommonDialog (propiedad ShowFont)

Agregar 1 CommonDialog, 1 CommandButton e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    With CommonDialog1
        .Flags = 259
        .ShowFont
        Text1.FontName = .FontName
        Text1.FontSize = .FontSize
        Text1.FontBold = .FontBold
        Text1.FontItalic = .FontItalic
        Text1.FontUnderline = .FontUnderline
        Text1.FontStrikethru = .FontStrikethru
    End With
   
    With Text1
        If .Text = "" Then
            .Text = "Hola mundo, te saluda ranefi"
        End If
    End With
End Sub

Es una forma fácil y rápida de utilizar esta propiedad. Nos vemos.

[ranefi]

Crear-eliminar carpetas y copiar-eliminar archivos

Agregar 4 CommandButtons e REPLACEar el siguiente código

Código:

Public Ruta As String
Public Carpeta As String, Archivo As String, _
    ArchivoNuevo As String
       
       
Private Sub Command1_Click()
On Error GoTo UPS1
    Ruta = "C:\"
    Carpeta = "ranefi"
   
    MkDir Ruta & Carpeta 'CREA UNA CARPETA
    MsgBox "La carpeta llamada " & _
        Carpeta & " fue creada en " & Ruta, _
        vbInformation, "Mensaje"
    Exit Sub
UPS1:
    MsgBox "Carpeta ya existente o unidad inválida", _
        vbCritical, "Error"
End Sub

Private Sub Command2_Click()
On Error GoTo UPS2
    Ruta = "C:\"
    Carpeta = "ranefi"
   
    RmDir Ruta & Carpeta 'ELIMINA UNA CARPETA
    MsgBox "La carpeta llamada " & _
        Carpeta & " fue eliminada de " & Ruta, _
        vbInformation, "Mensaje"
    Exit Sub
UPS2:
    MsgBox "Carpeta no existente o unidad inválida", _
        vbCritical, "Error"
End Sub

Private Sub Command3_Click()
On Error GoTo UPS3
    Ruta = "C:\"
    Carpeta = "ranefi\"
    Archivo = "ranefi.txt"
    ArchivoNuevo = "ranefiEsMuyGuapo.txt"
   
    FileCopy Ruta & Carpeta & Archivo, _
        Ruta & Carpeta & ArchivoNuevo 'COPIA UN ARCHIVO
    MsgBox "El archivo " & Archivo & _
        " fue copiado como " & ArchivoNuevo, _
        vbInformation, "Mensaje"
    Exit Sub
UPS3:
    MsgBox "Te faltó crear un archivo o la ruta es " & _
        vbCrLf & "inválida peladete", _
        vbCritical, "Error"
End Sub


Private Sub Command4_Click()
On Error GoTo UPS4
    Ruta = "C:\"
    Carpeta = "ranefi\"
    Archivo = "ranefiEsMuyGuapo.txt"
   
    Kill Ruta & Carpeta & Archivo 'ELIMINA UN ARCHIVO
    MsgBox "El archivo llamado " & Archivo & _
        " fue eliminado de " & Ruta & Carpeta, _
        vbInformation, "Mensaje"
    Exit Sub
UPS4:
    MsgBox "Te faltó crear un archivo o la ruta es " & _
        vbCrLf & "inválida peladete", _
        vbCritical, "Error"
End Sub

Private Sub Form_Load()
    Command1.Caption = "Crea Carpeta"
    Command2.Caption = "Elimina Carpeta"
    Command3.Caption = "Copia Archivo"
    Command4.Caption = "Elimina Archivo"
End Sub

Esto puede resultar muy útil para crear instaladores. Nos vemos.

[ranefi]

Ocultar y Mostrar la barra de tareas

Agregar 1 CommandButton e REPLACEar el siguiente código

Código:

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

Private Declare Function ShowWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
   

Private Sub Command1_Click()
    Dim InicioVentana As Long
   
    InicioVentana = FindWindow("Shell_TrayWnd", _
        vbNullString)
   
    With Command1
        If .Caption = "&Ocultar" Then
            ShowWindow InicioVentana, 0& 'ESCONDE LA BARRA
            .Caption = "&Mostrar"
        Else
            ShowWindow InicioVentana, 1& 'MUESTRA LA BARRA
            .Caption = "&Ocultar"
        End If
    End With
End Sub

Private Sub Form_Load()
    Command1.Caption = "&Ocultar"
End Sub

Recuerden, ShowWindow InicioVentana, 0&: Esconde la barra de tareas; ShowWindow InicioVentana, 1&: Muestra la barra de tareas. Nos vemos.

[ranefi]

Formulario que se autocopia y desplaza en forma aleatoria

Agregar un control Timer e REPLACEar el siguiente código

Código:

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

Private Sub Timer1_Timer()
    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

Código mejorado por MeGo85. Nos vemos.

[ranefi]

Abrir el contenido de un fichero txt con el bloc de notas

Agregar 1 CommandButton e REPLACEar el siguiente código

Código:

Private Declare Function WinExec Lib "kernel32" _
    (ByVal lpCmdLine As String, _
    ByVal nCmdShow As Long) As Long


Private Sub Command1_Click()
    WinExec "Notepad.exe c:\soyjiman.txt", 10
End Sub

Emmm, se podría usar para mostrar un instructivo o una ayuda rápida. Nos vemos.

[ranefi]

Interactuar con ventana consola y formularios

Agregar 1 control Label e REPLACEar el siguiente código

Código:

Private Const FOREGROUND_BLUE = &H1
Private Const FOREGROUND_GREEN = &H2
Private Const FOREGROUND_RED = &H4
Private Const BACKGROUND_BLUE = &H10
Private Const BACKGROUND_GREEN = &H20
Private Const BACKGROUND_RED = &H40
Private Const BACKGROUND_INTENSITY = &H80&
Private Const BACKGROUND_SEARCH = &H20&
Private Const FOREGROUND_INTENSITY = &H8&
Private Const FOREGROUND_SEARCH = (&H10&)
Private Const ENABLE_LINE_INPUT = &H2&
Private Const ENABLE_ECHO_INPUT = &H4&
Private Const ENABLE_MOUSE_INPUT = &H10&
Private Const ENABLE_PROCESSED_INPUT = &H1&
Private Const ENABLE_WINDOW_INPUT = &H8&
Private Const ENABLE_PROCESSED_OUTPUT = &H1&
Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_ERROR_HANDLE = -12&
Private Const INVALID_HANDLE_VALUE = -1&


Private Declare Function AllocConsole _
    Lib "kernel32" () As Long

Private Declare Function FreeConsole _
    Lib "kernel32" () As Long

Private Declare Function CloseHandle _
    Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function GetStdHandle _
    Lib "kernel32" (ByVal nStdHandle As Long) As Long

Private Declare Function WriteConsole _
    Lib "kernel32" Alias "WriteConsoleA" _
    (ByVal hConsoleOutput As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfCharsToWrite As Long, _
    lpNumberOfCharsWritten As Long, _
    lpReserved As Any) As Long

Private Declare Function ReadConsole _
    Lib "kernel32" Alias "ReadConsoleA" _
    (ByVal hConsoleInput As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfCharsToRead As Long, _
    lpNumberOfCharsRead As Long, _
    lpReserved As Any) As Long

Private Declare Function SetConsoleTextAttribute _
    Lib "kernel32" (ByVal hConsoleOutput As Long, _
    ByVal wAttributes As Long) As Long

Private Declare Function SetConsoleTitle _
    Lib "kernel32" Alias "SetConsoleTitleA" _
    (ByVal lpConsoleTitle As String) As Long

Private hConsoleOut As Long, hConsoleIn As Long, _
    hConsoleErr As Long


Private Sub Form_Load()
    If AllocConsole() Then
        hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE)
       
        If hConsoleOut = INVALID_HANDLE_VALUE Then
            MsgBox "No se pudo obtener STDOUT"
        End If
       
        hConsoleIn = GetStdHandle(STD_INPUT_HANDLE)
       
        If hConsoleOut = INVALID_HANDLE_VALUE Then
            MsgBox "No se pudo obtener STDIN"
        End If
    Else
        MsgBox "    ¡Chin! No encontré la consola"
    End If
   
    SetConsoleTitle "ranefi es muy guapo"
   
    SetConsoleTextAttribute hConsoleOut, _
        FOREGROUND_RED Or FOREGROUND_GREEN Or _
        FOREGROUND_INTENSITY Or BACKGROUND_BLUE
   
    ConsoleWriteLine "No te metas con mi cucu"
   
    ConsoleWrite "Dime tu nombre peladete: "
   
    Label1.AutoSize = True
    Label1.Caption = "Hola " + ConsoleReadLine() + _
        "     ¿pos ontablas peladete cochinón?"
   
    CerrarConsolaCochina
End Sub
Private Sub Form_Unload(Cancel As Integer)
    CerrarConsolaCochina
End Sub
Sub ConsoleWriteLine(sInput As String)
     ConsoleWrite sInput + vbCrLf
End Sub
Sub ConsoleWrite(sInput As String)
     Dim cWritten As Long
     
     WriteConsole hConsoleOut, ByVal sInput, _
        Len(sInput), cWritten, ByVal 0&
End Sub
Function ConsoleReadLine() As String
    Dim ZeroPos As Long
   
    ConsoleReadLine = String(10, 0)
   
    ReadConsole hConsoleIn, ConsoleReadLine, _
        Len(ConsoleReadLine), vbNull, vbNull
   
    ZeroPos = InStr(ConsoleReadLine, Chr$(0))
   
    If ZeroPos > 0 Then
        ConsoleReadLine = Left$(ConsoleReadLine, _
            ZeroPos - 3)
    End If
End Function

Function CerrarConsolaCochina()
    CloseHandle hConsoleOut
    CloseHandle hConsoleIn
    FreeConsole
End Function

Es fácil encontrarle más de una utilidad. Nos vemos.

[ranefi]

Crear un control Label en tiempo de ejecución

REPLACEar el siguiente código

Código:

Const WS_EX_STATICEDGE = &H20000
Const WS_EX_TRANSPARENT = &H20&
Const WS_CHILD = &H40000000
Const CW_USEDEFAULT = &H80000000
Const SW_NORMAL = 1

Private Type CREATESTRUCT
    lpCreateParams As Long
    hInstance As Long
    hMenu As Long
    hWndParent As Long
    cy As Long
    cx As Long
    y As Long
    x As Long
    style As Long
    lpszName As String
    lpszClass As String
    ExStyle As Long
End Type

Private Declare Function CreateWindowEx _
    Lib "user32" Alias "CreateWindowExA" _
    (ByVal dwExStyle As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String, _
    ByVal dwStyle As Long, ByVal x As Long, _
    ByVal y As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hWndParent As Long, _
    ByVal hMenu As Long, _
    ByVal hInstance As Long, _
    lpParam As Any) As Long

Private Declare Function ShowWindow _
    Lib "user32" (ByVal hwnd As Long, _
    ByVal nCmdShow As Long) As Long

Private Declare Function DestroyWindow _
    Lib "user32" (ByVal hwnd As Long) As Long

Dim mWnd As Long

Private Sub Form_Load()
    Dim CS As CREATESTRUCT

    mWnd = CreateWindowEx(WS_EX_STATICEDGE Or _
        WS_EX_TRANSPARENT, "STATIC", _
        "Todo mundo ama a ranefi", WS_CHILD, _
        0, 0, 300, 50, Me.hwnd, 0, _
        App.hInstance, CS)
       
    ShowWindow mWnd, SW_NORMAL
End Sub
Private Sub Form_Unload(Cancel As Integer)
    DestroyWindow mWnd
End Sub

Muy educativo.     ¿No creen? Jejejeje. Au revoir.

[ranefi]

Ejecutar secuencias de teclas en formulario para minimizarlo (CTRL + M)

REPLACEar el siguiente código

Código:

Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312

Private Type POINTAPI
            x As Long
            y As Long
End Type

Private Type Msg
            hWnd As Long
            Message As Long
            wParam As Long
            lParam As Long
            time As Long
            pt As POINTAPI
End Type

Private Declare Function RegisterHotKey _
            Lib "user32" (ByVal hWnd As Long, _
            ByVal id As Long, ByVal fsModifiers As Long, _
            ByVal vk As Long) As Long

Private Declare Function UnregisterHotKey _
            Lib "user32" (ByVal hWnd As Long, _
            ByVal id As Long) As Long

Private Declare Function PeekMessage _
            Lib "user32" Alias "PeekMessageA" _
            (lpMsg As Msg, ByVal hWnd As Long, _
            ByVal wMsgFilterMin As Long, _
            ByVal wMsgFilterMax As Long, _
            ByVal wRemoveMsg As Long) As Long

Private Declare Function WaitMessage _
            Lib "user32" () As Long

Private bCancel As Boolean


Private Sub ProcessMessages()
            Dim Message As Msg
           
            Do While Not bCancel
                       
                        WaitMessage
                       
                        If PeekMessage(Message, Me.hWnd, _
                                    WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
                                    WindowState = vbMinimized
                        End If
                       
                        DoEvents
            Loop
End Sub


Private Sub Form_Load()
            Dim ret As Long
           
            bCancel = False
           
            ret = RegisterHotKey(Me.hWnd, &HBFFF&, _
                        MOD_CONTROL, vbKeyM)
           
            Me.AutoRedraw = True
            Me.Print _
                        "Presiona CTRL + M para minimizar el formulario"
           
            Show
           
            ProcessMessages
End Sub
Private Sub Form_Unload(Cancel As Integer)
            bCancel = True
           
            Call UnregisterHotKey(Me.hWnd, &HBFFF&)
End Sub

Este código se puede combinar con el otro mensaje de Restaurar formulario con CTRL + Z. (Se encuentra en la página 4)

Nos vemos.

[ranefi]

Mantener como formulario hijo una aplicación externa y como padre nuestro formulario (ejemplo con el bloc de notas)

REPLACEar el siguiente código

Código:

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

Private Declare Function GetParent Lib "user32" _
            (ByVal hwnd As Long) As Long

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

Private Declare Function GetWindowThreadProcessId _
            Lib "user32" (ByVal hwnd As Long, _
            lpdwProcessId As Long) As Long

Private Declare Function GetWindow Lib "user32" _
            (ByVal hwnd As Long, ByVal wCmd As Long) As Long

Private Declare Function LockWindowUpdate _
            Lib "user32" (ByVal hwndLock As Long) As Long

Private Declare Function GetDesktopWindow _
            Lib "user32" () As Long

Private Declare Function DestroyWindow _
            Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function TerminateProcess _
            Lib "kernel32" (ByVal hProcess As Long, _
            ByVal uExitCode As Long) As Long

Private Declare Function GetCurrentProcess _
            Lib "kernel32" () As Long

Private Declare Function Putfocus Lib "user32" _
            Alias "SetFocus" (ByVal hwnd As Long) As Long

Const GW_HWNDNEXT = 2

Dim mWnd As Long



Function InstanceToWnd(ByVal target_pid As Long) As Long
            Dim test_hwnd As Long, test_pid As Long, _
                        test_thread_id As Long
            
            test_hwnd = FindWindow(ByVal 0&, ByVal 0&)
            
            Do While test_hwnd <> 0
                        If GetParent(test_hwnd) = 0 Then
                                    test_thread_id = _
                                                GetWindowThreadProcessId(test_hwnd, _
                                                test_pid)
                                    If test_pid = target_pid Then
                                                InstanceToWnd = test_hwnd
                                                Exit Do
                                    End If
                        End If
                        
                        test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
            Loop
End Function

Private Sub Form_Load()
            Dim Pid As Long
            
            LockWindowUpdate GetDesktopWindow
            
            Pid = Shell("c:\windows\notepad.exe", vbNormalFocus)
            
            If Pid = 0 Then
                        MsgBox "Error starting the app", _
                                    vbCritical, "Error"
            End If
            
            mWnd = InstanceToWnd(Pid)
            
            SetParent mWnd, Me.hwnd
            
            Putfocus mWnd
            
            LockWindowUpdate False
End Sub

Private Sub Form_Unload(Cancel As Integer)
            DestroyWindow mWnd 'DESCARGA BLOC DE NOTAS
            
            TerminateProcess GetCurrentProcess, 0 'CIERRA PROGRAMA
End Sub

NOTA: Es muy importante que comentes la siguiente línea de código: TerminateProce ss GetCurrentProc ess, 0; ya que si lo ejecutas con esta línea habilitada tu programa se cerrará (sí, el código fuente) y no se grabará nada. Nos vemos.

[ranefi]

Conocer tu IP real

Agregar 1 CommandButton e REPLACEar el siguiente código

Código:

Private Declare Function URLDownloadToFile Lib "urlmon" _
   Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, _
   ByVal szURL As String, _
   ByVal szFileName As String, _
   ByVal dwReserved As Long, _
   ByVal lpfnCB As Long) As Long
   
Private Declare Function DeleteUrlCacheEntry _
    Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long


Public Function GetPublicIP()
   Dim sSourceUrl As String
   Dim sLocalFile As String
   
   Dim hfile As Long
   Dim buff As String
   
   Dim pos1 As Long
   Dim pos2 As Long
   
   sSourceUrl = "http://vbnet.mvps.org/resources/" & _
        "tools/getpublicip.shtml"
   
   sLocalFile = "c:\ip.txt"
   
   Call DeleteUrlCacheEntry(sSourceUrl)
   
   If DownloadFile(sSourceUrl, sLocalFile) Then
      hfile = FreeFile
     
      Open sLocalFile For Input As #hfile
         buff = Input$(LOF(hfile), hfile)
      Close #hfile
     
      pos1 = InStr(buff, "var ip =")
     
      If pos1 Then
         pos1 = InStr(pos1 + 1, buff, "'", _
            vbTextCompare) + 1
         pos2 = InStr(pos1 + 1, buff, "'", _
            vbTextCompare) '- 1
         GetPublicIP = Mid$(buff, pos1, pos2 - pos1)
      Else
         GetPublicIP = "No se pudo obtener tu IP real"
      End If
     
      Kill sLocalFile
   Else
      GetPublicIP = "No se pudo obtener tu IP real"
   End If
End Function

Private Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
  DownloadFile = URLDownloadToFile(0, sURL, _
    sLocalFile, 0, 0) = ERROR_SUCCESS
End Function

Private Sub Command1_Click()
    Me.Caption = GetPublicIP
End Sub

Debes notar que se crea un archivo en la unidad C, así que si no lo quieres así, cambia la unidad.

Lo que hace este programa es buscar en una dirección de Internet una página con código PHP que te muestra la IP, de ahí, puedes extraer la IP real. Puedes hacer una página con código PHP y subirla a tu servidor, ésa sería una buena idea. Código de Niron Soft. Nos vemos.

[ranefi]

Código para permitir sólo mayúsculas en un TextBox

Código:

Private Sub Text1_KeyPress(KeyAscii As Integer)
            Dim CadenaTemporal as String

            CadenaTemporal = Chr(KeyAscii)
            KeyAscii = Asc(UCase(CadenaTemporal))
End Sub

[ranefi]

Cerrar el Administrador de tareas de Windows (Task Manager)

Agregar un control Timer e REPLACEar el siguiente código

Código:

Private Declare Function FindWindow Lib "user32" _
            Alias "FindWindowA" (ByVal lpClassName As String, _
            ByVal lpWindowName As String) 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_CLOSE = &H10
Dim x As Long

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

Private Sub Timer1_Timer()
            If Second(Now) Mod 1 = 0 Then
                        x = FindWindow(vbNullString, _
                                    "Administrador de tareas de Windows")
                        SendMessage x, WM_CLOSE, 0, 0
            End If
End Sub

    ¡Ay que cochinones somos! Ajajajaja.

Nota: Mod 1 = 0, controla la velocidad de cierre del Administrador de tareas, y bueno, también lo hace el intervalo del Timer. Nos vemos.

[ranefi]

Bloquear la bandeja del CD

Agregar 1 control ListBox, 2 CommandButton (un arreglo de controles; 0 y 1) e REPLACEar el siguiente código

En el formulario

Código:

Option Explicit




Private Sub Form_Load()
           LoadAvailableDrives List1
           Command1(0).Enabled = False
           Command1(1).Enabled = False
End Sub


Private Sub List1_Click()
           Command1(0).Enabled = List1.ListIndex > -1
           Command1(1).Enabled = List1.ListIndex > -1
End Sub


Private Sub Command1_Click(Index As Integer)
           Dim fLock As Boolean
           Dim result As Boolean
           Dim sDrive As String
           

           If List1.ListIndex > -1 Then
                  sDrive = List1.List(List1.ListIndex)

                  fLock = CBool(Index)
                  result = DeviceLock(sDrive, fLock)

                  If result Then
                             Select Case Index
                                    Case 0
                                               Label1.Caption = "El dispositivo " & _
                                                sDrive & " está desbloqueado."
                                    Case 1
                                               Label1.Caption = "El dispositivo " & _
                                                sDrive & " está bloqueado."
                             End Select
                  Else
                             Label1.Caption = _
                                    "Fallo en llamada - " & _
                                                "Quizá no existe el dispositivo."
                  End If
           End If
End Sub


Private Sub LoadAvailableDrives(lst As ListBox)
           Dim lpBuffer As String
           Dim drvType As Long
           Dim currDrive As String


           lpBuffer = GetDriveString()

           Do Until lpBuffer = Chr(0)
                  currDrive = StripNulls(lpBuffer)
                  drvType = GetDriveType(currDrive)
           
                  If (drvType = DRIVE_CDROM) Or _
                             (drvType = DRIVE_REMOVABLE) Then
                             lst.AddItem currDrive
                  End If
           Loop
End Sub


Private Function StripNulls(startstr As String) As String
      Dim pos As Long

      pos = InStr(startstr, Chr$(0))
     
      If pos Then
                  StripNulls = Mid$(startstr, 1, pos - 1)
                  startstr = Mid$(startstr, pos + 1, Len(startstr))
      End If
End Function


Private Function GetDriveString() As String
           Dim sBuffer As String

           sBuffer = Space$((26 * 4) + 1)
     
      If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then
                  GetDriveString = Trim$(sBuffer)
           End If
End Function

En el módulo

Código:

Option Explicit

Public Const DRIVE_REMOVABLE As Long = 2
Public Const DRIVE_CDROM As Long = 5
Public Const INVALID_HANDLE_VALUE As Long = -1&
Public Const GENERIC_READ As Long = &H80000000
Public Const FILE_SHARE_READ As Long = &H1
Public Const FILE_SHARE_WRITE As Long = &H2
Public Const FILE_ANY_ACCESS As Long = &H0
Public Const FILE_READ_ACCESS  As Long = &H1
Public Const FILE_WRITE_ACCESS As Long = &H2
Public Const OPEN_EXISTING As Long = 3
Public Const IOCTL_STORAGE_MEDIA_REMOVAL As _
    Long = &H2D4804

Public Type PREVENT_MEDIA_REMOVAL
   PreventMediaRemoval As Byte
End Type

Public Declare Function GetLogicalDriveStrings _
    Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
 
Public Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal lpRootPathName As String) As Long
 
Public Declare Function DeviceIoControl Lib "kernel32" _
  (ByVal hDevice As Long, _
   ByVal dwIoControlCode As Long, _
   lpInBuffer As Any, _
   ByVal nInBufferSize As Long, _
   lpOutBuffer As Any, _
   ByVal nOutBufferSize As Long, _
   lpBytesReturned As Long, _
   lpOverlapped As Any) As Long

Public Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As Any, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long

Public Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Public Function DeviceLock(sDrive As String, fLock As Boolean) As Boolean
   Dim hDevice As Long
   Dim PMR As PREVENT_MEDIA_REMOVAL
   Dim bytesReturned As Long
   Dim success As Long
 
   sDrive = UnQualifyPath(sDrive)

   hDevice = CreateFile("\\.\" & sDrive, _
                        GENERIC_READ, _
                        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                        ByVal 0&, _
                        OPEN_EXISTING, _
                        0&, 0&)

   
   If hDevice <> INVALID_HANDLE_VALUE Then
      PMR.PreventMediaRemoval = CByte(Abs(fLock))

      success = DeviceIoControl(hDevice, _
                                IOCTL_STORAGE_MEDIA_REMOVAL, _
                                PMR, _
                                Len(PMR), _
                                ByVal 0&, _
                                0&, _
                                bytesReturned, _
                                ByVal 0&)
   
   End If
                       
   Call CloseHandle(hDevice)
   DeviceLock = success <> 0
End Function


Private Function UnQualifyPath(ByVal sPath As String) As String
   sPath = Trim$(sPath)
   
   If Right$(sPath, 1) = "\" Then
      UnQualifyPath = Left$(sPath, Len(sPath) - 1)
   Else
      UnQualifyPath = sPath
   End If
End Function

Ideal para crear software de grabado de discos.

[ranefi]

Descargar un archivo de Internet SIN preguntar

Agregar 1 control CommandButton e REPLACEar el siguiente código

Código:

Private Declare Function URLDownloadToFile Lib "urlmon" _
   Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, _
   ByVal szURL As String, _
   ByVal szFileName As String, _
   ByVal dwReserved As Long, _
   ByVal lpfnCB As Long) As Long


Private Sub Command1_Click()
    Dim sSourceUrl As String

    sSourceUrl = "http://mx.geocities.com/" & _
        "posotroranefi/msnmsgr.zip"

    DownloadFile sSourceUrl, "C:\ranefi.zip"
End Sub


Private Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
  DownloadFile = URLDownloadToFile(0, sURL, _
    sLocalFile, 0, 0) = ERROR_SUCCESS
End Function

Noten que este código descargará un archivo al disco duro duro con el nombre de ranefi.zip. Nos vemos.