Anular Tecla Shift

Mediante el siguiente código se puede eliminar las entradas indeseadas con la tecla shift. si no se entra con la clave indicada, se anula la entrada con la tecla shift, y entrando con la clave se activa para la próxima vez que se entre. Public Function AlterarPropriedade(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer   Dim dbs As Database, prp As Property    Const conPropNotFoundError = 3270    Set dbs = CurrentDb   On Error GoTo Change_Err   dbs.Properties(strPropName) = varPropValue    AlterarPropriedade = True Change_Bye:    Exit Function Change_Err:   If Err = conPropNotFoundError Then ' Propiedad no ha sido localizada.      Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)      dbs.Properties.Append prp      Resume Next    Else      ' Error desconocido.      AlterarPropriedade = False      Resume Change_Bye    End If End Function Private Sub Form_Open(Cancel As Integer)    Dim f As Date    Dim hoy As Date    Dim usr As String   usr = InputBox("Introduzca el nombre de usuario", "Usuario", "Pepito de los Palotes")     If usr <> "*** MI CLAVE SECRETA ***" Then      AlterarPropriedade "AllowBypassKey", dbBoolean, False    Else      AlterarPropriedade "AllowBypassKey", dbBoolean, True    End If       DoCmd.Close acForm, "inicio" End Sub

Comprobar si una matriz está vacía

Emilio Sancha. Esto, seguro que es una tontería, pero me ha dado mucha guerra, hasta que se me ocurrío controlar el error. El caso es que cuando intentas mirar el tamaño de una matriz, si esta está vacia, da un error y el proceso casca, en un principio al rellenar la matriz, de paso rellenaba una variable booleana para saber si la matriz estaba o no vacía, ahora uso esta función y ya no necesito más. '**************************************** '* MatrizVacia '*devuelve Verdadero/Falso si la matriz pasada como argumento esté vacía o no '* Argumentos: vntMatriz '* uso: If MatrizVacia(vntMatriz) then '* ESH 21/09/04 10:57 '**************************************** Public Function MatrizVacia(vntMatriz As Variant) As Boolean    Dim lngTamaño As Long    On Error Resume Next  Public Function MatrizVacia(vntMatriz As Variant) As Boolean    Dim lngTamaño As Long    On Error Resume Next  Public Function MatrizVacia(vntMatriz As Variant) As Boolean    Dim lngTamaño As Long    On Error Resume Next    ' compruebo el tamaño de la matriz    lngTamaño = UBound(vntMatriz)    ' si está vacía se produce un error    If Err.Number = 9 Then      MatrizVacia = True    Else      MatrizVacia = False    End If MatrizVacia_Salir:    On Error GoTo 0    Exit Function  End Function            ' MatrizVacia

Saldo Acumulado en formularios continuos

Por Marius Puig Esta funcion calcula el saldo acumulado en un Formulario continuo para cada registro. Uso: AWsaldo([FORMULARIO];"nombre_campo1";"nombre_campo2") - [Formulario] debe escribirse tal como está, NO es el nombre del form) - nombre_campo2 es opcional, si se incluye se restará del valor de nombre_campo1. Ejemplos, en un cuadro de texto del Formulario: =AWsaldo([Formulario];"IMPORTE") =AWsaldo([Formulario];"DEBE";"HABER") '* ****************************** '* Antes de usar la funcion, marcar en referencias: '* Microsoft DAO 3.x '* ****************************** Public Function AWsaldo(opObject, opFLD1, Optional opFLD2 = Null) As Currency   Dim rst As DAO.Recordset, valACUM As Currency, fld1, fld2    On Error GoTo ErrAWsaldo    Set rst = opObject.RecordsetClone    With rst      Set fld1 = .Fields(opFLD1)      If IsNull(opFLD2) Then        fld2 = 0      Else        Set fld2 = .Fields(opFLD2)      End If     .Bookmark = opObject.Bookmark      Do While Not .BOF()        valACUM = valACUM + fld1 - fld2        .MovePrevious      Loop    End With    Set fld1 = Nothing    Set fld2 = Nothing    Set rst = Nothing  ErrAWsaldo:    AWsaldo = valACUM End Function

Impedir abrir Form si otro está abierto

