The following code was written in vbscript and I'm in the process of converting over to visual basic.
On the following line: If Right(LCase(oFile.Name), 3) = "pdf" Then I get the following error: Variable 'Right' is used before it has been assigned a value. A null reference exception could result at runtime. Also is says Object variable or With block variable not set.
To my best of knowledge, I believe it is checking to make sure the filenames right 3 characters are "pdf"?
For Each oFile In oFolder.Files
If Right(LCase(oFile.Name), 3) = "pdf" Then
Data = Replace(oFile.name, ".pdf", "")
Data = Replace(oFile.name, ".PDF", "")
Data = Split(Data, "-")
acct = Data(1)
lob = Data(2)
fileName = clientid & "-" & acct & "-" & lob & "-" & speciesid & "-" & seq & ".pdf"
outputLine = acct & "," & speciesid & "," & lob & "," & oFile.Name & "," & inputDate
oOutFile.WriteLine(outputLine)
End If
Next
You need to put:
Imports Microsoft.VisualBasic
at the beginning of your program. "Right" is a function in this namespace.
http://msdn.microsoft.com/en-us/library/dxs6hz0a(v=vs.80).aspx
Related
My Excel database generates a word document (when a button is clicked) from data the user enters into the database and opens an outlook email with the document attached automatically. When the email pops up with the attachment, the attachment name always has %20 in between the first and last name. I know this is because there is a blank space between the first and last name. Is there a way to remove the %20 and keep the blank space?
My Code
Option Explicit
Sub CreateWordDocuments()
'CREATE A WORD DOCUMENT TO TRANSFER INFORMATION FROM FILTERED
DATA
INTO A WORD TEMPLATE
Dim VSCRow, VSCCol, LastRow, TemplRow, MonthNumber, FromMonth,
ToMonth, DaysOfMonth, FromDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet5
If .Range("B3").Value = Empty Then
MsgBox "Please select the correct template from the drop down
list"
.Range("F4").Select
Exit Sub
End If
TemplRow = .Range("B3").Value ' Set the Template Value
TemplName = .Range("F4").Value ' Set Template Name
MonthNumber = .Range("V4").Value 'Set the Month Number
FromMonth = .Range("W4").Value
ToMonth = .Range("Y4").Value
DaysOfMonth = .Range("AA4").Value
FromDays = .Range("AC4").Value
ToDays = .Range("AF4").Value
DocLoc = Sheet10.Range("F" & TemplRow).Value ' Word Document
Filename
'Open Word Template
On Error Resume Next 'If Word is already open
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
' Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E99999").End(xlUp).Row 'Determine the last Row
For VSCRow = 8 To LastRow
MonthNumber = .Range("X" & VSCRow).Value
DaysOfMonth = .Range("AF" & VSCRow).Value
If TemplName <> .Range("Z" & VSCRow).Value And MonthNumber >=
FromMonth And MonthNumber <= ToMonth And DaysOfMonth >= FromDays
And DaysOfMonth <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc,
ReadOnly:=False) ' Open Template
For VSCCol = 5 To 42 'Move through the colunms for
information
TagName = .Cells(7, VSCCol).Value 'Tag Name
TagValue = .Cells(VSCRow, VSCCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:True,
Wrap:=wdFindContinue
End With
Next VSCCol
If .Range("H4").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".pdf" ' Create full filename and path with
current
workbook
WordDoc.ExportAsFixedFormat OutputFileName:=FileName,
ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & VSCRow).Value = TemplName 'Template Name to use
.Range("AA" & VSCRow).Value = Now
If .Range("S4").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook
Application
Set OutMail = OutApp.CreateItem(0) 'Create The Email
With OutMail
.To = Sheet5.Range("Y" & VSCRow).Value
.Subject = "Performance Metrics Verification, " &
Sheet5.Range("R"
& VSCRow).Value & " - " & Sheet5.Range("S" & VSCRow).Value & ", "
& Sheet5.Range("T" & VSCRow).Value.Body = "Good afternoon, " &
Sheet5.Range("E" & VSCRow).Value & ",here are your " &
Sheet5.Range("R" & VSCRow).Value & " - " &
Sheet5.Range("S" & VSCRow).Value & ", " & Sheet5.Range("T" &
VSCRow).Value & " performance metrics as captured by the WFW
database systems. Please review and sign. Comments may be
included
in the email body. Please return to me by COB " &
Sheet5.Range("AG"
& VSCRow).Value & ", If this date falls on a holiday, return on
the
next business day following the holiday."
.Attachments.Add FileName
.Display 'To send without displaying .Display to .Send
End With
Else
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just
created
End If '3 conditions are met
Next VSCRow
WordApp.Quit
End With
End Sub
Attachment with %20 between name
I got a bunch of PDFs in a folder which must be renamed. They are all built like this: YYYYMMDD_Text.pdf. The system is Windows 7.
I want to insert a - between the dates, so the documents look like:
YYYY-MM-DD_Text.pdf.
This is what I got, but it's not working and I searched a dozen threads but could not find the solution:
Ordner = "C:\xte Stelle\Test Doku"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Fld = fso.GetFolder(Ordner)
For i = 0 To UBound(Arr)
WScript.Echo i & vbTab & Arr(i)
Next
For Each File In Folder.Files
File.Name = Left(File.Name, 4) & "-" & Mid(File.Name, 6) & "-" & Mid(File.Name, 8)
End Sub
Edit:
This is what I got now. I can run it and it does not crash, but does not function either. It simply does nothing. Any idea on that?
Ordner = "C:\xte Stelle\Test Doku"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Fld = fso.GetFolder(Ordner)
Sub test
For Each File In Fld.Files
File.Name = Left(File.Name, 4) & "-" & Mid(File.Name, 5, 2) & "-" & Mid(File.Name, 7)
Next
End Sub
Your code is not only incomplete, but downright broken.
You have an End Sub without a corresponding Sub.
You assign a folder object to the variable Fld, but then enumerate files from a variable Folder.
Your second For Each loop is missing a Next.
The Mid function returns the number of characters defined by the third parameter starting from the position defined by the second parameter. If the third parameter is omitted the substring from the position defined by the third parameter to the end of the string will be returned. Hence your filename reconstruction should look like this:
File.Name = Left(File.Name, 4) & "-" & Mid(File.Name, 5, 2) & "-" & Mid(File.Name, 7)
Note: if you put your code in a procedure or function you need to actually invoke that procedure/function to get the code executed.
So far the code below is what I am using. It is running on a Siemens HMI (IPC477d) but when I test the script out, the error I get is
An Unhandled exception ('Bad File name or number') occurred in HmiRTm.exe[5984].
I want to know where is the mistake in my code.
The line of Code SmartTags(...) is part of the Software within HMI for handling PLC tags coming through. So it's just a variable in the PLC Code. The variable itself will always be a string value. I dont know if this was important but I thought I would throw that out there for anyone wondering what is happening with that line of code.
Sub CreateTXTReport()
'Tip:
' 1. Use the <CTRL+SPACE> or <CTRL+I> shortcut to open a list of all objects and functions
' 2. Write the code using the HMI Runtime object.
' Example: HmiRuntime.Screens("Screen_1").
' 3. Use the <CTRL+J> shortcut to create an object reference.
'Write the code as of this position:
Dim TT,DT
'If(SmartTags("
TT = FormatDateTime(Time,3)
DT = FormatDateTime(Date,0)
Dim fso, MYfile, strFileName, strFullName, strPath
strPath = "D:\txtFiles"
strFileName = "BatchFile_" & DT & "_" & TT & ".txt"
SmartTags("BatchFileName") = strFileName
Const forWriting=1,forReading=2, forAppending=8
Set fso = CreateObject("Scripting.FileSystemObject")
strFullName = fso.BuildPath(strPath,strFileName)
'If (fso.FileExists("D:\txtFiles\" & strFileName)) = True Then
'Set MYfile = fso.OpenTextFile("D:\txtFiles\" & strFileName, forAppending, True)
'Else
'Set MYfile = fso.CreateTextFile("D:\txtFiles\" & strFileName, forWriting, True)
'MYfile.WriteLine DT & "," & TT & "," & "BatchFile"
'End If
If (fso.FileExists(strFullName)) = True Then
Set MYfile = fso.OpenTextFile(strFullName, forAppending, True)
Else
Set MYfile = fso.CreateTextFile(strFullName, forWriting, True)
MYfile.WriteLine DT & "," & TT & "," & "BatchFile"
End If
MYfile.WriteLine(SmartTags("ReportVariable"))
MYfile.Close
PrintReport("BatchFile_" & DT & "_" & TT & ".txt" )
End Sub
I am trying to recursively loop through hundreds of directories, and thousands of JPG files to gather sort the files in new folders by date. So far, I am able to individually GetDetailsOf the files using the Shell NameSpace object, and I am also able to recursively loop through directories using the FileSystemObject. However, when I try to put them together in functions, etc, I am getting nothing back when I try to get the DateTaken attribute from the photo.
Here is my code so far:
sFolderPathspec = "C:\LocationOfFiles"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(sFolderPathspec)
Dim arrFiles()
getInfo(objDir)
Sub getInfo(pCurrentDir)
fileCount = 0
For Each strFileName In pCurrentDir.Files
fileCount = fileCount + 1
Next
ReDim arrFiles(fileCount,2)
i=0
For Each aItem In pCurrentDir.Files
wscript.Echo aItem.Name
arrFiles(i,0) = aItem.Name
strFileName = aItem.Name
strDir = pCurrentDir.Path
wscript.echo strDir
dateVar = GetDatePictureTaken(strFileName, strDir)
'dateVar = Temp2 & "_" & Temp3 & "_" & Temp1
arrFiles(i,1) = dateVar
WScript.echo i & "." & "M:" & monthVar & " Y:" & yearVar
WScript.echo i & "." & strFileName & " : " & arrFiles(i,1) & " : " & dateVar
i=i+1
Next
For Each aItem In pCurrentDir.SubFolders
'wscript.Echo aItem.Name & " passing recursively"
getInfo(aItem)
Next
End Sub
Function GetDatePictureTaken(strFileName, strDir)
Set objShell = CreateObject ("Shell.Application")
Set objCurrFolder = objShell.Namespace(strDir)
'wscript.Echo cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = cstr(objCurrFolder.GetDetailsOf(strFileName, 12))
strFileNameDate = CleanNonDisplayableCharacters(strFileNameDate)
arrDate = split(strFileNameDate, "/")
'''FAILS HERE WITH A SUBSCRIPT OUT OF RANGE ERROR SINCE IT GETS NULL VALUES BACK FROM THE GET DETAILS OF FUNCTION'''
monthVar = arrDate(0)
yearVar = arrDate(1)
dayVar = arrDate(2)
GetDatePictureTaken = monthVar & "\" & dayVar & "\" & yearVar
End Function
Function CleanNonDisplayableCharacters(strInput)
strTemp = ""
For i = 1 to len(strInput)
strChar = Mid(strInput,i,1)
If Asc(strChar) < 126 and not Asc(strChar) = 63 Then
strTemp = strTemp & strChar
End If
Next
CleanNonDisplayableCharacters = strTemp
End Function
The "Subscript out of range" error when accessing arrDate(0) is caused by arrDate being empty (UBound(arrDate) == -1). As a Split on a non-empty string will return an array, even if the separator is not found, and an attempt to Split Null will raise an "Invalid use of Null" error, we can be sure that strFileNameDate is "".
Possible reason for that:
The index of "Date Picture Taken" is 25 (XP) and not 12 (Win 7) - or whatever came to Mr. Gates' mind for Win 8.
The DPT property is not filled in.
Your cleaning function messed it up.
You have to test for strFileNameDate containing a valid date and decide where to put the files without a valid DPT.
P.S. Instead of doing the recursive loopings, you should consider to use
dir /s/b path\*.jpg > pictures.txt
and to process that file.
I'm working on a project to capture various disk performance metrics using VBScript and would like to use a sub procedure with an object as an argument. In the following code samples the object I'm referring to is objitem.AvgDiskQueueLength which will provide a value for the disk queue length. I haven't found a way to make it work since it is recognized as a string and then doesn't capture the value. My goal is to make it easy for anyone to change the counters that are to be captured by only having to make a change in one location(the procedure call argument). The way I'm going about this may not be the best but I'm open to suggestions. The sub procedure call is below.
PerfCounter "Average Disk Queue Length", "disk_queueLength", "objItem.AvgDiskQueueLength"
The following code is the sub procedure.
Sub PerfCounter(CounterDescription, CounterLabel, CounterObject)
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PerfFormattedData_PerfDisk_PhysicalDisk",,48)
args_index = args_index + 1
arrCriteria = split(command_line_args(args_index),",")
strDriveLetter = UCase(arrCriteria(0))
intCriticalThreshold = arrCriteria(1)
intWarningThreshold = arrCriteria(2)
For Each objItem in colItems
With objItem
WScript.Echo "objitem.name = " & objitem.name
If InStr(objItem.Name, strDriveLetter & ":") > 0 Then
intChrLocation = InStr(objItem.Name, strDriveletter)
strInstanceName = Mid(objItem.Name, intChrLocation, 1)
End If
If strDriveLetter = strInstanceName AND InStr(objItem.Name, strDriveLetter & ":") > 0 Then
If intActiveNode = 1 OR Len(intActiveNode) < 1 Then
WScript.Echo "CounterDescription = " & CounterDescription
WScript.Echo "CounterLabel = " & CounterLabel
WScript.Echo "CounterObject = " & CounterObject
If CInt(CounterOjbect) => CInt(intCriticalThreshold) Then
arrStatus(i) = "CRITICAL: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 2
arrExitCode(i) = intExitCode
ElseIf CInt(CounterOjbect) => CInt(intWarningThreshold) AND CInt(CounterObject) < CInt(intCriticalThreshold) Then
arrStatus(i) = "WARNING: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 1
arrExitCode(i) = intExitCode
Else
arrStatus(i) = "OK: " & strDriveLetter & ": " & CounterDescription
arrTrendData(i) = CounterLabel & "=" & CounterObject
intExitCode = 0
arrExitCode(i) = intExitCode
End If
Else
PassiveNode CounterDescription, CounterLabel
End If
End If
End With
Next
i = i + 1
ReDim Preserve arrStatus(i)
ReDim Preserve arrTrendData(i)
ReDim Preserve arrExitCode(i)
End Sub
Why cant you do this...
PerfCounter "Average Disk Queue Length", "disk_queueLength", objItem.AvgDiskQueueLength
To pass an object you have to pass an object, not a string. To make this method work as expected you would have to have the object prior to the procedure call, but in your code example it looks like you are trying to pass an object that you don't have. A working example:
Set objFSO = CreateObject("Scripting.FileSystemObject")
UseFileSystemObject objFSO
Sub UseFileSystemObject( objfso)
'Now I can use the FileSystemObject in this procedure.
End Sub
But calling the UseFileSystemObject procedure like this will not work,
UseFileSystemObject "objFSO"
because you are passing in a string not an object.
The only way I can think of to accomplish what you want is to use a select statement to write the appropriate attribute of the object, something like this.
Call PerfCounter "Average Disk Queue Length", "disk_queueLength", "AvgDiskQueueLength"
Sub PerfCounter(CounterDescription, CounterLabel, CounterObjectAttribute)
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PerfFormattedData_PerfDisk_PhysicalDisk",,48)
For Each objItem in colItems
Select Case CounterObjectAttribute
Case "ObjectAttribute1"
Case "ObjectAttribute2"
Case "AvgDiskQueueLength"
Wscript.Echo objItem.AvgDiskQueueLength
End Select
Next
End Sub
So in the select you would have to add a case for each attribute that can be used, but it would allow you to pass a string into the procedure. I might be way off on this, but I don't know how you can pass an object if you don't have the object first.