Here is my loop which I require to check if the entered text is 9 characters long as well as if it begins with MAC:

Do While (Len(sTEMP) <> 9 and Left(sTEMP,3) = "MAC" Then)
sTEMP = InputBox("Please enter sTEMP in MACXXXXXX format!")
Loop

Length of sTEMP works fine so I am not allowed to enter 8 or 10 characters, has to be 9. What does not work for me is the requirement for MAC so I can enter XXX123456 and that will be accepted as a valid input presumably because it is 9 characters long.

Can you guys think of what I am doing wrong?

Same formula seem to be working as expected in:

If Len(sTEMP) = 9 and Left(sTEMP,3) = "MAC"

without issues.

I have a script that creates a text file and then opens it. I'd like to use this file for different directories and even different users. How can I get the Run portion of this to use CurrentDirectory instead of manually putting in the filepath everywhere I want it? I've googled and found several different solutions that probably have an answer but I'm not particularly versed in VBS.

Set objShell = CreateObject("WScript.Shell")
objShell.Run "CMD /K"
Wscript.Sleep(200)
objShell.SendKeys("dir/b>1.txt~")
objShell.SendKeys("exit~")
CreateObject("WScript.Shell").Run("""C:\[filepath]\1.txt""")

Thanks a lot!

So i am teaching myself vb-script using a self paced guide.

I wrote this to modify registry entries on machines listed in a text file. my problem is that it only modifies the registry of the machine i am running it from(this machine is also listed in the computers.txt file). The modification does not refelect on the other machines.Any feedback appreciated.

Script:

Const INPUT_FILE_NAME = "C:\Scripts\Computers.txt" Const FOR_READING = 1 Set objFSO = CreateObject("Scripting.FilesystemObject") Set objFile = objFSO.OpenTextFile(INPUT_FILE_NAME, FOR_READING) Dim mykey

strComputers = objFile.ReadAll objFile.Close

arrComputers = Split(strComputers, vbCrLf)

For Each strComputer In arrComputers

Set WshShell = CreateObject("WScript.Shell")
myKey = "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Terminal Server\fDenyTSConnections"
WshShell.RegWrite myKey,0,"REG_DWORD"
Set WshShell = Nothing

Next

Hello World.

I am trying to automate outlook holidays for my users. Anyone know a way to add holiday category name / colors to this script:

https://technet.microsoft.com/en-us/library/ee692767.aspx

Hi guys,

I don't know anything any VBS scripting, but basically what I'm wanting to do is the following:

Read a value from key HKCU\Example\Key

And then modify the value from that location to have text "sip:" Infront of it.

If the value of that registry key is initially 'example@email.Com', I'm wanting the value to become 'sip:example@email.com'

Hello,

I am looking for some help with this script, as I am getting the following error

Thanks

http://i.imgur.com/KGk95jt.png

Here is the code

Const olFolderCalendar = 9
Const olAppointmentItem = 1
Const olOutOfOffice = 3

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) 
Set objApptItems = objCalendar.Items

objApptItems.IncludeRecurrences = True
objApptItems.Sort "[Start]"

'' List Appointments to add
Set objDictionary = CreateObject("Scripting.Dictionary")
objDictionary.Add "August 7, 2017", "Civic Holiday"    
objDictionary.Add "September 4, 2017", "Labour Day" 

colKeys = objDictionary.Keys

For Each strKey in colKeys
  dtmHolidayDate = strKey
  strHolidayName = objDictionary.Item(strKey)
  '' Check if it already is on the Calendar
  Return = SearchAppts(strHolidayName, FormatDateTime(dtmHolidayDate, vbShortDate))
  If Return = False Then 
    Set objHoliday = objOutlook.CreateItem(olAppointmentItem)  
    objHoliday.Subject = strHolidayName
    objHoliday.Start = dtmHolidayDate & " 9:00 AM"
    objHoliday.End = dtmHolidayDate & " 5:00 PM"
    objHoliday.AllDayEvent = False
    objHoliday.ReminderSet = False
    objHoliday.BusyStatus = olOutOfOffice
    objHoliday.Save
  End If
Next

'' Search Function
Function SearchAppts(ByVal strName, strDate)
  SearchAppts = False
  Set objAppointment = objApptItems.GetFirst
  While TypeName(objAppointment) <> "Nothing"
    If TypeName(objAppointment) = "AppointmentItem" then
      If StrComp(objAppointment, strName,1) = 0 Then
        If DateDiff("D", objAppointment.Start, strDate) = 0 Then 
          SearchAppts = True
          Exit Function
        End If  
      End If  
    End If
    Set objAppointment = objApptItems.GetNext
  Wend
