La página Web de Emilio Sancha - MVP 2006/11
La página Web de Emilio Sancha

Inicio    |   Access    |   Excel    |    Visual Script    |   Enlaces    |   Búsquedas    |   Apuntes    |   Libro de Visitas

 Suscripcion RSS 

'***********************************************************************************
'* esta función se utiliza para emular el anidamiento de ifs simplificandolo mucho
'* es primordial resetear en la primera expresión, si no no funcionará
'* permite enviar mensajes cuando no se cumpla un conjunto de condiciones
'* uso: SeCumple x1 >= MIN, ,True
'* SeCumple x2 <= MAX
'* SeCumple x1 < x2
'* if SeCumple then ... si se cumplen todas las condiciones anteriores entonces...
'* ESH 10/10/01 13:00
'*********************************************************************************** 
Public Function SeCumple(Optional vntExpresion As Variant, Optional vntAvisa As Variant = "", Optional vntResetea As Variant = False) As Boolean
Static bolResultado As Boolean
If vntResetea Then
   bolResultado = True
End If ' vntResetea
If Not CBool(vntExpresion) And Len(vntAvisa) Then
   MsgBox "ATENCION: " & vntAvisa, vbInformation
End If 	' CBool(Expression) And Len(vntAvisa)
bolResultado = CBool(vntExpresion) And bolResultado
SeCumple = bolResultado
End Function 	' SeCumple
'*******************************************************************************
'* TamañoTabla
'* Calcula el tamaño de la tabla pasada como parámetro
'* Argumentos: strTabla => Nombre de la tabla
'* uso: TamañoTabla "Pedidos"
'* ESH 26/02/06 09:49
'*******************************************************************************
 
Public Function TamañoTabla(strTabla As String) As Long
Dim Campo As Object, _
    rst As DAO.Recordset, _
    strSQL As String, _
    Matriz() As Variant, _
    i As Long, _
    lngCuenta As Long, _
    lngTamaño As Long
 
On Error GoTo TamañoTabla_TratamientoErrores
 
strSQL = "SELECT * FROM " & strTabla
 
Set rst = CurrentDb.OpenRecordset(strSQL, dbopendynaset)
 
rst.MoveLast
 
lngCuenta = rst.RecordCount
 
For Each Campo In rst.Fields
   ReDim Preserve Matriz(2, i)
   Matriz(0, i) = Campo.Name
   Matriz(1, i) = Campo.Type
   ' según el tipo de campo calculo el tamaño ocupado como el producto
   ' del número de registros por su correspondiente tamaño en bits
   Select Case Campo.Type
      Case dbBoolean                      ' 1 bit
         Matriz(2, i) = lngCuenta * 1
      Case dbByte                         ' 1 byte
         Matriz(2, i) = lngCuenta * 8
      Case dbCurrency, dbDate, dbDouble   ' 8 bytes
         Matriz(2, i) = lngCuenta * 64
      Case dbSingle, dbLong               ' 4 bytes
         Matriz(2, i) = lngCuenta * 32
      Case dbInteger                      ' 2 bytes
         Matriz(2, i) = lngCuenta * 16
   End Select
   i = i + 1
Next Campo
 
For i = 0 To UBound(Matriz, 2)
   ' acumulo el tamaño de todos los campos, para el caso de los
   ' campos texto y memo, recorro registro por registro y acumulo
   ' su longitud multiplicada por 8 para convertirla a bits
   If Matriz(1, i) = dbText Or Matriz(1, i) = dbMemo Then
      rst.MoveFirst
      Do While Not rst.EOF
         lngTamaño = lngTamaño + Nz(Len(rst(Matriz(o, i))), 0) * 8
         rst.MoveNext
      Loop
   Else
      lngTamaño = lngTamaño + Matriz(2, i)
   End If
Next i
' devuelvo el tamaño convertido a bytes
TamañoTabla = lngTamaño / 8
 
If Not rst Is Nothing Then
    rst.Close
    Set rst = Nothing
End If
 
TamañoTabla_Salir:
    On Error GoTo 0
    Exit Function
 
TamañoTabla_TratamientoErrores:
 
   MsgBox "Error " & Err.Number & " en proc.: TamañoTabla de Documento VBA: Form_frmTamaño (" & Err.Description & ")"
    Resume TamañoTabla_Salir

End Function              ' TamañoTabla

 
'*******************************************************************************
'* RenombraControles
'* Renombra los controles del formulario indicado siguiendo la notación Hungara
'* Argumentos: strObjeto => nombre del objeto (formulario o informe) cuyos
'*                          controles vamos a renombrar
'* uso: RenombraControles frmClientes
'* ESH 10/11/05 13:19
'* ESH 27/03/06 18:10 modificado para editar las etiquetas
'*******************************************************************************
 
Public Sub RenombraControles(strObjeto As String)
 
Dim ctlControl As Control, _
    strNombrePadre As String, _
    strPrefijo As String, _
    i As Long, _
    intTipo As Integer, _
    Objeto As Object

On Error GoTo RenombraControles_TratamientoErrores
 
' averiguo que tipo de objeto voy a renombrar
intTipo = Nz(DLookup("Type", "MSysObjects", "Name='" & strObjeto & "'"), 0)
 
