I used to use below VBscript to send files by mail as attachments to be able to add my signature in the e-mail message.
Since about two weeks the VBscript is showing an error every time I try to send a file. I tried to use normal "send to/mail recipient" and it works fine.
Would you advice how can this be solved?
Code:
Option Explicit
Dim objArgs, OutApp, oNameSpace, oInbox, oEmailItem, olMailItem
Dim a, oAttachments, subjectStr, olFormatHTML
olMailItem = 0
olFormatHTML = 2
Set objArgs = WScript.Arguments 'gets paths of selected files
Set OutApp = CreateObject("Outlook.Application") 'opens Outlook
Set oEmailItem = OutApp.CreateItem(olMailItem) 'opens new email
For a = 0 to objArgs.Count - 1
Set oAttachments = oEmailItem.Attachments.Add(objArgs(a))
subjectStr = subjectStr & Right(objArgs(a),Len(objArgs(a))-(InStrRev(objArgs(a),"\"))) & ", " 'recreates the default Subject e.g. Emailing: file1.doc, file2.xls
Next
If subjectStr = "" then subjectStr = "No Subject "
oEmailItem.Subject = "Emailing: " & Left(subjectStr, (Len(subjectStr)-2))
oEmailItem.BodyFormat = olFormatHTML
oEmailItem.Display
Error message:
Unable to execute - arguments list is too long
I have a vbscript ,which sends the folder contents as attachments to my email but the problem is i am unable to specify the path of windows folder because the windows path is different for different computers.
In my code following works
Const PATH = "C:\windows\Folder1\"
but since path is different for different machines. i tried following but no success
Const PATH = "%windows%\Folder1\"
Here is the full vbscript code
Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
Set objMessage = CreateObject("CDO.Message")
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFolder
Dim oFile
Dim oFiles
Const PATH = "%windows%\Folder\" 'This method not working!!!!!
Set oFolder = fso.GetFolder(PATH)
Set oFiles= oFolder.files
objMessage.Subject = "This is the email subject"
objMessage.From = "mailSender#MyMail.com"
objMessage.To = ""
objMessage.TextBody = "This is the body of the email. I’m fairly unoriginal"
For Each oFile in oFolder.files
objMessage.AddAttachment PATH & oFile.name
Next
'==This section will provide the configuration information for the remote SMTP server.
'==End remote SMTP server configuration section==
objMessage.Send
when the configuration information for the remote SMTP server the code works perfectly.
how will i specify the windows,programfiles,desktop(special folders) in this script??
>> WScript.Echo CreateObject("WScript.Shell").ExpandEnvironmentStrings("%windir%")
>>
C:\WINDOWS
>> WScript.Echo CreateObject("WScript.Shell").SpecialFolders("Desktop")
>>
C:\Documents and Settings\eh\Desktop
UPDATE:
sample usage:
Option Explicit
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
'Your problem in a nutshell
'Const PATH = "c:\windows\system" ' fails on systems with %windir% <> c:\windows
'Const PATH = "%windir%\system" ' fails with "Path not found" (FSO does not expand env vars)
Dim goWS : Set goWS = CreateObject("WScript.Shell")
' PATH can't be a Const, because Consts can be initialized with literals only
' I use the prefix "cs" to indicate "constant string - keep your fingers off!"
Dim csPATH : csPATH = goWS.ExpandEnvironmentStrings("%windir%\system")
Dim csDESKT : csDESKT = goWS.SpecialFolders("desktop")
WScript.Echo "# of files in system folder:", goFS.GetFolder(csPATH).Files.Count
WScript.Echo "# of files in desktop:", goFS.GetFolder(csDESKT).Files.Count
output:
cscript specfolders.vbs
# of files in system folder: 27
# of files in desktop: 49
Due to windows security architecture its not a good practice to do as you are trying. I would start from SpecialDirectories Class : http://msdn.microsoft.com/en-us/library/Microsoft.VisualBasic.FileIO.SpecialDirectories.aspx
If your objective is to send email with attachment? I will use the following example :
Public Shared Function SendMail(strFrom As String, strTo As String, strSubject As String, strMsg As String) As Boolean
Try
' Create the mail message
Dim objMailMsg As New MailMessage(strFrom, strTo)
objMailMsg.BodyEncoding = Encoding.UTF8
objMailMsg.Subject = strSubject
objMailMsg.Body = strMsg
Dim at As New Attachment(Server.MapPath("~/Uploaded/txt.doc"))
objMailMsg.Attachments.Add(at)
objMailMsg.Priority = MailPriority.High
objMailMsg.IsBodyHtml = True
'prepare to send mail via SMTP transport
Dim objSMTPClient As New SmtpClient()
objSMTPClient.DeliveryMethod = SmtpDeliveryMethod.PickupDirectoryFromIis
objSMTPClient.Send(objMailMsg)
Return True
Catch ex As Exception
Throw ex
End Try
End Function
Or
If you want to use folder location to attach the file. Firstly I will not use c:\windows\folder1 as a location for files. As this folder contains all your/clients system files and you might run into security issues.
Insert the following code :
Your code
\\ Const PATH = "%windows%\Folder\" 'This method not working!!!!!
\\ Set oFolder = fso.GetFolder(PATH)
Use the following
string PATH = My.Computer.FileSystem.SpecialDirectories.MyDocuments
Returns the string "C:\Users\Owner\Documents". here you can add new folder in above code. use concatenation like this & "\" & "Folder1"
Hope this is helpful...
I am confused on what I am doing wrong here...
<script language="javascript" runat="server">
function GMTNow(){return new Date().toGMTString()}
</script>
<%
Const AWS_BUCKETNAME = "uk-bucketname"
Const AWS_ACCESSKEY = "GOES HERE"
Const AWS_SECRETKEY = "SECRET"
LocalFile = Server.Mappath("/test.jpg")
Dim sRemoteFilePath
sRemoteFilePath = "/files/test.jpg" 'Remote Path, note that AWS paths (in fact they aren't real paths) are strictly case sensitive
Dim strNow
strNow = GMTNow() ' GMT Date String
Dim StringToSign
StringToSign = Replace("PUT\n\nimage/jpeg\n\nx-amz-date:" & strNow & "\n/"& AWS_BUCKETNAME & sRemoteFilePath, "\n", vbLf)
Dim Signature
Signature = BytesToBase64(HMACSHA1(AWS_SECRETKEY, StringToSign))
Dim Authorization
Authorization = "AWS " & AWS_ACCESSKEY & ":" & Signature
Dim AWSBucketUrl
AWSBucketUrl = "http://s3.amazonaws.com/" & AWS_BUCKETNAME
With Server.CreateObject("Microsoft.XMLHTTP")
.open "PUT", AWSBucketUrl & sRemoteFilePath, False
.setRequestHeader "Authorization", Authorization
.setRequestHeader "Content-Type", "image/jpeg"
.setRequestHeader "Host", AWS_BUCKETNAME & ".s3.amazonaws.com"
.setRequestHeader "x-amz-date", strNow
.send GetBytes(LocalFile) 'Get bytes of local file and send
If .status = 200 Then ' successful
Response.Write "<a href="& AWSBucketUrl & sRemoteFilePath &" target=_blank>Uploaded File</a>"
Else ' an error ocurred, consider xml string of error details
Response.ContentType = "text/xml"
Response.Write .responseText
End If
End With
Function GetBytes(sPath)
dim fs,f
set fs=Server.CreateObject("Scripting.FileSystemObject")
set f=fs.GetFile(sPath)
GetBytes = f.Size
set f=nothing
set fs=nothing
End Function
Function BytesToBase64(varBytes)
With Server.CreateObject("MSXML2.DomDocument").CreateElement("b64")
.dataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64 = .Text
End With
End Function
Function HMACSHA1(varKey, varValue)
With Server.CreateObject("System.Security.Cryptography.HMACSHA1")
.Key = UTF8Bytes(varKey)
HMACSHA1 = .ComputeHash_2(UTF8Bytes(varValue))
End With
End Function
Function UTF8Bytes(varStr)
With Server.CreateObject("System.Text.UTF8Encoding")
UTF8Bytes = .GetBytes_4(varStr)
End With
End Function
%>
Now getting the error.
msxml3.dll error '800c0008'
The download of the specified resource has failed.
/s3.asp, line 39
I'd like to explain how S3 Rest Api works as far as I know.First, you need to learn what should be the string to sign Amazon accepts.
Format :
StringToSign = HTTP-Verb + "\n" +
Content-MD5 + "\n" +
Content-Type + "\n" +
Date + "\n" +
CanonicalizedAmzHeaders +
CanonicalizedResource;
Generating signed string :
Signature = Base64( HMAC-SHA1( YourSecretAccessKeyID, UTF-8-Encoding-Of( StringToSign ) ) );
Passing authorization header:
Authorization = "AWS" + " " + AWSAccessKeyId + ":" + Signature;
Unfortunately you'll play byte to byte since there is no any SDK released for classic asp. So, should understand by reading the entire page http://docs.amazonwebservices.com/AmazonS3/latest/dev/RESTAuthentication.html
For string to sign as you can see above in format, there are three native headers are reserved by the API. Content-Type, Content-MD5 and Date. These headers must be exists in the string to sign even your request hasn't them as empty without header name, just its value. There is an exception, Date header must be empty in string to sign if x-amz-date header is already exists in the request. Then, If request has canonical amazon headers, you should add them as key-value pairs like x-amz-headername:value. But, there is another exception need to be considered for multiple headers. Multiple headers should combine to one header with values comma separated.
Correct
x-amz-headername:value1,value2
Wrong
x-amz-headername:value1\n
x-amz-headername:value2
Most importantly, headers must be ascending order by its group in the string to sign. First, reserved headers with ascending order, then canonical headers with ascending order.
I'd recommend using DomDocument functionality to generate Base64 encoded strings.
Additionally instead of a Windows Scripting Component (.wsc files), you could use .Net's interops such as System.Security.Cryptography to generating keyed hashes more effectively with power of System.Text. All of these interoperabilities are available in today's IIS web servers.
So, as an example I wrote the below script just sends a file to bucket you specified. Consider and test it.
Assumed local file name is myimage.jpg and will be uploaded with same name to root of the bucket.
<script language="javascript" runat="server">
function GMTNow(){return new Date().toGMTString()}
</script>
<%
Const AWS_BUCKETNAME = "uk-bucketname"
Const AWS_ACCESSKEY = "GOES HERE"
Const AWS_SECRETKEY = "SECRET"
LocalFile = Server.Mappath("/test.jpg")
Dim sRemoteFilePath
sRemoteFilePath = "/files/test.jpg" 'Remote Path, note that AWS paths (in fact they aren't real paths) are strictly case sensitive
Dim strNow
strNow = GMTNow() ' GMT Date String
Dim StringToSign
StringToSign = Replace("PUT\n\nimage/jpeg\n\nx-amz-date:" & strNow & "\n/"& AWS_BUCKETNAME & sRemoteFilePath, "\n", vbLf)
Dim Signature
Signature = BytesToBase64(HMACSHA1(AWS_SECRETKEY, StringToSign))
Dim Authorization
Authorization = "AWS " & AWS_ACCESSKEY & ":" & Signature
Dim AWSBucketUrl
AWSBucketUrl = "https://" & AWS_BUCKETNAME & ".s3.amazonaws.com"
With Server.CreateObject("MSXML2.ServerXMLHTTP.6.0")
.open "PUT", AWSBucketUrl & sRemoteFilePath, False
.setRequestHeader "Authorization", Authorization
.setRequestHeader "Content-Type", "image/jpeg"
.setRequestHeader "Host", AWS_BUCKETNAME & ".s3.amazonaws.com"
.setRequestHeader "x-amz-date", strNow
.send GetBytes(LocalFile) 'Get bytes of local file and send
If .status = 200 Then ' successful
Response.Write "<a href="& AWSBucketUrl & sRemoteFilePath &" target=_blank>Uploaded File</a>"
Else ' an error ocurred, consider xml string of error details
Response.ContentType = "text/xml"
Response.Write .responseText
End If
End With
Function GetBytes(sPath)
With Server.CreateObject("Adodb.Stream")
.Type = 1 ' adTypeBinary
.Open
.LoadFromFile sPath
.Position = 0
GetBytes = .Read
.Close
End With
End Function
Function BytesToBase64(varBytes)
With Server.CreateObject("MSXML2.DomDocument").CreateElement("b64")
.dataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64 = .Text
End With
End Function
Function HMACSHA1(varKey, varValue)
With Server.CreateObject("System.Security.Cryptography.HMACSHA1")
.Key = UTF8Bytes(varKey)
HMACSHA1 = .ComputeHash_2(UTF8Bytes(varValue))
End With
End Function
Function UTF8Bytes(varStr)
With Server.CreateObject("System.Text.UTF8Encoding")
UTF8Bytes = .GetBytes_4(varStr)
End With
End Function
%>
The Amazon Signature must be url encoded in a slightly different way to what VBSCript encodes. The following function will encode the result correctly:
JScript Version:
function amazonEncode(s)
{
return Server.UrlEncode(s).replace(/\+/g,"%20").replace(/\%2E/g,".").replace(/\%2D/g,"-").replace(/\%7E/g,"~").replace(/\%5F/g,"_");
}
VBScript Version:
function amazonEncode(s)
dim retval
retval = Server.UrlEncode(s)
retval = replace(retval,"+","%20")
retval = replace(retval,"%2E",".")
retval = replace(retval,"%2D","-")
retval = replace(retval,"%7E","~")
retval = replace(retval,"%5F","_")
amazonEncode = retval
end function
As for base64, I used .NET's already built functionality for it. I had to create a DLL to wrap it, so that I could use it from JScript (or VBScript).
Here's how to create that dll:
Download the free C# 2010 Express and install it.
You also need to use two other tools that you won’t have a path to, so you will need to add the path to your PATH environment variable, so at a cmd prompt search for regasm.exe, guidgen.exe and sn.exe (you might find several versions – select the one with the latest date).
• cd\
• dir/s regasm.exe
• dir/s sn.exe
• dir/s guidgen.exe
So as an example, a COM object that has just one method which just returns “Hello”:
Our eventual aim is to use it like this:
<%#Language=JScript%>
<%
var x = Server.CreateObject("blah.whatever");
Response.Write(x.someMethod());
%>
or
<%#Language=VBScript%>
<%
dim x
set x = Server.CreateObject("blah.whatever")
Response.Write x.someMethod()
%>
• Start C# and create a new project
• Select “Empty Project”
• Give it a name – this becomes the namespace by default (the blah in the sample above)
• Next save the project (so you know where to go for the next bit). This will create a folder structure like so:
o blah this contains your solution files that the editor needs (blah.sln etc)
blah this contains your source code and project files
• bin
o Debug the compiled output ends up here
• Next, using the cmd console, navigate to the root blah folder and create a key pair file:
sn –k key.snk
• Next you need a unique guid (enter guidgen at the cmd prompt)
o Select registry format
o Click “New Guid”
o Click “Copy”
• Back to C# editor – from the menu, select Project – Add Class
• Give it a name – this is the whatever in the sample above
• After the opening brace just after the namespace line type:
[GuidAttribute(“paste your guid here”)]
remove the curly brackets from your pasted guid
• You will need to add another “using” at the top
using System.Runtime.InteropServices;
• Finally you need to create someMethod
The final C# code looks like this (the bits in red may be different in your version):
using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;
using System.Runtime.InteropServices;
namespace blah
{
[GuidAttribute("AEF4F27F-9E97-4189-9AD5-64386A1699A7")]
public class whatever
{
public string someMethod()
{
return "Hello";
}
}
}
• Next, from the menu, select Project – Properties
o On the left, select Application and, for the Output type dropdown, select “Class Library”
o On the left, select Signing and tick the “Sign the assembly” box, then browse to the key.snk file you made earlier
o Save the properties (CTRL-S)
• Next build the dll (Press F6) – This will create a dll in the Debug folder
• Open a cmd window as administrator (right click cmd.exe and select “Run as Administrator”)
• Navigate to the Debug folder and enter the following to register the assembly:
regasm blah.dll /tlb:blah.tlb /codebase blah
That’s it – the above is a genuine COM component and will work in other applications, the example below allows for event handling and only really works in ASP due to the default property mechanism of ASP:
The code for the base64 stuff would be:
// returns a base 64 encoded string that has been encrypted with SHA256
// parameters:
// s string to encrypt
// k key to use during encryption
public string getBase64SHA256(string s, string k)
{
HMACSHA256 sha = new HMACSHA256();
System.Text.UTF8Encoding encoding = new System.Text.UTF8Encoding();
sha.Key = encoding.GetBytes(k);
byte[] hashBytes = sha.ComputeHash(encoding.GetBytes(s));
return System.Convert.ToBase64String(hashBytes);
}
// returns a base 64 encoded string that has been encrypted with SHA1
// parameters:
// s string to encrypt
// k key to use during encryption
public string getBase64SHA1(string s, string k)
{
HMACSHA1 sha = new HMACSHA1();
System.Text.UTF8Encoding encoding = new System.Text.UTF8Encoding();
sha.Key = encoding.GetBytes(k);
byte[] hashBytes = sha.ComputeHash(encoding.GetBytes(s));
return System.Convert.ToBase64String(hashBytes);
}
You would need the relevant usings:
using System.Security.Cryptography;
The signature in full must have all the query string name-value pairs in alphabetical order before computing the SHA and base64. Here is my version of the signature creator function:
function buildAmazonSignature(host,req,qstring)
{
var str="", i, arr = String(qstring).split("&");
for (i=0; i<arr.length; i++)
arr[i] = arr[i].split("=");
arr.sort(amazonSortFunc);
for (i=0; i<arr.length; i++)
{
if (str != "")
str += "&";
str += arr[i][0] + "=" + arr[i][1];
}
str = "GET\n"+host+"\n"+req+"\n"+str;
var utils = Server.CreateObject("FMAG.Utils");
var b64 = utils.getBase64SHA256(str, "xxxxxxxxxx");
utils = null;
return amazonEncode(b64);
}
function amazonSortFunc(a,b)
{
return (a[0]<b[0])?-1:((a[0]>b[0])?1:0);
}
VBScript doesn't have a very good array sort facility, so you'll have to work that one out yourself - sorry
Also I have the timestamp in this format:
YYYY-MM-DDTHH:MM:SSZ
Also the stuff in the query string included the following:
AWSAccessKeyId
SignatureMethod
SignatureVersion
Version
Expires
Action
Hope that helps
Thank you so much for this question, it has been such a great help to start my WSH/VBScript for my S3 backup service ;-)
I do not have much time, so I will not go through the details of the things I have changed from Chris' code, but please find below my little prototype script which works perfectly ;-)
This is just a WSH/VBScript, so you do not need IIS to run it, you just need to paste the content in a file with the ".vbs" extension, and you can then directly execute it ;-)
Option Explicit
'-- Amazon Web Services > My Account > Access Credentials > Access Keys --'
Dim strAccessKeyID: strAccessKeyID = "..."
Dim strSecretAccessKey: strSecretAccessKey = "..."
'-- Parameters: --'
Dim strLocalFile: strLocalFile = "..."
Dim strRemoteFile: strRemoteFile = "..."
Dim strBucket: strBucket = "..."
'-- Authentication: --'
Dim strNowInGMT: strNowInGMT = NowInGMT()
Dim strStringToSign: strStringToSign = _
"PUT" & vbLf & _
"" & vbLf & _
"text/xml" & vbLf & _
strNowInGMT & vbLf & _
"/" & strBucket + "/" & strRemoteFile
Dim strSignature: strSignature = ConvertBytesToBase64(HMACSHA1(strSecretAccessKey, strStringToSign))
Dim strAuthorization: strAuthorization = "AWS " & strAccessKeyID & ":" & strSignature
'-- Upload: --'
Dim xhttp: Set xhttp = CreateObject("MSXML2.ServerXMLHTTP")
xhttp.open "PUT", "http://" & strBucket & ".s3.amazonaws.com/" & strRemoteFile, False
xhttp.setRequestHeader "Content-Type", "text/xml"
xhttp.setRequestHeader "Date", strNowInGMT 'Yes, this line is mandatory ;-) --'
xhttp.setRequestHeader "Authorization", strAuthorization
xhttp.send GetBytesFromFile(strLocalFile)
If xhttp.status = "200" Then
WScript.Echo "The file has been successfully uploaded ;-)"
Else
WScript.Echo "There was an error :-(" & vbCrLf & vbCrLf & _
xhttp.responseText
End If
Set xhttp = Nothing
'-- NowInGMT ------------------------------------------------------------------'
Function NowInGMT()
'This is probably not the best implementation, but it works ;-) --'
Dim sh: Set sh = WScript.CreateObject("WScript.Shell")
Dim iOffset: iOffset = sh.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
Dim dtNowGMT: dtNowGMT = DateAdd("n", iOffset, Now())
Dim strDay: strDay = "NA"
Select Case Weekday(dtNowGMT)
Case 1 strDay = "Sun"
Case 2 strDay = "Mon"
Case 3 strDay = "Tue"
Case 4 strDay = "Wed"
Case 5 strDay = "Thu"
Case 6 strDay = "Fri"
Case 7 strDay = "Sat"
Case Else strDay = "Error"
End Select
Dim strMonth: strMonth = "NA"
Select Case Month(dtNowGMT)
Case 1 strMonth = "Jan"
Case 2 strMonth = "Feb"
Case 3 strMonth = "Mar"
Case 4 strMonth = "Apr"
Case 5 strMonth = "May"
Case 6 strMonth = "Jun"
Case 7 strMonth = "Jul"
Case 8 strMonth = "Aug"
Case 9 strMonth = "Sep"
Case 10 strMonth = "Oct"
Case 11 strMonth = "Nov"
Case 12 strMonth = "Dec"
Case Else strMonth = "Error"
End Select
Dim strHour: strHour = CStr(Hour(dtNowGMT))
If Len(strHour) = 1 Then strHour = "0" & strHour End If
Dim strMinute: strMinute = CStr(Minute(dtNowGMT))
If Len(strMinute) = 1 Then strMinute = "0" & strMinute End If
Dim strSecond: strSecond = CStr(Second(dtNowGMT))
If Len(strSecond) = 1 Then strSecond = "0" & strSecond End If
Dim strNowInGMT: strNowInGMT = _
strDay & _
", " & _
Day(dtNowGMT) & _
" " & _
strMonth & _
" " & _
Year(dtNowGMT) & _
" " & _
strHour & _
":" & _
strMinute & _
":" & _
strSecond & _
" +0000"
NowInGMT = strNowInGMT
End Function
'-- GetBytesFromString --------------------------------------------------------'
Function GetBytesFromString(strValue)
Dim stm: Set stm = CreateObject("ADODB.Stream")
stm.Open
stm.Type = 2
stm.Charset = "ascii"
stm.WriteText strValue
stm.Position = 0
stm.Type = 1
GetBytesFromString = stm.Read
Set stm = Nothing
End Function
'-- HMACSHA1 ------------------------------------------------------------------'
Function HMACSHA1(strKey, strValue)
Dim sha1: Set sha1 = CreateObject("System.Security.Cryptography.HMACSHA1")
sha1.key = GetBytesFromString(strKey)
HMACSHA1 = sha1.ComputeHash_2(GetBytesFromString(strValue))
Set sha1 = Nothing
End Function
'-- ConvertBytesToBase64 ------------------------------------------------------'
Function ConvertBytesToBase64(byteValue)
Dim dom: Set dom = CreateObject("MSXML2.DomDocument")
Dim elm: Set elm = dom.CreateElement("b64")
elm.dataType = "bin.base64"
elm.nodeTypedValue = byteValue
ConvertBytesToBase64 = elm.Text
Set elm = Nothing
Set dom = Nothing
End Function
'-- GetBytesFromFile ----------------------------------------------------------'
Function GetBytesFromFile(strFileName)
Dim stm: Set stm = CreateObject("ADODB.Stream")
stm.Type = 1 'adTypeBinary --'
stm.Open
stm.LoadFromFile strFileName
stm.Position = 0
GetBytesFromFile = stm.Read
stm.Close
Set stm = Nothing
End Function
Dear stone-edge-technology-VBScript-mates (*), let me know if it is working for you as well ;-)
(*) This is a reference to the comment from Spudley, see above ;-)
I am having trouble finding clear and reliable examples of connecting to a PostgreSQL database from Excel using VBA ADO. Admittedly, I am new to VBA and most examples and tutorials are very Access or MSSQL centered. (I work mostly in Ruby, Rails, Perl and PostgreSQL.)
I am looking for code to connect and return a simple query (SELECT * FROM customers;) to an Excel sheet. Connection parameters (server ip, user, pass, database) are located within cells in a separate worksheet.
I appreciate your help and patience.
Code:
Sub ConnectDatabaseTest()
Dim cnn As ADODB.connection
Dim cmd As ADODB.Command
Dim param As ADODB.Parameter
Dim xlSheet As Worksheet
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim i As Integer
' Connection Parameters
Dim strUsername As String
Dim strPassword As String
Dim strServerAddress As String
Dim strDatabase As String
' User:
strUsername = Sheets("CONFIG").Range("B4").Value
' Password:
strPassword = Sheets("CONFIG").Range("B5").Value
' Server Address:
strServerAddress = Sheets("CONFIG").Range("B6").Value
' Database
strDatabase = Sheets("CONFIG").Range("B3").Value
Set xlSheet = Sheets("TEST")
xlSheet.Activate
Range("A3").Activate
Selection.CurrentRegion.Select
Selection.ClearContents
Range("A1").Select
Set cnn = New ADODB.connection
sConnString = "DRIVER={PostgreSQL Unicode};DATABASE=" & strDatabase & ";SERVER=" & strServerAddress & _
";UID=" & strUsername & ";PWD=" & strPassword
cnn.Open sConnString
cmd.ActiveConnection = cnn
Dim strSQL As String
strSQL = "SELECT * FROM customers"
cmd.CommandType = ADODB.CommandTypeEnum.adCmdText
cmd.ActiveConnection = cnn
cmd.CommandText = strSQL
...
It seems to break here: cmd.ActiveConnection = cnn
EDIT: added sample code.
EDIT: sConnString gets set to:
DRIVER={PostgreSQL35W};DATABASE=my_database;SERVER=1.2.3.4;UID=analyst;PWD=sekrit
UPDATE 2/7: I changed the 'DRIVER' parameter in the connection string:
sConnString = "DRIVER={PostgreSQL Unicode};DATABASE=" & strDatabase & ";SERVER=" & strServerAddress & _
";UID=" & strUsername & ";PWD=" & strPassword & ";"
...and I get a different error: 'Run-time error 91: Object variable or With block variable not set'
Hm. Ideas?
I wan't using a DSN as I am using an ODBC driver as opposed to OLE DB. By referencing a DSN, the above code works with very few changes.
See this question for how I found the answer once I began to suspect OLE DB/ODBC to the issue.
Does ADO work with ODBC drivers or only OLE DB providers?
New Code here:
Sub GetCustomers()
Dim oConn As New ADODB.connection
Dim cmd As New ADODB.Command
' Connection Parameters
Dim strUsername As String
Dim strPassword As String
Dim strServerAddress As String
Dim strDatabase As String
' User:
strUsername = Sheets("CONFIG").Range("B4").Value
' Password:
strPassword = Sheets("CONFIG").Range("B5").Value
' Server Address:
strServerAddress = Sheets("CONFIG").Range("B6").Value
' Database
strDatabase = Sheets("CONFIG").Range("B3").Value
oConn.Open "DSN=my_system_dsn;" & _
"Database=" & strDatabase & ";" & _
"Uid=" & strUsername & ";" & _
"Pwd=" & strPassword
Set xlSheet = Sheets("CUSTOMERS")
xlSheet.Activate
Range("A3").Activate
Selection.CurrentRegion.Select
Selection.ClearContents
Range("A1").Select
Dim strSQL As String
strSQL = "SELECT * FROM customers"
cmd.CommandType = ADODB.CommandTypeEnum.adCmdText
cmd.ActiveConnection = oConn
cmd.CommandText = strSQL
Set rs = New ADODB.Recordset
Set rs = cmd.Execute
For i = 1 To rs.Fields.Count
ActiveSheet.Cells(3, i).Value = rs.Fields(i - 1).Name
Next i
xlSheet.Range(xlSheet.Cells(3, 1), _
xlSheet.Cells(3, rs.Fields.Count)).Font.Bold = True
ActiveSheet.Range("A4").CopyFromRecordset rs
xlSheet.Select
Range("A3").Select
Selection.CurrentRegion.Select
Selection.Columns.AutoFit
Range("A1").Select
rs.Close
oConn.Close
Set cmd = Nothing
Set param = Nothing
Set rs = Nothing
Set cnn = Nothing
Set xlSheet = Nothing
End Sub
The System DSN is configured to use the PostgreSQL Unicode driver. I chose not to use OLE DB even though there is a provider available. If you look at PGFoundry, you will see it has many problems and has not been updated in several years.
In the original Code, "PostgreSQL35W" is a DSN name which included the default host and port. When you changed to "PostgreSQL Unicode", it is a driver and your connection string is lacking the value for the port. Remember to access PostgreSQL directly from driver, you need at least 5 parameters:
host
port
userid
password
database
If you are using DSN, some parameters may be defined as default.
Not sure about the details of the actual DB connection, but there is a simple although common mistake with your statement: you need to use 'set' when working with objects:
set cmd.ActiveConnection = cnn
Set cmd = New ADODB.Command
cmd.ActiveConnection = cnn
Forgive me, as I am new to this. I found some code online that I'm using in a console application that can set up a local web server, and serve HTML pages locally. I will post the code - but I need to be able to serve ASP pages and pages with vbscripting. Is it possible with this code below, and if so, what can I add to do so? Since this code is so simple, I'm really hoping to modify it to add ASP/Vbscript, and continue on. Thanks in advance!!
Public ip As String = "127.0.0.1"
Public port As String = "80"
Public rootpath As String = "C:\wwwroot\"
Public defaultpage As String = "default.asp"
Public Sub Main()
Try
Dim hostName As String = Dns.GetHostName()
Dim serverIP As IPAddress = IPAddress.Parse(ip)
Dim tcpListener As New TcpListener(serverIP, Int32.Parse(port))
tcpListener.Start()
Console.WriteLine("Web server started at: " & serverIP.ToString() & ":" & Port)
Dim httpSession As New HTTPSession(tcpListener)
Dim serverThread As New Thread(New ThreadStart(AddressOf httpSession.ProcessThread))
serverThread.Start()
Catch ex As Exception
Console.WriteLine(ex.StackTrace.ToString())
End Try
End Sub
Public Class HTTPSession
Private tcpListener As System.Net.Sockets.TcpListener
Private clientSocket As System.Net.Sockets.Socket
Public Sub New(ByVal tcpListener As System.Net.Sockets.TcpListener)
Me.tcpListener = tcpListener
End Sub
Public Sub ProcessThread()
While (True)
Try
clientSocket = tcpListener.AcceptSocket()
' Socket Information
Dim clientInfo As IPEndPoint = CType(clientSocket.RemoteEndPoint, IPEndPoint)
Console.WriteLine("Client: " + clientInfo.Address.ToString() + ":" + clientInfo.Port.ToString())
' Set Thread for each Web Browser Connection
Dim clientThread As New Thread(New ThreadStart(AddressOf ProcessRequest))
clientThread.Start()
Catch ex As Exception
Console.WriteLine(ex.StackTrace.ToString())
If clientSocket.Connected Then
clientSocket.Close()
End If
End Try
End While
End Sub
Protected Sub ProcessRequest()
Dim recvBytes(1024) As Byte
Dim htmlReq As String = Nothing
Dim bytes As Int32
Try
' Receive HTTP Request from Web Browser
bytes = clientSocket.Receive(recvBytes, 0, clientSocket.Available, SocketFlags.None)
htmlReq = Encoding.ASCII.GetString(recvBytes, 0, bytes)
Console.WriteLine("HTTP Request: ")
Console.WriteLine(htmlReq)
Dim strArray() As String
Dim strRequest As String
strArray = htmlReq.Trim.Split(" ")
' Determine the HTTP method (GET only)
If strArray(0).Trim().ToUpper.Equals("GET") Then
strRequest = strArray(1).Trim
If (strRequest.StartsWith("/")) Then
strRequest = strRequest.Substring(1)
End If
If (strRequest.EndsWith("/") Or strRequest.Equals("")) Then
strRequest = strRequest & defaultPage
End If
strRequest = rootPath & strRequest
sendHTMLResponse(strRequest)
Else ' Not HTTP GET method
strRequest = rootPath & "Error\" & "400.html"
sendHTMLResponse(strRequest)
End If
Catch ex As Exception
Console.WriteLine(ex.StackTrace.ToString())
If clientSocket.Connected Then
clientSocket.Close()
End If
End Try
End Sub
' Send HTTP Response
Private Sub sendHTMLResponse(ByVal httpRequest As String)
Try
' Get the file content of HTTP Request
Dim streamReader As StreamReader = New StreamReader(httpRequest)
Dim strBuff As String = streamReader.ReadToEnd()
streamReader.Close()
streamReader = Nothing
' The content Length of HTTP Request
Dim respByte() As Byte = Encoding.UTF8.GetBytes(strBuff)
'Dim respByte() As Byte = Encoding.ASCII.GetBytes(strBuff)
' Set HTML Header
Dim htmlHeader As String = _
"HTTP/1.0 200 OK" & ControlChars.CrLf & _
"Server: WebServer 1.0" & ControlChars.CrLf & _
"Content-Length: " & respByte.Length & ControlChars.CrLf & _
"Content-Type: " & getContentType(httpRequest) & _
ControlChars.CrLf & ControlChars.CrLf
' The content Length of HTML Header
'Dim headerByte() As Byte = Encoding.ASCII.GetBytes(htmlHeader)
Dim headerByte() As Byte = Encoding.UTF8.GetBytes(htmlHeader)
Console.WriteLine("HTML Header: " & ControlChars.CrLf & htmlHeader)
' Send HTML Header back to Web Browser
clientSocket.Send(headerByte, 0, headerByte.Length, SocketFlags.None)
' Send HTML Content back to Web Browser
clientSocket.Send(respByte, 0, respByte.Length, SocketFlags.None)
' Close HTTP Socket connection
clientSocket.Shutdown(SocketShutdown.Both)
clientSocket.Close()
Catch ex As Exception
Console.WriteLine(ex.StackTrace.ToString())
If clientSocket.Connected Then
clientSocket.Close()
End If
End Try
End Sub
' Get Content Type
Private Function getContentType(ByVal httpRequest As String) As String
If (httpRequest.EndsWith("html")) Then
Return "text/html"
ElseIf (httpRequest.EndsWith("asp")) Then
Return "text/html"
ElseIf (httpRequest.EndsWith("htm")) Then
Return "text/html"
ElseIf (httpRequest.EndsWith("txt")) Then
Return "text/plain"
ElseIf (httpRequest.EndsWith("gif")) Then
Return "image/gif"
ElseIf (httpRequest.EndsWith("jpg")) Then
Return "image/jpeg"
ElseIf (httpRequest.EndsWith("jpeg")) Then
Return "image/jpeg"
ElseIf (httpRequest.EndsWith("pdf")) Then
Return "application/pdf"
ElseIf (httpRequest.EndsWith("pdf")) Then
Return "application/pdf"
ElseIf (httpRequest.EndsWith("doc")) Then
Return "application/msword"
ElseIf (httpRequest.EndsWith("xls")) Then
Return "application/vnd.ms-excel"
ElseIf (httpRequest.EndsWith("ppt")) Then
Return "application/vnd.ms-powerpoint"
Else
Return "text/plain"
End If
End Function
End Class
I think you have two choices.
Stop doing that because its certain to be world of pain and cost.
However if you are determined to try and make it happen then take a look at the ASP Classic Compiler codeplex project.