Esta función impide abrir un formulario mientras otro usuario este usando ese (u otro) formulario, en un entorno FrontEnd / BackEnd Uso: Private Sub Form_Open(Cancel As Integer) If Not AWformUnico() Then     Cancel = True     Exit Sub End If '... End Sub '****************************** '* Marcar en referencias: '* Microsoft DAO 3.x '* Windows Script Host Object Model (wshom.ocx) '* '* Si no usamos WSHOM borrar las lineas  'referencia a wshom '* (Esta funcion debe incluirse dentro del modulo del Form) ' '* '* ****************************** Private Function AWformUnico()    Static dbsUnico As DAO.Database    Dim tbl As DAO.TableDef, dbs As DAO.Database    Dim AWrutaDb, AWconnectDb, AWrutaDbForm, usrName    Dim shellTMP As New IWshNetwork_Class 'referencia a wshom   On Error GoTo errorAWformUnico   For Each tbl In CurrentDb.TableDefs      If tbl.Connect > "" Then        AWrutaDb = Mid(tbl.Connect, InStr(tbl.Connect, "DATABASE=") + 9)        AWconnectDb = Left(tbl.Connect, InStr(tbl.Connect, "DATABASE=") - 2)        AWrutaDbForm = Left(AWrutaDb, InStrRev(AWrutaDb, "\")) & "DbForm.mdb"        If Dir(AWrutaDbForm) = "" Then          DBEngine.Workspaces(0).CreateDatabase AWrutaDbForm, dbLangGeneral        End If        Set dbs = OpenDatabase(AWrutaDb, False, False, AWconnectDb)        Set dbsUnico = OpenDatabase(AWrutaDbForm, True, False)       On Error Resume Next       dbs.Properties.Delete "DbForm"        usrName = CurrentUser        usrName = usrName & " (" & shellTMP.ComputerName & "/" & hellTMP.UserName & ")"       ' linea superior, referencia a wshom        On Error GoTo errorAWformUnico        dbs.Properties.Append dbs.CreateProperty("DbForm", DB_TEXT, usrName)        dbs.Close        Exit For      End If    Next    AWformUnico = True  AWformUnicoExit:    Set dbs = Nothing    Exit Function    errorAWformUnico:   If Err.Number = 3045 Then      MsgBox "En este momento " & dbs.Properties("DbForm").Value & vbNewLine _      & "esta usando este formulario. " & vbNewLine & vbNewLine & "Intentelo mas tarde." _      , vbInformation, "No puede abrir " & Me.Caption     AWformUnico = False    Else      MsgBox Err.Description    End If    Resume AWformUnicoExit End Function

Cerrar Recordset

Por Emilio Sancha: Aquí va la primera mía ¿Cuantas veces al fallar algo en un proceso habéis recibido un error al cerrar un recordset por que realmente no se había llegado a abrir? Usando esta función para cerrar el recordset no habrá errores aunque no se haya abierto, está basada en una idea original del gran McPegasus '******************************************************************************* '* CierraRecordset '* Cierra el recordset indicado '* Argumentos: rst => nombre del recordset '* uso: CierraRecordset rst '* ESH 22/05/04 13:21 '******************************************************************************* Public Sub CierraRecordset(rst As DAO.Recordset)    On Error GoTo CierraRecordset_TratamientoErrores    If Not rst Is Nothing Then      rst.Close      Set rst = Nothing    End If          ' CierraRecordset   CierraRecordset_Salir:   On Error GoTo 0   Exit Sub   CierraRecordset_TratamientoErrores:     MsgBox "Error " & Err.Number & " en proc. CierraRecordset de Módulo Módulo2 (" & Err.Description & ")", vbOKOnly + vbCritical   GoTo CierraRecordset_Salir End Sub         ' CierraRecordset

Abrir pagina Web desde Access

Existen varios métodos para abrir una página Web desde Access. En este caso cito uno bastante curioso. (Necesita que el IE de Microsoft sea el explorador predeterminado): Sub AbreUrl()   Dim objIE As Object    Set objIE = CreateObject("InternetExplorer.Application")    With objIE      .MenuBar = False      .AddressBar = False      .StatusBar = False      .Toolbar = False      .Navigate http://www.mvp-access.com/buho/novedades.htm      .Visible = True    End With    Set objIE = Nothing End Sub De esta forma podemos controlar el tipo de ventana del IE

