I'm trying to add a list of users from a xls file and I get this error:
Line: 6
Char: 5
Invalid Syntax
The script I'm trying to use looks like this:
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open _
("C:\Scriptt/Users.xls")
intRow = 3
Do Until objExcel.Cells(intRow,1).Value = ""
Set objOU = GetObject("ou=REAL, dc=ormbunken, dc=com")
Set objUser = objOU.Create _
("User", "cn=" & objExcel.Cells(intRow, 2).Value)
objUser.sAMAccountName = objExcel.Cells(intRow, 1).Value
objUser.SetPassword = objExcel.Cells(intRow, 5).Value
objUser.GivenName = objExcel.Cells(intRow, 3).Value
objUser.SN = objExcel.Cells(intRow, 4).Value
objUser.AccountDisabled = FALSE
objUser.SetInfo
intRow = intRow + 1
Loop
objExcel.Quit
Does anyone know whats wrong?
Do you need to supply a protocol/server in the GetObject call? Like what this says
Set oOU = GetObject("LDAP://test.test.cz/ou=skup,dc=test,dc=test,dc=cz")
Set oUser = oOU.Create("User", "cn=" & "Test" & " " & "Tester")
taken from http://msdn.itags.org/iis/2649/
did a google, found http://www.computerperformance.co.uk/vbscript/vbscript_user_spreadsheet.htm
Related
I know there's additional stuff in the Declarations, it's for other macros I've written.
I've several calendars. I've a spreadsheet where I paste information about a site, and I've buttons that generate appointments and emails.
I've code to set an appointment, however it goes to my main calendar. I'm trying to get the appointment onto my other calendars. I've read about MAPI functions, but can't get it to work. The location is \myemail#me.com\Calendar. Name of the calendar is SVN Calendar.
Dim olApp As Outlook.Application9
Dim olEmail As Outlook.MailItem
Dim olCal As Outlook.AppointmentItem
Dim olFolder As Outlook.Folder
Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
Dim rtf() As Byte
Dim rngTo As Range
Dim rngCC As Range
Dim rngSUB As Range
Dim rngCALloc As Range
Dim rngCALstart As Range
Dim rngCALend As Range
Dim rngBody As Range
Dim myItem As Object
Sub newTestCreateCalendarUSA1()
'Testing calendar to other calendar than main.
' i.e. SVN Calendar. can't identify the actual calendar.
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
Set appt = olApp.CreateItem(olAppointmentItem)
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
MsgBox "Ensure all attendees are correct prior to sending invite."
appt.MeetingStatus = olMeeting
appt.RequiredAttendees = rngCC.Value
appt.Subject = rngSUB.Value
appt.Location = rngCALloc.Value
appt.Start = rngCALstart.Value
appt.End = rngCALend.Value
appt.AllDayEvent = True
m.BodyFormat = olFormatHTML
m.HTMLBody = Range("I31").Value
m.GetInspector().WordEditor.Range.FormattedText.Copy
appt.GetInspector().WordEditor.Range.FormattedText.Paste
appt.Display
m.Close False
End Sub
Edit: Thanks for directing me to follow the folder tree. I tried understanding the GetNameSpace thing, but couldn't get it to work.
I did find a different code and got it to make an appointment on the correct calendar.
Sub SVN_Calendar_Invite()
'trial run of SVN Calendar with other code
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("0000000098F32312526B334EAEC97D94705E33FB0100C964D8D325E3554DA24A72FB876E3F600001912394000000")
With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")
End With
With oFolder
Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
.AllDayEvent = True
.RequiredAttendees = rngCC.Value
.Start = rngDateStart.Value
.End = rngDateEnd.Value
.Subject = rngSUB.Value
.Location = rngLoc.Value
.Body = "The body of your appointment note"
.BusyStatus = olFree
.Save
.Move oFolder
End With
Set olNS = Nothing
Set olApp = Nothing
Set olApt = Nothing
End With
End Sub
I've these problems now.
1- if I use .Display to bring up the calendar item to review it, it doesn't display.
2- even though it's an all day event, and the cells are 3 days apart, it subtracts the end date by 1 day.
3- I have to manually invite the attendees, which defeats the purpose of doing this invite.
ok so im about two years late. found this thread while i was facing the same problem. manage to solve with some trial and error so, this works for me.
so you might give it a try for future pple who are googling for the same ans...
a lil more info is i did not set reference to Outlook under tools cos i have many user files.
'start
'break down here retype cos stackoverflow format xxx
Sub Add_Appt_to_Main_Sub_Calendar()
Dim BOOK2 As Workbook
Workbooks.Open Filename:= _
"Name of your file.csv"
'csv is readable by outlook but not excel, u need to change the file type first
'start pulling data from your csv file here
'if you are not setting reference to outlook under tools, please define all your outlook names as Object
Dim olAppts As Object
Dim Calfolder As Object
'this to define the main calendar folder
Dim Subfolder As Object
'this to define the sub calendar folder
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
Dim filter As Variant
'cos we dont want to keep import duplicate appt into outlook calendar so we need to create and define a filter
Dim olfolder As Object
'the folder picker by user
Dim strolFolder As String
' we want to get the name of the folder picker by user
Set olfolder = olApp.GetNamespace("MAPI").Pickfolder
'olfolder.Display
'how to find the name of the folder selected
On Error Resume Next
If olfolder = "" Then
MsgBox "No calendar selected."
Workbooks("Name of your file.csv").Close savechanges:=True
'close the csv file if no calendar selected by user
Exit Sub
Else
strolFolder = olfolder
'name of the file pick by user
Set Calfolder = olNamespace.GetDefaultFolder(9)
'defaultfolder(9) is the main calendar by default tagged to user outlook acc
strCalfolder = Calfolder
'name of the sub folder
MsgBox strolFolder
MsgBox strCalfolder
MsgBox (olfolder.folderpath)
MsgBox (Calfolder.folderpath)
'keep for debugging
If olfolder.folderpath <> Calfolder.folderpath Then
'this is the line that add appointment into sub calendar
Set olAppts = olNamespace.GetDefaultFolder(9).Folders(strolFolder)
'eg. Set olAppts = olNamespace.GetDefaultFolder(9).Folders("name of subfolder")
'this is the main folder
Set Calfolder = olNamespace.GetDefaultFolder(9)
'MsgBox Calfolder
'this is the sub folder i want to add in
Set Subfolder = Calfolder.Folders(strolFolder)
'MsgBox Subfolder
'add appt to subfolder
Set olAppt = Subfolder.items.Add
'MsgBox (olfolder.EntryID)
'MsgBox (olfolder)
'MsgBox (olfolder.FolderPath)
'keep for debugging
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
'Set olAppt = olAppts.items.Find(filter)
'currently this does a check in your main calendar
'if existing appointment based on subject, start date and location is not found, add appointment
' i need to do a search in the subcalendar instead of main calendar
Set olAppt = olAppts.items.Find(filter)
If TypeName(olAppt) = "Nothing" Then
Set myAppt = Subfolder.items.Add
'Set myAppt = olApp.CreateItem(1)
'if using main use create, if use subfolder add
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to sub calendar."
'if picked folder is sub calendar
Else
Set olApp = CreateObject("Outlook.Application")
strCalfolder = olNamespace.GetDefaultFolder(9)
Set olNamespace = olApp.GetNamespace("MAPI")
Set olAppts = olNamespace.GetDefaultFolder(9)
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
'filter by subject, start date and location
'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
On Error Resume Next 'enable error-handling machine
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
Set olAppt = olAppts.items.Find(filter)
'if existing appointment not found, add appointment
If TypeName(olAppt) = "Nothing" Then
Set myAppt = olApp.CreateItem(1)
myAppt.Subject = Cells(r, 2).Value
myAppt.Location = Cells(r, 8).Value
myAppt.Start = Cells(r, 7).Value
myAppt.Categories = Cells(r, 3).Value
myAppt.Duration = 120
myAppt.BusyStatus = 2
myAppt.ReminderSet = True
myAppt.Body = Cells(r, 11).Value
myAppt.Save
End If
r = r + 1
Loop
MsgBox "TCU added to main calendar."
End If
End If
'end add appt
'close ur csv file
Workbooks("Name of your file.csv").Close savechanges:=True
End Sub
I decided to learn VBA two weeks ago, and it's gone rather smooth. Now, however, I've encountered a problem I can't seem to solve on my own.
I've set up an excel document containing various modules. One of these modules extracts comments from a word document over to the excel sheet - which works as intended.
The problem is, I haven't been able to extract the first numbered header above each comment, which I'd very much like. Currently I have to do this manually after extracting the comments. As an example, I would like to also extract the first header and number above each comment, such as '2.1.1 Title'. If the comment is highlighting the header itself, it should be that header which is extracted as well.
I've tried a variety of things based on what I could find online, but every time I'm met with a variety of bugs I can't seem to fix. I've yet to find something that even sorta works. I did try one method which apparently should work in Word VBA, but I couldn't get it working within Excel.
Does anyone know how I would go about extracting the numbered headers? Any hints or tips will be greatly appreciated.
This is the code I have for the module:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("B" & 1).Font.Bold = True
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 3 + i).Value = wdDoc.Comments(i).Range.ListFormat.ListString 'Returns empty'
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Here is your code with some adjustments:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
wdDoc.Activate ' Added
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("E" & 1).Font.Bold = True ' Modified
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 1 + i).Value = wdDoc.Comments(i).Scope.ListFormat.ListString 'Returns empty' ' Modified ' Updated
Dim wp As Word.Paragraph: Set wp = wdDoc.Comments(i).Scope.Paragraphs(1) ' Updated
Do While wp.Range.ListFormat.ListString = "" ' Updated
Set wp = wp.Previous ' Updated
Loop ' Updated
Range("G" & 1 + i).Value = wp.Range.ListFormat.ListString ' Updated
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Please note my comments: Added and Modified
wdDoc.Activate was required at least on my computer, otherwise the
Range property is empty.
After initials a wrong column was bolded
The original text is referred to by the Range property, not the Scope (which is the content of the comment), so its ListFormat property should be used
The row index was not correct (3 instead of 1)
Looks working for me:
This requires Microsoft VBScript Regular Expression 5.5
Sub commentaires()
Dim regexOne As Object
Set regexOne = New RegExp
regexOne.Pattern = "^\d+\."
Dim s As String, s1 As String
Dim cmt As Word.Comment
Dim doc As Word.Document
For Each cmt In ActiveDocument.Comments
Dim wp As Word.Paragraph
Set wp = cmt.Scope.Paragraphs(1) ' Updated
Do While Not regexOne.Test(wp.Range.ListFormat.ListString)
Set wp = wp.Previous ' Updated
Loop ' Updated
s = s & _
wp.Range.ListFormat.ListString & ";" & _
cmt.Reference.Information(wdActiveEndAdjustedPageNumber) & ";""" & _
cmt.Scope & """;""" & _
cmt.Range.Text & """ " & vbCr
Next
Dim f As Integer
f = FreeFile
Open "c:\comments.csv" For Output As #f
Print #f, s
Close #f
End Sub
What I'm trying to accomplish is searching multiple computers for event code 41 (unexpected shutdown) in the windows system log, then write that into an excel file for each instance for each computer.
I receive no errors, but nothing is ever written into the excel file. I set up an echo to make sure it was reaching the correct part of the loop (it does!) and I set a literal entry to see if there was an error with the variables (it didn't write). At this point, I'm at a loss.
' https://technet.microsoft.com/library/ee176684.aspx
' http://blogs.technet.com/b/heyscriptingguy/archive/2009/04/06/how-can-i-check-my-event-logs.aspx
' http://stackoverflow.com/questions/21738159/extracting-error-logs-from-windows-event-viewer
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("H:\Chris Created Stuffs\Windows Stuffs\check_error_41.xlsx")
objExcel.Visible = False
i = 1
x = 0
'On error resume next
'This is the code that will read the computer names off of the
'appropriate spreadhseet
Do Until objExcel.Cells(i, 1).Value = ""
ReDim Preserve strPC(x)
strPC(x) = objExcel.Cells(i, 1).Value
i = i + 1
x = x + 1
Loop
'And this is the code that will write the success or failure
'data in the Excel spreadsheet
Set objSheet1 = objWorkbook.sheets("Missed")
Set objSheet2 = objWorkbook.sheets("Sheet1")
'Set objSheet1 = objExcel.ActiveWorkbook.Worksheets(1)
'Set objSheet2 = objExcel.ActiveWorkbook.Worksheets(2)
f = 1
m = 1
'Set obj = CreateObject("Scripting.FileSystemObject")
For Each strPC In strPC
Set objWMIService = GetObject("winmgmts:\\" & strPC & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_NTLogEvent WHERE LogFile='System'")
If Err.Number <> 0 Then
'objSheet1.Add
objSheet1.Cells(f, 1).Value = strPC
objSheet1.Cells(f, 2).Value = err.number
f = f + 1
Err.clear
Else
For Each objEvent in colItems
If objEvent.EventCode = 41 Then
'writeLog "Event Code: " & objEvent.EventCode
'writeLog "Event Identifier: " & objEvent.EventIdentifier
'writeLog "Logfile: " & objEvent.Logfile
'writeLog "Message: " & objEvent.Message
'writeLog "Record Number: " & objEvent.RecordNumber
'writeLog "Source Name: " & objEvent.SourceName
'writeLog "Time Generated: " & objEvent.TimeGenerated
'writeLog "Time Written: " & objEvent.TimeWritten
'objSheet2.Add
objSheet2.Cells(m,1).Value = strPC
objSheet2.Cells(m,2).Value = objEvent.EventCode
objSheet2.Cells(m,3).Value = objEvent.EventIdentifier
objSheet2.Cells(m,4).Value = objEvent.Logfile
objSheet2.Cells(m,5).Value = objEvent.Message
objSheet2.Cells(m,6).Value = objEvent.RecordNumber
objSheet2.Cells(m,7).Value = objEvent.SourceName
objSheet2.Cells(m,8).Value = objEvent.TimeGenerated
objSheet2.Cells(m,9).Value = objEvent.TimeWritten
objSheet2.Cells(m,10).Value = "Listen!"
m = m + 1
wscript.echo "We Got One!!!!"
Else
m = m + 1
End If
Next
Err.clear
End If
Next
objExcel.ActiveWorkbook.Save
objExcel.Quit
wscript.echo "Done"
I think your primary problem was ignoring the Workbook Object and Worksheet Object. In this code:
Do Until objExcel.Cells(i, 1).Value = ""
ReDim Preserve strPC(x)
strPC(x) = objExcel.Cells(i, 1).Value
i = i + 1
x = x + 1
Loop
Nothing is actually being pulled from the worksheet. I've had to guess a little as to the actual origin but the syntax is correct; you may have to make specific adjustments to your own worksheet layout.
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True 'False
Set objWorkbook = objExcel.Workbooks.Open("H:\Chris Created Stuffs\Windows Stuffs\check_error_41.xlsx")
i = 1
x = 0
'On error resume next
'This is the code that will read the computer names off of the appropriate spreadhseet
Do Until objWorkbook.Worksheets(1).Cells(i, 1).Value = ""
ReDim Preserve strPCs(x)
strPCs(x) = objWorkbook.Worksheets(1).Cells(i, 1).Value
'msgbox objWorkbook.Worksheets(1).Cells(i, 1).Value
i = i + 1
x = x + 1
Loop
'And this is the code that will write the success or failure data in the Excel spreadsheet
Set objSheet1 = objWorkbook.Worksheets("Missed")
Set objSheet2 = objWorkbook.Worksheets("Sheet1")
f = 1
m = 1
For Each strPC In strPCs
Set objWMIService = GetObject("winmgmts:\\" & strPC & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_NTLogEvent WHERE LogFile='System'")
If Err.Number <> 0 Then
'objSheet1.Add
objSheet1.Cells(f, 1).Value = strPC
objSheet1.Cells(f, 2).Value = err.number
f = f + 1
Err.clear
Else
For Each objEvent in colItems
If objEvent.EventCode = 41 Then
'writeLog "Event Code: " & objEvent.EventCode
'writeLog "Event Identifier: " & objEvent.EventIdentifier
'writeLog "Logfile: " & objEvent.Logfile
'writeLog "Message: " & objEvent.Message
'writeLog "Record Number: " & objEvent.RecordNumber
'writeLog "Source Name: " & objEvent.SourceName
'writeLog "Time Generated: " & objEvent.TimeGenerated
'writeLog "Time Written: " & objEvent.TimeWritten
'objSheet2.Add
objSheet2.Cells(m, 1).Value = strPC
objSheet2.Cells(m, 2).Value = objEvent.EventCode
objSheet2.Cells(m, 3).Value = objEvent.EventIdentifier
objSheet2.Cells(m, 4).Value = objEvent.Logfile
objSheet2.Cells(m, 5).Value = objEvent.Message
objSheet2.Cells(m, 6).Value = objEvent.RecordNumber
objSheet2.Cells(m, 7).Value = objEvent.SourceName
objSheet2.Cells(m, 8).Value = objEvent.TimeGenerated
objSheet2.Cells(m, 9).Value = objEvent.TimeWritten
objSheet2.Cells(m, 10).Value = "Listen!"
m = m + 1
'wscript.echo "We Got One!!!!"
'do not add to m on no-write; it only creates blank rows
End If
Next
Err.clear
End If
Next
'objWorkbook.Close True
'objExcel.Quit
wscript.echo "Done"
I've commented out the code lines to make the Excel application object hidden as to save asn close it in order that you can observe the process. Uncomment them once you are happy with the process.
I've looked on many sites, including all the questions that came up when I entered my title, and I can't seem to get my program to work. It activates the spreadsheet, but no data prints.
Option Explicit
Dim objExcel, objWorkbook
Dim strTIN, strName, strFName, strLName, strState, strEmpID, strRecDate, strComment
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\lpeder6\Desktop\Important Info\Data tracking.xlsx")
CopyData
Set objExcel = Nothing
Set objWorkbook = Nothing
'---------------CopyData - Copies required data-----------------
Sub CopyData()
strTIN = "2-123456789-00005"
strName = "Smith John "
strState = "MN"
strEmpID = "S987654321"
strRecDate = "04/02/2015"
strComment = "This is all that is in my comment."
strLName = Trim(Left(strName, 10))
strFName = Trim(Right(strName, 15))
strName = strLName & " " & strFName
objExcel.Visible = True
objWorkbook.Sheets(1).Activate
objWorkbook.Sheets(1).Cells(1, 1).Value = strTIN
objWorkbook.Sheets(1).Cells(1, 2).Value = strName
objWorkbook.Sheets(1).Cells(1, 3).Value = strState
objWorkbook.Sheets(1).Cells(1, 4).Value = strEmpID
objWorkbook.Sheets(1).Cells(1, 5).Value = strRecDate
objWorkbook.Sheets(1).Cells(1, 6).Value = strComment
objExcel.ActiveWorkbook.Close
End Sub
Any ideas will be greatly appreciated.
By 'no data prints', I'm assuming that you mean the data you input is not stored. This is because you are not saving the workbook as you close it. Change one line in the sub to:
objExcel.ActiveWorkbook.Close true
See Workbook.Close Method (Excel) for full syntax reference.
So I have this Auto Email Script, it all works fine but the problem I am having is that when an email pops up that isn't valid it will error out and quit, what I am wondering is, is there a way to tell it if there is an error skip that record and move onto the next one?
Set objMessage = CreateObject("CDO.Message")
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("##############").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 4
email = sh.Range("A" & row)
LastRow = sh.UsedRange.Rows.Count
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim f
Set f = fso.OpenTextFile("#####################.txt", ForReading)
BodyText = f.ReadAll
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
email = sh.Range("A" & row)
sh.Range("I" & row).Value = "Sent"
row = row + 1
End if
If email = "" Then
Wscript.Quit
End if
objMessage.Subject = "Billing: Meter Read"
objMessage.From = "################"
objMessage.To = email
objMessage.TextBody = BodyText
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "################"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
Next
wb.Save
f.Close
Set f = Nothing
Set fso = Nothing
wb.Close
End If
Next
It's still not clear to me what you mean by "invalid address". If you mean a malformed address you could validate it e.g. with a regular expression:
Set re = New RegExp
re.Pattern = "^[a-z0-9][a-z0-9._]*#[a-z][a-z0-9-]*\.[a-z]+$"
re.IgnoreCase = True
If re.Test(email) Then
'send mail
End If
Note that the expression above is rather conservative and covers only a safe subset of all potentially valid addresses.
If you mean that an address is rejected by your mail server you need to enable error handling for objMessage.Send as #mehow suggested:
On Error Resume Next
objMessage.Send
If Err Then WScript.Echo Hex(Err.Number) & ": " & Err.Description
On Error Goto 0