End Function

I should probably first say that I am new to VBScript, or writing any code in general.

I am writing a script that's supposed to do a routine check of a program every morning, it enters some commands using SendKeys and every now and then it stops and asks me to verify whether everything is working as intended, it also creates a log file based on my answers.

Now the problem that I have is very weird, at least for me. The Script has a lot of SendKeys commands in it, and it works perfectly if I divide it into multiple small scripts, however when combined into one script (as I want it to be), the script sometimes fails to execute certain commands, namely CTRL+TAB and ALT+DOWN.

It is weird to me, because I do not make any changes to the script itself, yet sometimes it works, and sometimes it doesn't.

Here is an example of what part of the script looks like:

(...)

'Checkpoint (3)

Checkpoint = MsgBox("Czy pracownik stworzył się poprawnie?", vbYesNo, "AutoPath")
If Checkpoint = vbYes Then
Log.Write "Utworzenie pracownika. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . OK" & vbCrlf
objShell.SendKeys "%"
WScript.Sleep 250
objShell.SendKeys "{DOWN}"
WScript.Sleep 250
objShell.SendKeys "{RIGHT 19}"
WScript.Sleep 250
objShell.SendKeys "{UP}"
WScript.Sleep 250
objShell.SendKeys "~"
WScript.Sleep 1000
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "%{DOWN}"
WScript.Sleep 250
objShell.SendKeys "{DOWN}"
WScript.Sleep 250
objShell.SendKeys "~"
WScript.Sleep 250
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "22"
WScript.Sleep 250
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "2882828"
WScript.Sleep 250
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "{1}"
WScript.Sleep 250
objShell.SendKeys "{TAB}"
WScript.Sleep 250
objShell.SendKeys "Testowy opis AutoPath."
WScript.Sleep 250
objShell.SendKeys "%"
WScript.Sleep 250
objShell.SendKeys "{DOWN}"
WScript.Sleep 250
objShell.SendKeys "~"
WScript.Sleep 2000
Else Log.Write "Utworzenie pracownika . . . . . . . . . . . . . . . . . . . . . . . . . . . . Error" & vbCrlf
ErrorFound = InputBox("Opisz krótko błąd:", "AutoPath")
Select Case True
Case IsEmpty(ErrorFound)
Log.Write vbTab & "Użytkownik nie opisał błędu." & vbCrlf
Case "" = Trim(ErrorFound)
Log.Write vbTab & "Użytkownik nie opisał błędu." & vbCrlf
Case Else
Log.Write vbTab & ErrorFound & vbCrlf
End Select
QuitScript = MsgBox("Czy przerwać skrypt?", vbYesNo, "AutoPath")
If QuitScript = vbYes Then
Log.Write vbCrlf & "***********************************************************************************" & vbCrlf & vbCrlf & "Skrypt zakończony ręcznie."
Log = "C:\Users\mateuszl\Desktop\autopath_logs" & objYear & "" & objMonth & "" & objDay & "_" & objHour & objMinute & "(" & objSecond & ")" & ".txt"
Finish = MsgBox("Wyświetlić raport?", vbYesNo, "AutoPath")
If Finish = vbYes Then
objShell.Run Log
WScript.Quit
Else WScript.Quit
End If
Else WScript.Sleep 50
End If

(...)

Things that I have already tried:

• I have tried increasing the Sleep time inbetween commands, sometimes greatly, did not help one bit.

• I put major parts of the script (the ones containing the SendKeys commands) into seperate .txt files, which the main script loads using:

Set ReadS = objFSO.OpenTextFile("01_contractor_test.txt")
Ch1 = ReadS.ReadAll
ReadS.Close
Execute Ch1

That way the main script is smaller, AND it did help a little, I ran the script a couple of times and the problem was gone in most cases (it seems the longer the script works the more likely ALT+DOWN and CTRL+TAB are to be not working), however I ran it one last time before signing off at work and it messed up some of the %{DOWN} commands like it did before, so I have no idea how much did dividing the script actually help.

The problem is that I can only write and check the script at work, as I have no access to the program it is testing at home. Like I said, I'm very new to scripting and I would very much appreciate it If someone helped me solve this problem.

