I have a login script that checks for a registry key and if the key is not found it runs a script that creates an outlook signature from info in AD then adds a key to the registry. The script has run perfectly on about 20 machines that i have tested it on, however it doesn't work correctly on 3 machines. For these 3 machines it passes the check for the reg key then launches the sigcreate script but skips the actual creation and just adds the reg key. Am i missing something?
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strTitle = objUser.Description
strCred = objUser.info
strStreet = objUser.StreetAddress
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strMobile = objUser.Mobile
strFax = objUser.FacsimileTelephoneNumber
strEmail = objUser.mail
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objSelection.Font.Name = "Arial"
objSelection.Font.Size = 11
if (strCred) Then objSelection.TypeText strName & ", " & strCred Else
objSelection.TypeText strName
objSelection.TypeParagraph()
objSelection.TypeText " " & strTitle
objSelection.TypeText Chr(11)
objSelection.TypeText " " & strPhone
objSelection.TypeText Chr(11)
objSelection.TypeText Chr(11)
objSelection.TypeText "Company Name"
objSelection.TypeText Chr(11)
objSelection.TypeText "Company Tagline"
objSelection.TypeText Chr(11)
objSelection.TypeText Chr(11)
objSelection.TypeText "Company Website"
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Standard Signature", objSelection
objSignatureObject.NewMessageSignature = "Standard Signature"
objDoc.Saved = True
objWord.Quit
Set oShell = CreateObject("Wscript.Shell")
sRegFile = "\\file1\users\Clerical\wallpaper\siglock.reg"
oShell.Run "regedit.exe /s " & Chr(34) & sRegFile & Chr(34), 0, True
Problem solved....apparently there were some remnants of Word 2000 on these 3 machines...i cleaned it up and that fixed my issue
Related
Thanks for the web site and thanks for taking you time to read this.
I created a signature based on a VBS Script i pulled for numerous web sites online and got the signature almost like i would like it to be, just got a few more tweaks before i stop messing with it. i can´t seem to get the vertical alignment to work. Can you help me out please.
The code is below and the image showing refering to what i need is attached.
i need to move the right side image to the a bottom aligned position
i need to remove the space i have between the blue bar and the table above.
Appriciate the help, i am not a programmer just trying to do my best to automate signatures in outlook.
On Error Resume Next
'Option Explicit
Dim objSysInfo,strUser,objUser,strName,strMail,strWebAddr,strCompany,strDepartment,strStreetAddr,strHomePhone,strIpPhone,strMobile
Dim objWord,objDoc,objSelection,objEmailOptions,objSignatureObject,objSignatureEntries,objLink,strlogoATL,strlogoMA,strlogoBAR
Dim objRange,objTable
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FirstName &" "& objUser.LastName
strMail = objuser.mail
strWebAddr = objuser.wWWHomePage
strCompany = objuser.Company
strDepartment = objUser.Department
strStreetAddr = objuser.streetaddress
strHomePhone = objuser.HomePhone
strIpPhone = objuser.ipPhone
strMobile = objuser.Mobile
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
'Name of Staff
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "10"
objSelection.Font.Color = RGB(91,91,91)
objSelection.TypeText strName
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Mail
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(91,91,91)
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strMail, , , strMail)
objSelection.TypeText(Chr(11))
'Tel
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(91,91,91)
objSelection.TypeText "Ext : "& strIpPhone & " " & " "& chr(124) & " Telem" & Chr(243) & "vel : " & strMobile
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Department
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText strDepartment
objSelection.TypeText(Chr(11))
'Address
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText strStreetAddr
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Company Contact details
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText "Tel : "& strHomePhone & " " & chr(124) & " "
'Web
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(0,153,181)
set objLink = objSelection.Hyperlinks.Add(objSelection.Range,strWebAddr)
strlogoATL="c:\Utils\Assinatura\ins_atl.jpg"
strlogoMA="c:\Utils\Assinatura\ins_ma.jpg"
strlogoBAR="c:\Utils\Assinatura\ins_bar.jpg"
Set objRange = objSelection.Range
objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.leftpadding = 0
objTable.rightpadding = 0
objTable.Columns(1).Width = objWord.CentimetersToPoints(12.00)
objTable.Cell(1, 1).Range.InlineShapes.AddPicture(strlogoATL)
objTable.Columns(2).Width = objWord.CentimetersToPoints(12.00)
objTable.Cell(1, 2).Range.ParagraphFormat.Alignment = 2
objTable.Cell(1, 2).Range.VerticalAlignment = wdAlignVerticalCenter
objTable.Cell(1, 2).Range.InlineShapes.AddPicture(strlogoMA)
objSelection.EndKey 6
objSelection.TypeParagraph()
Set objRange = objSelection.Range
objDoc.Tables.Add objRange, 1, 1
Set objTable = objDoc.Tables(2)
objTable.leftpadding = 0
objTable.rightpadding = 0
objTable.Columns(1).Width = objWord.CentimetersToPoints(24.00)
objTable.Cell(1, 1).Range.InlineShapes.AddPicture(strlogoBAR)
objSelection.EndKey 6
objSelection.TypeParagraph()
Set objSelection = objDoc.Range()
objSignatureEntries.Add "ATLANTICO", objSelection
objSignatureObject.NewMessageSignature = "ATLANTICO"
objSignatureObject.ReplyMessageSignature = "ATLANTICO"
objDoc.Saved = True
objWord.Quit
wscript.echo "Uma nova assinatura foi aplicada ao seu Outlook!"
Picture of problem shown below
I'm trying to write a .vbs script to pin an .exe to my taskbar and start menu.
However, the .exe will only run if I pass in a package parameter.
Here's the target of the shortcut:
"C:\Program Files (x86)\Launch\AppLauncher.exe" package=TEST
I currently have the following for code but I get the error message attached when I try and run it.
Const a = """"
arrActions = Array( _
"pin", "Start Menu", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST", _
"pin", "Taskbar", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST" _ )
For intAction = 0 To (UBound(arrActions) - 2) Step 3
arrFileNames = Array(arrActions(intAction + 2))
'strMode can be "Pin" or "Unpin"
strMode = arrActions(intAction)
'strLocation can be "Start Menu" or "Taskbar" or "Both"
strLocation = arrActions(intAction + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShellApp = CreateObject("Shell.Application")
Set objShell = CreateObject("WScript.Shell")
If LCase(strLocation) = "both" Then
arrLocations = Array("Start Menu", "Taskbar")
Else
arrLocations = Array(strLocation)
End If
For Each strLocation In arrLocations
If LCase(strMode) <> "pin" And LCase(strMode) <> "unpin" Then
WScript.Echo "Mode is incorrect. Please set to ""pin"" or ""unpin""."
WScript.Quit
ElseIf LCase(strLocation) <> "start menu" And LCase(strLocation) <> "taskbar" Then
WScript.Echo "Location is incorrect. Please set to ""Start Menu"" or ""Taskbar""."
WScript.Quit
Else
strMode = LCase(strMode)
If strMode = "pin" Then
strVerb = LCase(strMode & " to " & strLocation)
strMessage = " has been " & strMode & "ned to the " & strLocation & "."
ElseIf strMode = "unpin" Then
strVerb = LCase(strMode & " from " & strLocation)
strMessage = " has been " & strMode & "ned from the " & strLocation & "."
End If
For Each strFilePath In arrFileNames
If LCase(strFilePath) = "unpin_all" And strMode = "unpin" Then
strPinLocation = objShell.ExpandEnvironmentStrings("%APPDATA%") & _
"\Microsoft\Internet Explorer\Quick Launch\User Pinned\" & _
Replace(strLocation, " ", "") & "\"
For Each objFile In objFSO.GetFolder(strPinLocation).Files
strFullPath = objFile.Path
'Set objFile = objFSO.GetFile(objFile.Path)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
WScript.Echo strFullPath & strMessage
End If
Next
Next
Else
If objFSO.FileExists(strFilePath) = True Then
Set objFile = objFSO.GetFile(strFilePath)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
blnOptionFound = False
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
blnOptionFound = True
End If
Next
If blnOptionFound = True Then
WScript.Echo strFilePath & strMessage
Else
WScript.Echo "Unable to " & strMode & " " & strFilePath & _
" from the " & strLocation & ". The verb does not exist."
End If
Else
WScript.Echo "Could not find " & strFilePath
End If
End If
Next
End If
Next
Next
Error message
My boss is asking to update a very old script used before my time here to add State field from AD into it. Here is the below script that returns all active users and their email addresses. Now I just need to add State:
Const ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ADS_UF_ACCOUNTDISABLE = 2
Const strX400Search = "X400"
Set objRootDSE = GetObject("LDAP://rootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
strADPath = "LDAP://" & strDomain
Set objDomain = GetObject(strADPath)
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 5000
objCommand.CommandText = "<" & strADPath & ">" & _
";(&(|(objectClass=contact)(objectClass=group)) (mail=*))" & _
";distinguishedName,displayName,mail,proxyAddresses;subtree"
Set objRecordSet = objCommand.Execute
AddressCount = 0
varDisabledCounter = 0
objCommand.CommandText = "<" & strADPath & ">" & _
";(&(objectClass=user)(mail=*))" & _
";distinguishedName,displayName,mail,proxyAddresses;subtree"
Set objRecordSet = objCommand.Execute
strResult = strResult & "Name" & "," & "Email" & VbCrLf
While Not objRecordSet.EOF
strUserDN = objRecordSet.Fields("distinguishedName")
strUserDN=Replace(strUserDN,"/","\/")
set objUser= GetObject("LDAP://"& strUserDN & "")
If objUser.AccountDisabled = FALSE Then
strResult = strResult & objUser.givenName & " " & objUser.sn & ","
strResult = strResult & objUser.mail
strResult = strResult & VbCrLf
End If
objRecordSet.MoveNext
Wend
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile("C:\Email List.csv")
objOutputFile.Write strResult
LF=chr(10)
WScript.Echo "Done - Please Check C:\Email List.csv to see your file." & _
LF & LF & "If you have any questions please contact Kevin Reed"
This should probably do it...
Const ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ADS_UF_ACCOUNTDISABLE = 2
Const strX400Search = "X400"
Set objRootDSE = GetObject("LDAP://rootDSE")
strDomain = objRootDSE.Get("defaultNamingContext")
strADPath = "LDAP://" & strDomain
Set objDomain = GetObject(strADPath)
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 5000
objCommand.CommandText = "<" & strADPath & ">" & _
";(&(|(objectClass=contact)(objectClass=group)) (mail=*))" & _
";distinguishedName,displayName,mail,proxyAddresses,st;subtree"
Set objRecordSet = objCommand.Execute
AddressCount = 0
varDisabledCounter = 0
objCommand.CommandText = "<" & strADPath & ">" & _
";(&(objectClass=user)(mail=*))" & _
";distinguishedName,displayName,mail,proxyAddresses,st;subtree"
Set objRecordSet = objCommand.Execute
strResult = strResult & "Name" & "," & "Email" & VbCrLf
While Not objRecordSet.EOF
strUserDN = objRecordSet.Fields("distinguishedName")
strUserDN=Replace(strUserDN,"/","\/")
set objUser= GetObject("LDAP://"& strUserDN & "")
If objUser.AccountDisabled = FALSE Then
strResult = strResult & objUser.givenName & " " & objUser.sn & ","
strResult = strResult & objUser.mail & ","
strResult = strResult & objUser.st
strResult = strResult & VbCrLf
End If
objRecordSet.MoveNext
Wend
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile("C:\Email List.csv")
objOutputFile.Write strResult
LF=chr(10)
WScript.Echo "Done - Please Check C:\Email List.csv to see your file." & _
LF & LF & "If you have any questions please contact Kevin Reed"
I have a VB script which scans the mentioned log file for errors and sends a notification through an email.
How can I scan the latest log file in the folder? For example, Filename1.070615 (Filename1.mmddyy) is a log file. After a certain size, the logfile switches to new file with the same name but different date: Filename1.070615.
cdoSendUsingPort = 2, _
Const ForReading = 1
Dim intStartAtLine, strFileCreateddate, i, strResults, strTextToScanFor, bStartFromScratch
Dim strLastCheckedFor, strArrayToString, strSubject, strMailFrom, strMailTo
strMailto = "<Emailaddress>"
strMailFrom = "<FromAddress>"
strSubject = "Log scanner"
strSMTPServer = "x.x.x.x"
FileToRead = "D:\LOG\filename1.mmddyy"
arrTextToScanFor = Array("error","another thing")
Set WshShell = WScript.CreateObject("WScript.Shell")
searchkey = replace(replace(filetoread,":",""),"\","_")
On Error Resume Next
strLastFileCheckedCreateDate = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate")
strLastFileLastLineChecked = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
strLastCheckedFor = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString")
iLastCheckedLine = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
On Error GoTo 0
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set varFile = objFSO.GetFile(FileToRead)
arrLastCheckedForText = split(strLastCheckedFor,",")
strFileCreateDate = varfile.datecreated
strFileModifiedDate = varfile.datelastmodified
sStatus = "<li>Using mail server: " & strSMTPServer & "</li><li>Running from: " & wscript.scriptfullname & "</li>"
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
objTextFile.ReadAll
iLineCount = objTextFile.Line
objTextFile.close
If strLastCheckedFor = "" Then
bStartFromScratch = true
sStatus = sStatus & "<li>First run of script against string search</li>" & vbcrlf
ElseIf ubound(arrTextToScanFor) <> ubound(arrLastCheckedForText) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Count of string search criteria has changed</li>" & vbcrlf
Else
For each strItem in arrTextToScanFor
Else
bStartFromScratch = true
'MsgBox strResults
End If
If bStartFromScratch = true Then
sStatus = sStatus & "<li>String search criteria does not match prior search</li>" & vbcrlf
End If
Next
End If
If cint(iLineCount) < cint(iLastCheckedLine) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Last line checked (" & iLastCheckedLine & ") is greater than total line count (" & iLineCount & ") in file</li>"
End If
If CStr(strFileCreateDate) = CStr(strLastFileCheckedCreateDate) and bStartFromScratch <> true Then
intStartAtLine = strLastFileLastLineChecked
If bStartFromScratch <> true then
sStatus = sStatus & "<li>Continuing search from line " & intStartAtLine & "</li>" & vbcrlf
End If
ElseIf strFileCreateDate <> strLastFileCheckedCreateDate or bStartFromScratch = true Then
intStartAtLine = 0
If bStartFromScratch <> true then
sStatus = sStatus & "<li>File created date has changed, starting search from line 0</li>" & vbcrlf
End If
End If
i = 0
Dim strNextLine
For each strItem in arrTextToScanFor
strArrayToString = strArrayToString & delim & strItem
delim = ","
Next
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
Do While objTextFile.AtEndOfStream <> True
If i < CInt(intStartAtLine) Then
objTextFile.skipline
Else
'MsgBox i
strNextLine = objTextFile.Readline
For each strItem in arrTextToScanFor
If InStr(LCase(strNextLine),LCase(strItem)) Then
strResults = "<span style='font-family:courier-new;color:#696969'><span style='font-weight:bold;background-color:#BEF3F3'>Line " & i & ":</span> " & replace(lcase(strNextLine),lcase(strItem),"<span style='background-color:#FFFF81'>" & strItem & "</span>") & "</span><br>" & vbcrlf & strResults
bSendMail = true
End If
Next
End If
i = i + 1
Loop
objTextFile.close
Set WshShell = CreateObject("WScript.Shell")
'Let's save our settings for next time.
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\FileChecked", FileToRead, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate", strFileCreateDate, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked", i, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastScanned", Now, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString",strArrayToString, "REG_SZ"
set WshShell = nothing
strFileSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>File path:</td><td>" & FileToRead & "</td></tr>"
strFileCreateDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Created date:</td><td>" & strFileCreateDate & "</td></tr>"
strFileModifiedDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Modified date:</td><td>" & strFileModifiedDate & "</td></tr>"
strArraySummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Text string(s):</td><td>" & strArrayToString & "</td></tr>"
strFileLineSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Last line checked:</td><td>" & i & "</td></tr>"
strSummary = strFileSummary & strFileCreateDateSummary & strFileModifiedDateSummary & strArraySummary & strFileLineSummary
strBodyContent = "<table style='font-family:calibri;'>" & strSummary & "</table><br><br><span style='font-size:large;'>Entries:</span><br>" & strResults & "<div style='padding-top:30px;font-size:x-small'><br><div style='font-weight:bold;font-family:calibri;color:black;'>Job Details:<ul style='font-weight:normal;font-family:calibri;color:darkgray;'>" & sStatus & "</ul></div></div>"
on error goto 0
'Send the email if need be.
If bSendMail = true Then Call sendmail(strMailFrom,strMailTo,strSubject,strBodyContent)
'------------------------------------------------------------------------
'Function EmailFile - email the warning file
'------------------------------------------------------------------------
Function SendMail(strFrom,strTo,strSubject,strMessage)
Dim iMsg, iConf, Flds
On Error GoTo 0
'// Create the CDO connections.
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
'// SMTP server configuration.
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
'// Set the SMTP server address here.
.Item(cdoSMTPServer) = strSMTPServer
.Update
End With
'// Set the message properties.
With iMsg
Set .Configuration = iConf
.To = strMailTo
.From = strMailFrom
.Subject = strSubject
.htmlbody = strMessage
End With
'iMsg.HTMLBody = strMessage
'// Send the message.
iMsg.Send ' send the message.
If CStr(err.number) <> 0 Then
Else
End If
End Function
It would be a bit easier if your log files were named filename1.yymmdd.
Nevertheless, we can use a regex to not only verify the filename but also swap the date components to put them in our desired format!
Set re = New RegExp
re.Pattern = "^(filename1\.)(\d{2})(\d{2})(\d{2})$"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile In fso.GetFolder("d:\log").Files
If re.Test(objFile.Name) Then
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
If strCompareName > strLatest Then strLatest = strCompareName
End If
Next
' Switch the name back...
strLatest = re.Replace(strLatest, "$1$3$4$2")
WScript.Echo "The latest file is: " & strLatest
This line:
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
changes the format from mmddyy to yymmdd and saves it in a string for comparison.
Once we've finished our comparisons, we just need to take the latest file we found and reverse the process:
strLatest = re.Replace(strLatest, "$1$3$4$2")
to get the original filename back!
I want to upload a file via FTP without a "copying" dialog, and I want the script to close when finishing uploading the file (because there is sleep to upload the file, and when I remove it the code does not upload the file).
Set oShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
path = "kll.bat"
FTPUpload(path)
Sub FTPUpload(path)
On Error Resume Next
Const copyType = 16
waitTime = 2000
FTPUser = "username"
FTPPass = "password"
FTPHost = "ftp.example.com"
strFTP = "ftp://" & FTPUser & ":" & FTPPass & "#" & FTPHost
set objFTP = oShell.NameSpace(strFTP)
If objFSO.FileExists(path) Then
set objFile = objFSO.getFile(path)
strParent = objFile.ParentFolder
Set objFolder = oShell.NameSpace(strParent)
Set objItem = objFolder.ParseName(objFile.Name)
objFTP.CopyHere objItem, copyType
End If
If Err.Number <> 0 Then
End If
WScript.Sleep waitTime
End Sub
As per the documentation, try changing copyType to 20 (16 + 4):
Sub FTPUpload(path)
On Error Resume Next
Const copyType = 20 'respond "Yes to All" & don't display progress dialog
waitTime = 2000
FTPUser = "username"
FTPPass = "password"
FTPHost = "ftp.example.com"
strFTP = "ftp://" & FTPUser & ":" & FTPPass & "#" & FTPHost
set objFTP = oShell.NameSpace(strFTP)
If objFSO.FileExists(path) Then
set objFile = objFSO.getFile(path)
strParent = objFile.ParentFolder
Set objFolder = oShell.NameSpace(strParent)
Set objItem = objFolder.ParseName(objFile.Name)
objFTP.CopyHere objItem, copyType
End If
If Err.Number 0 Then
End If
WScript.Sleep waitTime
End Sub
If that doesn't work you seem to have encountered one of the situations where a flag is ignored. In that case you have to either live with the dialog, or switch to another upload method. One option is to run ftp.exe with an FTP script that you generate on the fly:
Set fso = CreateObject("Scripting.FileSystemObject")
scriptfile = fso.BuildPath(fso.GetSpecialFolder(2), fso.GetTempName)
Set f = fso.OpenTextFile(scriptfile, 2, True)
f.WriteLine "USER " & FTPUser
f.WriteLine "PASS " & FTPPass
...
f.WriteLine "QUIT"
f.Close
Set sh = CreateObject("WScript.Shell")
sh.Run "ftp -n -s:""" & scriptfile & """ " & FTPHost
fso.DeleteFile(scriptfile)
Or you could use ActiveXperts' Network Component.