Objeto ClipBoard en Access

En VBA de Access no existe el objeto Clipboard. A veces nos encontramos con la necesidad de copiar el contenido de un campo o de una expresión en el porta-papeles de Windows, para volcarlo posteriormente en cualquier otro sitio. El tema es relativamente sencillo de hacer, cuando nos movemos en una misma aplicación. Me explico. Si yo quiero conservar el valor de un campo para utilizarle en otro campo de cualquier otro formulario, bastará con declarar en un módulo Bas de nuestra aplicación, una variable Public que almacene dicho valor. Por ejemplo: Dim MiClipboard As String Si en Frm1 deseo «copiar» el contenido de Micampo1, bastaría, simplemente: MiClipboard=Me.Micampo1 Y posteriormente, si deseo volcar ese valor en Micampo2 de otro formulario, simplemente poner: Me.Micampo2 = MiClipboard Al fin y al cabo, hemos simulado un copy-paste y en muchas ocasiones puede servir y bastar. Pero hay más técnicas para esto. RunCommand Me.Campo1.SetFocus RunCommand acCmdCopy y luego Me.Campo2.SetFocus RunCommand acCmdPaste Actuar directamente sobre el objeto Portapapeles de Windows. En VBA hay que refenciar previamente Proyecto > Componentes > "Microsoft Forms 2.0 Object Library", Es decir, la fm20.dll Y luego, en efecto, instanacirla: Dim ObjetoClipboard As MSForms.DataObject Set ObjetoClipboard = New MSForms.DataObject ObjetoClipboard.Clear  'esto borra el portapapeles ObjetoClipboard.SetText "Esto va al portapapeles", 1 ObjetoClipboard.PutInClipboard MsgBox "En el portapapeles actualmente hay: " & ObjetoClipboard.GetText Si aplico esto al caso anterior.... Dim ObjetoClipboard As MSForms.DataObject Set ObjetoClipboard = New MSForms.DataObject ObjetoClipboard.Clear  'esto borra el portapapeles ObjetoClipboard.SetText Me.Campo1, 1 Me.Campo2 = ObjetoClipboard.GetText Vaciar el portapeles mediante API Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Sub VaciaPortapapeles()    OpenClipboard Me.hwnd    'Vacia el portapapeles:    EmptyClipboard End Sub

Tip Autodial de Access

Cuando nosotros colocamos en Access el codigo: Application.Run "utility.wlib_AutoDial", "983222222" realmente lo que estás cargando es un formulario del complemento de Access llamado Utility.mda Este fichero le podrás buscar en tu disco duro, pues es uno de los varios MDA que acompañan al producto de Access. En realidad, la llamada anterior, se hace a través de una funcion («wlib_autodial») que está dentro de ese completo, en el modulo de clase «utils». Esa función abre el formulario «acr_frmautodial» que es en realidad el formulario que se te muestra en pantalla cuando pones: Application.Run "utility.wlib_AutoDial", "983222222" ¿Y que hace este formulario? Pues nada mas que llamar a la API y marcar el numero de telefono que escribas en la caja de texto, y que dicho formulario recibe como parametro desde Application.Run "utility.wlib_AutoDial", "983222222" (En este caso 983222222) En resumen...y yendo a las tripas de todo esto, ese complmento, en esa parte, lo unico que hace es llamar a la api de esta forma: Declare Function TAPI_Make_Call Lib "tapi32.dll" _Alias  "tapiRequestMakeCall" _ (ByVal stNumber As String, _ ByVal  stDummy1 As String, _ ByVal  stDummy2 As String, _ ByVal  stDummy3 As String) As Long y ejecuta esta funcion, así de simple. Por lo tanto, podemos pasar de poner ese código  Application.Run "utility.wlib_AutoDial", "983222222" y construirnos un marcador telefónico al margen del complemento de access y del formulario mencionado. La función, todo junto ya, puesto en un módulo, podría quedar: Option Explicit Declare Function TAPI_Make_Call Lib "tapi32.dll" _ Alias  "tapiRequestMakeCall" _ (ByVal stNumber As String, _ ByVal  stDummy1 As String, _ ByVal  stDummy2 As String, _ ByVal  stDummy3 As String) As Long Function MarcaTelefono(Numero As String)    Dim VarRet As Long    If IsNumeric(Numero) = True Then      VarRet = TAPI_Make_Call(Numero, "", "", "")    End If End Function Y obtendrías el mismo resultado, pero sin el formulario de DAR conformidad para marcar el numero de TF. Desde cualquier formulario, que tenga un campo de texto con un número de teléfono, bastaría que asociaras a un boton de comando este codigo: MarcaTelefono Me.TxtTelefono donde TxtTelefono es una caja / campo de texto con el numero de telefono a marcar Saludos del Búho Function MarcaTelefono(Numero As String)    Dim VarRet As Long    If IsNumeric(Numero) = True Then      VarRet = TAPI_Make_Call(Numero, "", "", "")    End If End Function Y obtendrías el mismo resultado, pero sin el formulario de DAR conformidad para marcar el numero de TF. Desde cualquier formulario, que tenga un campo de texto con un número de teléfono, bastaría que asociaras a un boton de comando este codigo: MarcaTelefono Me.TxtTelefono donde TxtTelefono es una caja / campo de texto con el numero de telefono a marcar Saludos del Búho