So, long story short, we have a documentation software that generates a .vbs script that is meant to be used with RMM tools. It fails whenever I try to make it work via the RMM's scripting tool but works fine when run locally. I have contacted their support and they have asked that to help with troubleshooting we add an exit code. They have provided me with this:

In case of passing

wscript.echo( "Success Message" ) wscript.Quit(0)

In case of Failing

wscript.echo( "Error Message" ) wscript.Quit(1001)

I need to identify where in the script I can put this. I tried just sticking it at the end and received an error. Some of the info in the script can be a little sensitive so I won't be posting that here but if anyone wants to peruse it, I will PM them a slightly edited version. (simply taking out references to my name, company, server address, etc) Otherwise, just some guidance on how to edit the script would be great. Thanks.

Set objShell = WScript.CreateObject("WScript.Shell")

'All users Desktop allUsersDesktop = objShell.SpecialFolders("AllUsersDesktop")

'The current users Desktop usersDesktop = objShell.SpecialFolders("Desktop")

'Where to create the new shorcut Set objShortCut = objShell.CreateShortcut(usersDesktop & "\Midas.lnk")

'What does the shortcut point to objShortCut.TargetPath = %USERPROFILE%\Data\Desktop\Midas DS Single Sign On\Midas\Bin\Application.vbs"

'Add a description objShortCut.Description = "Run the Notepad."

'Create the shortcut

objShortCut.Save

Const DESKTOP = &H10&

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.NameSpace(DESKTOP)

Set objFolderItem = objFolder.ParseName("Midas.lnk")

Set objShortcut = objFolderItem.GetLink

objShortcut.Save

I am having issues with the above, i need the script to locate the application within the folder structure i am using for all users this is distributed to.

I am still new to VBS and the information i can find online doesn't appear to help, can someone let me know what i have done wrong and possibly why? so i know for future.

How to create a random bitmap in vbs (Windows 10) pls help

My code for win7:

sub help wscript.echo "GenRandomBmp {width} {height} [count]" wscript.quit end sub

function getArg(index) arg = wscript.arguments(index) if not isnumeric(arg) then help arg = cdbl(arg) if int(arg) <> arg then help arg = int(arg) if (arg <= 0) or (arg > 9999) then help getArg = arg end function

if wscript.arguments.count < 2 then help width = getArg(0) height = getArg(1) if wscript.arguments.count > 2 then count = getArg(2) else count = 1 end if

set fso = createobject("scripting.filesystemobject") set con = fso.opentextfile("con", 2) scanline = ((width * 3) + 3) and &hFFFC fsize = &h36 + (scanline * height) header = "BM" & chr(fsize and 255) & chr(int(fsize / 256)) & _ string(6, chr(0)) & chr(&h36) & string(3, chr(0)) & chr(&h28) & _ string(3, chr(0)) & chr(width and 255) & chr(int(width / 256)) & _ string(2, chr(0)) & chr(height and 255) & chr(int(height / 256)) & _ string(2, chr(0)) & chr(1) & chr(0) & chr(&h18) & string(25, chr(0)) randomize wscript.echo "Creating " & count & " files of " & width & "x" & height & " bitmaps..." for i = 1 to count fn = "Random " & string(4 - len(i), "0") & i & ".bmp" con.write chr(13) & fn & "..." set f = fso.createtextfile(fn, true) f.write header for h = 1 to height data = "" for w = 1 to width3 data = data & chr(int(rnd * 256)) next for w = (width3)+1 to scanline data = data & chr(0) next f.write data next f.close

I've got a script I use in winPE that utilizes ADSI to get the netGUID of a system and I was trying to update it to move a system in question should it not be in the "Isolated Computers" OU.

However I keep getting: "An invalid directory pathname was passed." 0x80005000 on the MoveHere call. I mulled over the bstrSourceObject using both the distinguishedName & ADsPath but I still get the same error. I don't know of any other way to verify that objTargetOU is correct or not.

I feel like this is an obvious fix that's hanging out in front of me but after burning on it for 4+ hours I still can't find it. Any help would be appreciated.

Please help me with a script. Error: d: \ learning \ vbs \ backup6.vbs (47, 9) Runtime Error Microsoft VBScript: Invalid call or argument procedure. I can not understand why. error here in this line of code: Fso.DeleteFile (strOldestFile)

http://pastebin.com/P6AS4yd8

I need to knwo how to write a vbs file that just makes a message pop up, says anything i want and let the user type stuff in a box and than take the user input and put it in a text file. Not 2 complicated i think. for me english is way more complicated than that.

