CODIGO RECOGIDO EN LAS NEWS DE ACCESS (MICROSOFT)
FRANCISCO GARCÍA AGUADO [ABRIL 2002]
'Aprovecha este fichero de texto para ir metiendo y almacenando
'las buenas respuestas que se dan en las News de Access
'http://personal4.iddeo.es/pacogarcia/happypagaag.zip
'Este codigo es para ver el numero de usurios conectados
'a una MDB leyendo el fichero LDB
'Dim str As String
'str = CurrentProject.Path & "\produccion_datos.mdb" '(Base de datos a consultar)
'lista_usuarios_conectados.RowSource = "Vaciar"        '(Cuadro de lista)
'lista_usuarios_conectados.RowSource = ""
'On Error GoTo et_ru
'Dim i, j As Integer
'Dim Usuari(10, 2) As String
'i = 1
'j = 0
'If Dir(str) <> "" Then
'    str = Left(str, Len(str) - 3) & "ldb"
'    Open str For Input As #1
'    Do While Not EOF(1)
'       Usuari(i, 1) = Input$(36, #1)
'        lista_usuarios_conectados.RowSource = Usuari(i, 1) & ";" & lista_usuarios_conectados.RowSource ' Usuari(i, 1)
'         i = i + 1
'        j = j + 1
'    Loop

'et_sortir:
'    Close #1
'    Exit Sub
'End If

'et_ru:
'    Select Case Err.Number
'        Case 55:
'            Resume Next
'        Case 62:
'            Resume et_sortir
'        Case 3021:
'            j = 0
'            Resume et_sortir
'        Case 53:
'            MsgBox "Sin usuarios activos"
'        Case Else:
'            MsgBox Err.Number & "  " & Err.Description
'    End Select
'    Close #1
'End Sub
'================================
'================================
'UN EJEMPLO DE ALGUIEN QUE ME CONTESTO EN LAS NEWS DE COMO
'RELLENAR UN COMBO CON LISTA DE VALORES
'Sub RellenarCombo(Combo As ComboBox, Vector As Variant)
'    Dim Valores As String
'    Dim Elem As Variant
'    Dim i As Integer
'    For Each Elem In Vector
'        Valores = Valores & Elem & ";"
'    Next
'    Combo.RowSource = Valores
'End Sub
'
'
'Private Sub Boton_Click()
'    Dim Vector As Variant
'    Dim i As Integer
'    ReDim Vector(1 To 10) As Integer
'    For i = 1 To 10
'        Vector(i) = i
'    Next
'    RellenarCombo Me.Cuadro, Vector
'End Sub


'Dim m() As Integer
'Dim Contador As Integer
'ReDim m(1 To 8)
'For Contador = 1 To 8
'    m(Contador) = Contador
'Next

' Otra utilidad muy buena
'Sacar el cuadro de impresora
'sin necesidad del Commondialog
' DoCmd.RunCommand acCmdPrint
'emviado por jcaleroj@hotmail.com (Suso).
'===========================
'===========================
'Otra utilidad para saber la creacion de una tabla
'y su ultima modificacion
'Function MiraTabla()
'Dim i As Date
'i = DLookup("datecreate", "msysobjects", "type=1 and name='Clientes'")
'
'i = DLookup("dateupdate", "msysobjects", "type=1 and name='clientes'")
'End Function
'========================
'========================
' Otra utilidad para cambiar en todos los registros de una
'tabla, un caracter por otro cambiar todas las N por T, por ejemplo
'Public Sub CambiarDatos()
'    Dim BaseDatos As Database
'    Dim Rs As Recordset
'    Dim PosInicial As Integer
'    Dim CampoX As String
'    Set BaseDatos = CurrentDb()
'    Set Rs = BaseDatos.OpenRecordset("Nombre de la Tabla")
'    Rs.MoveFirst
'    Do Until Rs.EOF()          ' Empieza a comparar hasta fin de fichero
'        PosInicial = InStr(Rs.[CampoaComparar], "N") 'Busca la primera N
'        Do While PosInicial <> 0
'            CampoX = Rs.[CampoaComparar]
                ' Sustituimos la primera aparicion de "N" por "T"
'            CampoX = Left$(CampoX, (PosInicial - 1)) & "T" & Right$(CampoX, (PosInicial + 1))
'            PosInicial = InStr(CampoX, "N")      'Busca las siguientes apariciones
'        Loop          'Termina el bucle de sustitucion en el mismo campo
'
'        Rs.MoveNext         ' Avanza siguiente Registro
'    Loop                      ' Sigue la comparacion
'
'    Close
'End Sub

'Despues de escribir este pequeño programita, solo tienes que llamar a la
'ventana de depuracion de código (CTRL+S) y teclear el nombre del
'procedimiento (CambiarDatos);
'Saludos.-
'Gomzky

'otro post para quitar botones de la barra de herramientas.
'Si quieres hacer ésto a través de código, debes tener activada una
'referencia a la biblioteca Microsoft Object Library en tu proyecto de Visual
'Basic y poner este código (que desactivaría la opción Eliminar registro),
'por ejemplo en el evento Al cargar del formulario:

'    Dim ctl As CommandBarControl
'
'      For Each ctl In CommandBars("Menu Bar").Controls(2).Controls
'        If ctl.Caption = "Eliminar regi&stro" Then
'          ctl.Enabled = False
'          Exit For
'        End If
'      Next

'y en el evento Al cerrar del formulario, pones el mismo código, pero cambias
'la línea

'    ctl.Enabled = False

'por

'    ctl.Enabled = True

'et voilà.

'COPIAR AL PORTAPAPELES DE WINDOWS
'Call ClipBoard_SetData("Lo que quieras copiar")
'*******************************************************************
'Private Const GHND = &H42
'Private Const MAXSIZE = 4096
'Private Const CF_TEXT = 1

'Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _
'  dwBytes As Long) As Long
'Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
'  As Long
'Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
  As Long
'Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
'  ByVal lpString2 As Any) As Long
'Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
  As Long
'Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) _
  As Long
'Private Declare Function CloseClipboard Lib "user32" () As Long
'Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _
  Long) As Long
'Private Declare Function EmptyClipboard Lib "user32" () As Long
'Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
  As Long, ByVal hMem As Long) As Long
'*************************************************************************
'Function ClipBoard_SetData(MyString As String)
'  Dim hGlobalMemory As Long, lpGlobalMemory As Long
'  Dim hClipMemory As Long, x As Long
'  hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
'  lpGlobalMemory = GlobalLock(hGlobalMemory)
'  lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
'  If GlobalUnlock(hGlobalMemory) <> 0 Then
'    MsgBox "Could not unlock memory location. Copy aborted."
'    GoTo OutOfHere2
'  End If
'  If OpenClipboard(0&) = 0 Then
'    MsgBox "No se puede abrir el protapapeles. Copia abortada."
'    Exit Function
'  End If
'  x = EmptyClipboard()
'  hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
'OutOfHere2:
'  If CloseClipboard() = 0 Then
'    MsgBox "Could not close Clipboard."
'  End If
'End Function
'***************************************************************************
'Eduardo Olaz
'IMprimir un TXT 
Public Sub Imprimir(ByVal Texto As String)

    Dim lngFichero As Long
    lngFichero = FreeFile
    Open "LPT1" For Output As #lngFichero
    Print #lngFichero, Texto
    Close #lngFichero

End Sub
_________________________________

Para imprimir haz símplemente:

        Imprimir "Primera línea"
        Imprimir "Segunda línea"

Para extraer la página usa

        Imprimir chr$(12)
'=====================================================================
'Respuesta de Happy a  Javier Muñoz sobre una pregunta
'de como ocultar barras de herramientas.
'Hola Javier, respondiendo a tu pregunta sobre las barras 
'de herramientas, te mando este código, que lo que haría es 
'al abrir un formulario, desactivar todas las barras de 
'herramientas, menos la barra de menús. Creará una matriz y 
'guardará en ella los nombres de las barras de herramientas 
'que estén activas, para que al cerrar el formulario, todo 
'vuelva al estado anterior. Para que esto tenga efecto, 
'deberás activar una referencia a la librería Microsoft 
'Office x.x Object Library. 
 
'Primero definimos unas variables a 
'nivel de módulo para que estén disponibles
'en la vida del formulario
'Matriz que guardará los nombres de 
'las barras de herramientas

Dim barrasDisponibles() As String
'Variable que guardará el número
'de barras disponibles

Dim numBarras As Integer
 
