What is the function for system to capture the username

  • Thread starter Dave VB logic for excel
  • Start date
D

Dave VB logic for excel

Hello,

im currently working in excel sheet. i wanto add function where it can
capture the username whenever any users open the sheet. It can capture from
system or licencing. I would like to know the function or vb formula.

Please help

Thanks in advanced
 
D

Dave VB logic for excel

Hello,

Thanks alot but its doesnt work. Im using exel 2003. how to solve it? and
also.. do i just copied and paste in vb editor? wat about the cell that i
want the information to visible?
 
G

Gord Dibben

Copy the function to a general module in your workbook.

Then in any cell in any sheet of that workbook enter =UserNameWindows()

just as you would any other function.

Takes no arguments.


Gord Dibben MS Excel MVP
 
C

Chris Bode

Code to Unprotect protection and cracking protection password


--------------------

Sub AllInternalPasswords()
'Breaks worksheet and workbook structure passwords.
'Bob McCormick probably originator of base code algorithm
'Modified for coverage of workbook structure / windows
'passwords and for multiple passwords
'Norman Harker 26-Dec-2002
'Reveals passwords NOT "the" passwords
Dim Mess As String, Header As String
Dim Authors As String, Version As String
Dim RepBack As String, AllClear As String
Dim PWord1 As String
Dim ShTag As Integer, WinTag As Integer
Dim w1 As Integer, w2 As Integer
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Application.ScreenUpdating = False
Header = "AllInternalPasswords User Message"
Authors = vbCrLf & vbCrLf & vbCrLf & "Adapted from Bob McCormick"
Authors = Authors & " base code by Norman Harker."
Version = vbCrLf & vbCrLf & "Version 1.0 26-Dec-2002"
RepBack = vbCrLf & vbCrLf & "Please report success or "
RepBack = RepBack & "failure back to newsgroup."
AllClear = vbCrLf & vbCrLf & "The workbook should now"
AllClear = AllClear & " be free of all password protection so"
AllClear = AllClear & " make sure you:" & vbCrLf & vbCrLf
AllClear = AllClear & "SAVE IT NOW!" & vbCrLf & vbCrLf
AllClear = AllClear & "and also" & vbCrLf & vbCrLf
AllClear = AllClear & "BACKUP!, BACKUP!!, BACKUP!!!" & vbCrLf
AllClear = AllClear & vbCrLf & "Also, remember that the password"
AllClear = AllClear & " was put there for a reason. Don't "
AllClear = AllClear & "stuff up crucial formulas or data."
ShTag = 0: WinTag = 0
If ActiveWorkbook.ProtectStructure = True Then
WinTag = 1
End If
If ActiveWorkbook.ProtectWindows = True Then
WinTag = 1
End If
For w1 = 1 To Worksheets.Count
If Worksheets(w1).ProtectContents = True Then
ShTag = 1
Exit For
End If
Next
If ShTag = 0 And WinTag = 0 Then
Mess = "There were no passwords on sheets, or workbook "
Mess = Mess & "structure or windows."
Mess = Mess & Authors & Version
MsgBox Mess, vbInformation, Header
Exit Sub
End If
Mess = "After pressing OK button this will take some time."
Mess = Mess & vbCrLf & vbCrLf & "Amount of time depends on"
Mess = Mess & " how many different passwords, the passwords"
Mess = Mess & " and, your computer's specification." & vbCrLf
Mess = Mess & vbCrLf & "Just be patient! Make me a coffee!"
Mess = Mess & Authors & Version
MsgBox Mess, vbInformation, Header
If WinTag = 0 Then
Mess = "There was no protection to workbook structure "
Mess = Mess & " or windows." & vbCrLf & vbCrLf
Mess = Mess & "Proceeding to unprotect sheets."
Mess = Mess & Authors & Version
MsgBox Mess, vbInformation, Header
End If
If WinTag = 1 Then
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If ActiveWorkbook.ProtectStructure = False Then
If ActiveWorkbook.ProtectWindows = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & _
Chr(i5) & Chr(i6) & Chr(n)
Mess = "You had a Worksheet Structure or Windows"
Mess = Mess & " Password set." & vbCrLf & vbCrLf
Mess = Mess & "The password found was: " & vbCrLf
Mess = Mess & vbCrLf & PWord1
Mess = Mess & vbCrLf & vbCrLf & "Note it down for "
Mess = Mess & "potential future use in other "
Mess = Mess & "workbooks by same person who set this "
Mess = Mess & "password." & vbCrLf & vbCrLf
Mess = Mess & "Now to check and clear other passwords."
Mess = Mess & Authors & Version
MsgBox Mess, vbInformation, Header
GoTo SheetSection
End If
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
End If
SheetSection:
If WinTag = 1 And ShTag = 0 Then
Mess = "Only structure / windows protected with the"
Mess = Mess & " password that was just found."
Mess = Mess & AllClear & Authors & Version & RepBack
MsgBox Mess, vbInformation, Header
WinTag = 0 'Won't run on return from below.
Exit Sub
End If
For w1 = 1 To Worksheets.Count
'Attempt clearance with PWord1
If Worksheets(w1).ProtectContents = True Then
On Error Resume Next
Worksheets(w1).Unprotect PWord1
End If
Next
ShTag = 0
For w1 = 1 To Worksheets.Count
'Checks for all clear ShTag triggered to 1 if not.
If Worksheets(w1).ProtectContents = True Then
ShTag = 1
Exit For
End If
Next
If ShTag = 0 Then
Mess = AllClear & Authors & Version & RepBack
MsgBox Mess, vbInformation, Header
Exit Sub
End If
For w1 = 1 To Worksheets.Count
If Worksheets(w1).ProtectContents = True Then
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
Worksheets(w1).Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Worksheets(w1).ProtectContents = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & _
Chr(i5) & Chr(i6) & Chr(n)
Mess = "You had a Worksheet password set." & vbCrLf
Mess = Mess & vbCrLf & "The password found was: "
Mess = Mess & vbCrLf & vbCrLf & PWord1
Mess = Mess & vbCrLf & vbCrLf
Mess = Mess & "Note it down for potential future use"
Mess = Mess & " in other workbooks by same person who"
Mess = Mess & " set this password." & vbCrLf & vbCrLf
Mess = Mess & "Now to check and clear other passwords."
Mess = Mess & Authors & Version
MsgBox Mess, vbInformation, Header
ShTag = 0
For w2 = 1 To Worksheets.Count
If Worksheets(w2).ProtectContents = True Then
ShTag = 1
End If
Next
If ShTag = 0 Then
Mess = AllClear & Authors & Version & RepBack
MsgBox Mess, vbInformation, Header
Exit Sub
End If
GoTo SheetSection
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
End If
Next
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

What is the formula to capture username from system into excel she 4
What is the fucntion or formula to capture username into excel she 1
How to add username in excel 2
How to capture Username into specific cells 6
how to capture the event changing the name of a sheet 1
Capture NT username 4
capturing the Sub or Function name in the error message 8
Excel How to capture data to a specified excel sheet(first workbook) of two different workbooks from the 0

Top