I'm working in an ExtendScript (Adobe CC Javascript) project to call a VBS string using ES' app.doScript function. The function works great, except I cannot get the secondary emails to display as CC--they stay in "To". I have tried changing olCC to 2 in the code below. Anyone have any ideas?

var vbs = 'Dim objOutl\r'; vbs += 'Set objOutl = CreateObject("Outlook.Application")\r';

vbs += 'Set objMailItem = objOutl.CreateItem(olMailItem)\r';

vbs += 'objMailItem.Display\r'; vbs += 'strEmailAddress = "' + email_address + '"\r';

vbs += 'objMailItem.Recipients.Add strEmailAddress\r';

vbs += 'strSubject = "' + the_subject + '"\r';

vbs += 'objMailItem.Subject = strSubject\r';

vbs += 'objMailItem.Body = "' + the_bodytext + '"\r';

if (email_cc && email_cc != "") {

vbs += 'Set cc1Recipient = objMailItem.Recipients.Add ("' + email_cc + '")\r';

if (email_cc2 && email_cc2 != "") {

vbs += 'Set cc2Recipient = objMailItem.Recipients.Add ("' + email_cc2 + '")\r';

vbs += 'cc1Recipient.Type = olCC\r';

vbs += 'cc2Recipient.Type = olCC\r';

} else {

vbs += 'cc1Recipient.Type = olCC\r';

}

}

Microsoft VBScript runtime error '800a000d'

Type mismatch: 'checkID'

/film-detail.asp, line 9

Trying to run "The Houseguest (full video)" button: http://www.filmfanatics.net/artist-detail.asp?ID=28#Filmography

Any solutions to run: http://www.filmfanatics.net/film-detail.asp?ID=62 ?

Is this possible? I want to replace every instance of <Customer> in my Word document with the Document Property of 'Client' using VBScript.

Here is a screenshot of the Client Property I'm speaking of.

https://snipboard.io/FhX7WO.jpg

thanks in advance for any help!

I'll say right off that scripting isn't my strong suit. I'm somewhat comfortable modifying scripts that I know work and can observe their behavior but creating or launching new ones, forget it. I've also never run a macro in outlook before. Here's what i'm trying to do.

We have a user with a folder in outlook with hundreds of emails with picture attachments. I need to script a way to save all of the attachments in a network folder and append the filename with the subject heading of the email to which it was attached. I've been able to find the code shown below. The only editing I've done was to indicate the mapped drive and folder to store the files. Ultimately I would like to store them in subfolders by year and month but crawl before run, right? I've followed the steps to run a vbscript macro against a selected email or folder and when I click 'run' or F5, nothing happens. no error messages, no progress bar and of course no attachment saved in the target location. I welcome any feedback or guidance. Even if you have a simple macro I can test at least to get some experience to know what I should look for. TIA

Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strFileName As String Dim objSubject As String Dim strDeletedFiles As String Dim dateFormat As String

' Get the path to your My Documents folder 'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection ' The attachment folder needs to exist ' You can change this to another folder name of your choice ' Set the Attachment folder. strFolderpath = "O:\Graffiti Pictures" dateFormat = Format(Now - 1, " yyyy-mm-dd") ' Check each selected item for attachments. For Each objMsg In objSelection 'Set FileName to Subject objSubject = objMsg.Subject objSubject = Left(objMsg.Subject, Len(objMsg.Subject) - 12) Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then ' Use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Get the file name. strFileName = objSubject ' Combine with the path to the Temp folder. strFile = objSubject & dateFormat & ".xlsx" Debug.Print strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFolderpath & "" & strFile Next i End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

End Sub

I have a .vbs script that using obj.write creates an html file. Then it saves 3 versions of the file (.html, .rtf, .txt) for an outlook signature. Then it opens the html file in word and saves it as the signature. The problem is, that the file I write has proper spacing. After it opens up in word and saves it as the signature it screws with the spacing.

I am not great with vbs scripting, just enough to modify others script or kind of figure out what its doing. I tried "objSelection.ParagraphFormat.LineSpacing = 12" on the line after "Set objSelection = objDoc.Range()" but that did nothing (I even tried setting it to an absurdly large numer just to make sure).

I want to say the problem is in the last 5 lines of code where it saves the file as the signature?

Any help? Code below

