1
General / Re:** ¿Referenciar o no referenciar?
« Último mensaje por xavi en Enero 11, 2025, 11:19:07 am »Esta página no admite preguntas. Para ello referirse a www.mvp-access.com y presentar la duda allí.
' Supongamos que deseas cambiar la fecha de creación del archivo "TESTFILE" a "12/12/2017 10:00".
' Primero, copia el archivo a una nueva ubicación con la fecha deseada.
FileCopy "TESTFILE", "NUEVO_TESTFILE"
' Luego, establece la fecha de modificación del nuevo archivo.
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("NUEVO_TESTFILE")
f.DateCreated = #12/12/2017 10:00#
' Finalmente, puedes eliminar el archivo original si es necesario.
Kill "TESTFILE"
Set OUTAPP = CreateObject("Outlook.Application")
Set OUTMAIL = OUTAPP.CreateItemFromTemplate(Application.CurrentProject.Path & "\oficio.oft")
' oficio.oft es una plantila de mail con la firma
With OUTMAIL
.To = mail
.cc = ""
.bcc = ""
.BodyFormat = olFormatHTML
.Subject = "asunto del envio"
adjunto1 = Application.CurrentProject.Path & "\factura.pdf"
.Attachments.Add (adjunto1)
Sub MostrarVariables()
'Declaramos variables
'
Dim i As Integer
'
i = 1
'
'Mientras el valor de Environ NO sea vacío, se obtiene el valor.
While Environ(i) <> Empty
'
ActiveWorkbook.Sheets("Hoja1").Range("A8").Offset(i, 0).Value = Environ(i)
'
i = i + 1
'
Wend
'
End Sub
Public clnClient As New Collection 'Instances of frmClient.
Function OpenAClient()
'Purpose: Open an independent instance of form frmClient.
Dim frm As Form
'Open a new instance, show it, and set a caption.
Set frm = New Form_frmClient
frm.Visible = True
frm.Caption = frm.Hwnd & ", opened " & Now()
'Append it to our collection.
clnClient.Add Item:=frm, Key:=CStr(frm.Hwnd)
Set frm = Nothing
End Function
Function CloseAllClients()
'Purpose: Close all instances in the clnClient collection.
'Note: Leaves the copy opened directly from database window/nav pane.
Dim lngKt As Long
Dim lngI As Long
lngKt = clnClient.Count
For lngI = 1 To lngKt
clnClient.Remove 1
Next
End Function
Private Sub Form_Close()
'Purpose: Remove this instance from clnClient collection.
Dim obj As Object 'Object in clnClient
Dim blnRemove As Boolean 'Flag to remove it.
'Check if this instance is in the collection.
For Each obj In clnClient
If obj.Hwnd = Me.Hwnd Then
blnRemove = True
Exit For
End If
Next
'Deassign the object and remove from collection.
Set obj = Nothing
If blnRemove Then
clnClient.Remove CStr(Me.Hwnd)
End If
End Sub
Function DiaLabIntl(dtmFechaInicial As Date, intDiasProceso As Integer, Optional strTipoSemanaLaboral As String = "0000011", Optional blnAplicaFestivos As Boolean = True) As Date
' Función análoga a la de Excel utilizando el tipo de semana laboral como cadena y un boolean para aplicar laborables y festivos
' En caso de aplicar festivos será necesario indicar el nombre de la tabla y el campo de la tabla que contiene la fecha
' La cadena de strTipoSemanaLaboral se establece con 7 ceros y unos. El cero indica laborable y el uno festivo.
' Así, "0000011" indica el fin de semana de sábado-domingo. Esa técnica nos permite gestionar (casi) cualquier combinación
Const cTablaFestivos As String = "tblDatFestivos"
Const cCampoFecha As String = "FechaFestiva"
Dim dtmLaFecha As Date
Dim intdias As Integer
' Establecemos la fecha inicial
dtmLaFecha = dtmFechaInicial
' Bucle sin condiciones
Do
' Evaluamos si el día de la semana se ha estipulado como festivo.
If Mid(strTipoSemanaLaboral, Weekday(dtmLaFecha, vbMonday), 1) = "1" Then
' Es un NO-laborable: no hacemos nada
Else
' En este punto "parece" un laborable pero miramos si es festivo (si procede)
If blnAplicaFestivos And DCount("*", cTablaFestivos, cCampoFecha & "= " & CLng(dtmLaFecha)) > 0 Then
' es un festivo: nada
Else
' Ni es fin de semana, ni es festivo (sea porque no aplica, sea porque no lo es)
intdias = intdias + 1
End If
End If
' Comprobamos si hemos alcanzado el limite de días
If intdias >= intDiasProceso Then
DiaLabIntl = dtmLaFecha
Exit Function
End If
' Aumentamos un día
dtmLaFecha = DateAdd("d", 1, dtmLaFecha)
' Comprobación de seguridad
If dtmLaFecha > DateAdd("d", intDiasProceso + 1000, dtmFechaInicial) Then
MsgBox "Creo que nos hemos pasado de largo", vbExclamation
DiaLabIntl = "01/01/1900"
Exit Function
End If
Loop
End Function
Function rngHTML(Rng As Object) ' Range
Dim fso As Object
Dim ts As Object
Dim TempWB As Object ' Workbook
Dim TempFile As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'' copy the range and create a new workbook to paste the data into
'Rng.Copy
Set TempWB = xlsApp.Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
.Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'' publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
fileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'' read all data from the htm file into rngHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
rngHTML = ts.readall
ts.Close
rngHTML = Replace(rngHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
'' delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Option Compare Database
Option Explicit
' Declaraciones (para aDialogColor)
#If Win64 Then
Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#Else
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#End If
' Estructura (para aDialogColor)
Private Type COLORSTRUC
lStructSize As Long
hWnd As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Estructura de devolución de valor
Public Type udtSysDialogColor
IsSelected As Boolean
PreSelected As Variant
SelectedColor As Long
End Type
Public uSysDialogColor As udtSysDialogColor
' Constantes (para aDialogColor)
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_RGBINIT = &H1
Public Function aDialogColor()
Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
CS.lStructSize = Len(CS)
CS.hWnd = Application.hWndAccessApp
CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
CS.lpCustColors = String$(16 * 4, 0)
' Were we passed a value in PreselectedColor
If Not IsMissing(uSysDialogColor.PreSelected) Then
CS.rgbResult = uSysDialogColor.PreSelected
End If
x = CHOOSECOLOR(CS)
If x = 0 Then
' ERROR - return preselected Color
uSysDialogColor.IsSelected = False
Exit Function
Else
' Normal processing
uSysDialogColor.SelectedColor = CS.rgbResult
uSysDialogColor.IsSelected = True
End If
End Function