I have been tasked with rolling out several hundred new computers.
The computers will all be imaged and will not be joined to the domain until they are physically on the clients desk. The trick is, I need to take some data from their local profile on their current machine, and migrate it to the new workstation.
So, I created a script to pull their data, and store it to a server until the new computer is added to the domain, and the user logs on with their Domain Account.
I read the solution here: http://www.experts-exchang
I tried a solution where the registry keys that go along with the user's SID are created, but when the user logs on, Windows just overwrites the values with new information, and creates a profile folder called USERID123.DOMAINNAME. So, I tried modifying the folder path to create a profile folder called USERID123.DOMAINNAME, and again, it overwrote the registry keys and created a profile folder called USERID123... Yes, I wanted to slap myself multiple times about the face and neck, but I thought I might get canned for that. So I'm here asking for your help. I have no cookies though, sorry.
This is a working function I scraped together to try the above note.
Function createUserProfile(userSID,
Const HKLM = &H80000002
'userSID = "S-1-5-21-12345678-1234567
'userID = "USERID123"
strKey = "Software\Microsoft\Window
strComputer = "."
Set oReg=GetObject("winmgmts:{
strUserKeyPath = strKey & "\" & userSID
oReg.CreateKey HKLM, strUserKeyPath
strUserPathKeyName = "ProfileImagePath"
strUserPathValue = "%SystemDrive%\Documents and Settings\" & userID
oReg.SetExpandedStringValu
strUserFlagKeyName = "Flags"
strUserFlagValue = 1
oReg.SetDWORDValue HKLM,strUserKeyPath,strUse
Set oReg = Nothing
Set objFSO = CreateObject("Scripting.Fi
userFolderPath = "C:\Documents and Settings\" & userID
objFSO.CreateFolder userFolderPath
objFSO.CreateFolder userFolderpath & "\Cookies"
objFSO.CreateFolder userFolderpath & "\Desktop"
objFSO.CreateFolder userFolderpath & "\Favorites"
objFSO.CreateFolder userFolderpath & "\My Documents"
objFSO.CreateFolder userFolderpath & "\Start Menu"
Set objFSO = Nothing
createUserProfile = "Successfully created profile for " & userID
End Function
What I'm really getting at is, I want to create the a local profile for a domain user before they ever log on, and without having to use their ID/Password credentials.
Anyone? Anyone? BUELLER?
If you read all that, thank you!
This Question has been solved and asker verified All Experts Exchange premium technology solutions are available to subscription members.
Experts Exchange has been collecting answers to technology questions since 1996…3 million and counting! If you have a question, chances are we already have your answer.
If you can't find the exact answer you're looking for, ask our exclusive community of 50,000 experts. You’ll get a personalized answer from a trusted professional.
Thousands of free tech tips, tricks, how-to’s and tutorials are available in our peer reviewed articles section. See for yourself how smart our experts are, no login required.
Save solutions to your questions, answers you’ve discovered through searching plus helpful articles in your personal knowledgebase for easy future access.
Access the answers to your technology questions today.
30-day free trial. Register in 60 seconds.
Members of the expert community talk about why the experience at Experts Exchange is different than what you will find anywhere else.
Try it out and discover for yourself.
30-day free trial. Register in 60 seconds.
Join the community of experts here and help other tech pros by answering question in your area of expertise. You can earn FREE access to all Experts Exchange's premium features and resources.
You might try to convert the user to a Roaming Profile first. Roaming profile is stored on a server share.
When they logon to the new machine it will get their profile from the Server. After the user has logged on/off and everything seems OK, then you can remove the Profile Path (In AD Users -> Properties -> Profile tab) - empty the box.
After the user logs on/off some more, then the profile should be running completely from the local hard drive.
Thinking about it (but not being able to test it today)....if you use the following code to obtain the SID for an AD account, you might be able to export the correct ProfileList key when you back up the profile, then just import the reg after you join the computer to the domain. Then you might be able to copy the user profile folder straight over.....
I will try to test that soon.....
Regards,
Rob.
Hey guys, thanks for the responses!
@chakko, that's an interesting idea. I'll look into it today, and see if that will be an option. I'm not sure how much control I have over AD objects yet.
@Rob, thank you for your reply. I had not considered exporting the ProfileList keys yet. I'll explore this more once I get into the office.
One thing I did notice though, is that HKEY_USERS is also populated with a SID_KEY and a SID_KEY_Classes when a "profile" is created. I am also going to look into creating this hive of keys also. I suspect that once a "shell" is created in the registry, Windows will be able to add/update any subkeys it needs, but it's just going to be finding out which keys it must see as present before it will do that.
Anyhow, totally appreciate the responses. I'm all giddy with excitement now... That may not have been the right word. :)
Just so no one spends any more time trying to solve this, I have a working solution, and I will post it this evening.
@chakko, that was a great idea, it would have worked if I had sufficient rights to a User object in Active Directory, but I have almost no rights to modify.
@Rob, your script in conjunction with my script and some (ok quite a bit more) extra script, I was able to get a pretty decent solution together. I'm hopeful that someone may be able to streamline it.
Thanks!
Hey guys,
Well I finally had a chance to test this, and it turns out that the method of backing up the
HKLM\Software\Microsoft\Wi
key, importing that to a new computer, and *then* copying C:\Documents and Settings\<username> to the new computer does work! You can then log onto the new computer without it creating a new <username>.<domain> profile path.
So I'm writing an export script, and an import script that will automate this task for the most part, which I will post here in the next few days.
Regards,
Rob.
So, I am so, so, sorry about not replying earlier. I had a change of job in mid project.
The short answer to creating a profile for a user before they log on is 1) create a reg key with the user's SID, 2) create a sub key with the path to %systemroot%\Documents and Settings\[Users ID] for their profile path, then 3) copy the Default User profile from C:\Documents and Settings\Default User to C:\Documents and Settings\[UserID]. Now, if you migrate their profile folders (we only did Desktop, Favorites, My Documents, and My Recent Documents) to a repository, you can import it back to the new location created above.
I'm not sure how much space I have here, but I created an HTA file that does the listed process. Copy and paste this code into a new text file, save it as Backup.HTA, and run.
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtm
<html xmlns="http://www.w3.org/1
<head>
<title>User Migration</title>
<hta:application id="BackupAccounts" applicationname="Command Line Agruments" singleinstance="yes">
<style type="text/css">
.funcHeader {
text-decoration: none;
}
.funcHeader:hover {
text-decoration: underline;
color: black;
cursor: hand;
}
.actionSelect {
position: absolute;
top: 0px;
left: 0px;
border-style: solid;
border-width: 1px;
border-color: black;
}
.tabHeaderSelectedCell {
font-weight: bold;
border-left-color: black;
color: black;
border-top-style: solid;
border-top-color: black;
border-right-style: solid;
border-left-style: solid;
background-color: #778899;
border-right-color: black;
width: 33%;
}
.tabHeaderSelected {
font-weight: bold;
vertical-align: middle;
text-align: center;
background-color: #778899;
}
.tabHeaderNotSelectedCell {
border-right: black thin solid;
border-top: black thin solid;
border-left: black thin solid;
color: black;
background-color: #998877;
border-bottom-color: black;
border-bottom-style: solid;
width: 31%;
}
.tabHeaderNotSelected {
font-weight: normal;
vertical-align: middle;
text-align: center;
background-color: #998877;
}
.tabHeaderSelected:hover {
}
.tabHeaderNotSelected:hove
background-color: #998877;
cursor: hand;
color:#FFFFFF;
}
.tabNotVisible {
display:none;
}
.tabVisible {
display:block;
}
a {
color:#FFFFFF;
text-decoration: none;
}
a:hover {
text-decoration: underline;
color: white;
}
body {
margin:0px;
background-color:#580000; /*#F6F6F6; #CBCBCB;*/
font-family:Arial, Helvetica, sans-serif;
font-size:12px;
color:#FFFFFF;
}
</style>
<SCRIPT Language="VBScript">
'http://www.w3.org/TR/CSS2
'onclick="Msgbox(rbScope(0
Dim currComputer
Dim currUser
Dim vcUser
Dim lastPCPath
lastPCPath = " "
currComputer = getLocalComputerName(".")
tmpRLE = readLastEntry(4)
lastPCPath = tmpRLE(0)
'===============
'===============
Sub Window_onLoad
arrCommands = Split(BackupAccounts.comma
cmds = Ubound(arrCommands)
If cmds > 2 Then
For i = 3 to (Ubound(arrCommands) - 1) Step 2
Select Case Split(arrCommands(i), ":")(0)
Case "Computer"
currComputerName.InnerHTML
Case "User"
currUserName.InnerHTML = Split(arrCommands(i), ":")(1)
End Select
'Msgbox arrCommands(i)
'testSpan.InnerHTML = testSpan.InnerHTML & "
" & arrCommands(i)
'document.getElementById("
Next
Else
currComputer = getLocalComputerName(".")
VCName.InnerHTML = currComputer
VCLink.InnerHTML = currComputer
Dim r
If testPing(currComputer) = True Then
r = Split(pingPC(currComputer)
SetStatus(r(1))
SetIP(r(2))
SetDomain(r(3))
document.GetElementByID("V
VCAccounts.InnerHTML = getUsersList
innerVal = Split(lastPCPath, "|")(0)
If UBOUND(tmpRLE) = 0 Then
If Not innerVal = currComputer Then
oldPCPath.InnerHTML = innerVal
oldPCPath.className = "funcHeader"
Call oldPCPath.attachEvent("onc
End If
Else
oldPCList = "<Select name=""optLastPC"" id=""optLastPC"" SIZE=""4"" onchange=""readLog"">"
For i = 0 to UBOUND(tmpRLE)
oldPCList = oldPCList & "<Option value=""" & Split(tmpRLE(i), "|")(0) & """>" & Split(tmpRLE(i), "|")(0)
Next
oldPCList = oldPCList & "</Select>"
oldPCPath.InnerHTML = oldPCList
End If
End If
End If
End Sub
'===============
'===============
Function readLog
Select Case window.event.srcElement.id
Case "oldPCPath"
val = oldPCPath.InnerHTML
Case "optLastPC"
val = window.event.srcElement.va
End Select
Dim returnValues()
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
logFileName = "log.txt"
Dim arrDel()
Dim cleanList()
Dim newContents
Set fso = CreateObject("Scripting.Fi
If fso.FileExists(logFileName
Set rFile = fso.OpenTextFile(logFileNa
If rFile.AtEndOfStream Then
Else
contents = rFile.ReadAll
rFile.Close
For each c in Split(contents, VbCrLf)
If Len(Trim(c)) > 0 Then
newContents = newContents & c & VbCrLf
End If
Next
arrContents = Split(newContents, vbcrlf)
findVal = Split(Filter(arrContents, val)(0), "|")
user = findVal(1)
userSID = findVal(2)
exportedTo = findVal(3)
Set tmp = Document.getElementById(wi
If tmp.children.length = 1 Then
Set n = Document.createElement("DI
n.InnerHTML = "User Exported: " & user
n.InnerHTML = n.InnerHTML & "
User SID: " & userSID
n.InnerHTML = n.InnerHTML & "
User Export Location: " & exportedTo
tmp.appendChild(n)
Else
tmp.removeChild(tmp.lastCh
Set n = Document.createElement("DI
n.InnerHTML = "User Exported: " & user
n.InnerHTML = n.InnerHTML & "
User SID: " & userSID
n.InnerHTML = n.InnerHTML & "
User Export Location: " & exportedTo
tmp.appendChild(n)
End If
End If
Else
End If
End Function
'===============
'===============
Sub showOptions(val)
Select Case val
Case 0
document.getElementById("t
document.getElementById("t
document.getElementById("t
document.getElementById("t
Case 1
document.getElementById("t
document.getElementById("t
document.getElementById("t
document.getElementById("t
Case 2
document.getElementById("t
document.getElementById("t
document.getElementById("t
document.getElementById("t
Case 3
document.getElementById("t
document.getElementById("t
document.getElementById("t
document.getElementById("t
Dim oldPCs
Set oldPCs = document.getElementById("o
If oldPCs.children(0).length > 1 Then
spanImportPCs.InnerHTML = "\\CSPTempServer\C$\" & oldPCs.children(0)(1).valu
End If
Set oldPCs = Nothing
End Select
End Sub
'===============
'===============
Sub hideOptions(val)
Select Case val
Case 0
document.getElementById("t
Case 1
document.getElementById("t
Case 2
document.getElementById("t
Case 3
document.getElementById("t
End Select
End Sub
'===============
'===============
Function readLastEntry(last)
Dim returnValues()
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
logFileName = "log.txt"
Dim arrDel()
Dim cleanList()
Dim i
Dim newContents
Set fso = CreateObject("Scripting.Fi
If fso.FileExists(logFileName
Set rFile = fso.OpenTextFile(logFileNa
If rFile.AtEndOfStream Then
ReDim returnValues(0)
returnValues(0) = "None"
Else
contents = rFile.ReadAll
rFile.Close
For each c in Split(contents, VbCrLf)
If Len(Trim(c)) > 0 Then
newContents = newContents & c & VbCrLf
End If
Next
arrContents = Split(newContents, vbcrlf)
If last > UBOUND(arrContents) Then
ReDim returnValues(UBOUND(arrCon
Else
ReDim returnValues(last - 1)
End If
'There's one blank line in arrContents... the last one, so remove it from the For loop.
Dim count
count = Ubound(arrContents) - 1
ReDim cleanList(count)
For i = 0 to count
cleanList(i) = arrContents(i)
Next
For rev = UBOUND(returnValues) to LBOUND(returnValues) Step -1
returnValues(rev) = cleanList(UBOUND(cleanList
Next
End If
Else
'logfile doesn't exist, so create it, and add current computer to list.
Set rFile = fso.CreateTextFile(logFile
Set rFile = Nothing
ReDim returnValues(0)
returnValues(0) = "None"
End If
readLastEntry = returnValues
Set objTextFile = Nothing
Set nFile = Nothing
Set fso = Nothing
Set rFile = Nothing
End Function
'===============
'===============
Function getRowInfo(searchInfo)
Dim retVals()
Const ForReading = 1
logFileName = "log.txt"
Set fso = CreateObject("Scripting.Fi
If fso.FileExists(logFileName
Set rFile = fso.OpenTextFile(logFileNa
If rFile.AtEndOfStream Then
ReDim retVals(0)
retVals(0) = "None"
Else
contents = rFile.ReadAll
rFile.Close
arrContents = Split(contents, vbcrlf)
If UBOUND(Filter(arrContents,
tmpVals = Split(Filter(arrContents, searchInfo)(0), "|")
ReDim retVals(UBOUND(tmpVals) - 1)
retVals(0) = tmpVals(1)
retVals(1) = tmpVals(2)
retVals(2) = tmpVals(3)
Else
ReDim retVals(0)
retVals(0) = "None"
End If
End If
End If
getRowInfo = retVals
Set fso = Nothing
Set rFile = Nothing
End Function
'===============
'===============
Function logImagedComputers(thisPC)
Dim returnValues()
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
logFileName = "log.txt"
Dim arrDel()
Dim cleanList()
Dim i
Dim newContents
Set fso = CreateObject("Scripting.Fi
If fso.FileExists(logFileName
Set rFile = fso.OpenTextFile(logFileNa
If rFile.AtEndOfStream Then
newContents = newContents & thisPC
Else
contents = rFile.ReadAll
rFile.Close
For each c in Split(contents, VbCrLf)
If Len(Trim(c)) > 0 Then
newContents = newContents & c & VbCrLf
End If
Next
newContents = newContents & thisPC
End If
Else
'logfile doesn't exist, so create it, and add current computer to list.
Set rFile = fso.CreateTextFile(logFile
Set rFile = Nothing
newContents = thisPC
End If
Set objTextFile = fso.OpenTextFile(logFileNa
objTextFile.WriteLine(newC
objTextFile.Close
Set objTextFile = Nothing
Set nFile = Nothing
Set fso = Nothing
Set rFile = Nothing
End Function
'===============
'===============
Function vcAction(sender)
Select Case sender.value
Case "Remove"
document.getElementById("a
document.getElementById("r
'msgbox(sender.value)
Case "Add"
document.getElementById("a
document.getElementById("r
'msgbox(sender.value)
Case "Rename"
document.getElementById("a
document.getElementById("r
End Select
End Function
'===============
'===============
Function checkKey(sender)
keyval=window.event.keyCod
Select Case sender.id
Case "tdAdd"
If keyval = 13 or keyval = 27 Then
Dim scope
If sender.children("rbScope")
scope = sender.children("rbScope")
Else
scope = sender.children("rbScope")
End If
Msgbox(scope & "\" & sender.children("txtAddUse
hideOptions(0)
End If
Case "tdRemove"
If keyval = 13 or keyval = 27 Then
Msgbox("This function has not been implemented yet.")
hideOptions(1)
'Msgbox(sender.children("t
End If
Case "tdExport"
If keyval = 13 or keyval = 27 Then
Dim t
Set t = document.Forms("BackupAcco
If t.UList.selectedindex > -1 Then
Dim selUser
selUser = t.UList(t.UList.selectedin
If Ubound(Split(Trim(selUser)
selUser = Split(Trim(selUser), ".")(0)
End If
If Len(currUser) > 0 And Len(Trim(selUser)) > 0 Then
If pathExists(sender.children
checkPath = fullPath(sender.children("
Dim r
pc = currComputer
userID = currUser
userSID = vcUserSid.InnerHTML
profilePath = checkPath & "\" & currComputer & "\" & currUser
importRow = pc & "|" & userID & "|" & userSID & "|" & profilePath
r = writeUserInfo(currUser, checkPath)
r = r & vbcrlf & logImagedComputers(importR
Msgbox(r)
'r = r & vbcrlf & logImagedComputers(currCom
'MSGBOX(r)
'Msgbox("Export " & curruser & " profile to " & sender.children("txtExport
Else
Msgbox("Cannot Export " & curruser & " profile to " & sender.children("txtExport
End If
End If
Else
Msgbox("No user to export")
End If
hideOptions(2)
End If
Case "tdImport"
If keyval = 13 or keyval = 27 Then
checkPath = fullPath(sender.children("
checkLog = getRowInfo(checkPath)
Stop
If checkLog(0) = "None" Then
Msgbox("No account to import from path selected")
Else
AddResult = AddUser(checkLog(0), checkLog(1), currComputer)
'conResult = setContext(CurrentUserCont
MSGBOX(AddResult)
'MSGBOX(setContext)
'If Len(currUser) > 0 Then
' Msgbox("Import " & currUser & " profile from " & sender.children("txtImport
'End If
End If
hideOptions(3)
End If
Case "strAdminID"
If keyval = 13 or keyval = 27 Then
document.getElementById("s
End If
Case "strAdminPW"
If keyval = 13 or keyval = 27 Then
result = ""
For each rb in Document.Forms("BackupAcco
If rb.checked=true then
Select Case rb.value
Case "Remove"
result = updateComputer("Remove")
MSGBOX(result)
If Instr(result, "Fail") > 0 Then
Call Reboot
End If
Case "Rename"
result = updateComputer("Rename")
MSGBOX(result)
If Instr(result, "Fail") > 0 Then
Call Reboot
End If
Case "Add"
result = updateComputer("Add")
MSGBOX(result)
Call Reboot
End Select
End If
Next
End If
Case "strNewPCName"
If keyval = 13 or keyval = 27 Then
document.getElementById("a
document.getElementById("s
End If
End Select
End Function
'===============
'===============
Function fullPath(path)
Dim fsoCheck
Set fsoCheck = CreateObject("Scripting.Fi
Set f = fsoCheck.GetFolder(path)
If f.Drive.DriveType = 3 Then
fullPath = Replace(f.Path, f.Drive.Path, f.Drive.ShareName)
Else
fullPath = f.Path
End If
Set f = Nothing
Set fsoCheck = Nothing
End Function
'===============
'===============
Function setContext(context)
Const HKLM = &H80000002
Dim i
i = Split(context, ":")
user = i(0)
context = i(1)
server = i(2)
ntDefault = i(0)
strKey = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue = "UserName"
strKey2 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue2 = "Context"
strKey3 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue3 = "Server"
strKey4 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue4 = "DefaultUserName"
strComputer = currComputer
Set oReg=GetObject("winmgmts:{
oReg.SetStringValue HKLM,strKey,strValue,user
set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.SetStringValue HKLM,strKey2,strValue2,con
Set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.SetStringValue HKLM,strKey3,strValue3,ser
Set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.SetStringValue HKLM,strKey4,strValue4,ntD
Set oReg = Nothing
setContext = "Set Context successfully."
End Function
'===============
'===============
Function getContext
Const HKLM = &H80000002
strKey1 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue1 = "UserName"
Dim strNovID
strKey2 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue2 = "Context"
Dim strNovContext
strKey3 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue3 = "Server"
Dim strNovServer
strKey4 = "SOFTWARE\Novell\Location Profiles\Services\{1E6CEEA
strValue4 = "DefaultUserName"
Dim strNTID
strComputer = currComputer
Set oReg=GetObject("winmgmts:{
oReg.GetStringValue HKLM,strKey1,strValue1,str
strVal1 = UCase(strVal1)
set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.GetStringValue HKLM,strKey2,strValue2,str
Set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.GetStringValue HKLM,strKey3,strValue3,str
If strNovServer = "" Then
strNovServer = "NOSERV"
End If
Set oReg = Nothing
Set oReg=GetObject("winmgmts:{
oReg.GetStringValue HKLM,strKey4,strValue4,str
If strNTID = "" Then
strNTID = "NONTID"
End If
Set oReg = Nothing
getContext = strNovID & ":" & strNovContext & ":" & strNovServer & ":" & strNTID
End Function
'===============
'===============
Function AddUser(userID, userIDSID, strComputer)
If instr(checkWinVer(currComp
AddUser = "Cannot Create Profile"
Exit Function
Else
'This is for when creating a Vista local profile is available.
userPath = "\Documents and Settings"
End If
Const HKLM = &H80000002
strKey = "Software\Microsoft\Window
Set oReg=GetObject("winmgmts:{
strUserKeyPath = strKey & "\" & userIDSID
oReg.CreateKey HKLM, strUserKeyPath
strKeyPath = strKey & "\" & userIDSID
strUserCentPathKeyName = "CentralProfile"
strUserCentPathValue = ""
oReg.SetStringValue HKLM,strKeyPath,strUserCen
strUserPathKeyName = "ProfileImagePath"
strUserPathValue = "%SystemDrive%\Documents and Settings\" & userID
oReg.SetExpandedStringValu
strUserFlagKeyName = "Flags"
strUserFlagValue = 1
oReg.SetDWORDValue HKLM,strKeyPath,strUserFla
Set oReg = Nothing
Set ProfileFolder=CreateObject
defaultUser = "C:\Documents and Settings\Default User"
newUser = "C:\Documents and Settings\" & userID
If ProfileFolder.FolderExists
ProfileFolder.CopyFolder defaultUser, newUser
End If
Set ProfileFolder=Nothing
AddUser = "Successfully created profile for: " & userID
End Function
'===============
'===============
Function pathExists(path)
Dim p
Set p = CreateObject("Scripting.Fi
pathExists = false
If p.FolderExists(path) = true Then
pathExists = true
Exit Function
End If
Set p = Nothing
End Function
'===============
'===============
Function writeUserInfo(user, saveTo)
Dim objFSO, objFolder, objShell, objTextFile, objFile
Dim strDirectory, strFile, strText, strCopyDir
strDirectory = saveTo
strCopyDir = strDirectory & "\" & currComputer
strFile = "\" & currUser & ".txt"
strText = " Data"
If instr(checkWinVer(currComp
FromPath = "\\" & currComputer & "\C$\Users\" & currUser
Else
FromPath = "\\" & currComputer & "\C$\Documents and Settings\" & currUser
End If
ToPath = strCopyDir & "\" & currUser
Dim printers
Dim thisFrm
Dim drives
Dim folders
Dim biosInf
Dim iPopCon
' Create the File System Object
Set objFSO = CreateObject("Scripting.Fi
' Check that the strDirectory folder exists
If objFSO.FolderExists(strCop
Set objFolder = objFSO.CreateFolder(strCop
Set objFolder = Nothing
strCopyDir = strCopyDir & "\" & currUser
If objFSO.FolderExists(strCop
Set objFolder = objFSO.CreateFolder(strCop
End If
Else
strCopyDir = strCopyDir & "\" & currUser
If objFSO.FolderExists(strCop
Set objFolder = objFSO.CreateFolder(strCop
End If
End If
If objFSO.FileExists(strCopyD
Set objFile = objFSO.CreateTextFile(strC
End If
Set objFile = Nothing
Set objFolder = Nothing
Const ForAppending = 8
Set thisFrm = Document.Forms("BackupAcco
biosInf = thisFrm.VCBIOS.value
printers = thisFrm.PrinterInfo.value
drives = thisFrm.driveInfo.value
folders = copyFolders(FromPath, strCopyDir)
iPopCon = GetiPopConfig(fromPath, toPath)
Set objTextFile = objFSO.OpenTextFile(strCop
strText = "USERID:" & currUser & vbcrlf _
& "USERSID:" & vcUserSid.InnerHTML & vbcrlf _
& "USERPRINTERS:" & printers & vbcrlf _
& "USERDRIVES:" & drives & vbcrlf _
& "USERPROFILEFOLDERS:" & folders & vbcrlf _
& "USERIPOPCONFIG:" & iPopCon & vbcrlf _
& currComputer & "CONFIG:" & biosInf & vbcrlf _
& currComputer & "IPADDRESS:" & VCIP.InnerHTML & vbcrlf _
& "DEFAULTNOVELLINFO:" & vcUserNovellData.InnerHTML
objTextFile.WriteLine(strT
objTextFile.Close
Set objTextFile = Nothing
Set thisFrm = Nothing
writeUserInfo = "Successfully stored profile data for " & currUser & " from PC:" & currComputer & "."
End Function
'===============
'===============
Function checkWinVer(strComputer)
Const Impersonate = "winmgmts:{impersonationLe
aryServers = strComputer
Set oWMI = GetObject(Impersonate & aryServers & "\root\cimv2")
Set QueryWMI = oWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem")
For Each oItem In QueryWMI
Select Case oItem.osType
Case 0
osType = "(0x0) Unknown"
Case 1
osType = "(0x1) Other"
Case 2
osType = "(0x2) MACROS"
Case 3
osType = "(0x3) ATTUNIX"
Case 4
osType = "(0x4) DGUX"
Case 5
osType = "(0x5) DECNT"
Case 6
osType = "(0x6) Digital UNIX"
Case 7
osType = "(0x7) OpenVMS"
Case 8
osType = "(0x8) HPUX"
Case 9
osType = "(0x9) AIX"
Case 10
osType = "(0xA) MVS"
Case 11
osType = "(0xB) OS400"
Case 12
osType = "(0xC) OS/2"
Case 13
osType = "(0xD) JavaVM"
Case 14
osType = "(0xE) MSDOS"
Case 15
osType = "(0xF) WIN3x"
Case 16
osType = "(0x10) WIN95"
Case 17
osType = "(0x11) WIN98"
Case 18
osType = "(0x12) WINNT"
Case 19
osType = "(0x13) WINCE"
Case 20
osType = "(0x14) NCR3000"
Case 21
osType = "(0x15) NetWare"
Case 22
osType = "(0x16) OSF"
Case 23
osType = "(0x17) DC/OS"
Case 24
osType = "(0x18) Reliant UNIX"
Case 25
osType = "(0x19) SCO UnixWare"
Case 26
osType = "(0x1A) SCO OpenServer"
Case 27
osType = "(0x1B) Sequent"
Case 28
osType = "(0x1C) IRIX"
Case 29
osType = "(0x1D) Solaris"
Case 30
osType = "(0x1E) SunOS"
Case 31
osType = "(0x1F) U6000"
Case 32
osType = "(0x20) ASERIES"
Case 33
osType = "(0x21) TandemNSK"
Case 34
osType = "(0x22) TandemNT"
Case 35
osType = "(0x23) BS2000"
Case 36
osType = "(0x24) LINUX"
Case 37
osType = "(0x25) Lynx"
Case 38
osType = "(0x26) XENIX"
Case 39
osType = "(0x27) VM/ESA"
Case 40
osType = "(0x28) Interactive UNIX"
Case 41
osType = "(0x29) BSDUNIX"
Case 42
osType = "(0x2A) FreeBSD"
Case 43
osType = "(0x2B) NetBSD"
Case 44
osType = "(0x2C) GNU Hurd"
Case 45
osType = "(0x2D) OS9"
Case 46
osType = "(0x2E) MACH Kernel"
Case 47
osType = "(0x2F) Inferno"
Case 48
osType = "(0x30) QNX"
Case 49
osType = "(0x31) EPOC"
Case 50
osType = "(0x32) IxWorks"
Case 51
osType = "(0x33) VxWorks"
Case 52
osType = "(0x34) MiNT"
Case 53
osType = "(0x35) BeOS"
Case 54
osType = "(0x36) HP MPE"
Case 55
osType = "(0x37) NextStep"
Case 56
osType = "(0x38) PalmPilot"
Case 57
osType = "(0x39) Rhapsody"
End Select
Select Case oItem.ProductType
Case 1
pType = "Workstation"
Case 2
pType = "Domain Controller"
Case 3
pType = "Server"
End Select
If oItem.osType > 14 And oItem.osType < 20 Then
checkWinVer = oItem.Caption & " " & oItem.CSDVersion & "" & osType & " " & pType
Else
checkWinVer = osType
End If
Next
Set oWMI = Nothing
Set QueryWMI = Nothing
End Function
'===============
'===============
Function copyFolders(fromPath, toPath)
Dim FSO
Dim progress
Dim Desktop, Favorites, MyDocs, MyRecent
If instr(checkWinVer(currComp
Desktop = FromPath & "\Desktop"
Favorites = FromPath & "\Favorites"
MyDocs = FromPath & "\Documents"
'MyRecent = FromPath & "\My Recent Documents"
'Would be C:\Users\[UserID]\AppData\
Else
Desktop = FromPath & "\Desktop"
Favorites = FromPath & "\Favorites"
MyDocs = FromPath & "\My Documents"
MyRecent = FromPath & "\My Recent Documents"
End If
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("Scripting.Fi
If FSO.FolderExists(FromPath)
copyFolders = FromPath & " doesn't exist."
Else
On Error Resume Next
'Desktop
If FSO.FolderExists(ToPath & "\Desktop") = False Then
FSO.CreateFolder(ToPath & "\Desktop")
End If
FSO.CopyFolder Desktop & "\*", ToPath & "\Desktop", True
FSO.CopyFile Desktop & "\*.*", ToPath & "\Desktop", True
progress = "Desktop copied successfully." & vbcrlf
'Favorites
If FSO.FolderExists(ToPath & "\Favorites") = False Then
FSO.CreateFolder(ToPath & "\Favorites")
End If
FSO.CopyFolder Favorites & "\*", ToPath & "\Favorites", True
FSO.CopyFile Favorites & "\*.*", ToPath & "\Favorites", True
progress = progress & "Favorites copied successfully." & vbcrlf
'My Documents
If FSO.FolderExists(ToPath & "\My Documents") = False Then
FSO.CreateFolder(ToPath & "\My Documents")
'progress = progress & "Created My Documents folder on new PC." & vbcrlf
End If
If FSO.FolderExists(MyDocs) = True Then
progress = progress & MyDocs & " path exists." & vbcrlf
End If
FSO.CopyFolder MyDocs & "\*", ToPath & "\My Documents", True
FSO.CopyFile MyDocs & "\*.*", ToPath & "\My Documents", True
progress = progress & "My Documents copied successfully." & vbcrlf
'My Recent Documents
If FSO.FolderExists(ToPath & "\My Recent Documents") = False Then
FSO.CreateFolder(ToPath & "\My Recent Documents")
progress = progress & "Created My Recent Documents folder on new PC." & vbcrlf
End If
If FSO.FolderExists(MyRecent)
progress = progress & MyRecent & " path exists." & vbcrlf
End If
FSO.CopyFolder MyRecent & "\*", ToPath & "\My Recent Documents", True
FSO.CopyFile MyRecent & "\*.*", ToPath & "\My Recent Documents", True
progress = progress & MyRecent & " copied successfully." & vbcrlf
copyFolders = progress
End If
Set FSO = Nothing
'Exit Sub
End Function
'===============
'===============
Function explorePath(sender)
If pathExists(sender.InnerHTM
Set ObjShell = CreateObject("WScript.Shel
strPath = sender.InnerHTML
objShell.Run "explorer.exe /e, " & strPath
Else
Msgbox("Path does not exist: " & strPath)
End If
End Function
'===============
'===============
Sub VCNameChange
Dim vcNameField
Dim vcInputNameField
Set vcNameField = Document.GetElementByID("V
Set vcInputNameField = Document.GetElementByID("s
vcNameField.style.visibili
Set vcNameField = Nothing
With vcInputNameField
.value = VCName.InnerHTML
.style.visibility = "visible"
End With
Set vcInputNameField = Nothing
End Sub
'===============
'===============
Sub selectText
End Sub
'===============
'===============
Sub italics
Dim vcNameField
Set vcNameField = Document.GetElementByID("V
With vcNameField
.style.fontStyle = "italic"
.style.fontWeight = "bold"
.style.backgroundColor = "#778899"
End With
Set vcNameField = Nothing
End Sub
'===============
'===============
Sub normal
Dim vcNameField
Set vcNameField = Document.GetElementByID("V
With vcNameField
.style.fontStyle = "normal"
.style.fontWeight = "normal"
.style.backgroundColor = ""
End With
Set vcNameField = Nothing
End Sub
'===============
'===============
Sub link
Dim vcLinkField
Set vcLinkField = Document.GetElementByID("V
With vcLinkField
.style.textDecoration = "underline"
.style.cursor = "hand"
End With
Set vcLinkField = Nothing
End Sub
'===============
'===============
Sub linkNormal
Dim vcLinkField
Set vcLinkField = Document.GetElementByID("V
With vcLinkField
.style.textDecoration = "none"
.style.cursor = "default"
End With
Set vcLinkField = Nothing
End Sub
'===============
'===============
Sub testNewVal
Dim viewedComputerField
Set viewedComputerField = Document.GetElementByID("V
Dim inputTargetPC
Set inputTargetPC = document.getElementByID("s
'Msgbox(pingPC(inputTarget
If Not inputTargetPC.value = viewedComputerField.InnerH
r = Split(pingPC(inputTargetPC
If Split(r(1), ":")(1) = 0 Then
Msgbox((Split(r(0), ":")(1)) & " is offline.")
inputTargetPC.style.visibi
viewedComputerField.style.
Else
currComputer = Split(r(0), ":")(1)
VCLink.InnerHTML = currComputer
SetStatus(r(1))
SetIP(r(2))
SetDomain(r(3))
inputTargetPC.style.visibi
viewedComputerField.style.
viewedComputerField.InnerH
End If
Else
inputTargetPC.style.visibi
viewedComputerField.style.
End If
Set inputTargetPC = Nothing
Set viewedCOmputerField = Nothing
End Sub
'===============
'===============
Sub setDomain(strInfo)
VCDomainLbl.InnerHTML = Split(strInfo, ":")(0)
VCDomainName.InnerHTML = Split(strInfo, ":")(1)
End Sub
'===============
'===============
Sub setIP(strInfo)
VCIP.InnerHTML = Split(strInfo, ":")(1)
End Sub
'===============
'===============
Sub setStatus(strInfo)
If Split(strInfo, ":")(1) = 0 Then
VCStatus.InnerHTML = "Offline"
Else
VCStatus.InnerHTML = "Online"
End If
End Sub
'===============
'===============
Sub btnShow_OnClick
Dim oShell
runText = """BackupAccounts.HTA""" & """Computer:" & currComputer & "" & """User:" & currUser & ""
Set oShell = CreateObject("WScript.Shel
oShell.Run runText
Set oShell = Nothing
Self.Close
End Sub
'===============
'===============
Sub tabClicked(val)
Dim tabBIOS, tabAccounts, tabOther
Dim tabBIOSHeader, tabAccountsHeader, tabOtherHeader
Set tabBIOS = document.getElementById("B
Set tabBIOSHeader = document.getElementById("B
Set tabAccounts = document.getElementById("A
Set tabAccountsHeader = document.getElementById("A
Set tabOther = document.getElementById("O
Set tabOtherHeader = document.getElementById("O
Select Case val
Case 0
'Msgbox("BIOS Tab clicked")
tabBIOS.className = "tabVisible"
tabBIOSHeader.classname = "tabHeaderSelected"
tabBIOSHeader.parentElemen
tabAccounts.className = "tabNotVisible"
tabAccountsHeader.classNam
tabAccountsHeader.parentEl
tabOther.className = "tabNotVisible"
tabOtherHeader.className = "tabHeaderNotSelected"
tabOtherHeader.parentEleme
Case 1
tabBIOS.className = "tabNotVisible"
tabBIOSHeader.classname = "tabHeaderNotSelected"
tabBIOSHeader.parentElemen
tabAccounts.className = "tabVisible"
tabAccountsHeader.classNam
tabAccountsHeader.parentEl
tabOther.className = "tabNotVisible"
tabOtherHeader.className = "tabHeaderNotSelected"
tabOtherHeader.parentEleme
Case 2
tabBIOS.className = "tabNotVisible"
tabBIOSHeader.classname = "tabHeaderNotSelected"
tabBIOSHeader.parentElemen
tabAccounts.className = "tabNotVisible"
tabAccountsHeader.classNam
tabAccountsHeader.parentEl
tabOther.className = "tabVisible"
tabOtherHeader.className = "tabHeaderSelected"
tabOtherHeader.parentEleme
End Select
Set tabBIOS = Nothing
Set tabBIOSHeader = Nothing
Set tabAccounts = Nothing
Set tabAccountsHeader = Nothing
Set tabOther = Nothing
Set tabOtherHeader = Nothing
End Sub
'===============
'===============
Function getLocalComputerName(strCo
If strComputer <> "" Then
If strComputer = "." Then
local = 1
Else
local = 0
End If
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{imper
If Err.Number = 0 Then
Set colItems = objWMIService.ExecQuery("S
For Each objItem in colItems
getLocalComputerName = objItem.Name
Next
Set colItems = Nothing
Else
getLocalComputerName = "# " & Err.Description
End If
Set objWMIService = Nothing
Err.Clear
End If
End Function
'===============
'===============
Function domainOrWorkgroup(strCompu
If strComputer = "." Then
Set objWMISvc = GetObject("winmgmts:\\.\ro
Else
Set objWMISvc = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
End If
Set colItems = objWMISvc.ExecQuery("Selec
For Each objItem in colItems
strComputerDomain = objItem.Domain
If objItem.PartOfDomain Then
domainOrWorkgroup = "1:" & strComputerDomain
'Msgbox "Computer Domain:" & strComputerDomain
Else
domainOrWorkgroup = "0:" & strComputerDomain
'Msgbox "Workgroup:" & strComputerDomain
End If
Next
Set objWMISvc = Nothing
Set colItems = Nothing
End Function
'===============
'===============
Function launch
Dim runText
Set oShell = CreateObject("WScript.Shel
runText = "mstsc.exe /v " & Trim(VCLink.InnerHTML)
oShell.Run runText
Set oShell = Nothing
End Function
'===============
'===============
Function pingPC(strComputer)
'Returns String Computer:XXXXX;Status:int;
'0 Computer:[Value];
'1 Status:[Value - 0 offline, 1 online];
'2 IP:[value];
'3 DomainRole:[value - Domain or Workgroup]
Dim objPing
Dim r
r = ""
Set objPing = GetObject("winmgmts:\\" & strComputer & "\root\cimv2").ExecQuery("
For Each objStatus in objPing
If IsNull(objStatus.StatusCod
r = "Computer:" & strComputer & ";Status:0;IP:" & objStatus.ProtocolAddress & ";0:0"
Else
r = "Computer:" & strComputer & ";Status:1;IP:" & objStatus.ProtocolAddress
Set colComputer = GetObject("winmgmts:\\" & strComputer & "\root\cimv2").ExecQuery("
For Each oComputer in colComputer
iDR = oComputer.DomainRole
sName = oComputer.Domain
Next
If iDR = 0 Or iDR = 2 Then
r = r & ";Workgroup:" & sName
Else
r = r & ";Domain:" & sName
End If
End If
Next
Set objPing = Nothing
Set colComputer = Nothing
pingPC = r
End Function
'===============
'===============
Function testPing(strComputer)
If (IsConnectible(strComputer
testPing = True
Else
testPing = false
End If
End Function
'===============
'===============
Function IsConnectible(ByVal strHost, ByVal intPings, ByVal intTO)
Dim lngResult
Set objShell = CreateObject("Wscript.Shel
If (intPings = "") Then
intPings = 2
End If
If (intTO = "") Then
intTO = 750
End If
'Stop
lngResult = objShell.Run("%comspec% /c ping -4 -n " & intPings & " -w " & intTO & " " & strHost & " | find ""TTL="" > nul 2>&1", 0, True)
Select Case lngResult
Case 0
IsConnectible = True
Case Else
IsConnectible = False
End Select
End Function
'===============
'===============
Function getBIOS(strComputer)
Dim result
result = ""
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colSMBIOS = objWMIService.ExecQuery ("Select * from Win32_SystemEnclosure")
For Each objSMBIOS in colSMBIOS
result = result & "Part Number: " & objSMBIOS.PartNumber & vbcrlf
result = result & "Serial Number: " & objSMBIOS.SerialNumber & vbcrlf
result = result & "Asset Tag: " & objSMBIOS.SMBIOSAssetTag
Next
Set objWMIService = Nothing
getBIOS = result
End Function
'===============
'===============
Function getRemoteDrives(strCompute
Dim response
If strComputer <> "" Then
'Set objDrives = GetObject("winmgmts:{imper
'Set objDrives = GetObject("winmgmts:\\" & strComputer).InstancesOf("
Set objDrives = GetObject("winmgmts:{imper
response = "Connected." & vbcrlf
For Each INST in objDrives
response = response & (INST.deviceid) & vbTAB & (INST.ProviderName) & vbcrlf
Next
End If
Set objDrives = Nothing
getRemoteDrives = response
End Function
'===============
'===============
Sub DivChange (yesnobox, layername)
Dim strObjName
strObjName = "document.MainForm." & yesnobox & ".value"
If eval(strObjName) = "No" Then
document.getElementById(la
Elseif eval(strObjName) = "Yes" then
document.getElementById(la
End If
End Sub
'===============
'===============
Function visible(t)
Dim row
Dim labelAction
Select Case t
Case 0
Set row = document.getElementById("V
rowVal = document.getElementById("V
Set labelAction = document.getElementById("V
if rowVal = "none" then
row.style.display = ""
labelAction.InnerHTML = "(Hide)"
else
row.style.display = "none"
labelAction.InnerHTML = "(Show)"
end if
Case 1
Set row = document.getElementById("u
rowVal = document.getElementById("u
Set labelAction = document.getElementById("u
if rowVal = "visible" then
row.style.visibility = "hidden"
labelAction.InnerHTML = "(Show)"
else
row.style.visibility = "visible"
labelAction.InnerHTML = "(Hide)"
end if
Case 2
Case Else
End Select
Set row = Nothing
Set labelAction = Nothing
End Function
'===============
'===============
Function GetiPopConfig(fromPath, toPath)
Set configFileObj=CreateObject
If currComputer = "." Then
configFile = "C:\GCTI\iPop\Config\confi
Else
configFile = "\\" & currComputer & "\C$\GCTI\iPop\Config\conf
End If
newUser = toPath & "\config.XML"
If configFileObj.FileExists(c
configFileObj.copyFile configFile, newUser
Set configFileObj = Nothing
GetiPopConfig = "Successfully stored iPop Config."
Else
GetiPopConfig = "No iPop config"
End If
End Function
'===============
'===============
Function getUsersList
Dim c
c = getComputerLocalAccounts("
Dim Rows
Rows = UBound(c, 2)
Dim size
size = Rows + 2
getUsersList = "<select name=""UList"" SIZE=""" & size & """ style=""Width:150px; DISPLAY: block; OVERFLOW: auto; BORDER-TOP-STYLE: none; BORDER-BOTTOM-STYLE: none; BORDER-RIGHT-STYLE: none; BORDER-LEFT-STYLE: none; background-color=#778899""
For i = 0 To Rows
getUsersList = getUsersList & "<option value=""" & c(0, i) & """>"
getUsersList = getUsersList & c(0, i)
Next
getUsersList = getUsersList & "</select>"
End Function
'===============
'===============
Sub display()
Dim t
Set t = document.Forms("BackupAcco
Dim selUser
If UBOUND(Split(t.UList(t.ULi
selUser = Split(t.UList(t.UList.sele
If Not selUser = currUser Then
vcUser = selUser
vcLoggedOnUser.InnerHTML = vcUser
If VCDomainLbl.InnerHTML = "Domain" Then
strUserSID = getSIDasString(vcUser)
vcUserSid.InnerHTML = strUserSID
End If
vcUserID.InnerHTML = vcUser
vcUserNovellData.InnerHTML
Dim printers
printers = printerList(currComputer)
t.printerInfo.value = printers
Dim drives
drives = driveList(currComputer)
t.driveInfo.value = drives
document.GetElementByID("V
currUser = selUser
End If
End If
End Sub
'===============
'===============
Function driveList(strComputer)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set drives = objWMIService.ExecQuery("S
Dim driveStr
For Each drive in drives
Dim d
d = drive.DeviceID & drive.ProviderName
driveStr = driveStr & d & vbcrlf
Next
Set drives = Nothing
driveList = driveStr
End Function
'===============
'===============
Function getComputerLocalAccounts(s
Dim DocsSettings
Dim IDList()
If strComputer = "." Then
DocsSettings = "C:\Documents and Settings\"
Else
DocsSettings = "\\" & strComputer & "\C$\Documents and Settings\"
End If
Set objFSO = CreateObject("Scripting.Fi
Set objFolder = objFSO.GetFolder(DocsSetti
On Error Resume Next
Dim i, j
i = 0
j = 0
For Each f In objFolder.SubFolders
If Not isException(UCase(f.Name))
If (DateDiff("d", f.DateLastModified, Now) < 30) Then
If i = 0 Then
ReDim IDList(1, 0)
Else
ReDim Preserve IDList(UBound(IDList, 1), UBound(IDList, 2) + 1)
End If
IDList(0, i) = UCase(f.Name)
IDList(1, i) = UCase(f.DateLastModified)
i = i + 1
End If
End If
Next
getComputerLocalAccounts = IDList
End Function
'===============
'===============
Function isException(ByVal foldername)
select case foldername
Case "ALL USERS"
isException = True
Case "DEFAULT USER"
'Case "DEFAULT"
isException = True
Case "LOCALSERVICE"
isException = True
Case "NETWORKSERVICE"
isException = True
Case "ADMINISTRATOR"
isException = True
'Case "PUBLIC"
'isException = True
Case Else
isException = False
End Select
End Function
'===============
'===============
Function printerList(strComputer)
Const DEFAULT = 4
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set printers = objWMIService.ExecQuery("S
Dim printerStr
For Each printer in printers
Dim p
if printer.Attributes And 4 then
p = "(DEFAULT)PRINTER NAME:" & printer.Name & " | PORT:" & printer.PortName
else
p = "PRINTER NAME:" & printer.Name & " | PORT:" & printer.PortName
end if
printerStr = printerStr & p & vbcrlf
Next
Set objWMIService = Nothing
Set printers = Nothing
printerList = printerStr
End Function
'===============
'===============
Function getSIDasString(userID)
strUserADsPath = Get_LDAP_User_Properties("
If Left(strUserADsPath, 7) = "LDAP://" Then
Set objUser = GetObject(strUserADsPath)
arrSid = objUser.objectSid
strSidHex = OctetToHexStr(arrSid)
strSidDec = HexStrToDecStr(strSidHex)
getSIDasString = strSidDec
Else
getSIDasString = "Could not find adsPath for " & userID
End If
End Function
'===============
'===============
'Working VBScript Active Directory Binary SID conversion to String SID
' Source: http://forums.techarena.in
'Function to convert OctetString (byte array) to Hex string.
Function OctetToHexStr(arrbytOctet)
Dim k
OctetToHexStr = ""
For k = 1 To Lenb(arrbytOctet)
OctetToHexStr = OctetToHexStr & Right("0" & Hex(Ascb(Midb(arrbytOctet,
Next
End Function
'===============
'===============
Function HexStrToDecStr(strSid)
' Function to convert Hex string Sid to Decimal string (SDDL) Sid.
' SID anatomy:
' Byte Position
' 0 : SID Structure Revision Level (SRL)
' 1 : Number of Subauthority/Relative Identifier
' 2-7 : Identifier Authority Value (IAV) [48 bits]
' 8-x : Variable number of Subauthority or Relative Identifier (RID) [32 bits]
'
' Example:
'
' <Domain/Machine>\Administr
' Pos : 0 | 1 | 2 3 4 5 6 7 | 8 9 10 11 | 12 13 14 15 | 16 17 18 19 | 20 21 22 23 | 24 25 26 27
' Value: 01 | 05 | 00 00 00 00 00 05 | 15 00 00 00 | 06 4E 7D 7F | 11 57 56 7A | 04 11 C5 20 | F4 01 00 00
' str : S- 1 | | -5 | -21 | -2138918406 | -2052478737 | -549785860 | -500
Const BYTES_IN_32BITS = 4
Const SRL_BYTE = 0
Const IAV_START_BYTE = 2
Const IAV_END_BYTE = 7
Const RID_START_BYTE = 8
Const MSB = 3 'Most significant byte
Const LSB = 0 'Least significant byte
Dim arrbytSid, lngTemp, base, offset, i
ReDim arrbytSid(Len(strSid)/2 - 1)
' Convert hex string into integer Array
For i = 0 To UBound(arrbytSid)
arrbytSid(i) = CInt("&H" & Mid(strSid, 2 * i + 1, 2))
Next
' Add SRL number
HexStrToDecStr = "S-" & arrbytSid(SRL_BYTE)
' Add Identifier Authority Value
lngTemp = 0
For i = IAV_START_BYTE To IAV_END_BYTE
lngTemp = lngTemp * 256 + arrbytSid(i)
Next
HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)
' Add a variable number of 32-bit subauthority or
' relative identifier (RID) values.
' Bytes are in reverse significant order.
' i.e. HEX 01 02 03 04 => HEX 04 03 02 01
' = (((0 * 256 + 04) * 256 + 03) * 256 + 02) * 256 + 01
' = DEC 67305985
For base = RID_START_BYTE To UBound(arrbytSid) Step BYTES_IN_32BITS
lngTemp = 0
For offset = MSB to LSB Step -1
lngTemp = lngTemp * 256 + arrbytSid(base + offset)
Next
HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)
Next
End Function ' HexStrToDecStr
'===============
'===============
Function Get_LDAP_User_Properties(s
' This is a custom function that connects to the Active Directory, and returns the specific
' Active Directory attribute value, of a specific Object.
' strObjectType: usually "User" or "Computer"
' strSearchField: the field by which to seach the AD by. This acts like an SQL Query's WHERE clause.
' It filters the results by the value of strObjectToGet
' strObjectToGet: the value by which the results are filtered by, according the strSearchField.
' For example, if you are searching based on the user account name, strSearchField
' would be "samAccountName", and strObjectToGet would be that speicific account name,
' such as "jsmith". This equates to "WHERE 'samAccountName' = 'jsmith'"
' strCommaDelimProps: the field from the object to actually return. For example, if you wanted
' the home folder path, as defined by the AD, for a specific user, this would be
' "homeDirectory". If you want to return the ADsPath so that you can bind to that
' user and get your own parameters from them, then use "ADsPath" as a return string,
' then bind to the user: Set objUser = GetObject("LDAP://" & strReturnADsPath)
' Now we're checking if the user account passed may have a domain already specified,
' in which case we connect to that domain in AD, instead of the default one.
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
' Otherwise we just connect to the default domain
Set objRootDSE = GetObject("LDAP://RootDSE"
strDNSDomain = objRootDSE.Get("defaultNam
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Comman
Set adoConnection = CreateObject("ADODB.Connec
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnectio
' Filter on user objects.
'strFilter = "(&(objectCategory=person)
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
' Define the maximum records to return
adoCommand.Properties("Pag
adoCommand.Properties("Tim
adoCommand.Properties("Cac
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
strReturnVal = ""
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strReturnVal = "" Then
strReturnVal = adoRecordset.Fields(intCou
Else
strReturnVal = strReturnVal & VbCrLf & adoRecordset.Fields(intCou
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strReturnVal
End Function
'===============
'===============
Function getUser(strComputer)
If strComputer <> "" Then
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{imper
If Err.Number = 0 Then
Set system = objWMIService.ExecQuery("S
Dim userStr
For Each user In system
If InStr(user.UserName, "\") > 0 Then
Dim u
u = Split(user.UserName, "\")
Dim userID
userID = u(1)
End If
Next
Set system = Nothing
getUser = UCASE(TRIM(userID))
Else
getUser = "# " & Err.Description
End If
Set objWMIService = Nothing
Err.Clear
End If
End Function
'===============
'===============
Function renameComputer(newName, strAdminName, strAdminPw)
Dim result
Set objWMIService = GetObject("Winmgmts:root\c
' Call always gets only one Win32_ComputerSystem object.
For Each objComputer in _
objWMIService.InstancesOf(
Return = objComputer.rename(newName
If Return <> 0 Then
renameComputer = False
Else
renameComputer = True
End If
Next
End Function
'===============
'===============
Function updateComputer(action)
On Error Resume Next
Const JOIN_DOMAIN = 1
Const ACCT_CREATE = 2
Const ACCT_DOMAIN_JOIN_IF_JOINED
Dim adminID
Dim adminPW
Dim result
domain = "" ' Set your domain
strDomain = "Domain.com" 'Set your DNS suffix
strOU = "OU=Default,DC=Domain,DC=c
newName = Document.getElementById("s
If Split(document.getElementB
adminID = document.getElementById("s
adminID = domain & "\" & adminID
Else
adminID = document.getElementById("s
End If
adminPW = document.getElementById("s
varExitErrorLevel = 0
Dim strCommand
Select Case action
Case "Add" strCommand = "Join"
Case "Rename" strCommand = "Rename"
Case "Remove" strCommand = "Remove"
End Select
'Set objNetwork = CreateObject("WScript.Netw
'strHostName = objNetwork.ComputerName
'Set objNetwork = Nothing
Set objWMIComputer = GetObject("winmgmts:{imper
Select Case strCommand
Case "Rename"
If renameComputer(newName, adminID, adminPW) = False Then
result = "Failed to rename computer."
Else
result = "Successfully renamed computer." & VbCrLf & "Please Reboot."
End If
Case "Join"
varWMIJoinReturnValue = objWMIComputer.JoinDomainO
If varWMIJoinReturnValue = 2224 Then
varWMIJoinReturnValue = objWMIComputer.JoinDomainO
End If
result = result & vbcrlf & "Successfully added to domain." & vbcrlf & varWMIJoinReturnValue
Case "Remove"
varWMIJoinReturnValue = objWMIComputer.UnJoinDomai
varExitErrorLevel = 0
Set ADSISysInfo = CreateObject("ADSystemInfo
Set objADSIComputer = GetObject("LDAP://" & ADSISysInfo.ComputerName & "")
objADSIComputer.DeleteObje
Set objADSIComputer = Nothing
Set ADSISysInfo = Nothing
result = result & vbcrlf & "Deleted domain computer account."
End Select
Set objWMIComputer = Nothing
updateComputer = result
End Function
'===============
'===============
Function fncErrorMessage(varErrorNu
If strErrorDescription = "" Then
'List of system error codes and network management error codes
Select Case varErrorNumber
Case 5 strErrorDescription = "Access is denied"
Case 87 strErrorDescription = "The parameter is incorrect"
Case 110 strErrorDescription = "The system cannot open the specified object"
Case 1323 strErrorDescription = "Unable to update the password"
Case 1326 strErrorDescription = "Logon failure: unknown username or bad password"
Case 1355 strErrorDescription = "The specified domain either does not exist or could not be contacted"
Case 2224 strErrorDescription = "The account already exists"
Case 2691 strErrorDescription = "The machine is already joined to the domain"
Case 2692 strErrorDescription = "The machine is not currently joined to a domain"
End Select
End If
fncErrorMessage = "Error: " & varErrorNumber & ". " & strErrorDescription & "."
If flgSetExitErrorLevel Then varExitErrorLevel = 1
End Function
'===============
'===============
Dim oWMI, oOS, obj
Sub Reboot
If Msgbox("Your Computer Needs to Reboot Before Changes Can be Made. " & vbCrLf & "Would you Like To Reboot Now?" , vbYesNo, Title) = vbYes then
Set oWMI = GetObject("winmgmts:{imper
On Error GoTo 0
For Each obj in oWMI.ExecQuery("Select * from Win32_OperatingSystem")
Set oOS = obj
Exit For
Next
Call ShutDownNow()
End If
End Sub
Sub ShutDownNow
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
oOS.Win32shutdown EWX_REBOOT '+ EWX_FORCE
End Sub
'===============
'===============
</SCRIPT>
</head>
<body bgcolor="#580000" style="padding-right: 0px; padding-left: 0px; padding-bottom: 0px;
margin: 0px; padding-top: 0px; font-family: Arial, Helvetica, sans-serif; font-size: 12px;
color: #FFFFFF;">
<form id="BackupAccountsForm">
<table style="border-collapse: collapse; width: 100%; height: 10% direction: ltr;
padding-right: 1px; padding-left: 1px; border-left-color: black; border-top-style: double;
border-top-color: black; border-right-style: double; border-left-style: double;
border-right-color: black;">
<tr>
<td style="height: 30px; vertical-align: top">
Viewing Computer: <span id="VCName" style="cursor: text; position: absolute;
visibility: visible; top: 5px; left: 120px;" onmouseover="italics" onmouseout="normal"
onmousedown="VCNameChange"
<input type="text" name="strTargetPC" style="position: absolute; visibility: hidden;
top: 4px; left: 120px; width: 150px; color: black; border-top-style: none; font-family: Arial;
border-right-style: none; border-left-style: none; height: auto; border-bottom-style: none;"
onblur="testNewVal">
</td>
<td style="height: 30px; vertical-align: top;">
: </td>
<td style="height: 30px; vertical-align: top;">
Status: </td>
</tr>
<tr>
<td style="height: 20px; width: 280px;">
</td>
<td style="height: 20px">
</td>
<td style="height: 20px">
IP Address: </td>
</tr>
</table>
<table style="width: 100%; border-collapse: collapse;">
<tr>
<td class="tabHeaderSelectedCe
Well I must say, that's an impressive HTA! Nice work!
Mine is a lot simpler than, and doesn't provide half the functionality, but I've split my export into a HTA, and my Import into just a vbscript.
The export HTA will backup the ProfileList registry key, and the user profile with XCopy, so that the permissions are kept during the copy.
The export HTA is below.....The Import script will follow......
LOL thanks. Like I said ... what was it, like 9 months ago? ... It could be streamlined, I'm sure, but the functionality is there.
The idea was that a desktop support person could carry a USB stick around with this HTA on it (because it creates a log.txt file, and uses it as a database), and export off the old machine. Then install the new computer, and plug the USB stick back in, and would know where to go to get the previous user/computer/sid/path information to add to the newly created profile on the newly added machine.
Anyhow, thanks again. Your function was a great help.
:)
Business Accounts
Answer for Membership
by: RobSampsonPosted on 2009-03-10 at 22:46:40ID: 23854181
I do the same thing when I change PCs, and currently, we back up the profile on the old pc, get them to log into the new computer (which creates their profile with the right folder name against the right SID), then we reboot, log in as admin, and copy their old profile data into
c:\documents and settings\<username>
I would love to be able to copy the profile back into the new computer without having them log in first, and then have them log in and not have a new folder created. Your function looks interesting...I'll have to test it....you can't be far off with the ProfileList keys.....
I looked at MoveUser.exe but that's for account to account moving.....
Someone else may know how to do this easily, but I'll look into it in the meantime...
Regards,
Rob.