I'm making a program to improve your gaming skills, so its not a hacking program!
Now, I'm stuck on one thing, I need sort of a keylogger, that will logg what you do, For example, when you press space, it has to put Jumped in a Rich Text Box.
When you left mouse click, it has to add Shots Fired to the Rich Text Box, and then, when right mousebutton is clicked, add Aiming Down Sights, but when its released it should also add something like Stopped Aiming Down Sights.
I found out i had to ad this code, but still, i haven't foun the spacebar yet
If Chr(i) = "(" Then
txtkeys.Text = txtkeys.Text & "[Arrow Down]"
ElseIf Chr(i) = "%" Then
txtkeys.Text = txtkeys.Text & "[Arrow Left]"
ElseIf Chr(i) = "'" Then
txtkeys.Text = txtkeys.Text & "[Arrow Right]"
ElseIf Chr(i) = "&" Then
txtkeys.Text = txtkeys.Text & "[Arrow up]"
ElseIf Chr(i) = "" Then
txtkeys.Text = txtkeys.Text & "[mouse click left]"
ElseIf Chr(i) = "" Then
txtkeys.Text = txtkeys.Text & "[mouse click right]"
ElseIf Chr(i) = "" Then
txtkeys.Text = txtkeys.Text & "[backspace]"
ElseIf Chr(i) = "." Then
txtkeys.Text = txtkeys.Text & "[delete]"
ElseIf Chr(i) = "" Then
txtkeys.Text = txtkeys.Text & "[shift]"
ElseIf Chr(i) = " " Then
txtkeys.Text = txtkeys.Text & "[tab]"
ElseIf Chr(i) = "¾" Then
txtkeys.Text = txtkeys.Text & "."
ElseIf Chr(i) = "¼" Then
txtkeys.Text = txtkeys.Text & ","
ElseIf Chr(i) = "¿" Then
txtkeys.Text = txtkeys.Text & "/"
Related
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 some code that copies cells from Excel, pastes them as a picture, saves the picture, and then sends an email with that picture in it's body. The problem is that because the image gets saved on my hard drive, when it gets sent out to the recipients cannot see the image. Is there a way of getting around this?
The code is as follows:
Sub Email()
Dim objOutlook As Object
Dim objMail As Object
Dim TempFilePath As String
Dim Location As String
Dim RecipientNumber As String
Dim rng As Range
Dim PrimaryRecipients As String
Dim SecondaryRecipients As String
Dim To_Name As String
Worksheets("Contacts").Activate
Range("A2").Select
While ActiveCell <> "" And ActiveCell <> "0"
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
ActiveCell.Offset(1, 0).Select
RecipientNumber = ActiveCell.Value
To_Name = ActiveCell.Offset(0, 4).Value
If To_Name = "" Or To_Name = "0" Then
To_Name = ActiveCell.Offset(0, 7).Value
Worksheets("Output 2").Activate
Range("C2").Value = RecipientNumber
Dim objChart As Chart
Call ActiveSheet.Range("A1:M28").CopyPicture(xlScreen, xlPicture)
Sheets.Add.Name = "Without Formatting"
Worksheets("Without Formatting").Shapes.AddChart
Worksheets("Without Formatting").Activate
ActiveSheet.Shapes.Item(1).Select
Set objChart = ActiveChart
objChart.Paste
With ActiveChart.Parent
.Height = 300 ' resize
.Width = 750 ' resize
.Top = 100 ' reposition
.Left = 100 ' reposition
End With
Dim DayForLocation As String
Dim MonthForLocation As String
Dim YearForLocation As String
Dim DateForLocation As String
DayForLocation = Day(Now)
MonthForLocation = Month(Now)
YearForLocation = Year(Now)
DateForLocation = YearForLocation & MonthForLocation & DayForLocation
Dim FileLocation As String
FileLocation = "C:\Users\asfadsf\Documents\" & DateForLocation
If Dir("C:\Users\asfadsf\Documents\" & DateForLocation) <> "" Then
MkDir ("C:\Users\asfadsf\Documents\" & DateForLocation)
End If
FileLocation = FileLocation & RecipientNumber & ".jpeg"
objChart.Export (FileLocation)
Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'Keep_Format
With objMail
.To = PrimaryRecipients
.Cc = SecondaryRecipients
.Subject = "Information: " & RecipientNumber & " Updated Profiler"
Dim Greeting As String
If Time >= #12:00:00 PM# Then
Greeting = "Afternoon"
Else
Greeting = "Morning"
End If
Dim LastMonth As String
LastMonth = MonthName((Month(Date)) - 1)
Dim InsertImage As String
InsertImage = "<img src='" & FileLocation & "'>"
.HTMLBODY = "<font face=Arial><p>" & "Good " & Greeting & " " & To_Name & "," & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
' .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
.HTMLBODY = .HTMLBODY + InsertImage
.HTMLBODY = .HTMLBODY + "<p>" & "Kind Regards" & "<br>"
.HTMLBODY = .HTMLBODY + "<img src='C:\Users\asfadsf\Documents\test.jpg'>"
.Send
End With
Worksheets("Contacts").Activate
Application.DisplayAlerts = False
Sheets("Without Formatting").Delete
Application.DisplayAlerts = True
Wend
Set objOutlook = Nothing
Set objMail = Nothing
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
This is quite an issue, can someone please help?
Maybe these two lines I changed / added are better than the two lines of comment above to illustrate what I mean:
With objMail
.To = PrimaryRecipients
.Cc = SecondaryRecipients
.Subject = "Information: " & RecipientNumber & " Updated Profiler"
Dim Greeting As String
If Time >= #12:00:00 PM# Then
Greeting = "Afternoon"
Else
Greeting = "Morning"
End If
Dim LastMonth As String
LastMonth = MonthName((Month(Date)) - 1)
Dim InsertImage As String
InsertImage = "<img src='" & FileLocation & "'>"
.HTMLBODY = "<font face=Arial><p>" & "Good " & Greeting & " " & To_Name & "," & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
.HTMLBODY = .HTMLBODY + "<p>" & "Email text." & "</p>"
' .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
.HTMLBODY = .HTMLBODY + InsertImage
.HTMLBODY = .HTMLBODY + "<p>" & "Kind Regards" & "<br>"
.Attachments.Add "C:\Users\asfadsf\Documents\test.jpg"
.HTMLBODY = .HTMLBODY + "<img src='test.jpg'>"
.Send
End With
The only thing I actually changed is this:
.Attachments.Add "C:\Users\asfadsf\Documents\test.jpg"
.HTMLBODY = .HTMLBODY + "<img src='test.jpg'>"
You'll note that you don't see test.jpg as an attachment anymore but rather directly displayed in the body of the email.
Ok, like many other people, I am a noob on VB Scripting. What I am trying to do is create a VB Script that will manipulate a file name from Fulton A1032-CCC Adamsville to just A1032-CCC. I have browsed many site trying to find the answer but only came up with on that halfway worked.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='H:\Darrell 2014 folder\Distview Wiki Revamp\To'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In colFiles
strPath = objFile.Drive & objFile.Path
strExtension = objFile.Extension
strFileName = objFile.FileName
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 10) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 10)
End If
strNewName = strPath & strFileName & "." & strExtension
errResult = objFile.Rename(strNewName)
Next
Please Help
Why not just use the replace function instead? For example:
Dim fileName As String
fileName = "Fulton A1032-CCC Adamsville"
fileName = Replace(fileName, "Fulton ", "")
fileName = Replace(fileName, " Adamsville", "")
MsgBox fileName
The output is A1032-CCC. This also works if either or both of the search strings don't exist.
Learn to count:
>> WScript.Echo Len(" Adamsville")
>>
11
>>
or write a function:
>> Function endsWith(b, t)
>> endsWith = Right(b, len(t)) = t
>> End Function
>> WScript.Echo CStr(endsWith("Fulton A1032-CCC Adamsville", " Adamsville"))
>>
True
Update wrt downvotes:
As the downvotes indicate that there are at least two people who can't count either:
Option Explicit
Function qq(s) : qq = """" & s & """" : End Function
Dim strFileName : strFileName = "Fulton A1032-CCC Adamsville"
Dim intLength
WScript.Echo 0, qq(strFileName)
' assume the structure of the input data is:
' <todelete+blank><tokeep><blank+todelete>
WScript.Echo 1, qq(Split(strFileName)(1))
' the ot's code 'works' if you count correctly
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 11) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 11)
End If
WScript.Echo 2, qq(strFileName)
output:
cscript 25689666.vbs
0 "Fulton A1032-CCC Adamsville"
1 "A1032-CCC"
2 "A1032-CCC"
I have this piece of code from the ScriptIT guys.
Set objSysInfo = CreateObject("ADSystemInfo")
strComputer = objSysInfo.ComputerName
Set objComputer = GetObject("LDAP://" & strComputer)
arrOUs = Split(objComputer.Parent, ",")
arrMainOU = Split(arrOUs(0), "=")
wscript.echo arrMainOU(1)
The problem I'm having is that arrMainOU(1) echoes the OU twice. I tried setting up a simple test, but it fails. I don't see this issue covered here or on google.
If arrMainOU(1) = "myOU" Then
wcript.echo "true"
End If
I need to compare 1 value within arrMainOU(1) to an array that contains OU strings. I need a case statement that performs actions depending on whether it's OU1 or OU2 and so on.
I'm getting stuck at evaluating arrMainOU(1) though. If I output the value to a file, then it only writes one value.
Any help would be appreciated - Thank you
Try this code snippet to understand the 'SPLIT' function:
Set objSysInfo = CreateObject("ADSystemInfo")
strComputer = objSysInfo.ComputerName
Set objComputer = GetObject("LDAP://" & strComputer)
arrOUs = Split(objComputer.Parent, ",")
retstring = ""
For ii = LBound( arrOUs) To UBound( arrOUs)
arrMainOU = Split(arrOUs(ii), "=")
For jj = LBound( arrMainOU) To UBound( arrMainOU)
retstring = retstring & "arrOUs(" & CSTR( ii) & ") = " & arrOUs(ii) & vbTab
retstring = retstring & "arrMainOU(" & CSTR( jj) & ") = " & arrMainOU(jj) & vbNewLine
Next
retstring = retstring & vbNewLine
Next
Wscript.Echo retstring