'Al cargarse el formulario
Private Sub Form_Load()
Dim cbr As CommandBar
 
  'Recorremos la colección CommandBars
  For Each cbr In CommandBars
    'Si la barra está activa
    If cbr.Enabled Then
      'y no es la barra de menús
      If cbr.Name <> "Menu Bar" Then
        'Redimensionamos la matriz a un elemento más
        ReDim Preserve barrasDisponibles(numBarras)
        barrasDisponibles(numBarras) = cbr.Name
        numBarras = numBarras + 1
        'Desactivamos la barra
        cbr.Enabled = False
      End If
    End If
  Next
  
End Sub

'Al cerrar el formulario
Private Sub Form_Close()
Dim i As Integer
  
  'Recorremos la matriz con los nombres de las 
  'barras que estaban activadas
  For i = 0 To numBarras - 1
    'y las volvemos a activar
    CommandBars(barrasDisponibles(i)).Enabled = True
  Next
  
End Sub
 
'Fíjate que mientras tengas desactivadas las barras de 
'herramientas sólo tendrás disponible la barra de menús. Si 
'haces click con el botón derecho, no aparecerá ningún 
'menú, ni nada estará activado. Si quieres activar otras 
'barras de menú contextuales, echale un vistazo al ejemplo 
'sobre barras de herramientas que construí, que se hizo 
'para ayudar en cosas como ésta y alguna más.
 
'=============================================
'Esto sirve para meter un report en vista previa, llamado
'desde un formulario MODAL. Si se hace sin mas, el Report
'se queda en segundo plano y no se ve.
'Yo mismo busque la respuesta:
Sub OpenReport(ReportName As String, Optional View As Integer, Optional _
    FilterName As String, Optional WhereCondition As String)
Dim loFormArray() As String
Dim loform As Form
Dim intCount As Integer
Dim intX As Integer
    For Each loform In Forms
        If loform.Visible Then
            ReDim Preserve loFormArray(intCount)
            loFormArray(intCount) = loform.Name
            loform.Visible = False
            intCount = intCount + 1
        End If
    Next
    DoCmd.OpenReport ReportName, View, FilterName, WhereCondition
    Do While IsVisible(acReport, ReportName): DoEvents: Loop
    For intX = intCount - 1 To 0 Step -1
        Forms(loFormArray(intX)).Visible = True
    Next
End Sub
Function IsVisible(intObjType As Integer, strObjName As String) As Boolean
Dim intObjState As Integer
    intObjState = SysCmd(acSysCmdGetObjectState, intObjType, strObjName)
    IsVisible = intObjState And acObjStateOpen
End Function
'
'
'=================================
'Funcion de Eduardo Olaz para, metiendo el numero de la semana
'natural del año, nos de el día de inicio de la semana y el día de fin
Public Function PrimerDiaSemanaN( _
                  ByVal Semana As Long, _
                  Optional ByVal Año As Long = -1) _
                  As Date
   '************************************
   'Esta función devuelve el primer día
   'de un Nº de semana de un año
   'El año es opcional
   'Si no se introduce toma el año actual
   'Considera semana Nº 1
   'la 1ª con cuatro días en el año
   '  (Constante vbFirstFourDays)
   'El primer día de la semana es Lunes
   '  (Constante vbMonday)
   ' © Eduardo Olaz - Enero de 2001
   '************************************

   Dim datLunesSemana1 As Date
   Dim datLunesTemporal As Date
   Dim lngSemana As Long
   Dim lngAñoTemporal As Long
   Dim lngDiaSemana As Long

   'Si no se ha introducido año toma el actual
   If Año = -1 Then
      Año = Year(Date)
   End If
   If Semana < 1 Or Semana > 53 Then
      Exit Function
   End If

   datLunesSemana1 = CDate("1/1/" & CStr(Año))
   lngSemana = DatePart("ww", _
                        datLunesSemana1, _
                        vbMonday, _
                        vbFirstFourDays)
   lngDiaSemana = DatePart("w", _
                        datLunesSemana1, _
                        vbMonday)
   If lngSemana > 1 Then
      datLunesSemana1 = datLunesSemana1 + 8 - lngDiaSemana
   Else
      datLunesSemana1 = datLunesSemana1 + 1 - lngDiaSemana
   End If

   datLunesTemporal = datLunesSemana1 + 7 * (Semana - 1)
   lngAñoTemporal = Year(datLunesTemporal)

   'Comprueba (Semana 53) si el año es el solicitado
   If lngAñoTemporal > Año Then
      Exit Function
   Else
      PrimerDiaSemanaN = datLunesTemporal
   End If

End Function

'_________________
'Esta funcion la puse yo en las News para ejecutar cualquier fichero
'y que Access reconociera automaticamante la aplicacion que tenía
'asociada por defecto.

El primer paso es meter el siguiente código dentro de un Módulo:

Option Compare Database
Option Explicit
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal
hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long)
As Long
Public Const SW_SHOW = 1
'Funcion
Function EjecutaFichero(frm As Form, ByVal document_name As String)
On Error GoTo Err_Comando7_Click
 ShellExecute frm.hwnd, "open", document_name, "", "", SW_SHOW
Exit_Comando7_Click:
    Exit Function

Err_Comando7_Click:
    MsgBox "Funcion EjecutaFichero, Módulo Funciones" & Chr(13) & Chr(10) &
"Aviso Nº: " & Err.Number & Chr(13) & Chr(10) & "Mensaje :" &
Err.Description, vbCritical + vbOKOnly, "Mensaje de posible Error"
    Resume Exit_Comando7_Click
End Function

Una vez creada esta funcion, ya la podemos llamar desde cualquier
formulario, de la forma:

Private Sub Comando170_Click()
On Error GoTo Err_Comando170_Click

Dim Nada
Nada = EjecutaFichero(Me, "C:\minutas\datos.mdb")

Exit_Comando170_Click:
    Exit Sub

Err_Comando170_Click:
    MsgBox Err.Description
    Resume Exit_Comando170_Click

End Sub
'
'
'============================================================
'
'OTRA DE EDURADO OLAZ PARA DIBUJAR LINEAS Y
'RECTANGULOS EN REPORTES
'Abre un nuevo informe y escribe este código

____________________________________

Private Sub Report_Page()
        Const conIzquierda As Long = 50
        Const conDerecha As Long = 9000
        Const conArriba As Long = 100
        Const conAbajo As Long = 12000
        Const conEstrecho As Long = 1
        Const conAncho As Long = 50
        Const conLineas As Long = 40

        Dim i As Long
        Dim Y As Long
        Dim X As Long
        Dim lngIncremento As Long

        lngIncremento = (conAbajo - conArriba) / conLineas

        DrawWidth = conEstrecho
        Line (conIzquierda, conArriba)-(conIzquierda, conAbajo)
        DrawWidth = conAncho
        Line (conIzquierda, conAbajo)-(conDerecha, conAbajo)
        DrawWidth = conEstrecho
        Line (conDerecha, conAbajo)-(conDerecha, conArriba)
        DrawWidth = conAncho
        Line (conDerecha, conArriba)-(conIzquierda, conArriba)

        DrawWidth = conEstrecho
        For i = 1 To conLineas - 1
            Y = conArriba + i * lngIncremento
            Line (conIzquierda, Y)-(conDerecha, Y)
        Next i
        X = conIzquierda + (conDerecha - conIzquierda) / 8
        Line (X, conArriba)-(X, conAbajo)
        X = conIzquierda + (conDerecha - conIzquierda) / 2
        Line (X, conArriba)-(X, conAbajo)
        X = conDerecha - (conDerecha - conIzquierda) / 4
        Line (X, conArriba)-(X, conAbajo)
        DrawWidth = conAncho / 2
        'También se puede dibujar un rectángulo
        'con la opción B
        Line (conIzquierda, conAbajo + 500)-(conDerecha, conAbajo + 1000), ,B
End Sub

Aquí la tienes DameCarpetaWindows()

Usa el API GetWindowsDirectory
'_______________________________________
Funcion de Eduardo Olaz para saacar la carpeta
'donde esta el Sistema (Windows)

Declare Function GetWindowsDirectory _
                        Lib "kernel32.dll" _
                        Alias "GetWindowsDirectoryA" ( _
                        ByVal lpBuffer As String, _
                        ByVal nSize As Long) _
                        As Long

Public Function DameCarpetaWindows() As String
   'Devuelve la carpeta de Windows
   ' eduardo@olaz.net
   Const conlngCadena As Long = 255
   Dim strDirectorio As String * conlngCadena
   Dim lngDirectorio As Long
   Dim lngPath As Long
   lngDirectorio = conlngCadena

   lngPath = GetWindowsDirectory(strDirectorio, lngDirectorio)
   DameCarpetaWindows = Left$(strDirectorio, lngPath)
