Repeated 1 mail while sending mail via Thunderbird from Excel - excel

I have created VBA code for sending mails with different attachments to different addresses, via Thunderbird. The code looks correct but while creating particular mail bodies it uses still the first values. And the strange fact is that in the debugging window all looks correct and the values are changing.
$
Option Explicit
Sub SendMailThunder_Click()
Dim strEmpfaenger1 As String
Dim strBetr As String
Dim strBody As String
Dim strFile2 As Variant
Dim strTh As String
Dim strCommand As Variant
Dim Nazev As String
Dim vysledek As Variant
Dim Seznam As Excel.Worksheet
Dim PS As Integer
Dim y As Long
Set Seznam = ThisWorkbook.Worksheets("Ridici")
' number of items in the column
PS = Seznam.Cells(Rows.Count, 11).End(xlUp).Row
With Seznam
For y = 4 To PS
' Name of attachment
Nazev = .Cells(y, 12).Value
' selected email
strEmpfaenger1 = .Cells(y, 15).Value
strBetr = .Range("O1")
strBody = .Range("O2")
strTh = "C:\Users\alois.konecny\AppData\Local\Mozilla Thunderbird\thunderbird.exe"
' path to attachment
cesta = .Range("N1")
' attachment including path
priloha = "\" & Nazev & ".xls"
vysledek = cesta & priloha
strFile2 = vysledek
strCommand = strCommand & " -compose " & "to=" & Chr(34) & strEmpfaenger1 & Chr(34)
strCommand = strCommand & ",subject=" & Chr(34) & strBetr & Chr(34)
strCommand = strCommand & ",body=" & Chr(34) & strBody & Chr(34)
strCommand = strCommand & ",attachment=" & "file:///" & Replace(strFile2, "\", "/")
Shell strTh & strCommand, vbNormalFocus
Next y
End With
End Sub
$

The code is a bit hard to read, but have your tried this:
file://
instead of
file:///

Related

Excel VBA - Save As suggested filename and filepath from a cell value

I have a macro in an Excel Workbook, that is connected to a button that says Export
When I click the button, it triggers the Export XML dialog and I have to manually search for a folder to export it into and enter the filename.
Since the folders in my Documents are named exactly the same as the value of the Cell A24, i would like it to direct itself into the correct folder and suggest me a filename based on the value of the Cell A24 with some extra text behind it.
So far i have this in the VBA:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim POFileName As String
Dim FOFileName As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24")
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22")
POFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath & FOFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath & POFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
This gives me the right filename suggestion, but it doesn't direct me to the folder and goes to Desktop.
Any help would be appriciated!
EDIT:
I tried merging the Strings together a bit more and came up with this:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22") & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
The problem is, that VBA thinks that in:
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
the first Range("A24") belongs to the filename part and doesn't continue on with the filepath. So if the value in A24 was "test", then this suggests saving the xml to Desktop with the filename testttest_report 11 2020

Access VB - Shell string problems

Trying to create the string for use with the Shell command in Access VB. The string works if written in full but if I try to use variables in the string the command does not work even if the use of variables produces exactly the full string, (in the immediate window), that works.
I suspect something is going on in the interpretation of the string version of the code but can't work out what.
Here's the code, I have used CHR(34) to produce the quotation marks that I want to show in the string. Suggestions would be so much appreciated - I don't have much hair left!
Private Sub temp()
Dim strFilePath As String
Dim strFileName As String
Dim strZipFilename As String
Dim strPDFfilename As String
Dim strShellString As String
Dim shell As Object
Dim result As Long
Set shell = CreateObject("WScript.shell")
strFilePath = "E:\Documents\Excel Spreadsheets\Roz Theremas\Access\PDFs"
strFileName = "17-03-31temp"
strZipFilename = strFilePath & "\" & strFileName & ".zip"
strZipFilename = Chr(34) & strZipFilename & Chr(34)
strPDFfilename = strFilePath & "\" & strFileName & ".pdf"
strPDFfilename = Chr(34) & strPDFfilename & Chr(34)
strShellString = Chr(34) & Chr(34) & Chr(34) & "C:\Program Files\7-Zip\7z.exe" & Chr(34) & Chr(34) & " a -tzip " & Chr(34) & strZipFilename & Chr(34) & " " & Chr(34) & strPDFfilename & Chr(34) & Chr(34)
'Non Working shell command
result = shell.Run(strShellString, 0, False)
'Working shell command
result = shell.Run("""C:\Program Files\7-Zip\7z.exe"" a -tzip ""E:\Documents\Excel Spreadsheets\Roz Theremas\Access\PDFs\17-03-31temp.zip"" ""E:\Documents\Excel Spreadsheets\Roz Theremas\Access\PDFs\17-03-31temp.pdf""", 0, False)
'Immediate Window output of strShellString
' """C:\Program Files\7-Zip\7z.exe"" a -tzip ""E:\Documents\Excel Spreadsheets\Roz Theremas\Access\PDFs\17-03-31temp.zip"" ""E:\Documents\Excel Spreadsheets\Roz Theremas\Access\PDFs\17-03-31temp.pdf"""
End Sub
My hair is saved - I worked out the answer! So, for posterity here it is.
I modified strFilePath to put quotes around the two word folder names and removed quotations from around the strZipFilename and strPDFFilename lines. I guess Shell was suffering from a surfeit of quotes.
Whilst modifying it I added a password to the zip file and changed the false to true at the end of the string command so that it would return an error code.
Thanks to anyone who spent time trying to work out what I had done.
Public Sub temp()
Dim strFilePath As String
Dim strFileName As String
Dim strZipFilename As String
Dim strPDFfilename As String
Dim strPassword As String
Dim shell As Object
Dim result As Long
Set shell = CreateObject("WScript.shell")
strPassword = "frog"
strFilePath = "E:\Documents\""Excel Spreadsheets""\""Roz Theremas""\Access\PDFs"
strFileName = "17-03-31temp"
strZipFilename = strFilePath & "\" & strFileName & ".zip"
strPDFfilename = strFilePath & "\" & strFileName & ".pdf"
result = shell.Run("""C:\Program Files\7-Zip\7z.exe"" a -tzip " & "-p" & strPassword & " " & strZipFilename & " " & strPDFfilename, 0, True)

How to fix weird VBA Script error: “Missing ; before statement.”

I am trying to utilize a "dictionary" script that I found to define words in a column. VB throws out that error at me and I am clueless as to how to fix it. AM I using anything that a vba app script could understand? Here is the website that I am using to insert this function into excel: https://script.google.com
Code:
Function DefineWord(wordToDefine As String) As String
' Array to hold the response data.
Dim d() As Byte
Dim r As Research
Dim myDefinition As String
Dim PARSE_PASS_1 As String
Dim PARSE_PASS_2 As String
Dim PARSE_PASS_3 As String
Dim END_OF_DEFINITION As String
'These "constants" are for stripping out just the definitions from the JSON data
PARSE_PASS_1 = Chr(34) & "webDefinitions" & Chr(34) & ":"
PARSE_PASS_2 = Chr(34) & "entries" & Chr(34) & ":"
PARSE_PASS_3 = "{" & Chr(34) & "type" & Chr(34) & ":" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & "text" & Chr(34) & ":"
END_OF_DEFINITION = "," & Chr(34) & "language" & Chr(34) & ":" & Chr(34) & "en" & Chr(34) & "}"
Const SPLIT_DELIMITER = "|"
' Assemble an HTTP Request.
Dim url As String
Dim WinHttpReq As Variant
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
'Get the definition from Google's online dictionary:
url = "http://www.google.com/dictionary/json?callback=dict_api.callbacks.id100&q=" & wordToDefine & "&sl=en&tl=en&restrict=pr%2Cde&client=te"
WinHttpReq.Open "GET", url, False
' Send the HTTP Request.
WinHttpReq.Send
'Print status to the immediate window
Debug.Print WinHttpReq.Status & " - " & WinHttpReq.StatusText
'Get the defintion
myDefinition = StrConv(WinHttpReq.ResponseBody, vbUnicode)
'Get to the meat of the definition
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_1, vbTextCompare))
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_2, vbTextCompare))
myDefinition = Replace(myDefinition, PARSE_PASS_3, SPLIT_DELIMITER)
'Split what's left of the string into an array
Dim definitionArray As Variant
definitionArray = Split(myDefinition, SPLIT_DELIMITER)
Dim temp As String
Dim newDefinition As String
Dim iCount As Integer
'Loop through the array, remove unwanted characters and create a single string containing all the definitions
For iCount = 1 To UBound(definitionArray) 'item 0 will not contain the definition
temp = definitionArray(iCount)
temp = Replace(temp, END_OF_DEFINITION, SPLIT_DELIMITER)
temp = Replace(temp, "\x22", "")
temp = Replace(temp, "\x27", "")
temp = Replace(temp, Chr$(34), "")
temp = iCount & ". " & Trim(temp)
newDefinition = newDefinition & Mid$(temp, 1, InStr(1, temp, SPLIT_DELIMITER) - 1) & vbLf 'Hmmmm....vbLf doesn't put a carriage return in the cell. Not sure what the deal is there.
Next iCount
'Put list of definitions in the Immeidate window
Debug.Print newDefinition
'Return the value
DefineWord = newDefinition
End Function
This looks like visual basic, Google uses Apps script which is essentially javascipt. In Javascript you terminate statements with semicolon, that's what it's looking for.
link here:Google Help Forum

Error assigning string to object

I'm trying to search for a file, in d:\ folder with the name Division_Application_Partner.xlsx where Division Application and Partner are variables holding string values.
This is the code I gave:
Set WorkbookPath = Dir(path & Division + "_" + Application + "_" + TradingPartner + ".xlsx")`enter code here`
It throws an error saying " Compile Error: Type Mismtach "
Is the name of the file im giving wrong
Here's the code:
Dim WorkbookPath As WorkBook
Dim path as String
Division = Range("C11").Value
Application = Range("C15").Value
TradingPartner = Range("C19").Value
path = "d:\"
'MsgBox (path)
'MsgBox (Division)
'MsgBox (Application)
MsgBox (TradingPartner)
If Len(Dir(path & Division & "_" & Application & "_" & TradingPartner & ".xlsx")) = 0 Then
Set WorkbookPath = Division & "_" & Application & "_" & TradingPartner & ".xlsx"
End If
I tried concatenating using & like you suggested. Still it shows the same error.
You try assign string to object, this why you getting an error
Dim WorkbookPath As WorkBook
Better try
Dim myWkb as Workbook
Set myWkb = Workbooks.Open(your_concat_string)
and dont use reserved words
Application
Finally
Sub test()
Dim wkbExternWorkbook As Workbook
Dim strPath As String
Dim strDivision As String, strApplication As String, strTradingPartner As String
strDivision = Range("C11").Value
strApplication = Range("C15").Value
strTradingPartner = Range("C19").Value
strPath = "D:\"
If Len(Dir(strPath & strDivision & "_" & strApplication & "_" & strTradingPartner & ".xlsx")) <> 0 Then
Set wkbExternWorkbook = Workbooks.Open(strPath & strDivision & "_" & strApplication & "_" & strTradingPartner & ".xlsx")
End If
End Sub
I would start with using & exclusively for string concatenation. The use of + is primarily for adding numbers though it can concatenate strings. However, there are all sorts of caveats to that when using option strict and so forth, so you're better off using what was intended.
The other thing you should do is actually output all those variables before attempting to concatenate or pass them to Dir. Something like:
MsgBox "[" & path & "]"
repeated for all the others as well. The output of that may well point to the problem.
Try this:
Sub test()
Dim application As Variant
Dim division As Variant
Dim WorkbookPath As String
Dim tradingpartner As Variant
Dim path As String
division = Range("C11").Value
application = Range("C15").Value
tradingpartner = Range("C19").Value
path = "d:\"
'MsgBox (path)
'MsgBox (Division)
'MsgBox (Application)
MsgBox (tradingpartner)
If Len(Dir(path & division & "_" & application & "_" & tradingpartner & ".xlsx")) = 0 Then
Workbooks.Add
ActiveWorkbook.SaveAs division & "_" & application & "_" & tradingpartner & ".xlsx"
End If
End Sub
You would first add the workbook and then save it using the created name.

Finding the English definition of a word in VBA

In Excel, if I enter the word "PIZZA" into a cell, select it, and SHIFT+F7, I can get a nice English dictionary definition of my favorite food. Pretty cool.
But I'd like a function that does this. Something like '=DEFINE("PIZZA")'.
Is there a way through VBA scripts to access Microsoft's Research data? I was considering using a JSON parser and a free online dictionary, but it seems like Excel has a nice dictionary built-in. Any ideas on how to access it?
In case VBA's Research object doesn't work out, you can try the Google Dictionary JSON method as so:
First, add a reference to "Microsoft WinHTTP Services".
After you see my mad, JSON parsing skillz, you may also want to add your favorite VB JSON parser, like this one.
Then Create the following Public Function:
Function DefineWord(wordToDefine As String) As String
' Array to hold the response data.
Dim d() As Byte
Dim r As Research
Dim myDefinition As String
Dim PARSE_PASS_1 As String
Dim PARSE_PASS_2 As String
Dim PARSE_PASS_3 As String
Dim END_OF_DEFINITION As String
'These "constants" are for stripping out just the definitions from the JSON data
PARSE_PASS_1 = Chr(34) & "webDefinitions" & Chr(34) & ":"
PARSE_PASS_2 = Chr(34) & "entries" & Chr(34) & ":"
PARSE_PASS_3 = "{" & Chr(34) & "type" & Chr(34) & ":" & Chr(34) & "text" & Chr(34) & "," & Chr(34) & "text" & Chr(34) & ":"
END_OF_DEFINITION = "," & Chr(34) & "language" & Chr(34) & ":" & Chr(34) & "en" & Chr(34) & "}"
Const SPLIT_DELIMITER = "|"
' Assemble an HTTP Request.
Dim url As String
Dim WinHttpReq As Variant
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
'Get the definition from Google's online dictionary:
url = "http://www.google.com/dictionary/json?callback=dict_api.callbacks.id100&q=" & wordToDefine & "&sl=en&tl=en&restrict=pr%2Cde&client=te"
WinHttpReq.Open "GET", url, False
' Send the HTTP Request.
WinHttpReq.Send
'Print status to the immediate window
Debug.Print WinHttpReq.Status & " - " & WinHttpReq.StatusText
'Get the defintion
myDefinition = StrConv(WinHttpReq.ResponseBody, vbUnicode)
'Get to the meat of the definition
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_1, vbTextCompare))
myDefinition = Mid$(myDefinition, InStr(1, myDefinition, PARSE_PASS_2, vbTextCompare))
myDefinition = Replace(myDefinition, PARSE_PASS_3, SPLIT_DELIMITER)
'Split what's left of the string into an array
Dim definitionArray As Variant
definitionArray = Split(myDefinition, SPLIT_DELIMITER)
Dim temp As String
Dim newDefinition As String
Dim iCount As Integer
'Loop through the array, remove unwanted characters and create a single string containing all the definitions
For iCount = 1 To UBound(definitionArray) 'item 0 will not contain the definition
temp = definitionArray(iCount)
temp = Replace(temp, END_OF_DEFINITION, SPLIT_DELIMITER)
temp = Replace(temp, "\x22", "")
temp = Replace(temp, "\x27", "")
temp = Replace(temp, Chr$(34), "")
temp = iCount & ". " & Trim(temp)
newDefinition = newDefinition & Mid$(temp, 1, InStr(1, temp, SPLIT_DELIMITER) - 1) & vbLf 'Hmmmm....vbLf doesn't put a carriage return in the cell. Not sure what the deal is there.
Next iCount
'Put list of definitions in the Immeidate window
Debug.Print newDefinition
'Return the value
DefineWord = newDefinition
End Function
After that, it's just a matter of putting the function in your cell:
=DefineWord("lionize")
via the Research object
Dim rsrch as Research
rsrch.Query( ...
To query, you need the GUID of a valid web service. I haven't been able to find the GUID's for Microsoft's built in service though.

Resources