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
|
Por ErBuho - 5 de Septiembre, 2005, 1:30, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por Emilio Sancha - 5 de Septiembre, 2005, 1:29, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:28, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:27, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:26, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:25, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:24, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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 
|
Por ErBuho - 5 de Septiembre, 2005, 1:23, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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
|
Por ErBuho - 5 de Septiembre, 2005, 1:22, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
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

|
Por ErBuho - 5 de Septiembre, 2005, 1:20, Categoría: Access con Codigo VBA
Enlace Permanente
| Referencias (0)
|
|
|
|