End Function
'Esta función cambia la propiedad DecimalPlaces
'a 2 en todos los campos tipo Double de todas
'las tablas de una bd.
' Juan M. Afán de Ribera - happy
'----------------------------------------------------
Function CambiarDecimalesCamposDoble()
Dim tdf As TableDef, fld As Field, prp As Property

  For Each tdf In CurrentDb.TableDefs
    For Each fld In tdf.Fields
      If fld.Type = dbDouble Then
      For Each prp In fld.Properties
        If prp.Name = "DecimalPlaces" Then
          prp.Value = 2
        End If
      Next
      End If
    Next
  Next

End Function

'Esta función cambia la propiedad DecimalPlaces
'a 2 en el campo de la tabla que se pasa como
'argumento a la función
' Juan M. Afán de Ribera - happy
'--------------------------------------------------------
Function CambiarDecimales(NombreTabla As String, NombreCampo As String)
Dim tdf As TableDef, fld As Field, prp As Property

  For Each tdf In CurrentDb.TableDefs
    If tdf.Name = NombreTabla Then
    For Each fld In tdf.Fields
      If fld.Name = NombreCampo Then
      For Each prp In fld.Properties
        If prp.Name = "DecimalPlaces" Then
          prp.Value = 2
        End If
      Next
      End If
    Next
    End If
  Next

End Function

'Estas son mías
Option Compare Database
Option Explicit

Function MiraReferenciasVBA()
    Dim Ref As Reference


   'Sacado de la ayuda de Access para ver si se ha
   'roto alguna referencia del proyecto de VBA.
   'Bhúo, Junio de 2002

   'Puede servir para cuando distribuyamos una aplicacion
   'con referencias externas a funciones inmersas en: OCX,DLL, MDE, MDB...)
   'que nosotros en el proyecto hemos referenciado desde una determinada ubicación
   'local de nuestro PC y a la hora de ejecutar el programa el usuario, pueda dar errores
   'por no tener dichas referencias o tenerlas en otra ubicacion distinta
   'y de esta forma el usuario nos pueda avisar de esta contingencia.
   'Esta función se puede poner en el formulario de inicio de la aplicación
   'para avisar al usuario de este tema.

    For Each Ref In References
       
        If Ref.IsBroken = False Then
         ' este msgbox e puramente informativo de las referencias que están OK
         ' y es para probar este código.
         MsgBox "Nombre de la Referencia: " & Ref.Name & vbCrLf _
          & "En la ruta: " & Ref.FullPath & vbCrLf _
          & "Versión de la Referencia: " & Ref.Major & "." & Ref.Minor, vbInformation + vbOKOnly, "Referencias en VBA"
        Else
         ' referencia rota
          MsgBox "Nombre de la Referencia rota:" & Ref.Name & vbCrLf _
           & "Ruta Origina: " & Ref.FullPath & vbCrLf _
           & "GUID completo de la Referencia: " & Ref.Guid, vbCritical + vbOKOnly, "AVISO: Servicio de mantenimiento del programa 95-22222222."
         'aquí la acción a seguir...
         
         'Sacado tambien de la yuda de access.
         'En este ejemplo, se podría poner ruta completa, mediante
         'un dialogo de Windows e intentar referenciar de nuevo
         'la referencia rota o bien abandonar la aplicacion.
         'En este caso ponemos una ruta fija que sirva de ejemplo:
         'C:\Windows\System\Mscal.ocx
         'Recordar que el nombre y Path original de la referencia
         'sería ref.FullPath
         If CrearNuevaReferencia("C:\Windows\System\Mscal.ocx") = False Then
          MsgBox "No se ha podido regenerar la referencia.", vbCritical + vbOKOnly, "Aviso"
         Else
          MsgBox "La Referencia, " & Ref.FullPath & " se ha establecido correctamente.", vbExclamation + vbOKOnly, "Correcto"
         End If
        End If
    Next Ref
End Function

Function CrearNuevaReferencia(PathCompletoFichero As String) As Boolean
    Dim Ref As Reference

    On Error GoTo Error_CrearNuevaReferencia
    Set Ref = References.AddFromFile(PathCompletoFichero)
    CrearNuevaReferencia = True

Exit_CrearNuevaReferencia:
    Exit Function

Error_CrearNuevaReferencia:
    MsgBox "Aviso Nº: " & Err & "..." & Err.Description & " [" & PathCompletoFichero & "]", vbCritical + vbOKOnly, "Aviso de Error"
    CrearNuevaReferencia = False
    Resume Exit_CrearNuevaReferencia
End Function

' Jesus Lopez, cambiar una consult permamente
Puedes modificar una consulta de la siguiente manera:

Dim qdf As DAO.QueryDef
set qdf = CurrentDb.QueryDefs("LaConsulta")
qdf.SQL = "LA NUEVA SENTENCIA SQL"

'=======================
Te mando un procedimiento que hace las dos cosas, crea el 
acceso directo y recupera la fecha de la última 
modificación. Es un honor y un placer poder ayudarte.

Un abrazo.

Sub AccesoDirectoYAtributos()
Dim shell As Object
Dim fso As Scripting.FileSystemObject
Dim rutaescritorio As String
Dim fichero As Scripting.File

Set shell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")

rutaescritorio = shell.SpecialFolders("Desktop")
On Error Resume Next
fso.DeleteFile rutaescritorio & "\Acceso a AINCTB.lnk"
On Error GoTo 0

Set vinculo = shell.CreateShortcut(rutaescritorio 
& "\Acceso a AINCTB.lnk")
vinculo.Arguments = "\ainctb\ainctb.mdb"
vinculo.Description = "prueba de acceso directo"
vinculo.HotKey = "CTRL+ALT+SHIFT+X"

vinculo.TargetPath = _
"C:\Archivos de programa\Microsoft Office\Office10
\MSACCESS.EXE"
vinculo.WindowStyle = 3
vinculo.WorkingDirectory = "c:\ainctb"
vinculo.Save

' Recuperar atributos de archivo
Set fichero = fso.GetFile("c:\ainctb\ainctb.mdb")
MsgBox (fichero.DateLastModified)
End Sub

Windows Script Host (WSH)

Windows Script Host es una aplicación host "invisible" que permite ejecutar los scripts directamente desde los sistemas operativos Windows. WSH se considera como una archivo de proceso por lotes avanzado. Es particularmente utilizada por los administradores a la hora de automatizar las tareas o crear scripts de conexión (ejecutados en el momento del logon de un usuario).

WSH existe en dos versiones :

CScript.exe, una versión de "línea de comandos", particularmente adaptada para tareas que no requieren la interacción del usuario, o destinada a manipular la información de los flujos de datos estándar,

WScript.exe, una versión de "Win32", que permite interactividad con el usuario por la inclusión de información o de diálogos.

El código VBScript siguiente verifica la existencia de un acceso directo en el escritorio del usuario a una hoja Excel "planning.xls". Sólo en caso de que esta última no existiera, él lo crearía. El Runtime de Scripting, así como los objetos Shell y Shortcut de WSH, son utilizados para realizar esta acción.

dim oShell
dim oLnk
dim oFS

dim sLocalPath
dim sRemotePath

set oFS = WScript.CreateObject("Scripting.FileSystemObject")
set oShell = WScript.CreateObject("WScript.Shell")

sLocalPath = oShell.SpecialFolders("Desktop") & "\Planning.lnk"
sRemotePath = "\\equiposrv\actividad\planning.xls"

if not oFS.FileExists(sLocalPath) then
	set oLnk = oShell.CreateShortcut(sLocalPath)
	oLnk.TargetPath = sRemotePath
	oLnk.Save
end if

set oLNK = nothing
set oShell = nothing
set oFS = nothing

Scripting remoto

Scripting remoto es una tecnología que permite un script DHTML (con Internet Explorer como aplicación host) para llamar a funciones de script ASP (con IIS como aplicación host). Esta arquitectura utiliza un applet de Java que lanza las llamadas entre el usuario y el servidor web, sin crear la consulta HTTP.

Codificador de Scripts

Codificador de Scripts es una herramienta de línea de comandos que permite encriptar un archivo fuente de VBScript o JScript para garantizar la propiedad intelectual. La decodificación está segura por el motor de script, incluso por ejemplo por la inclusión de etiquetas del tipo :

<script language="VBScript.encode" src="hot.vbs"></script>

 

Depurador de Scripts

Depurador de Scripts es un entorno de depuración que amplía las funcionalidades de ciertas aplicaciones host. Utilizado junto con Internet Explorer o Internet Information Server, los desarrolladores pueden ver, publicar y depurar los scripts ejecutados por estas aplicaciones, gracias a las siguientes funcionalidades : 

