vb

Obtener la ubicación de las carpetas del sistema

Con esta función API puedes recuperar la ubicación de la situación, en el sistema donde esta corriendo tu aplicación, de las carpetas del sistema, como el Escritorio, Impresoras, Fuentes, Favoritos, Etc…

Copia este ejemplo en un formulario:

Option Explicit On
' Definimos las constantes de las carpetas 
Const CSIDL_DESKTOP = &H0
Const CSIDL_PROGRAMS = &H2
Const CSIDL_CONTROLS = &H3
Const CSIDL_PRINTERS = &H4
Const CSIDL_PERSONAL = &H5
Const CSIDL_FAVORITES = &H6
Const CSIDL_STARTUP = &H7
Const CSIDL_RECENT = &H8
Const CSIDL_SENDTO = &H9
Const CSIDL_BITBUCKET = &HA
Const CSIDL_STARTMENU = &HB
Const CSIDL_DESKTOPDIRECTORY = &H10
Const CSIDL_DRIVES = &H11
Const CSIDL_NETWORK = &H12
Const CSIDL_NETHOOD = &H13
Const CSIDL_FONTS = &H14
Const CSIDL_TEMPLATES = &H15
Const MAX_PATH = 260
Private Type SHITEMID
    cb As Long 
    abID As Byte 
End Type 
Private Type ITEMIDLIST 
    mkid As SHITEMID 
End Type 
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, _
    ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, _
    ByVal nFolder As Long, ByVal pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Sub Form_Load()
    ' Activamos el grafico persistente en el formulario 
    Me.AutoRedraw = True
    ' Mostramos la información en el formulario 
    ' Algunas carpetas devolvera vacio en función del sistema en el que trabajeis 
    Me.Print("Carpeta Desktop..........: " + CarpetadelSistema(CSIDL_DESKTOP))
    Me.Print("Carpeta Programs.........: " + CarpetadelSistema(CSIDL_PROGRAMS))
    Me.Print("Carpeta Controls.........: " + CarpetadelSistema(CSIDL_CONTROLS))
    Me.Print("Carpeta Printers.........: " + CarpetadelSistema(CSIDL_PRINTERS))
    Me.Print("Carpeta Personal.........: " + CarpetadelSistema(CSIDL_PERSONAL))
    Me.Print("Carpeta Favorites........: " + CarpetadelSistema(CSIDL_FAVORITES))
    Me.Print("Carpeta Star UP..........: " + CarpetadelSistema(CSIDL_STARTUP))
    Me.Print("Carpeta Recent...........: " + CarpetadelSistema(CSIDL_RECENT))
    Me.Print("Carpeta Send To..........: " + CarpetadelSistema(CSIDL_SENDTO))
    Me.Print("Carpeta Bit Bucket.......: " + CarpetadelSistema(CSIDL_BITBUCKET))
    Me.Print("Carpeta Start Menu.......: " + CarpetadelSistema(CSIDL_STARTMENU))
    Me.Print("Carpeta Desktop Directory: " + CarpetadelSistema(CSIDL_DESKTOPDIRECTORY))
    Me.Print("Carpeta Drivers..........: " + CarpetadelSistema(CSIDL_DRIVES))
    Me.Print("Carpeta Network..........: " + CarpetadelSistema(CSIDL_NETWORK))
    Me.Print("Carpeta Net Hood.........: " + CarpetadelSistema(CSIDL_NETHOOD))
    Me.Print("Carpeta Fonts............: " + CarpetadelSistema(CSIDL_FONTS))
    Me.Print("Carpeta Templates........: " + CarpetadelSistema(CSIDL_TEMPLATES))
End Sub
Private Function CarpetadelSistema(ByVal CSIDL As Long) As String
    Dim Res As Long, Camino As String, IDL As ITEMIDLIST
    ' Obtenemos el controlador del sistema 
    Res = SHGetSpecialFolderLocation(100, CSIDL, IDL)
    If Res = 0 Then
        'Creamos el buffer 
        Camino = Space$(512)
        'Obtenermos el camino de IDList 
        Res = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Camino) 
        ' Eliminamos los caracteres Chr(0) 
        CarpetadelSistema = Left$(Camino, InStr(Camino, Chr$(0)) - 1)
        Exit Function
    End If
    CarpetadelSistema = ""
