MACRO TO GET COMPUTER ID IN CELL

[K]

Hi all, In my office myself and other colleagues save files on one
network drive and we all have name of our computers. Like my computer
name is 07856J and when I click in this PC icon I got all the drive
like C:/ , D:/ etc in it. This computer name or computer ID been
given to all the computers by the company. I want macro that when
someone open a file his computer name or number or ID should come in
Range("A1") so when if someone else open the same file again later on
he'll know that who opened this file before him. Please can anybody
help

 

[Bob Phillips]

Just use


Private Sub Workbook_Open()

With ThisWorkbook.Worksheets(1)
.Range("A1").Value = Environ("Username")
End With

End Sub

'This is workbook event code.
'To input this code, right click on the Excel icon on the worksheet
'(or next to the File menu if you maximise your workbooks),
'select View Code from the menu, and paste the code


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Gary''s Student]

Range("A1").Value = Environ("computername")

 

[Office_Novice]

Try this
Option Explicit

Private Sub WorkBook_Open()
On Error Resume Next

Dim objshell, objExcel, objSheet
Dim RegActiveComputerName, RegComputerName, RegHostName, RegLogonUserName
Dim RegExchangeDomain, RegGPServer, RegLogonServer, RegDNSDomain
Dim ActiveComputerName, ComputerName, HostName, LogonUserName
Dim ExchangeDomain, GPServer, LogonServer, DNSDomain
Dim strComputer, objWMIService, IPConfigSet, IPConfig, i

Application.ScreenUpdating = False

RegActiveComputerName =
"HKLM\System\CurrentControlSet\Control\ComputerName\ActiveComputerName\ComputerName"
RegComputerName =
"HKLM\System\CurrentControlSet\Control\ComputerName\ComputerName\ComputerName"
RegHostName =
"HKLM\System\CurrentControlSet\Services\Tcpip\Parameters\Hostname"
RegLogonUserName =
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Logon
User Name"
RegExchangeDomain =
"HKEY_CURRENT_USER\Software\Microsoft\Exchange\LogonDomain"
RegGPServer =
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Group
Policy\History\DCName"
RegLogonServer = "HKEY_CURRENT_USER\Volatile Environment\LOGONSERVER"
RegDNSDomain = "HKEY_CURRENT_USER\Volatile Environment\USERDNSDOMAIN"
Set objshell = CreateObject("WScript.Shell")
Set objExcel = CreateObject("Excel.Application")
ActiveComputerName = objshell.regread(RegActiveComputerName)
ComputerName = objshell.regread(RegComputerName)
HostName = objshell.regread(RegHostName)
LogonUserName = objshell.regread(RegLogonUserName)
ExchangeDomain = objshell.regread(RegExchangeDomain)
GPServer = objshell.regread(RegGPServer)
LogonServer = objshell.regread(RegLogonServer)
DNSDomain = objshell.regread(RegDNSDomain)
objExcel.Visible = True
objExcel.Workbooks.Add
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set IPConfigSet = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

For Each IPConfig In IPConfigSet
If Not IsNull(IPConfig.IPAddress) Then
For i = LBound(IPConfig.IPAddress) To UBound(IPConfig.IPAddress)
objSheet.Cells(2, 8).Value = IPConfig.IPAddress(i) ' WScript.Echo
IPConfig.IPAddress(i)
Next
End If
Next
With objSheet
.Name = "Computer Info"
.Cells(1, 1).Value = "Active Computer Name"
.Cells(1, 2).Value = "Computer Name"
.Cells(1, 3).Value = "Host Name"
.Cells(1, 4).Value = "User Name"
.Cells(1, 5).Value = "Exchange Domain"
.Cells(1, 6).Value = "Group Policy Server"
.Cells(1, 7).Value = "DNS Server"
.Cells(1, 8).Value = "IP Address"
.Cells(2, 1).Value = ActiveComputerName
.Cells(2, 2).Value = ComputerName
.Cells(2, 3).Value = HostName
.Cells(2, 4).Value = LogonUserName
.Cells(2, 5).Value = ExchangeDomain
.Cells(2, 6).Value = GPServer
.Cells(2, 7).Value = DNSDomain
End With
objSheet.Range("A1:H1").Font.Bold = True
objSheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[K]