Visualización del script que se está ejecutando. 
Control de la ejecución del script con puntos de parada y en ejecución. 
Visualización y modificación de los valores de las variables y propiedades utilizadas. 
Visualización y control de la pila de llamadas.
Todas estas funcionalidades se integran en la herramienta de desarrollo Visual Interdev 6, haciendo obsoleto el uso del Depurador de Scripts.

Interfaces de Windows Script

Interfaces de Windows Script son un juego de interfaces COM que los desarrolladores de Visual C++ utilizan, para crear

aplicaciones destinadas para ser host de script, exponiendo posiblemente un modelo de objetos intrínsecos, 
de nuevos motores de scripts.
Microsoft proporciona estas interfaces sujeto a la aceptación de una licencia de utilización y desarrollo.

Control de Script

Control de Script es un control ActiveX (msscript.ocx) que permite a los desarrolladores crear una aplicación que soporta el scripting. De utilización más cómoda que las Interfaces de Windows Script, está limitado, pero es un medio eficaz para crear rápidamente pequeñas aplicaciones que tienen que ejecutar scripts.

Microsoft proporciona este control sujeto a la aceptación de una licencia de utilización y desarrollo.


Soporte técnico

Consejos generales

Como se ha dicho anteriormente, Windows Script hablando con propiedad, no es un producto, ni una herramienta de desarrollo. En cierta medida, la mayoría de los problemas acerca de Windows Script son de hecho, él limite para utilizar esta arquitectura.

Así, los problemas encontrados generalmente no se deben a Windows Script, sino al contexto general de su utilización (desarrollo de una aplicación web, preparar un agente en una carpeta pública de Exchange).

La solución a semejante problema pasa por una buena comprensión de la arquitectura (saber las dependencias entre el motor de script, la aplicación host, los modelos de objetos utilizados), un conocimiento profundo de los principales motorores (VBScript et JScript) y de los principales modelos de objetos (ADO, ADSI, etc.).

La tabla siguiente permite identificar la fuente de un componente de Windows Script, además de determinar posibles incoherencias de instalación entre la aplicación host y comprender por qué esta u otra funcionalidad no es accesible (versión anterior de Windows Script).

'=============================
'Funcion que resta un minuto a la hora actual

    Dim fecha As Date
    fecha = DateAdd("n", -1, Now)
    MsgBox fecha & " " & Now

-- 
Saludos:
 
Jesús López
MCP SQL Server
'========================


'Codigo de Happy para saber el numero de usuarios conectados, utilizaando ADO
Sub UsuariosConectados()
Dim cnn As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim fld As ADODB.Field

'Abre la conexión para el proyecto actual y llama al
'método OpenSchema para devolver la lista actual de usuarios.
    Set cnn = CurrentProject.Connection
    Set rst = cnn1.OpenSchema(adSchemaProviderSpecific, , _
        "{947bb102-5d43-11d1-bdbf-00c04fb92675}")


'Imprimimos en la ventana de inmediato las propiedades
'de la lista de usuarios
    While Not rst.EOF
      For Each fld In rst.Fields
        Debug.Print fld.Name & ": " & fld.Value
      Next
      rst1.MoveNext
    Wend

End Sub

Aún así, por lo que tengo entendido, a veces los identificadores de usuarios
permanecen después de haberse desconectado
La función OpenSchema te devuelve un recorset con información a cerca de la base de datos, dependiendo de los parámetros que le pases te dará una información u otra, hay una información "estándar" y otra que es específica del motor de base de datos (proveedor OLEDB), para obtener esa información específica tienes que pasale adSchemaProviderSpecific y un GUID que determina el tipo de información a devolver. Este GUID lo define el proveedor OLEDB y tiene que estar documentado en algún sitio. En el caso de Access (proveedor OLEDB del Jet 4) son los siguientes:
 
DBSCHEMA_JETOLEDB_ISAMSTATS  ISAM Performance Statistics 
GUID: {8703b612-5d43-11d1-bdbf-00c04fb92675} 
 
DBSCHEMA_JETOLEDB_REPLCONFLICTTABLES  
   
List of Conflict Tables in Replicas 
GUID: {e2082df2-54ac-11d1-bbdbb-00c04fb92675} 
 
DBSCHEMA_JETOLEDB_REPLPARTIALFILTERLIST   
List of Partial Filters in Replicas 
GUID: {e2082df0-54ac-11d1-bdbb-00c04fb92675} 
 
DBSCHEMA_JETOLEDB_USERROSTER   
Jet User Roster 
GUID: {947bb102-5d43-11d1-bdbf-00c04fb92675} 

'===============================
'Codigo de Eduardo Olaz para crear formularios dinamicamente
En anteriores intervenciones he dicho cosas como:

1.-  No se pueden crear controles
      en tiempo de ejecución
2.- No se pueden crear matrices de controles

Pues, de alguna manera, no es cierto

 Asignar al Click de un botón
el procedimiento CrearFormulario
______________________________________

Option Explicit

Sub CrearFormulario()
' **************
' Código de prueba
' eduardo@olaz.net
' Junio de 2002
' **************

    Dim frm As Form
    Dim strFormulario As String
    Const conFilas As Long = 16
    Const conColumnas As Long = 16
    Const conAncho As Long = 400
    Const conAlto As Long = 400
    Const conSeparacion As Long = 50
    Const conMargenX As Long = 40
    Const conMargenY As Long = 40
    Const conComilla As String = """"
    Const conIncrementoColor As Long = 65536
    Dim lngFila As Long
    Dim lngColumna As Long
    Dim lngX As Long
    Dim lngY As Long
    Dim ctlEtiqueta As Control
    Dim ctlLabel As Control, ctlText As Control
    Dim ctlBoton As Control
    Dim intDataX As Integer, intDataY As Integer
    Dim intLabelX As Integer, intLabelY As Integer
    Dim colColor As Long
    Dim aControles() As Control
    Dim strCodigoBotonSalir As String
    Dim mdlFormulario As Module

    ReDim aControles(conColumnas, conFilas)
    ' Crea el nuevo formulario
    Set frm = CreateForm
    colColor = 0 * conIncrementoColor \ 16
    With frm
        .RecordSelectors = False
        .NavigationButtons = False
        .Width = 7300
        .ScrollBars = 0
        .DividingLines = False
        .MinMaxButtons = 0
    End With

    For lngFila = 0 To conFilas - 1
        lngY = lngY + conAncho + conSeparacion
        For lngColumna = 0 To conColumnas - 1
           lngX = lngX + conAlto + conSeparacion
           Set aControles(lngColumna, lngFila) = CreateControl(frm.Name,
acLabel, , "", "", _
            lngX, lngY, conAncho, conAlto)
            Set ctlEtiqueta = aControles(lngColumna, lngFila)
            With ctlEtiqueta
                .BackColor = colColor
                .BackStyle = 1
            End With
            colColor = colColor + conIncrementoColor
        Next lngColumna

        lngX = 0
    Next lngFila

        Set ctlBoton = CreateControl(frm.Name, acCommandButton, , "", "",
8000, 8000, 1500, 500)
        ctlBoton.Caption = "Salir"
        ctlBoton.Name = "cmdSalir"

    Set mdlFormulario = frm.Module
    strCodigoBotonSalir = "Private sub " & ctlBoton.Name & "_Click()" & _
                        vbCrLf & _
                        vbCrLf & _
                        "msgbox " & conComilla & "Cierro el formulario" &
conComilla & _
                        " & me.name " & _
                        vbCrLf & _
                        "    docmd.Close" & _
                        vbCrLf & _
                        "End Sub"
    With mdlFormulario
        .InsertText strCodigoBotonSalir
    End With
    ' Restaura el formulario.
    DoCmd.Restore
    Erase aControles
    Set ctlEtiqueta = Nothing
    strFormulario = frm.Name
    DoCmd.Save acForm, strFormulario
    DoCmd.OpenForm strFormulario

    Debug.Print Forms(strFormulario).Width
    Set frm = Nothing
End Sub

______________________________________

¿Os ha gustado...?

Saludos:

Eduardo

'=================================
Ante todo pido disculpas por incluir texto con formato HTML, pero se ve el código más claro que en el caso de Sólo texto.
El tamaño no es sólo por el formato, sino por el contenido.
 
Por cierto, para colorear el código he utilizado un programa desarrollado por "El Guille"
Si te interesa lo puedes encontrar en
http://guille.costasol.net/utilidades/htmcodecolor/gsHTMCC2.zip

--------------------------------------------------------------------------------

Este código hace lo siguiente
 
Utilizando Sólo DAO
 
CrearBD Crea la base de datos
 DatosAmigos.mdb
 
CrearTablas 
    Crea 2 tablas, en esa base de datos, definiendo diferentes tipos de datos e índices.
         Amigos
         Sexos
    Establece una relación de integridad referencial con borrado en cascada en el campo idSexo entre
         Sexos
            y
         Amigos
 
AñadirDatos
    Añade datos a las dos tablas
 
MostrarAmigosDeMadrid
    Abre un recordset con algunos de los campos de las tablas, seleccionando los amigos de Madrid, y los muestra en la ventana de depuración.
 
Y ahora paciencia para digerir el código, que me ha salido un pelín largo.
¡Que aproveche!

--------------------------------------------------------------------------------

 
Option Explicit

' Código ejemplo para el uso de ADO
' eduardo@olaz.net
' Junio de 2002
 
Const constrBD As String = "DatosAmigos.mdb"
Const conblnExclusivo As Boolean = True
Public Const conComilla As String = """"