Usuario de Windows

Es una pregunta que se suele repetir: Saber el nombre del usuario que ha iniciado sesión en Windows. Formas de hacerlo...varias. Primera Forma: API Option Explicit Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _     "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Function DameUsuarioApi() As String    'Utilizando API de Windows    Dim lngLen As Long, lngX As Long    Dim strUserName As String    strUserName = String$(254, 0)    lngLen = 255    lngX = apiGetUserName(strUserName, lngLen)    If lngX <> 0 Then      DameUsuarioApi = Left$(strUserName, lngLen - 1)    Else      DameUsuarioApi = "Incapaz de detectar usuario."    End If End Function Segunda Forma: Variables de Entorno Function DameUsuarioSencilla() As String    'Utilizando Variables de entorno    DameUsuarioSencilla = Environ("USERNAME") End Function Tercera forma: Utilizando Windows Script Host Function DameNombreUsuarioWSH() As String    'Dos lineas y me devuelve el nombre del PC y del usuario Activo    'Mas facil, imposible    'Buho Junio 2003    Dim ObjetoRed As Object    Set ObjetoRed = CreateObject("WScript.Network")    MsgBox "Nombre del PC en Red : " & ObjetoRed.ComputerName & vbCrLf _        & "Usuario: " & ObjetoRed.UserName, vbInformation, "Aviso"    DameNombreUsuarioWSH = ObjetoRed.UserName    Set ObjetoRed = Nothing End Function

Ruta de las Tablas Vinculadas

Para saber desde código la ruta de las tablas vinculadas a una MDB concreta, se pueden implementar funciones que así nos lo muestren. Aquí van dos, una utilizando el objeto Tabledef de Dao y otra sacando esta información de la tabla del sistema MSysObjects, en concreto, de su campo Database. Primer método DAO Function RutaVInculacion() As String    Dim tbfSrc As DAO.TableDef    Dim NombreBase As String    Dim RutaBase As String    For Each tbfSrc In CurrentDb.TableDefs      If (tbfSrc.Connect <> "") Then    'esta es vinculada        NombreBase = Mid(tbfSrc.Connect, InStrRev(tbfSrc.Connect, "\") + 1)        MsgBox "Catón, el nombre de la base es: " & NombreBase        RutaBase = Replace(Mid(tbfSrc.Connect, InStrRev(tbfSrc.Connect, _       "=") + 1), NombreBase,"")        MsgBox "Caton, la ruta es: " & RutaBase        'devolvemos la ruta        RutaVInculacion = RutaBase        Exit Function      End If    Next End Function Segundo Método Function RutaVInculacion() As String    Dim PosibleRuta As String    PosibleRuta = Nz(DLookup("Database", "MSysObjects", _                             "len([Database])<>0"), "")     If PosibleRuta <> "" Then      PosibleRuta = Replace(PosibleRuta, Mid(PosibleRuta, _                    InStrRev(PosibleRuta, "\") + 1), "")      RutaVInculacion = PosibleRuta    End If End Function

Enlaces
eGrupos
ZoomBlog