Try this
Option Explicit

Private Sub WorkBook_Open()
On Error Resume Next

Dim objshell, objExcel, objSheet
Dim RegActiveComputerName, RegComputerName, RegHostName, RegLogonUserName
Dim RegExchangeDomain, RegGPServer, RegLogonServer, RegDNSDomain
Dim ActiveComputerName, ComputerName, HostName, LogonUserName
Dim ExchangeDomain, GPServer, LogonServer, DNSDomain
Dim strComputer, objWMIService, IPConfigSet, IPConfig, i

Application.ScreenUpdating = False

RegActiveComputerName =
"HKLM\System\CurrentControlSet\Control\ComputerName\ActiveComputerName\Comp­uterName"
RegComputerName =
"HKLM\System\CurrentControlSet\Control\ComputerName\ComputerName\ComputerNa­me"
RegHostName =
"HKLM\System\CurrentControlSet\Services\Tcpip\Parameters\Hostname"
RegLogonUserName =
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Logon
User Name"
RegExchangeDomain =
"HKEY_CURRENT_USER\Software\Microsoft\Exchange\LogonDomain"
RegGPServer =
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Group
Policy\History\DCName"
RegLogonServer = "HKEY_CURRENT_USER\Volatile Environment\LOGONSERVER"
RegDNSDomain = "HKEY_CURRENT_USER\Volatile Environment\USERDNSDOMAIN"
Set objshell = CreateObject("WScript.Shell")
Set objExcel = CreateObject("Excel.Application")
ActiveComputerName = objshell.regread(RegActiveComputerName)
ComputerName = objshell.regread(RegComputerName)
HostName = objshell.regread(RegHostName)
LogonUserName = objshell.regread(RegLogonUserName)
ExchangeDomain = objshell.regread(RegExchangeDomain)
GPServer = objshell.regread(RegGPServer)
LogonServer = objshell.regread(RegLogonServer)
DNSDomain = objshell.regread(RegDNSDomain)
objExcel.Visible = True
objExcel.Workbooks.Add
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set IPConfigSet = objWMIService.ExecQuery _
    ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

For Each IPConfig In IPConfigSet
    If Not IsNull(IPConfig.IPAddress) Then
        For i = LBound(IPConfig.IPAddress) To UBound(IPConfig.IPAddress)
           objSheet.Cells(2, 8).Value = IPConfig.IPAddress(i) ' WScript.Echo
IPConfig.IPAddress(i)
        Next
    End If
Next
  With objSheet
    .Name = "Computer Info"
    .Cells(1, 1).Value = "Active Computer Name"
    .Cells(1, 2).Value = "Computer Name"
    .Cells(1, 3).Value = "Host Name"
    .Cells(1, 4).Value = "User Name"
    .Cells(1, 5).Value = "Exchange Domain"
    .Cells(1, 6).Value = "Group Policy Server"
    .Cells(1, 7).Value = "DNS Server"
    .Cells(1, 8).Value = "IP Address"
    .Cells(2, 1).Value = ActiveComputerName
    .Cells(2, 2).Value = ComputerName
    .Cells(2, 3).Value = HostName
    .Cells(2, 4).Value = LogonUserName
    .Cells(2, 5).Value = ExchangeDomain
    .Cells(2, 6).Value = GPServer
    .Cells(2, 7).Value = DNSDomain
  End With
  objSheet.Range("A1:H1").Font.Bold = True
  objSheet.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub





- Show quoted text -

wow guys that very brilliant. Thanks lot everyone