Type TAmigo
    Nombre As String * 25
    Apellido As String * 25
    Sexo As String * 15
    FechaNacimiento As Date
    LugarNacimiento As String * 25
    Telefono As String * 25
    Nota As String
End Type

Public Sub CrearBDEnCarpetaActual( _
    Optional ByVal BaseDatos As String = constrBD)
    Dim strRuta As String
    
    strRuta = CurrentProject.Path & "\"
    'Llamamos al procedimiento para crear la BD
    CrearBD strRuta, BaseDatos
End Sub

Public Sub CrearBD( _
            ByVal Ruta As String, _
            ByVal FicheroBD As String)
            
    Dim wrkActual As DAO.Workspace
    Dim dbNuevo As DAO.Database
    Dim strFicheroBD As String
    Dim lngRespuesta As Long
    
    If Right(Ruta, 1) <> "\" Then
        Ruta = Ruta & "\"
    End If
    strFicheroBD = Ruta & FicheroBD
    'Comprobamos si existe la BD a crear
    If Dir(strFicheroBD) = FicheroBD Then
        lngRespuesta = MsgBox(" ¿Desea borrar la base de datos" & vbCrLf _
                        & strFicheroBD & "?", _
                        vbYesNo + vbInformation, _
                        " La base de datos " & FicheroBD & " ya existe")
        'Si la respuesta es sí borramos la BD anterior
        If lngRespuesta = vbYes Then
            Kill strFicheroBD
        Else
            Exit Sub
        End If
    End If
    'Asignamos a wrkActual la sesión actual
    Set wrkActual = DBEngine.Workspaces(0)
    'Asignamos a dbNuevo la base de datos creada
    'con el sistema de ordenación Español moderno
    Set dbNuevo = CreateDatabase(strFicheroBD, dbLangGeneral)
    dbNuevo.Close
    Set dbNuevo = Nothing
    Set wrkActual = Nothing
End Sub

Public Sub CrearTablas()
    'Ojo, sin control de excepciones

    Dim dbDatos As DAO.Database
    Dim tdfTabla As DAO.TableDef
    Dim fldCampo As DAO.Field
    Dim idxIndice As DAO.Index
    Dim relRelacion As DAO.Relation
    Dim strNombreBD As String
    Dim strRuta As String
      
    strRuta = CurrentProject.Path
    strNombreBD = strRuta & "\" & constrBD
    
    ' Si no existe Datos.mdb lo creamos
    If Dir(strNombreBD) = "" Then
        CrearBD strRuta, constrBD
    End If
    'Asignamos la BD Datos.mdb a dbDatos, abriéndola en modo exclusivo
    'Mdiante la función DameBDAmigos
    Set dbDatos = DameBDAmigos(conblnExclusivo)
    
    '**************************************************
    'Creamos la tabla [Sexos]
    Set tdfTabla = dbDatos.CreateTableDef("Sexos")
    
    'Vamos añadiendo los campos a la tabla
    With tdfTabla
        'Le añadimos el campo [idSexo], Texto 1 carácter
        Set fldCampo = .CreateField("idSexo", dbText, 1)
        With fldCampo
            ' vamos a permitir sólo ciertos tipos de datos
            .ValidationRule = "=M or =F or =I or = H"
            .ValidationText = "Debe introducir M ó F ó I ó H " _
               & "(Masculino, Femenino, Indefinido, Hermafrodita)"
            .Required = True
            .AllowZeroLength = False
        End With
        .Fields.Append fldCampo
        'Le añadimos el campo [Sexo], Autoincremental
        Set fldCampo = .CreateField("Sexo", dbText, 15)
        fldCampo.Required = True
        fldCampo.AllowZeroLength = False
        .Fields.Append fldCampo
    End With
    
    'Añadimos la tabla a Tabledefs

    
    '--------------------------------------------------
    'Creamos los índices para la tabla Sexos
    With tdfTabla
        'Creamos el índice de [idSexo]
        Set idxIndice = .CreateIndex("idSexo")
        'Le decimos qué campo va a procesar
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("idSexo")
            'Definimos el campo como clave
            .Unique = True
            .Primary = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Sexo]
        Set idxIndice = .CreateIndex("Sexo")
        With idxIndice
            .Fields.Append .CreateField("Sexo")
            .Unique = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
    End With
    
    dbDatos.TableDefs.Append tdfTabla
        
    '**************************************************
    'Creamos la tabla [Amigos]
    Set tdfTabla = dbDatos.CreateTableDef("Amigos")
    
    'Vamos añadiendo los campos a la tabla
    With tdfTabla
        'Le añadimos el campo [idAmigo], Autoincremental
        Set fldCampo = .CreateField("idAmigo", dbLong)
        .Fields.Append fldCampo
        fldCampo.Attributes = dbAutoIncrField
        
        'También se puede crear un campo de forma directa
        'Creamos el campo [AmigoNombre]
        .Fields.Append .CreateField("AmigoNombre", dbText, 25)
        .Fields("AmigoNombre").Required = True
        
        'Creamos el campo [AmigoApellido]
        .Fields.Append .CreateField("AmigoApellido", dbText, 25)
        .Fields("AmigoApellido").Required = True
        
        'Le añadimos el campo [idSexo], texto, de 1 caracter
        .Fields.Append .CreateField("idSexo", dbText, 1)
        'Podemos volver a llamar a ese campo para definir propiedades
        Set fldCampo = .Fields("idSexo")
             With fldCampo
                .Required = True
                .AllowZeroLength = False
            End With
        
        'Creamos el campo [AmigoFechaNacimiento]
        .Fields.Append .CreateField("AmigoFechaNacimiento", dbDate)
        .Fields("AmigoFechaNacimiento").Required = False
        
        'Creamos el campo [AmigoLugarNacimiento]
        .Fields.Append .CreateField("AmigoLugarNacimiento", dbText, 25)
        .Fields("AmigoLugarNacimiento").Required = False
        
        'Creamos el campo [AmigoTelefono]
        .Fields.Append .CreateField("AmigoTelefono", dbText, 25)
        .Fields("AmigoTelefono").Required = False
        
        'Creamos el campo [Notas]
        .Fields.Append .CreateField("Notas", dbMemo)
        .Fields("Notas").Required = False
    End With
    
    'Añadimos la tabla a Tabledefs
    dbDatos.TableDefs.Append tdfTabla
    
    '--------------------------------------------------
    'Creación de índices
    '[idAmigo] llamado idAmigo
    'Otro para [idSexo] Llamado idSexo
    
    With tdfTabla
        'Creamos el índice de [idAmigo]
        Set idxIndice = .CreateIndex("idAmigo")
        'Le decimos qué campo va a procesar
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("idAmigo")
            'Definimos el campo como clave
            .Unique = True
            .Primary = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Sexo]
        Set idxIndice = .CreateIndex("Sexo")
        With idxIndice
            .Fields.Append .CreateField("idSexo")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Nombre]
        Set idxIndice = .CreateIndex("Nombre")
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("AmigoNombre")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        'Creamos el índice [Apellido]
        Set idxIndice = .CreateIndex("Apellido")
        With idxIndice
            ' Creamos el índice Apellido
            .Fields.Append .CreateField("AmigoApellido")
            .Required = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        Set idxIndice = .CreateIndex("FechaNacimiento")
        With idxIndice
        ' Creamos el índice FechaNacimiento
            .Fields.Append .CreateField("AmigoFechaNacimiento")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        'Creamos un índice compuesto del Nombre y Apellido
        'Indice ApellidoNombre
        Set idxIndice = .CreateIndex("ApellidoNombre")
        'Le decimos qué campos va a incluir
        With idxIndice
            .Fields.Append .CreateField("AmigoApellido")
            .Fields.Append .CreateField("AmigoNombre")
            'Definimos como clave única
            '(es un ejercicio
            ' y no voy a tener amigos repetidos
            ' en Nombre y Apellidos)
            .Unique = True
        End With
        .Indexes.Append idxIndice
    End With
    
    'Vamos ahora a relacionar la dos tablas
    'a través de su campo idSexo
    'las relaciones pertenecen a la Base de Datos
    With dbDatos
        'Creamos la relación con actualización en cascada
        '    (dbRelationUpdateCascade),
        'que muestre todos los datos de sexo
        'y los de la tabla amigos relacionados
        '    (dbRelationLeft)
        Set relRelacion = .CreateRelation("SexoAmigos", _
                "Sexos", "Amigos", _
                dbRelationUpdateCascade + dbRelationLeft)
                
        'Creamos los campos de la relación
        With relRelacion
            .Fields.Append .CreateField("IdSexo")
            .Fields!idSexo.ForeignName = "idSexo"
        End With
        .Relations.Append relRelacion
    End With
    