If intTipo = -32768 Then                                 ' formulario
   ' abro el objeto en modo diseño y oculto
   DoCmd.OpenForm strObjeto, acDesign, , , , acHidden
   Set Objeto = Forms(strObjeto)
ElseIf intTipo = -32764 Then                             ' informe
   ' abro el objeto en modo diseño y oculto
   DoCmd.OpenReport strObjeto, acDesign, , , , acHidden
   Set Objeto = Reports(strObjeto)
Else
   MsgBox "El objeto " & strObjeto & " no es un formulario o informe de la base de datos", vbOKOnly + vbCritical, "Error"
   Exit Sub
End If
 
   For Each ctlControl In Objeto.Controls
      ' obtengo el prefijo para el tipo de control
      Select Case ctlControl.ControlType
            '      Case acBoundObjectFrame
         Case acCheckBox
            strPrefijo = "chk"
         Case acComboBox
            strPrefijo = "cbo"
         Case acCommandButton
            strPrefijo = "cmd"
            '      Case acCustomControl
         Case acImage
            strPrefijo = "img"
         Case acLabel
            strPrefijo = "lbl"
            ' en el caso de las etiquetas elimino los dos puntos finales
            ctlControl.Caption = Replace(ctlControl.Caption, ":", "")
            For i = 2 To Len(ctlControl.Caption)
               ' "troceo" la etiqueta en las distintas palabras que contiene
               ' una mayúscula precedida de una minúscula
               If Asc(Mid(ctlControl.Caption, i, 1)) >= 65 And Asc(Mid(ctlControl.Caption, i, 1)) <= 90 _
                  And Asc(Mid(ctlControl.Caption, i - 1, 1)) >= 97 And Asc(Mid(ctlControl.Caption, i - 1, 1)) <= 122 Then
                  ctlControl.Caption = Left(ctlControl.Caption, i - 1) & " " & Mid(ctlControl.Caption, i)
               End If
            Next i
         Case acLine
            strPrefijo = "lin"
         Case acListBox
            strPrefijo = "lst"
            '      Case acObjectFrame
         Case acOptionButton
            strPrefijo = "opt"
         Case acOptionGroup
            strPrefijo = "grp"
            '      Case acPage
            '      Case acPageBreak
            '      Case acRectangle
         Case acSubform
            strPrefijo = "sub"
         Case acTabCtl
            strPrefijo = "tab"
         Case acTextBox
            strPrefijo = "txt"
            '      Case acToggleButton
      End Select
 
      ' obtengo el nombre del control padre sin tildes
      If ctlControl.Parent.Name <> strObjeto Then
         strNombrePadre = SinTildes(ctlControl.Parent.Name)
      Else
         strNombrePadre = ctlControl.Name
      End If
      ' si el nombre del padre ya incluye prefijo, lo quito
      Select Case LCase(Left(strNombrePadre, 3))
         Case "chk", "cbo", "cmd", "img,", "lbl", "lin", "opt", "grp", "sub", "tab", "txt"
            strNombrePadre = Mid(strNombrePadre, 4)
      End Select
      ' si todavía no era "correcto" el nombre del control lo modifico
      If Left(ctlControl.Name, 3) <> strPrefijo & strNombrePadre Then
         ctlControl.Name = strPrefijo & strNombrePadre
      End If
   Next
 
RenombraControles_Salir:
   On Error Resume Next
   ' cierro el objeto guardando los cambios
   If intTipo = -32768 Then
      DoCmd.Close acForm, strObjeto, acSaveYes
   ElseIf intTipo = -32764 Then
      DoCmd.Close acReport, strObjeto, acSaveYes
   End If
 
   Set Objeto = Nothing
   On Error GoTo 0
   Exit Sub
 
RenombraControles_TratamientoErrores:
   MsgBox "Error " & Err.Number & " en proc.: RenombraControles de Módulo: mdlUtilidades (" & Err.Description & ")"
   Resume RenombraControles_Salir
 
End Sub        ' RenombraControles
 
 
'*******************************************************************************
'* SinTildes
'* Devuelve sin tildes (acentos, dieresis) la palabra pasada como parámetro
'* Argumentos: strTexto => cadena de texto a convertir
'* uso: SinTildes strTexto
'* ESH 10/11/05 18:22
'*******************************************************************************
 
Function SinTildes(strTexto As String) As String
strTexto = Replace(strTexto, "á", "a")
strTexto = Replace(strTexto, "é", "e")
strTexto = Replace(strTexto, "í", "i")
strTexto = Replace(strTexto, "ó", "o")
strTexto = Replace(strTexto, "ú", "u")
strTexto = Replace(strTexto, "ü", "u")
SinTildes = strTexto
End Function            ' SinTildes
 
 

 

NOTA: La información contenida en esta página, así como el código fuente incluido en la misma, se proporciona TAL CUAL, sin garantías de ninguna clase, y no otorga derecho alguno. Usted asume cualquier riesgo al poner en práctica, utilizar o ejecutar lo explicado, recomendado o sugerido en la presenta página.

This page is provided AS IS with no warranties, and confers no rights. You assume all risk for your use.

Ultima actualización:  Sábado, 15 de Octubre de 2016
© Emilio Sancha 2.004-2.016