End Function
Anuncios

Asignar la hora actual al sistema

Con esta función API puedes actualizar la hora del sistema completando los datos del tipo SYSTEMTIME, la declaración sería.

Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Un ejemplo:

Dim HoraSistema As SYSTEMTIME
Dim FechaActual As Date
Dim lReturn As Long

' Una fecha al azar
FechaActual = CDate(#12/1/2003 4:45:23 AM#)

' Ahora preparamos los datos para actualizar el reloj del sistema
With HoraSistema
    .wYear = DatePart("yyyy", FechaActual)
    .wMonth = DatePart("m", FechaActual)
    .wDay = DatePart("d", FechaActual)
    .wHour = DatePart("h", FechaActual)
    .wMinute = DatePart("n", FechaActual)
    .wSecond = DatePart("s", FechaActual)
    .wMilliseconds = 0
End With
' Asignamos la hora al sistema
lReturn = SetSystemTime(HoraSistema)

Conocer si es año bisiesto.

Prueba esta función, si devuelve True es que es Bisiesto.

Function BisiestoSINO(Year As Date) As Boolean
    Dim Mod400 As Long, Mod100 As Long, Mod4 As Long
    
    BisiestoSINO = False 'Indica si es bisiesto o no
    Mod400 = Year Mod 400
    Mod100 = Year Mod 100
    Mod4 = Year Mod 4
    
    If (Mod400 = 0) Then BisiestoSINO = True
    If (Mod100 = 0) And (Mod400  0) Then BisiestoSINO = False
    If (Mod4 = 0) And (Mod100  0) Or ((Mod4 = 0) And (Mod400 = 0)) Then BisiestoSINO = True
End Function

Publicado en microsoft.public.es.asp por Pablo Viojo

Function BisiestoSINO(Year As Date) As Boolean
    BisiestoSINO = Day(DateSerial(Year(Fecha), 3, 0)) = 29
End Function

Tagen nos ha enviado otra función más cortita.

Conocer el último día del mes.

Sólo tienes que sumar un mes al día 1 del mes actual y restarle un día.

Function UltimoDiaMes(Fecha As Date) As Date 
    UltimoDiaMes = DateAdd("d", -1, DateAdd("m", 1, DateSerial(Year(Fecha), Month(Fecha), 1))) 
End Function 

Tagen nos ha enviado otras 2 funciones para obtener el mismo resultado.

Están basadas en que para la función DateSerial el día 0 de un mes es el ultimo día del mes anterior.

Function UltimoDiaMes(Fecha As Date) As Date 
    UltimoDiaMes = DateSerial(Year(Fecha), Month(Fecha) + 1, 0) 
End Function 

Function UltimoDiaMes2(Fecha As Date) As Byte 
    UltimoDiaMes2 = Day(DateSerial(Year(Fecha), Month(Fecha) + 1, 0)) 
End Function 

Publicado en microsoft.public.es.vb por Rubén Vigón

Hacer PING desde código Visual Basic.

El Winsock maneja protocolos, no es una herramienta que cubre necesidades puntuales. Prueba esta API que maneja el protocolo ICMP.

Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, _ 
    ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, _ 
    ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long 

Publicado en microsoft.public.es.vb por foreback

Cómo crear un DSN mediante código VB.

Este ejemplo genera en el registro de windows la entrada necesaria para crear un DSN desde el código de nuestro programa. Este código es fácil de trasladar a otros lenguajes, ya que sólo hay que tocar el registro.

Option Explicit
Private Const REG_SZ = 1    'Constant for a string variable type.
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, _
   ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, _
   ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
   ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Sub Command1_Click()
   Dim DataSourceName As String
   Dim DatabaseName As String
   Dim Description As String
   Dim DriverPath As String
   Dim DriverName As String
   Dim LastUser As String
   Dim Regional As String
   Dim Server As String
   Dim lResult As Long
   Dim hKeyHandle As Long   'Specify the DSN parameters.
   DataSourceName = ""
   DatabaseName = ""
   Description = ""
   DriverPath = ""
   LastUser = ""
   Server = ""
   DriverName = "SQL Server"   'Create the new DSN key.

   'Set the values of the new DSN key.
   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.INI" & DataSourceName, hKeyHandle)
   lResult = RegSetValueEx(hKeyHandle, "Database", 0&, REG_SZ, ByVal DatabaseName, Len(DatabaseName))
   lResult = RegSetValueEx(hKeyHandle, "Description", 0&, REG_SZ, ByVal Description, Len(Description))
   lResult = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, ByVal DriverPath, Len(DriverPath))
   lResult = RegSetValueEx(hKeyHandle, "LastUser", 0&, REG_SZ, ByVal LastUser, Len(LastUser))
   lResult = RegSetValueEx(hKeyHandle, "Server", 0&, REG_SZ, ByVal Server, Len(Server))
   'Close the new DSN key.
   lResult = RegCloseKey(hKeyHandle)

   'Open ODBC Data Sources key to list the new DSN in the ODBC Manager.
   'Specify the new value.   'Close the key.
   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.INIODBC Data Sources", hKeyHandle)
   lResult = RegSetValueEx(hKeyHandle, DataSourceName, 0&, REG_SZ, ByVal DriverName, Len(DriverName))
   lResult = RegCloseKey(hKeyHandle)