Set idxIndice = Nothing
Set fldCampo = Nothing
Set tdfTabla = Nothing
dbDatos.Close
Set dbDatos = Nothing

End Sub

Public Sub AñadirDatos()
    Dim strRuta As String
    Dim strBD As String
    Dim lngRespuesta As Long
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    strRuta = CurrentProject.Path & "\"
    strBD = strRuta & constrBD
    
    'Comprueba si existe la Base de datos
    If Dir(strBD) = constrBD Then
        lngRespuesta = MsgBox( _
                    "La base " & constrBD & " existe" _
                    & vbCrLf & _
                    "¿Desea borrarla?", _
                    vbInformation + vbYesNo, _
                    " Permiso para masacrar " & constrBD)
        If lngRespuesta = vbYes Then
            Kill strBD
        Else
            MsgBox "No se van a cambiar los datos", _
                    vbInformation + vbOKOnly, _
                    " Interrumpido procedimiento"
            Exit Sub
        End If
    End If

    'Crea la BD con tablas
    CrearTablas
    
    Set db = DameBDAmigos(conblnExclusivo)
    'Voy a abrir el recordset como dinámico
    Set rs = db.OpenRecordset("Sexos", dbOpenDynaset)
    
    With rs
        'Si no tiene datos los añadiremos
        If Not .RecordCount Then
            .AddNew
            'Añadimos un registro nuevo
            !idSexo = "M"
            !Sexo = "Masculino"
            'Una vez lleno lo actualizamos
            .Update
            
            .AddNew
            !idSexo = "F"
            !Sexo = "Femenino"
            .Update
            
            .AddNew
            !idSexo = "I"
            !Sexo = "Indefinido"
            .Update
            
            .AddNew
            !idSexo = "H"
            !Sexo = "Hermafrodita"
            .Update
            
        End If
    End With
    rs.Close
    'Voy a abrir el recordset como tabla
    Set rs = db.OpenRecordset("Amigos", dbOpenTable)
    With rs
        'Si no tiene datos los añadiremos
        If Not .RecordCount Then
            .AddNew
            !AmigoNombre = "Boris"
            !AmigoApellido = "Izaguirre"
            !AmigoFechaNacimiento = #9/29/1965#
            !AmigoLugarNacimiento = "Caracas"
            !AmigoTelefono = "91 111 111 111"
            !idSexo = "I"
            !Notas = "Obsesionado por bajarse los pantalones"
            .Update
            
            .AddNew
            !AmigoNombre = "Inés"
            !AmigoApellido = "Sastre"
            !AmigoFechaNacimiento = #11/21/1973#
            !AmigoLugarNacimiento = "Madrid"
            !AmigoTelefono = "91 222 222 222"
            !idSexo = "F"
            !Notas = "Le gusta montar a caballo, jugar golf y nadar"
            .Update
            
            .AddNew
            !AmigoNombre = "Michael Joseph"
            !AmigoApellido = "Jackson"
            !AmigoFechaNacimiento = #8/29/1958#
            !AmigoLugarNacimiento = "Gary - Indiana (USA)"
            !AmigoTelefono = "00 1 333 333 333 333"
            !idSexo = "H"
            !Notas = "A este chico últimamente se le está poniendo mala cara"
            .Update
            
            .AddNew
            !AmigoNombre = "Francisco"
            !AmigoApellido = "Ribera"
            !AmigoFechaNacimiento = #1/3/1974#
            !AmigoLugarNacimiento = "Madrid"
            !AmigoTelefono = "639 444 444"
            !idSexo = "M"
            !Notas = "Le gustan los cuernos"
            .Update
            
            .AddNew
            !AmigoNombre = "Aitana"
            !AmigoApellido = "Sánchez - Gijón"
            !AmigoFechaNacimiento = #9/5/1968#
            !AmigoLugarNacimiento = "Roma"
            !AmigoTelefono = "655 555 555"
            !idSexo = "F"
            !Notas = "Una gata sobre el tejado de zinc"
            .Update
            
        End If
    End With
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Public Sub MostrarAmigosDeMadrid()

    Dim strSQL As String
    Dim strBD As String
    Dim lngRegistro As Long

    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Dim Amigo As TAmigo
      
    Set db = DameBDAmigos()
    strSQL = "SELECT Sexo, " _
            & "[AmigoNombre] & " _
            & conComilla & " " & conComilla & "& " _
            & "[AmigoApellido] AS Amigo, " _
            & "Notas FROM Sexos LEFT JOIN Amigos " _
            & "ON Sexos.idSexo = Amigos.idSexo " _
            & "WHERE AmigoLugarNacimiento = " _
            & conComilla & "Madrid" & conComilla

    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    
    If rs.RecordCount Then
        Debug.Print Tab(1); "Sexo"; _
                Tab(16); "Amigo"; _
                Tab(45); "Notas"
                
        rs.MoveFirst
        Do While Not rs.EOF
            With rs
                Debug.Print Tab(1); !Sexo; _
                    Tab(16); !Amigo; _
                    Tab(45); !Notas
                .MoveNext
            End With
        Loop
    End If
     
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Public Function DameBDAmigos( _
            Optional ByVal Exclusivo As Boolean = False) _
            As DAO.Database
    Dim strRuta As String
    Dim strBD As String
    
    strRuta = CurrentProject.Path & "\"
    strBD = strRuta & constrBD
    
    'Si no existe la base de datos
    If Not Dir(strBD) = constrBD Then
        'La creamos
        CrearBD strRuta, constrBD
    End If
    Set DameBDAmigos = DBEngine.Workspaces(0).OpenDatabase( _
                        strBD, _
                        Exclusivo)
End Function


--------------------------------------------------------------------------------
'Supongo que a más de uno le vendrá bien, si es que no se le indigesta antes.
'Eduardo

'======================================
Between(#[dia comienzo]# And #[Dia
final]#)
Para las consultas y las fechas de las narices
'============================================
'Para saber si se hanpresionado dos teclas
Primero debes hacer que sea el formulario el que procese las pulsaciones de
tecla, antes que cualquiera de los controles
Eso se consigue poniendo la propiedad KeyPreview a True, por ejemplo al
cargar el formulario.

Tras esto deberás analizar las teclas presionadas en el evento KeyDown del
formulario

Option Explicit

Private Sub Form_Load()
    KeyPreview = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim blnPresionadaAlt As Boolean
    blnPresionadaAlt = (Shift And acAltMask) > 0
    If KeyCode = vbKeyF5 And blnPresionaAlt Then
        MsgBox "Has presionado las teclas:" _
                & vbCrLf _
                & "Alt + F5"
    End If
End Sub

' Mismo codigo de Eduardo OLaz para cualquiercombinacion de teclas
Option Explicit

Private Sub Form_Load()
    KeyPreview = True
    'Hace que el formulario procese las teclas el primero
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim blnTeclaAlt As Boolean
    Dim blnTeclaControl As Boolean
    Dim blnTeclaMayuscula As Boolean
    Dim strTeclas As String

    blnTeclaAlt = (Shift And acAltMask) > 0
    blnTeclaControl = (Shift And acCtrlMask) > 0
    blnTeclaMayuscula = (Shift And acShiftMask) > 0

    If blnTeclaAlt Or blnTeclaControl Or blnTeclaMayuscula Then
        If blnTeclaAlt Then
            strTeclas = strTeclas & " Tecla [Alt]"
        End If
        If blnTeclaControl Then
            strTeclas = strTeclas & " Tecla [Ctrl]"
        End If
        If blnTeclaMayuscula Then
            strTeclas = strTeclas & " Tecla [Mayúscula]"
        End If

    Select Case KeyCode
    Case vbKeyRight
        strTeclas = strTeclas & " y Tecla [Derecha]"
    Case vbKeyLeft
        strTeclas = strTeclas & " y Tecla [Izquierda]"
    Case vbKeyUp
        strTeclas = strTeclas & " y Tecla [Arriba]"
    Case vbKeyDown
        strTeclas = strTeclas & " y Tecla [Abajo]"
    Case vbKeyReturn
        strTeclas = strTeclas & " y Tecla [Intro]"
    Case Else
        Exit Sub
    End Select

        MsgBox "Has presionado:" _
                & vbCrLf _
                & strTeclas
    End If