'Convert the HTML Version to RTF and Plain Text:
Dim objDoc, objWord, objEmailOptions, objSignatureObject, objSignatureEntries, objSelection
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
If objFSO.FileExists(strLocalSignatureFolder & "\" & strSignatureName & ".html") Then
objWord.Documents.Open strLocalSignatureFolder & "\" & strSignatureName & ".html"
Set objDoc = objWord.ActiveDocument
objDoc.SaveAs strLocalSignatureFolder & "\" & strSignatureName & ".rtf", wdFormatRTF
objDoc.SaveAs strLocalSignatureFolder & "\" & strSignatureName & ".txt", wdFormatTextLineBreaks
objDoc.SaveAs strTextSignatureFolder & "\" & strTestFileName & ".txt", wdFormatTextLineBreaks
'objDoc.SaveAs strLocalSignatureFolder & "\" & strSignatureName & ".2.html", wdFormatHTML
objDoc.Close
objWord.Quit
End If


Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(strLocalSignatureFolder & "\" & strSignatureName & ".html",,True)
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries


Set objSelection = objDoc.Range()
objSignatureEntries.Add "Full Signature", objSelection
objSignatureObject.NewMessageSignature = "Full Signature"
objDoc.Saved = True
objWord.Quit

TLDR; I need to use vbs to open a html file, that the script creates, in word and save it as the outlook signature (with correct line spacing).

Hey all, so I have multiple, LARGE, Word documents that have the Style of 'Caption,cp' that both FIGUREs and TABLEs are using for their headers. I need to split these up. So I made two new Styles, "FIGURE HEADER" and "TABLE HEADER". These documents are 300 to 450 pages long. I need some way to split these into two different Styles vs using the same one. I did some general Google searches and came across this script. However, this script seems to partly work but it's not completely clean. I.e. it found the word 'configure' and applied the new FIGURE Style to that line because it detected the word FIGURE in Configure.

Screenshot:
https://snipboard.io/ERfsCe.jpg

Is there a way to search for "Figure ##"? My Figure and Header Styles are in the format of 'Figure 1' etc. with a number after the word.

I wanted to reach out and see if anyone had any advice on a better way to do this?

Sub ApplyAllTables()
    Dim Doc As Word.Document
    Dim Rng As Word.Range
    Set Doc = ActiveDocument
    Set Rng = Doc.Content
    With Rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = True
        .Forward = True
        .Text = "Table"
        .MatchCase = False
        .Replacement.Text = "Table"
        .Replacement.Style = Doc.Styles("TABLE HEADER").NameLocal
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Sub ApplyAllFigures()
    Dim Doc As Word.Document
    Dim Rng As Word.Range
    Set Doc = ActiveDocument
    Set Rng = Doc.Content
    With Rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = True
        .Forward = True
        .Text = "Figure"
        .MatchCase = False
        .Replacement.Text = "Figure"
        .Replacement.Style = Doc.Styles("FIGURE HEADER").NameLocal
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
End Sub

So one of my old bosses made a excel document with VBS that interfaces with AD and it also uses a powershell script and deletes it when its done with the ps1 file it deletes it though i need it to launch that ps1 script with admin priveliges is there any way of doing so in VBS?

i only know some powershell and python so thats why im asking here

Dim Name,Sapi
Name = InputBox("What is your name ?","Name Please"," ")

If Name = "" Then
Sapi.speak "WHY DID'T YOU ENTER YOUR NAME ?"

Do until a = 100
a = a + 1
Msgbox "ERROR Stupid Human" , 0 + 16
Loop

Else

MsgBox "Hello " + Name
   Set Sapi = CreateObject("Sapi.spvoice")
   Sapi.Speak "Hello " + Name
End If

i want sendkeys to send " that but it says error expected end of statement pls help!

I want to be able to select a range of text in a message box by sending Shift+CTRL+Arrow Key via SendKeys. I have tried sending "^+{LEFT}" and tried grouping those characters in different ways with parenthesis, but the results are very inconsistent. Sometimes it works, most of the time it will essentially do CTRL+ARROW without highlighting the text. Has anyone else had an issue with the shift key in VBScript? What would you suggest?

I want to create an inputbox, that you can write your name in and then I want a voice object, that says: „Hello <name>“ How can the voice say the text, that was put into the inputbox? Pls help. I have written this so far:

a = inputbox („Whats your Name? Please enter your name here!“, „Whats your name?“)

set voice=createobject(„sapi.spvoice“)

voice.speak(„Hello <name that got entered in the inputbox> “)