End Sub

Publicado en microsoft.public.es.vb por Roberto Carretero

Extraer el valor Rojo, Verde y Azul de un color Hexadecimal.

Con estas funciones podrás extraer el valor RGB de Rojo, Verde y Azul de un valor Hexadecimal.

Public Function RedFromRGB(ByVal RGB As Long) As Integer
   RedFromRGB = &HFF& And RGB
End Function
Public Function GreenFromRGB(ByVal RGB As Long) As Integer
   GreenFromRGB = (&HFF00& And RGB)  256
End Function
Public Function BlueFromRGB(ByVal RGB As Long) As Integer
   BlueFromRGB = (&HFF0000 And RGB)  65536
End Function

Publicado en es.comp.lenguajes.visual-basic por iNFiNiTY

Implementar y Destruir Timer con API´s

Con estas funciones podrás crear Timers que no se detendrán con un MsgBox.

Para Crear el Timer

Declare Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long 

Y esta otra para Destruirlo

Declare Function KillTimer Lib "User32" (ByVal hWnd As Long, nIDEvent As Long) As Long

Volcar el contenido de un fichero en una cadena de texto.

Crea un proyecto que contenga un TextBox (Text1) y añade el siguiente código:

Private Sub Form_Load()
    Text1.Text = "c:autoexec.bat"
    Debug.Print DameContenidoFichero(Text1.Text)
End Sub
Function DameContenidoFichero(ByVal xFicheroDatos As String) As String
    ' Devuelve en una cadena el contenido del fichero indicado
    Dim xContenido As String, lLongitud As Long, iFreeFile As Integer   
    
    iFreeFile = FreeFile()
    Open xFicheroDatos For Binary Access Read Shared As #iFreeFile
    lLongitud = LOF(iFreeFile)
    xContenido = Space(lLongitud)
    Get #iFreeFile, , xContenido
    Close #iFreeFile
    DameContenidoFichero = xContenido
End Function

En la ventana de depuración debe salirte el contenido del fichero.

Iniciar o finalizar el Salvapantallas de Windows.

Con estas dos funciones puedes activar o desactivar el Salvapantallas.

Para realizar este proyecto debes crear un formulario con 2 botones, uno “Habilitar” y otro “Deshabilitar”.

Private Declare Function SystemParametersInfo Lib "user32" _
        Alias "SystemParametersInfoA" (ByVal uAction As Long, _
        ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Const SPI_SETSCREENSAVEACTIVE = 17
Private Sub DesHabilitar_Click()
    Dim lngRet As Long
    lngRet = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, True, 0, 0)
End Sub

Private Sub Habilitar_Click()
    Dim lngRet As Long
    lngRet = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, False, 0, 0)
End Sub