End Sub

'Funciones de Olaz para ver si tengo la SR1 de Access
Option Compare Database
Option Explicit

' ******** Code Start ********
'  structure contains version information about a file. This
'  information is language and code page independent.
Private Type VS_FIXEDFILEINFO
    '  Contains the value 0xFEEFO4BD (szKey)
    dwSignature As Long
    '  Specifies the binary version number of this structure.
    dwStrucVersion As Long
    '  most significant 32 bits of the file's binary version number.
    dwFileVersionMS As Long
    '  least significant 32 bits of the file's binary version number.
    dwFileVersionLS As Long
    '  most significant 32 bits of the binary version number of
    ' the product with which this file was distributed
    dwProductVersionLS As Long
    '  least significant 32 bits of the binary version number of
    ' the product with which this file was distributed
    dwFileFlagsMask As Long
    '  Contains a bitmask that specifies the valid bits in dwFileFlags.
    dwProductVersionMS As Long
    '  Contains a bitmask that specifies the
    '  Boolean attributes of the file.
    dwFileFlags As Long
    '  operating system for which this file was designed.
    dwFileOS As Long
    '  general type of file.
    dwFileType As Long
    '  function of the file.
    dwFileSubtype As Long
    '  most significant 32 bits of the file's 64-bit
    ' binary creation date and time stamp.
    dwFileDateMS As Long
    '  least significant 32 bits of the file's 64-bit binary
    ' creation date and time stamp.
    dwFileDateLS As Long
End Type

'  Returns size of version info in Bytes
Private Declare Function apiGetFileVersionInfoSize _
    Lib "version.dll" Alias "GetFileVersionInfoSizeA" _
    (ByVal lptstrFilename As String, _
    lpdwHandle As Long) _
    As Long

'  Read version info into buffer
' /* Length of buffer for info *
' /* Information from GetFileVersionSize *
' /* Filename of version stamped file *
Private Declare Function apiGetFileVersionInfo Lib _
    "version.dll" Alias "GetFileVersionInfoA" _
    (ByVal lptstrFilename As String, _
    ByVal dwHandle As Long, _
    ByVal dwLen As Long, _
    lpData As Any) _
    As Long

'  returns selected version information from the specified
'  version-information resource.
Private Declare Function apiVerQueryValue Lib _
    "version.dll" Alias "VerQueryValueA" _
    (pBlock As Any, _
    ByVal lpSubBlock As String, _
    lplpBuffer As Long, _
    puLen As Long) _
    As Long

Private Declare Sub sapiCopyMem _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)

