I am trying to send some files from a folder to a fixed email address, the files need to be sent in individual emails, the file names are random.
This topic got me started:
Send individual emails to predefined set of people with all files in a folder
I altered the code a tiny bit to suit my needs, but when I run the macro it isn't sending the files. I'm sure its a simple mistake but my knowledge is limited!
This is my code:
Option Explicit
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test"
Const RECIP_A As String = "me#hotmail.com"
Const EMAIL_BODY As String = "Please find attached file. Thanks and Regards, ABC"
Sub SendPDFs()
On Error GoTo ErrorHandler
Dim fileName As String
fileName = Dir(SOURCE_FOLDER)
Do While Len(fileName) > 0
Call CreateEmail(SOURCE_FOLDER & fileName)
fileName = Dir
Loop
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CreateEmail(fileName As String)
Dim olApp As Outlook.Application
Dim msg As Outlook.MailItem
' create email
Set olApp = Outlook.Application
Set msg = olApp.CreateItem(olMailItem)
' set properties
With msg
.Body = EMAIL_BODY
.Recipients.Add (RECIP_A)
.Attachments.Add fileName
.Send
End With
End Function
Ah! The only problem with the code is
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test"
Change that to
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test\"
Now try it. I tried and tested it and it works.
Also ensure that you have added reference to the Outlook object library.
Related
I got this:
"vba runtime error, cannot save the attachment. path does not exist. verify the path is correct"
I use this:
Sub Save_Outlook_Attachements_Calls()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim callfol As Outlook.Folder
Dim salefol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim fPat As String
fPat = ThisWorkbook.Path
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set callfol = ns.Folders("xxx.xxx#xxx.com").Folders("OutlookData").Folders("Calls")
For Each i In callfol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 0 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
For Each at In mi.Attachments
'------------ ------------
at.SaveAsFile (fPat & "\Outlookdata\calls\" & Date & "." & FSO.GetExtensionName(fPat & "\Outlookdata\calls\" & at.Filename))
Next at
End If
End If
Next i
End Sub
It's the Row in the end that gets the error message:
Starting with "at.SaveAsFile (fPat &"
I have checked what the variabel "Fpat" contains, and its "H:\VBA"
So its like it always has been, and the server still called H:
All of that has been working perfect, but suddenly it doesn't?
Its a server map, but i can reach it in the file explorer like normal.
I have restarted the pc :) but error persists.
Any suggestions?
I solved it, i had changed the windows system language to English last week, not just the programs, in which already is in english.
That made the date variable im using to the format 2022/06/20, ie: "/" and that cannot be used in a file name..
i never thought i would find it by my self :)
I am working on a project and I am writing to a file from another file, but I want a .VBS file to say it like TTS. here is the code for that... But
Dim message, sapi
Set sapi=CreateObject("This Text")
sapi.Speak message
And then the words "This Text" will come out of the speakers.
But, I don't want the words "This Text" to come out, I want it to say the words inside a .txt file (tts_text.txt)
So it needs to read a text file and store that in a variable and then the tts should read and say the variable.
Use this to read/learn about the objects and their capabilities:
Option Explicit
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim goVC : Set goVC = CreateObject("SAPI.SpVoice")
goVC.Speak goFS.OpenTextFile(WScript.ScriptFullName).ReadAll()
You can give a try for this vbscript example :
Option Explicit
Dim Contents,File,message
File = "c:\tts_text.txt"
Contents = "It didn’t work after mass shootings at a nightclub in Orlando,"&_
"college campuses in Virginia and Oregon, a church in Charleston,"&_
"or at a movie theater and high school in Colorado."&_
"Or after two lawmakers survived assassination attempts." & vbcrlf &_
"But after a gunman killed 58 people and wounded more than 500 at a Las Vegas concert," & vbcrlf &_
"Democrats are going to try again to revamp the nation’s gun laws."
' We write this contents to the file
WriteTextFile Contents, file, 0
' We read the file contents and we store it into a variable message
message = ReadFileText(File)
' Now we can speak this message with SAPI object
Speak_from_File message
'**********************************************************
Sub Speak_from_File(message)
Dim Voice
Set Voice = CreateObject("SAPI.SpVoice")
Voice.Volume = 100
Voice.Rate = 0
Voice.Speak message
End Sub
'**********************************************************
Sub WriteTextFile(sContent, sPath, lFormat)
'lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath,2,True,lFormat)
.WriteLine sContent
.Close
End With
End Sub
'**********************************************************
Function ReadFileText(sFile)
Dim objFSO,oTS,sText
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oTS = objFSO.OpenTextFile(sFile,1)
sText = oTS.ReadAll
oTS.close
set oTS = nothing
Set objFSO = nothing
ReadFileText = sText
End Function
'**********************************************************
I have a PNG picture in my SQL Server, I'm successfully getting the image and saving it to file.
rs.Open "Select pic from Table", connObj, adOpenDynamic, adLockOptimistic
If rs.RecordCount > 0 Then
If Not IsNull(rs.Fields("pic").Value) Then
Set mstream = New ADODB.Stream
mstream.Type = adTypeBinary
mstream.Open
mstream.Write rs.Fields("pic").Value
mstream.SaveToFile App.Path & "\MyPhoto.jpg", adSaveCreateOverWrite
End If
End If
rs.Close
As you can see I already have my extension as .jpg but I don't think it matters, when I use the image in my vb6 application using LoadPicture() I get an Invalid Picture error. If I open the image and re-save it as jpg or bmp, LoadPicture() works.
So how can I save the picture properly as bmp/jpg?
You might find these two functions useful
Private Function LoadPictureFromBlob(baData() As Byte) As StdPicture
With CreateObject("WIA.Vector")
.BinaryData = baData
Set LoadPictureFromBlob = .Picture
End With
End Function
Private Sub SavePictureToJpg(oPic As StdPicture, sFile As String, Optional ByVal Quality = 80)
Const wiaFormatJPEG As String = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Dim oImg As Object
SavePicture oPic, sFile
Set oImg = CreateObject("WIA.ImageFile")
oImg.LoadFile sFile
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Convert").FilterID
.Filters.Item(1).Properties("FormatID").Value = wiaFormatJPEG
.Filters.Item(1).Properties("Quality").Value = Quality
Set oImg = .Apply(oImg)
End With
On Error Resume Next
Kill sFile
On Error GoTo 0
oImg.SaveFile sFile
End Sub
Just use Set oPic = LoadPictureFromBlob(rs.Fields("pic").Value) to read the .png and then either use built-in SavePicture oPic, App.Path & "\MyPhoto.bmp" to save to .bmp or SavePictureToJpg oPic, App.Path & "\MyPhoto.jpg" for .jpg and decide on the optional quality parameter.
I have a folder C:\test\ that has multiple .txt files which I need to append to one output text file. Using FSO and TextStream I can write the files explicitly with no problem in this manner:
Public Sub test()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Const Path As String = "C:\test\"
Dim helloWorld As Object
Set helloWorld = FSO.CreateTextFile(FileName:=(Path & "helloworld.txt"), OverWrite:=True, Unicode:=False)
helloWorld.WriteLine FSO.GetFile("C:\test\Product_ID_update.txt").OpenAsTextStream(ForReading).ReadAll
helloWorld.WriteLine FSO.GetFile("C:\test\RPT-4475.txt").OpenAsTextStream(ForReading).ReadAll
helloWorld.Close
End Sub
It works perfectly, but I have hundreds of files to append so it would be crazy to type them all out, so I wrote some code to put all the file names into an array, then loop over each index to generate the file path. Here is the code:
Sub Combine_Text_Files2()
Dim InputDirPath As String
InputDirPath = "C:\test\"
Dim InputFileType As String
InputFileType = "*.txt"
Dim OutputDirPath As String
OutputDirPath = "C:\test\"
Dim OutputFileName As String
OutputFileName = "_CombinedOutput.txt"
Dim InputFileName As String
InputFileName = Dir$(InputDirPath & InputFileType)
Dim FileArray() As String
Dim i As Integer: i = 0
Do Until InputFileName = vbNullString
ReDim Preserve FileArray(0 To i)
FileArray(i) = InputFileName
InputFileName = Dir$
i = i + 1
Loop
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim Stream As Object
Set Stream = FSO.CreateTextFile((OutputDirPath & OutputFileName), OverWrite:=True, Unicode:=False)
Dim FileNameAndPath As String
For i = LBound(FileArray) To UBound(FileArray)
FileNameAndPath = (InputDirPath & FileArray(i))
Debug.Print ("Processing: " & FileNameAndPath)
Dim fileToCopy As File
Set fileToCopy = FSO.GetFile(FileNameAndPath)
Dim streamToCopy As TextStream
Set streamToCopy = fileToCopy.OpenAsTextStream(ForReading)
Dim text As String
text = streamToCopy.ReadAll
Stream.WriteLine FSO.GetFile(FileNameAndPath).OpenAsTextStream(ForReading).ReadAll
Debug.Print ("Appended to " & OutputFileName & ": " & FileNameAndPath)
Next i
Stream.Close
End Sub
The FileNameAndPath value gets updated correctly, and as it goes through the first Stream.WriteLine iteration, it appends only the first letter of the first file to the output file, then moves on to the next iteration, and on the next Stream.WriteLine it fails due to Invalid procedure call or argument.
I've been trying to debug this for quite a while but not certain what is causing this. Only thing I can think of that might be causing it is the array, because it's really the only thing that is different AFAIK... Any help would be greatly appreciated!
Additional details
If I comment out the WriteLine call it goes through the entire array, printing all file paths to immediate. As you can see I broke down the original one-liner into multiple steps for debugging.
Replicating it is easy:
Create a C:\test\ directory
Create two or more text files and add text content to each of them
Run the code in the VBE
I found the problem. The problem was not the code, it works fine (though I feel sure could be improved, I'll take it over to Code Review).
The problem was that some of the source files were actually originally Excel documents that became converted to .txt and apparently carried over some meta-data that Notepad ignored, but the VBA compiler did not know what to do with trying to put it into a String.
Lesson learned, perform a sanity check of your source data.
I have a VBS file that I am trying to use to determine what folders and files are in a certain directory. I believe I have the code written correctly, but whenever I try to write out the file or current directory I get a blank text document with nothing but the root directory written out. Any advice would be greatly appreciated.
Dim NewFile
Function GetFolders (strFolderPath)
Dim objCurrentFolder, colSubfolders, objFolder, files
Set objCurrentFolder = objFSO.GetFolder(strFolderPath)
Set colSubfolders = objCurrentFolder.SubFolders
For Each objFolder In colSubfolders
NewFile.WriteLine(" - " & objFolder.Path)
Set files = folder.Files
For each folderIdx In files
NewFile.WriteLine(" - "& folderIdx.Name)
Next
Call GetFolders (objFolder.Path)
Next
End Function
Dim fso, sFolder
Set fso = CreateObject("Scripting.FileSystemObject")
sFolder = Wscript.Arguments.Item(0)
If sFolder = "" Then
Wscript.Echo "No Folder parameter was passed"
Wscript.Quit
End If
Set NewFile = fso.CreateTextFile(sFolder&"\FileList.txt", True)
NewFile.WriteLine(sFolder)
Call GetFolders(sFolder)
NewFile.Close
You haven't payed sufficient attention to your variable naming. Your script is a good example of the reason why all VBScripts should start with the line:-
Option Explicit
This would highlight all the variables that haven't been declared which in turn will point out typos and inconsistencies in variable naming. Here is how I would write it:-
Option Explicit
Dim msFolder : msFolder = Wscript.Arguments.Item(0)
If msFolder = "" Then
Wscript.Echo "No Folder parameter was passed"
Wscript.Quit
End If
Dim mfso : Set mfso = CreateObject("Scripting.FileSystemObject")
Dim moTextStream : Set moTextStream = mfso.CreateTextFile(msFolder & "\FileList.txt", True)
moTextStream.WriteLine(msFolder)
WriteFolders mfso.GetFolder(msFolder)
moTextStream.Close
Sub WriteFolders(oParentFolder)
Dim oFolder
For Each oFolder In oParentFolder.SubFolders
moTextStream.WriteLine(" - " & oFolder.Path)
Dim oFile
For Each oFile In oFolder.Files
moTextStream.WriteLine(" - " & oFile.Name)
Next
WriteFolders oFolder
Next
End Sub