Salvare un file con suffisso di chi utilizza il computer e salvataggio dell'intera cartella in un'altra directory

Question

Buongiorno  a tutti, desidererei salvare il file in uso in una directory definita indicando anche il nome di chi usa il computer in quel momento.

Inoltre desidererei ad intervalli di tempo prestabiliti salvare (come copia di Backup)l'intera cartella di lavoro contenenti i files in utilizzo. Con il codice postato non riesco ad aggiungere al file salvato il nome di chi usa il computer pur avendo ricercato una funzione ch efa questo ( Get Username), dove sbaglio.

Quindi ricapitolando:

1. salvataggio del file con l'aggiunta dellUSERNAME;
2. Backup dell'intera cartella di lavoro ( compresi tutti i files contenenti).

' Access the GetUserNameA function in advapi32.dll and

     ' call the function GetUserName.

     Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _

     (ByVal lpBuffer As String, nSize As Long) As Long

     ' Main routine to Dimension variables, retrieve user name

     ' and display answer.

     Sub Get_User_Name()

     ' Dimension variables

     Dim lpBuff As String * 25

     Dim ret As Long, UserName As String

     ' Get the user name minus any trailing spaces found in the name.

     ret = GetUserName(lpBuff, 25)

     UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)

     ' Display the User Name

     MsgBox UserName

     End Sub

Sub CopiaFoglio()

Dim VBC As Object

 Dim p As String

 ' Seleziona la cartella destinazione in DDir

 With Application.FileDialog(msoFileDialogFolderPicker)

 .InitialFileName = DDir '<<< Filtro per nome

 .Title = "Scegli la directory per il foglio " & ActiveSheet.Name

 .Show

 If .SelectedItems.Count = 0 Then 'directory non scelta

 MsgBox ("Scelta non effettuata, procedura abortita")

 Exit Sub

 End If

 DDir = .SelectedItems(1) & ""

 End With

 'Copia il foglio in un'altro al volo

 'Converte tutte le formule del foglio nel

 'valore al momento calcolato

 Sheets("Foglio1").Copy

 Cells.Select

 Selection.Copy

 Cells.Select

 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

 :=False, Transpose:=False

 Application.CutCopyMode = False

 Range("A1").Select

 ' Salva il foglio

 NewFName = DDir & FPrefix & ActiveSheet.Name & UserName ? è qui che non va, come devo impostarlo ( sempre se sia giusto cosi).

& Format(Now, "yyyy-mm-dd_hh-mm-ss") & ".xlsx"

 ActiveWorkbook.SaveAs Filename:=NewFName

 ActiveWorkbook.Close

' With ActiveWorkbook.VBProject

 'For Each VBC In .VBComponents

 'If VBC.Type = 100 Then

 'With VBC.CodeModule

 '.DeleteLines 1, .CountOfLines

 '.CodePane.Window.Close

 'End With

 'End If

 'Next VBC

 'End With

 End Sub

In attesa di un vostro gentile e comptetente riscontro vi saluto e vi auguro buona giornata.

Ciao Nicola.

Answer 1

Buongiorno Mauro, grazie per avermi assistito e aiutato, ho utilizzato, per il mio scopo questo: Application.UserName e va benissimo, inoltre, non si sa mai ho fatto tesoro anche della  funzione utente di rete (valido per 32/64 bit).

Ti chiedo per cortesia ( poiché in rete e anche su questo forum ho trovato il codice di David che mi salva il file e non l'intera cartella di lavoro comprensiva di tutti i files in essa contenuti) come posso salvare impostando magari un tempo prestabilito che in automatico mi salva  il tutto sovrascrivendo la stessa cartella oppure cancellando quella precedentemente  salvata in modo da avere sempre una copia di backup in caso di perdita di dati accidentali.

Public Sub s()

    Dim sh As Worksheet

     Dim sPath As String

     Dim sNomeFile As Variant

     Dim lRisposta As Long

    Set sh = ThisWorkbook.Worksheets("Foglio1")

     sPath = "C:\Users\x880588\Desktop\mio"          '<--- qui definisci il percorso fisso di salvataggio

     'se la directory definita non esiste la creo

     If Dir(sPath, vbDirectory) = "" Then MkDir sPath

     Application.ScreenUpdating = False

     With sh

         If Not IsDate(.Range("Q2").Value) Then

              MsgBox "Nessuna data trovata!"

              Set sh = Nothing

             Exit Sub

         End If

         '--------------------------------------------

         'Definisco il nome del file da salvare

         sNomeFile = InputBox("Dimmi il nome del file da salvare?" _

             , "... salvataggio file ...")

         If sNomeFile = Empty Then

             MsgBox "Non hai specificato nulla" & vbNewLine _

                 & "Verrà utilizzato il nome PIPPO.XLSM"

             sNomeFile = "PIPPO.XLSM"

         ElseIf Right(sNomeFile, 5) <> ".XLSM" Then

             sNomeFile = sNomeFile & ".XLSM"

         End If

         '--------------------------------------------

         sNomeFile = sPath & sNomeFile

         If Dir(sNomeFile) <> "" Then

             lRisposta = _

                 MsgBox(Prompt:="Il file: " & sNomeFile & " esiste già! Sovrascriverlo?", _

                 Title:="Attenzione", _

                 Buttons:=vbYesNo + vbQuestion)

             If lRisposta = vbNo Then Exit Sub

        End If

         'Application.CutCopyMode = False    'in questo contesto di codice non serve

         .Copy

         ActiveWorkbook.SaveAs Filename:=sNomeFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled

         ActiveWorkbook.Close

     End With

     Application.ScreenUpdating = True

     Set sh = Nothing

End Sub

Ciao Nicola.

Answer 2

Buongiorno  a tutti, desidererei salvare il file in uso in una directory definita indicando anche il nome di chi usa il computer in quel momento.

<cut>

Ecco qui, senza nessuna funzione l'utente di Office:

Public Sub m()

    MsgBox Application.UserName

End Sub

E con funzione l'utente di rete (valido per 32/64 bit):

#If Win64 Then

    Public Declare PtrSafe Function GetUserName Lib "advapi32.dll" _

        Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As LongLong) As Long

#Else

    Public Declare PtrSafe Function GetUserName Lib "advapi32.dll" _

        Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

#End If

Public Function fUserName() As String

    Dim s As String * 255

    Dim lLen As Long

    Dim sString As String

    sString = ""

    On Error Resume Next

    lLen = GetUserName(s, 255)

    lLen = InStr(1, s, Chr(0))

    If lLen > 0 Then

        sString = Left(s, lLen - 1)

    Else

        sString = s

    End If

    On Error GoTo 0

    fUserName = UCase(Trim(sString))

End Function

Public Sub mm()

    MsgBox fUserName

End Sub

Da richiamare così.

Public Sub mm()

    MsgBox fUserName

End Sub

Le parti in grassetto sono quelle che dei utilizzare nella tua stringa, qui sono messe all'interno di una routine in modo che tu possa visualizzarle in una MsgBox.