Function fGetProductVersion(strExeFullPath As String) As String
'
'  Returns the build number for Office exes
'
' Sample usage (Access 2000)
'      ?fGetProductVersion(SysCmd(acSysCmdAccessDir) & "Frontpg.exe") '
'  Product                  Pre-SR1              Post-SR1
'  ---------------------------------------------------------
'  MSAccess.exe        9.0.0.2719           9.0.0.3822
'  WinWord.exe        9.0.0.2717            9.0.0.3822
'  Excel.exe              9.0.0.2719           9.0.0.3822
'  FrontPg.exe          4.0.2.2717            4.0.2.3821
'  Outlook.exe          9.0.0.2416            9.0.0.2416
'  PowerPnt.exe        9.0.0.2716            9.0.0.3821
'  WinProj.exe          8.0.98.407            Don't have it, sorry.
'
On Error GoTo ErrHandler
Dim lngSize As Long
Dim lngRet As Long
Dim pBlock() As Byte
Dim lpfi As VS_FIXEDFILEINFO
Dim lppBlock As Long

    '  GetFileVersionInfo requires us to get the size
    '  of the file version information first, this info is in the format
    '  of VS_FIXEDFILEINFO struct
    lngSize = apiGetFileVersionInfoSize( _
                        strExeFullPath, _
                        lngRet)

    '  If the OS can obtain version info, then proceed on
    If lngSize Then
        '  the info in pBlock is always in Unicode format
        ReDim pBlock(lngSize)
        lngRet = apiGetFileVersionInfo(strExeFullPath, 0, _
                                lngSize, pBlock(0))
        If Not lngRet = 0 Then
            '  the same pointer to pBlock can be passed to VerQueryValue
            lngRet = apiVerQueryValue(pBlock(0), _
                                "\", lppBlock, lngSize)

            '  fill the VS_FIXEDFILEINFO struct with bytes from pBlock
            '  VerQueryValue fills lngSize with the length of the block.
            Call sapiCopyMem(lpfi, ByVal lppBlock, lngSize)
            '  build the version info strings
            With lpfi
                fGetProductVersion = HIWord(.dwFileVersionMS) & "." & _
                                                LOWord(.dwFileVersionMS) &
"." & _
                                                HIWord(.dwFileVersionLS) &
"." & _
                                                LOWord(.dwFileVersionLS)
            End With
        End If
    End If

ExitHere:
    Erase pBlock
    Exit Function
ErrHandler:
    Resume ExitHere
End Function

Private Function LOWord(dw As Long) As Integer
'    retrieves the low-order word from the given 32-bit value.
    If dw And &H8000& Then
        LOWord = dw Or &HFFFF0000
    Else
        LOWord = dw And &HFFFF&
    End If
End Function

Private Function HIWord(dw As Long) As Integer
'    retrieves the high-order word from the given 32-bit value.
  HIWord = (dw And &HFFFF0000) \ &H10000
End Function
' ******** Code End *********

Saludos:

Eduardo
')======================
'======================
Una buena solucion para ejecutar una macro
nada mas arrancar
msaccess.exe C:\rutaDeMiMDB\miBase.mdb /x nombredeMacro
'=========================
'=========================
'Imprimir las copias que se quieran de un Reporte
'Por Happy
Por ej: este código imprimiría 2 veces el informe "Empleados":

    DoCmd.OpenReport "Empleados", acPreview
    DoCmd.SelectObject acReport, "Empleados"
    DoCmd.PrintOut , , , , 2
    DoCmd.Close acReport, "Empleados"

' OTRO EJEMPLO MUY BUENO DE HAPPY PARA IMPRIMIR DOS
'COPIAS DE UN REPORT, PERO QUE SE ABRA PREVIAMENTE
'EL CUADRO DE IMPRESORA
DoCmd.OpenReport "Empleados", acViewPreview
SendKeys "{TAB 4}" + "2"
DoCmd.RunCommand acCmdPrint



'=====================================
'SACADO DE MICROSOFT PARA ABRIR UN
'RECORDSET DE UNFICHERO DE TEXTO
'=====================================
Start a text editor, such as NotePad or WordPad. 


In a new text file, type the following text and save the file as Contacts.txt: 


   First     NameLast NameHireDate
   Nancy     Davolio  10-22-91
   Robert    King     10-23-91
In another new text file, type the following text and save the file as Schema.ini: 


   [Contacts.txt]
   ColNameHeader=True
   Format=FixedLength
   MaxScanRows=0
   CharacterSet=OEM
   Col1="First Name" Char Width 10
   Col2="Last Name" Char Width 9
   Col3="HireDate" Date Width 8
NOTE: Make sure both the Contacts.txt and Schema.ini files are stored in the same folder (directory), for example, C:\My Documents. 
Example 1 
To create a recordset that uses data from a text file (Contacts.txt), follow these steps: 
Create a module and type the following line in the Declarations section if it is not already there: 


Option Explicit
Type the following procedure: 


Function TestSchema()
   Dim db As DATABASE, rs As Recordset
   Set db = OpenDatabase("c:\my documents", False, _
   False,"TEXT;Database=c:\my documents;table=contacts.txt")
   Set rs = db.OpenRecordset("contacts.txt")

   rs.MoveLast
   Debug.Print "Record count= " & rs.RecordCount
   rs.Close

End Function
To test this function, type the following line in the Debug window, and then press ENTER: 
?TestSchema() 
Note that "Record count= 2" is displayed. 


Example 2 
To create a table linked to a text file (Contacts.txt), follow these steps: 
Create a module and type the following line in the Declarations section if it is not already there: 


Option Explicit
Type the following procedure: 


Function LinkSchema()
   Dim db As DATABASE, tbl As TableDef
   Set db = CurrentDb()
   Set tbl = db.CreateTableDef("Linked Text")

   tbl.Connect = "Text;DATABASE=c:\my documents;TABLE=contacts.txt"
   tbl.SourceTableName = "contacts.txt"
   db.TableDefs.Append tbl
   db.TableDefs.Refresh
End Function
To test this function, type the following line in the Debug window, and then press ENTER: 
?LinkSchema() 
Note that linked table is added to the database. 


=================================
=================================
Ejemplo de Chea para con un campo fecha, saber si es el cumpleaños
de un cliente:

En el evento Current del formulario, pones el siguiente código

if format(date(),"dd-mm") = format([fecha_nacimiento],dd-mm") then
    msgbox [nombre]  & " está de cumpleaños (por ejemplo)"
endif

==============================================
Limitar el número de registros en una tabla: 

If DCount ("*","Reservas","FechaReserva=Forms!Reservas!Fecha")>50 then
                msgbox "Ya hay 50 registros"
end if
=============================================
Function DoCompact()
Dim ReStart As Boolean
Dim strCompacter As String
Dim strExePath As String
    ' esta linea me da la ruta donde esta instalado Access

    strExePath = SysCmd(acSysCmdAccessDir) & "msAccess.Exe"
    strCompacter = Chr$(34) & CodeDb.Name & Chr$(34) _
                 & " /cmd" & " " & CurrentDb.Name
    If ReStart = True Then
      strCompacter = strCompacter & ";True"
    Else
      strCompacter = strCompacter & ";False"
    End If
    Call Shell(strExePath & " " & strCompacter, vbNormalFocus)
End Function
=============================
=============================

Para saber cual es la ruta de Vinculacion de una MDB
Function RutaVinculacion() As String
On Error GoTo Err_Comando7_Click
  Dim DbEx As Database                          'Declaramos DB como Base
  Dim strNombreTabla As String
  Dim strRuta As String
  Dim intX As Integer
  Dim pstrRutaDBActuAl As String
  pstrRutaDBActuAl = CodeDb.Name

    'Conocer la ruta completa de la base de datos vinculada.
    Set DbEx = OpenDatabase(CodeDb.Name)
    'Buscar las tablas, no seleccionando las tablas del sistema
     For intX = 0 To DbEx.TableDefs.Count - 1   'desde 0
        If Left(DbEx.TableDefs(intX).Name, 4) <> "MSys" Then
            'Comprobar si el atributo de la tabla es Vinculada.
            If (DbEx.TableDefs(intX).Attributes And dbAttachedTable) Or (DbEx.TableDefs(intX).Attributes And dbAttachedODBC) Then
                'Asignar el nombre de la tabla.
                strNombreTabla = DbEx.TableDefs(intX).Name
                'Asignar el nombre de la ruta donde esta la tabla vinculada.
                strRuta = DbEx.TableDefs(strNombreTabla).Connect
                'Quitar ;DATABASE=
                strRuta = Mid(strRuta, 11, Len(strRuta))
                'si hemos entrado aquí es que ya tenemos la ruta de las tablas
                'vinculadas. Muestro el mensaje correspondiente.-
                RutaVinculacion = strRuta
                
                'cierro la base de datos y abandono
                DbEx.Close
                Set DbEx = Nothing
                Exit Function
            End If
        End If
    Next intX
    RutaVinculacion = "C:\MINUTAS\DATOS.MDB"
    DbEx.Close                          'Cerrar la Base de datos
    Set DbEx = Nothing
Exit_Comando7_Click:
 Exit Function
Err_Comando7_Click:
 MsgBox "Se ha producido el Error Nº: " & Err.Number & " ." & Err.Description, vbCritical + vbOKOnly, "Error de Datos"
 Resume Exit_Comando7_Click
End Function
==============================
==============================
Funcion de Happy para extraer una cadena que encuentre un \
Function ExtraerPath(nombrebd As String) As String
  ExtraerPath = Left(nombrebd, InStrRev(nombrebd, "\"))
End Function

Function ExtraerNombre(nombrebd As String) As String
  ExtraerNombre = Right(nombrebd, Len(nombrebd) - InStrRev(nombrebd, "\"))
End Function
por la derecha o por la izquierda.

'===============================
'==========Mas Happy para recuperar la ultima tabla borrada:

En una bd importa varias tablas de otra bd (neptuno, por ejemplo). Luego
borra una de ellas. Después ejecuta este código desde un botón de comando o
desde donde quieras (no compactes la bd, hazlo inmediatamente después de
borrar la tabla).

Sub RecuperarTabla()
Dim tdf As Object
Dim strSQL As String
Dim tablasBorradas() As String
Dim cnt As Integer, i As Integer

cnt = -1

  For Each tdf In CurrentDb.TableDefs
    If Left(tdf.Name, 1) = "~" Then
      cnt = cnt + 1
      tdf.Name = Right(tdf.Name, Len(tdf.Name) - 1)
      ReDim Preserve tablasBorradas(cnt)
      tablasBorradas(cnt) = tdf.Name
    End If
  Next

  For i = 0 To cnt
    strSQL = "SELECT * INTO TablaRecuperada" & i & " FROM "
    strSQL = strSQL & tablasBorradas(i) & ";"
    CurrentDb.Execute strSQL, dbFailOnError
  Next

End Sub

¡==========================
'==============================
probe con este codigo y funciona, a condición de que no esté activado el
"Auto Expand" o expansión automática, que lo que hace es "sugerir" un valor
del combo, cambiando la propiedad "text".

Insertar en el evento "OnChange" o "Al Cambiar"

combo1.RowSource = "SELECT CALLE FROM LISTACALLES WHERE CALLE LIKE '*" &
combo1.Text & "*'"

Saludos,

Magdalena
"chelo" <chesosa@ciudad.com.ar> escribió en el mensaje
news:e#lXqXQNCHA.1900@tkmsftngp11...
Hola querido grupo una consulta que he visto en aplicaciones hechas en
Visual Basic.

E Intentado hacer que un cuadro combinado que lista calles, me muestre solo
las calles que contengan el texto que se tipeo, es decir que filtre solo
esas por ejemplo:

nombre de calles:
MARCOS SALIS
AYACUCHO
MISIONES
MARCELO T. ALVEAR
AVENIDA MARCHANDO
ETC...

Si yo tipeo la cadena "marc" en el cuadro que solo me muestre las que
contengan esa cadena de texto es decir
MARCOS SALIS
MARCELO T. ALVEAR
AVENIDA MARCHANDO

' Codigo de Happy para revincular una DBF
'Ojo hay diferencias con la revinculacion de tablas normales de una MDB
Dim tdf As Object

  For Each tdf In CurrentDb.TableDefs
    If tdf.Name = "Fact_Aux" Then
      tdf.Connect = "dBase III;DATABASE=" & Ruta_fichero_a_vincular
      tdf.refreshlink
    End If
  Next

'En Ruta_fichero_a_vincular solo hay que poner la ruta, sin el nombre de la DBF

'===============
Esta otra funcion quedaría para revincular tablas desde otra mdb
Dim objAcObj As AccessObject
Dim objCurData As CurrentData
Dim Tabla As TableDef
  Set objCurData = Application.CurrentData
  RutaFichero = "C:\CarpetaDatos\Datos.Mdb"

     For Each objAcObj In objCurData.AllTables
        Set Tabla = CurrentDB.TableDefs(objAcObj.Name)
          If Tabla.Attributes And dbSystemObject
            'en este if quito las tablas del sistema que no se deben vincular
          Else
           Tabla.Connect = ";DATABASE=" & RutaFichero
           Tabla.RefreshLink
          End If
      Next objAcObj

'================================
' Otra para averiguar el DIR del sistema
'
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'*************************************************************
' Nombre:   GetWinDir
'               por Enrique Martínez - 01/07/96
'
' Finalidad:
'               Recupera el nombre completo de la trayectoria
'               del directorio Windows.
'
' Resultado:
'   String:     En caso de error devuelve 'vbNullString'.
'
'*************************************************************
Public Function GetWinDir() As String

    Dim sBuffer As String, lSize As Long

    sBuffer = String(260, vbNullChar)

    lSize = GetWindowsDirectory(sBuffer, Len(sBuffer) - 1)

    sBuffer = Left(sBuffer, lSize)

    If lSize Then
        ' Si es el directorio raíz
        If Right(sBuffer, 1) = "\" Then
            GetWinDir = sBuffer
        Else
            GetWinDir = sBuffer & "\"
        End If
    Else
        GetWinDir = vbNullString
    End If

End Function