Moderatori: Anthony47, Flash30005
Marius44 ha scritto:Ciao
Vista la "leggerezza" della protezione di Excel secondo me non risolvi nulla.
Forse, e ripeto forse, si potrebbe utilizzare il menu a tendina coi nomi (o diminutivi) ma potresti integrarlo con l'ulteriore inserimento di una psw univoca; si continua solo se il nome selezionato e la psw corrispondono a quanto memorizzato.
Ma, mi ripeterò fino alla noia, non esiste in Excel una "vera" protezione.
Ciao,
Mario
Public strNome As String
Public datData As Date
Sub Workbook_Open()
Do
strNome = InputBox("Qual'è il tuo nome?" & vbNewLine & "Digitare 'Esci' per chiudere il file.", "Registrazione utente")
datData = Now
If StrConv(strNome, 1) = "ESCI" Then
ActiveWorkbook.Save
ActiveWindow.Close
End If
'xxxxxxxxxxxxxxxxxxxxxxx
Loop While strNome = ""
nomepercorso = ActiveWorkbook.Path & "\reg_acc.txt"
If Dir(nomepercorso, vbNormal) = "" Then
Open nomepercorso For Output As #1
Print #1, "Data accesso", ",", "Nome"
Close #1
End If
Open nomepercorso For Append As #1
Print #1, strNome, datData
Close #1
End Sub
Option Explicit
Dim RecordCorrente, NumCampi, Matrice(), Campi, NumRec
Sub UsoDelFile()
Dim np As String, MioTest As String, dat As String, mes As String
Dim FileNum As Integer, R As Integer, C As Integer, i As Integer
np = ActiveWorkbook.Path & "\reg_acc.txt" 'np=nomepercorso
FileNum = FreeFile()
Open np For Input As #FileNum
Line Input #FileNum, MioTest
Close #FileNum
Campi = Split(MioTest, ",")
NumCampi = UBound(Campi) + 1
ReDim Campi(1 To NumCampi)
Close
FileNum = FreeFile()
R = 0
Open np For Input As #FileNum
For C = 1 To NumCampi
Input #FileNum, Campi(C)
Next
Do While Not EOF(FileNum)
R = R + 1
ReDim Preserve Matrice(1 To NumCampi, 1 To R)
For C = 1 To NumCampi
Input #FileNum, Matrice(C, R)
Next
Loop
Close #FileNum
NumRec = UBound(Matrice, 2)
For i = 1 To NumRec
dat = Right(Matrice(1, i), 20)
If IsDate(dat) Then
dat = Trim(dat)
If Left(dat, 10) = Left(Now, 10) Then
mes = mes & Matrice(1, i) & vbLf
End If
End If
Next
MsgBox mes
End Sub
Sub QuanteVolte()
Dim np As String, MioTest As String, dat As String, mes As String
Dim FileNum As Integer, R As Integer, C As Integer, i As Integer
np = ActiveWorkbook.Path & "\reg_acc.txt" 'np=nomepercorso
FileNum = FreeFile()
Open np For Input As #FileNum
Line Input #FileNum, MioTest
Close #FileNum
Campi = Split(MioTest, ",")
NumCampi = UBound(Campi) + 1
ReDim Campi(1 To NumCampi)
Close
FileNum = FreeFile()
R = 0
Open np For Input As #FileNum
For C = 1 To NumCampi
Input #FileNum, Campi(C)
Next
Do While Not EOF(FileNum)
R = R + 1
ReDim Preserve Matrice(1 To NumCampi, 1 To R)
For C = 1 To NumCampi
Input #FileNum, Matrice(C, R)
Next
Loop
Close #FileNum
NumRec = UBound(Matrice, 2)
For i = 1 To NumRec
dat = Matrice(1, i)
dat = Trim(dat)
mes = mes & Matrice(1, i) & vbLf
Next
MsgBox mes
End Sub
Private Sub Workbook_Open()
Dim Ckwb As Workbook, myTim As Single
'
Sheets("TIP.MERCE").Range("G1").ClearContents
Sheets("LOC.MERCE").Select
With ActiveSheet.Shapes.Range(Array("ListBox1"))
.Visible = True
.Top = ActiveWindow.VisibleRange.Cells(2, 3).Top * 1.1
.Left = ActiveWindow.VisibleRange.Cells(2, 3).Left * 1.1
End With
myTim = Timer
Do
'attesa scelta:
DoEvents: DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
If Sheets("TIP.MERCE").Range("G1") <> "" Then Exit Do
If (Timer - myTim) > 60 Or Timer < myTim Then
'uscita per TimeOut=60 sec
MsgBox ("Nessuna scelta fatta")
Sheets("TIP.MERCE").Range("G1").Value = "NonSelezionato"
Exit Do
End If
DoEvents: DoEvents
Loop
'Nascondi ListBox:
ActiveSheet.Shapes.Range(Array("ListBox1")).Visible = False
'Continua il codice originale:
FFName = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE SIDERURGICO.xlsx" '<<< Percorso e nome del file da aprire
mySplit = Split(FFName, "\", , vbTextCompare)
'etc etc
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRan As String
Dim myC As Range, Worked As Range
'
myRan = "F3:G1000"
Set Worked = Application.Intersect(Target, Range(myRan))
If Not Worked Is Nothing Then
Application.EnableEvents = False
For Each myC In Worked
'Inserisci log in colonna H:
Cells(myC.Row, "H").Value = "Utente: " & Sheets("TIP.MERCE").Range("G1").Value & " - Time: " & Format(Now, "dd-mmm-yy hh:mm")
Next myC
Application.EnableEvents = True
End If
'Continua il codice originale:
myRan = "F3:F1000" '<<< L'area per i cui cambiamenti viene subito fatto un File Save
'etc etc
Marius44 ha scritto:Ciao
Allora, segui quanto detto appresso.
Nella stessa cartella in cui c'è il file da controllare crea un Documento di testo e denominalo "reg_acc" (cioè registro accessi.
Nel file da controllare inserisci in ThisWorkBook
- Codice: Seleziona tutto
Public strNome As String
Public datData As Date
Sub Workbook_Open()
Do
strNome = InputBox("Qual'è il tuo nome?" & vbNewLine & "Digitare 'Esci' per chiudere il file.", "Registrazione utente")
datData = Now
If StrConv(strNome, 1) = "ESCI" Then
[....]
[....]
Nel primo codice potresti inserire il controllo di eventuale psw dove ho indicato 'xxxxxxxxxxxxxxxxx
Prova e fai sapere. Ciao,
Mario
PS - Ovviamente nel mio esempio il file da controllare è uno solo. Lascio a te la cura delle variazioni eventuali visto che tu hai due files.
Marius44 ha scritto:Ciao
Il mio è solo un "suggerimento" su come fare.
Non ci sono nomi ed il file è uno solo. Fra l'altro nel tuo post iniziale io trovo un solo file allegato e non due.
E' meglio se approfondisci il codice di Anthony
Ciao,
Mario
Marius44 ha scritto:Ciao
Vero è che ho qualche ... anno ma non credo di essere ancora rinco....
Ho scaricato quanto presente nel primo post, ho visto che è zippato ma dentro c'è solo P.SIDERURGICO - ufficio
Se trovo un po' di tempo vedo di realizzare qualcosa (anche se ritengo quello di Anthony appropriato).
Ovvio che WorkBook_Open deve essere una sola.
Ciao,
Mario
Option Explicit
Sub LeggiUltimi()
Dim np As String, x, gg
Dim miotest(), a, i, mes As String
gg = InputBox("Inserire una data (gg/mm/aaaa)", "Utilizzi fino alla data")
If gg = "" Then Exit Sub
np = ActiveWorkbook.Path & "\reg_acc.txt"
Open np For Input As #1
a = 1
Do While Not EOF(1)
Input #1, x
ReDim Preserve miotest(1 To a)
miotest(a) = Trim(x)
a = a + 1: x = ""
Loop
Close #1
For i = 1 To UBound(miotest)
If CDate(Left(Right(miotest(i), 19), 10)) <= CDate(gg) Then
mes = mes & miotest(i) & vbLf
End If
Next i
MsgBox mes
End Sub
Sub LeggiTutti()
Dim np As String, x
Dim miotest(), a, i, mes As String
np = ActiveWorkbook.Path & "\reg_acc.txt"
Open np For Input As #1
a = 1
Do While Not EOF(1)
Input #1, x
ReDim Preserve miotest(1 To a)
miotest(a) = x
a = a + 1: x = ""
Loop
Close #1
For i = 1 To UBound(miotest)
mes = mes & miotest(i) & vbLf
Next i
MsgBox mes
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim psw As String, flg As String, perc As String
Dim dt As Date
If Not Intersect(Target, Range("J2")) Is Nothing Then
If Target = "" Then Exit Sub
MaskPsw.Show vbModal 'chiede inserimento psw
End If
End Sub
Option Explicit
Private Sub cmdEsci_Click()
Unload MaskPsw
End Sub
Private Sub cmdEsegui_Click()
Dim psw As String, flg As String, perc As String, Utente As String
Dim dt As Date
Utente = Sheets(1).Range("J2")
psw = TextBox1.Text
flg = Application.WorksheetFunction.VLookup(Utente, Sheets(1).Range("P1:Q4"), 2, 0) 'confronta
If flg <> psw Then
MsgBox "La psw non è corretta" 'se errata avvisa ed esce
Exit Sub
End If
'controllo superato
dt = Now
perc = ActiveWorkbook.Path & "\reg_acc.txt"
If Dir(perc, vbNormal) = "" Then
Open perc For Output As #1
Print #1, "Nome", "Data accesso"
Close #1
End If
Open perc For Append As #1
Print #1, Utente, dt
Close #1
MsgBox "Password corretta." & vbLf & "Buon lavoro.", vbExclamation, "Controllo Password"
Unload MaskPsw
End Sub
Marius44 ha scritto:Buongiorno a tutti
Confermo che io vedo solo un file.
Comunque ho realizzato quanto trovate in allegato.
La cartella contiene tre file: File_ONE, File_TWO e reg_acc (quest'ultimo è un file di testo)
In File_ONE - Foglio1 vi sono due pulsanti
- Fino alla data - Mostra le aperture del file fino alla data indicata
- Totale utilizzi - Mostra TUTTE le aperture del file
Non ho previsto un pulsante per eventuale "pulizia"
Queste le macro associate ai pulsanti
- Codice: Seleziona tutto
Option Explicit
Sub LeggiUltimi()
Dim np As String, x, gg
Dim miotest(), a, i, mes As String
gg = InputBox("Inserire una data (gg/mm/aaaa)", "Utilizzi fino alla data")
[....]
[....]
[....]
Close #1
MsgBox "Password corretta." & vbLf & "Buon lavoro.", vbExclamation, "Controllo Password"
Unload MaskPsw
End Sub
Questo il link https://www.dropbox.com/sh/o6r2gciat28bhbv/AABQtMf9FOf2Ojcly0rqRhr0a?dl=0
Ciao,ùMario
Anthony47 ha scritto:.
-come LinkedCell inserisci TIP.MERCE!G1
Anthony47 ha scritto:Se puo' aiutare a debuggare la situazione, anche io vedo i DUE file; uso 7Zip, ma vedo due file anche se (dopo aver fatto download del file zippato) faccio "Apri con /Esplora risorse"
Ciao
Torna a Applicazioni Office Windows
Macro modifica date scelta periodo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 11 |
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
File batch per copiare file selezionato da menu contestuale Autore: valle1975 |
Forum: Programmazione Risposte: 3 |
Visitano il forum: Nessuno e 12 ospiti