I am trying to use vba/XMLHTTP in an Access 2010 database to upload a file. While it is going through the process and I'm not receiving any errors, nothing ends up on my web site.
Here's the code which is called using:
response = HTTP_FileUpload(ShowName, "www.website_name","POST")
Public Function HTTP_FileUpload(FileName As String, ByVal pUrl As String, _
Optional ByVal pMethod As String = "GET") As String
Dim strResponse As String
On Error GoTo ErrorHandler
Dim xmlStream As Object
Set xmlStream = CreateObject("ADODB.Stream")
xmlStream.Mode = 3 ' //read write
xmlStream.Type = adTypeBinary
xmlStream.Open
xmlStream.LoadFromFile FileName
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.XMLHTTP")
objHttp.Open pMethod, pUrl, False
Debug.Print "file Name is " & FileName & " Size of file is " & xmlStream.Size
objHttp.setRequestHeader "Content-Type", "text/generic"
objHttp.setRequestHeader "Content-Length", xmlStream.Size
objHttp.send
strResponse = objHttp.responseText
HTTP_FileUpload = strResponse
Set objHttp = Nothing
Exit Function
ErrorHandler:
MsgBox "Error - code is " & Err.Number & " - " & Err.Description
End Function
Related
I am using the code from Mark Bertenshaw's post: VB6 -- using POST & GET from URL and displaying in VB6 Form
On 32 Bit development machine Mark's code works fine. But on my 64 Bit machine it Gives an out of memory error at the code:
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
The returned data from the http request is very simple {"response": 2}, or {"response": 6} etc.
On the 32bit machine it is loading scrrun.dll from system32 folder but on 64bit machine it is loading from sysWOW64 folder (in the references).
Is it that that is causing the issue as I think the Memory error message is a red herring?
User Control (HTTPService)
Option Explicit
Private Const m_ksProperty_Default As String = ""
Private m_sHost As String
Private m_nPort As Long
Private m_sPath As String
Private m_dctQueryStringParameters As Scripting.Dictionary
Private m_sOutput As String
' Ensure that all parts of the query string are deleted.
Public Sub ClearQueryString()
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
' Executes "GET" method for URL.
Public Function Get_() As String
' Read in data from URL. UserControl_AsyncReadComplete will fire when finished.
UserControl.AsyncRead "http://" & m_sHost & ":" & CStr(m_nPort) & "" & m_sPath & "?" & GetQueryString(), vbAsyncTypeByteArray, m_ksProperty_Default, vbAsyncReadSynchronousDownload
' Return the contents of the buffer.
Get_ = m_sOutput
' Clear down state.
m_sOutput = vbNullString
End Function
' Returns query string based on dictionary.
Private Function GetQueryString() As String
Dim vName As Variant
Dim sQueryString As String
For Each vName In m_dctQueryStringParameters
sQueryString = sQueryString & CStr(vName) & "=" & m_dctQueryStringParameters.Item(vName) & "&"
Next vName
GetQueryString = Left$(sQueryString, Len(sQueryString) - 1)
End Function
' Sets the remote host.
Public Property Let Host(ByVal the_sValue As String)
m_sHost = the_sValue
End Property
' Sets the directory and filename part of the URL.
Public Property Let Path(ByVal the_sValue As String)
m_sPath = the_sValue
End Property
' Sets the port number for this request.
Public Property Let Port(ByVal the_nValue As Long)
m_nPort = the_nValue
End Property
' Sets a name/value pair in the query string. Supports duplicate names.
Public Property Let QueryStringParameter(ByVal the_sName As String, ByVal the_sValue As String)
m_dctQueryStringParameters.Item(the_sName) = the_sValue
End Property
' Fired when the download is complete.
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
' Gets the data from the internet transfer.
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
End Sub
Private Sub UserControl_Initialize()
' Initialises the scripting dictionary.
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
Calling it from:
Button Code
Private Sub cmdCheckNow_Click()
On Error GoTo err_trap
Call hideCheckNow
QProGIF1.Visible = True
Call DeleteUrlCacheEntry("http://mysite.co.uk/mobicleanud/chkupdates.php")
DoEvents
HttpService.Host = "mysite.co.uk"
HttpService.Port = 80
HttpService.Path = "/thefolder/chkupdates.php"
HttpService.QueryStringParameter("license") = licensekey
HttpService.QueryStringParameter("vers") = "SOFTWARE2"
HttpService.QueryStringParameter("appmajor") = App.Major
HttpService.QueryStringParameter("appminor") = App.Minor
HttpService.QueryStringParameter("apprevis") = App.Revision
txtOutput.Text = HttpService.Get_
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "9" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (9) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "8" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (8) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "7" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (7) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "6" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (6) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
QProGIF1.Visible = False
If txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "2" & "})" Then
lblchecked.Caption = "Your License was validated and there is a new version of Mobiclean Pro available to Download and Install."
lblchecked.Visible = True
QProGIF1.Visible = False
DoEvents
cmdGet.Visible = True
Exit Sub
End If
If txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "3" & "})" Then
lblchecked.Caption = "Your License was validated. You have the latest version of Mobiclean Pro - No Update available."
lblchecked.Visible = True
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
exit_sub:
Exit Sub
err_trap:
frmError.lblErrorMessage.Caption = "An error has occurred - Code: " & Err.Number & " Description: " & Err.description
frmError.Show vbModal
Resume exit_sub
End Sub
Just can't find what is causing the issue.
Error Message is
Out of Memory
If built on On 64Bit Win 10
No error message if built on 32Bit win 10 and reads file and continues no problem
I am working on Classic Asp with VBScript. I am trying to display list of files from a directory with download option. like,
When i click on the download link the corresponding file need to be download for that i have used the following code like,
<html>
<head>
<title> My First ASP Page </title>
</head>
<body>
<%
Dim fso
Dim ObjFolder
Dim ObjOutFile
Dim ObjFiles
Dim ObjFile
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("F:\karthik")
'Creating an Output File to write the File Names
Set ObjOutFile = fso.CreateTextFile("F:\WindowsFiles.txt")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Writing Name and Path of each File to Output File
Response.Write("<table cellpadding=""4"" cellspacing=""5"" >")
For Each ObjFile In ObjFiles
Response.Write("<tr><td>"&ObjFile.Name & String(50 - Len(ObjFile.Name), " ")&"</td><td>Download</td></tr>")
Next
Response.Write("</table>")
ObjOutFile.Close
%><br>
<script language="vbscript" type="text/vbscript">
Sub HTTPDownload( myURL, myPath )
' Standard housekeeping
Dim i, objFile, objFSO, objHTTP, strFile, strMsg
Const ForReading = 1, ForWriting = 2, ForAppending = 8
' Create a File System Object
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
' Check if the specified target file or folder exists,
' and build the fully qualified path of the target file
If objFSO.FolderExists( myPath ) Then
strFile = objFSO.BuildPath( myPath, Mid( myURL, InStrRev( myURL, "/" ) + 1 ) )
ElseIf objFSO.FolderExists( Left( myPath, InStrRev( myPath, "\" ) - 1 ) ) Then
strFile = myPath
Else
WScript.Echo "ERROR: Target folder not found."
Exit Sub
End If
' Create or open the target file
Set objFile = objFSO.OpenTextFile( strFile, ForWriting, True )
' Create an HTTP object
Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" )
' Download the specified URL
objHTTP.Open "GET", myURL, False
objHTTP.Send
' Write the downloaded byte stream to the target file
For i = 1 To LenB( objHTTP.ResponseBody )
objFile.Write Chr( AscB( MidB( objHTTP.ResponseBody, i, 1 ) ) )
Next
' Close the target file
objFile.Close( )
End Sub
</script>
</body>
</html>
It seems you are trying to do this on the server-side using client-side scripting. Here is a better solution that uses server-side ASP to send the file. You will need to split your code over two pages.
Your current script should be replaced with this:
<html>
<head>
<title> My First ASP Page </title>
</head>
<body>
<% Dim fso
Dim ObjFolder
Dim ObjOutFile
Dim ObjFiles
Dim ObjFile
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("F:\karthik")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Writing Name and Path of each File to Output File
Response.Write("<table cellpadding=""4"" cellspacing=""5"" >")
For Each ObjFile In ObjFiles
Response.Write("<tr><td>"&ObjFile.Name & String(50 - Len(ObjFile.Name), " ")&"</td><td>Download</td></tr>")
Next
Response.Write("</table>")
%><br>
</body>
</html>
Then you need to create another script which I have called download.asp which handles the download:
<%
Dim objConn, strFile
Dim intCampaignRecipientID
strFile = Request.QueryString("file")
If strFile <> "" Then
Response.Buffer = False
Dim objStream
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile("F:\karthik\" & strFile)
Response.ContentType = "application/x-unknown"
Response.Addheader "Content-Disposition", "attachment; filename=" & strFile
Response.BinaryWrite objStream.Read
objStream.Close
Set objStream = Nothing
End If
%>
I like this solution, but users can see the downloads in the history, or modify the querystring. This solution can be modified for POST usage this way:
in the page code modify the link:
FileName`
and further down
<form id="frm2dl" action="download.asp" method="post"><input type="hidden" id="file2dl" name="file2dl" value="" /></form>
then in your javascript file get the filename:
function getfile(obj) {
var f=obj.innerText;
$("#frm2dl #file2dl").val(f);
$("#frm2dl").submit();
}
alternately you could use a file ID then in the download.asp have a lookup function from ID to filename.
Then in the download.asp use request.form("file2dl") instead of request.querystring.
UPDATE:
Also, depending on server version you might get the 4MB limit (I have to work with Microsoft-IIS/7.5 on intranet). Therefore for large files the code will not work. Here is my improved version:
Dim strFileName, strFilePath, objFSO, objStream, objFile, intFileSize
Const lChkSize = 524288 ' 500KB - server typical limit is 4MB
'If session("loggedIn") = True Then ' insert your logon validation code here. bypassed for testing
strFileName = request.form("file2dl")
strFilename = Replace(strFilename,"..","") ' prevent parent path navigation - also ensure uploaded files do not contain this sequence
strFilename = Replace(strFilename,"/","") ' prevent path navigation
strFilename = Replace(strFilename,"\","") ' filenames should already be cleaned by a previous process
strFilePath = server.MapPath("/insert your URL absolute sources filepath here/" & strFilename)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strFilePath) Then
Set objFile = objFSO.GetFile(strFilePath)
intFileSize = objFile.Size
Set objFile = Nothing
Response.AddHeader "Content-Disposition","attachment; filename=" & strFileName
Response.ContentType = "application/x-msdownload"
Response.AddHeader "Content-Length", intFileSize
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile strFilePath
Do While Not objStream.EOS And Response.IsClientConnected
Response.BinaryWrite objStream.Read(lChkSize)
Response.Flush()
Loop
objStream.Close
Set objStream = Nothing
Else
Response.write "Error finding file: " & request.form("file2dl")
End if
Set objFSO = Nothing
'End If
I have this code in Visual Basic .net and I would like to make the same thing in Visual Basic 6. The code upload an image to a given URL. I have to use Rest protocol because the server I upload the image request it.
Dim res As New RestSharp.RestRequest("URL_OF_SERVER", RestSharp.Method.POST)
res.AddFile("file", "File_location_on_PC")
Dim restClient As New RestSharp.RestClient()
Dim r As New RestSharp.RestResponse
r = restClient.Execute(res)
Is it posible to do the same Rest Protocol in Visual Basic 6?
EDIT 1: I HAVE TRIED THIS BUT AN ERROR HAPPENS
Dim xmlhttp As MSXML2.XMLHTTP30
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open NombreArchivo For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
" Content-Disposition: form-data; name=""image002""; filename=""C:\image002.jpg" & _
"--" & STR_BOUNDARY & "--"
'--- post
Set xmlhttp = New MSXML2.XMLHTTP30
With xmlhttp
.Open "POST", Url, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.send pvToByteArray(sPostData)
End With
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
ERROR :
responseText
{"message":"file.not_found","error":"There is no file in request.","status":400,"cause":[]}
Thanks!
If you need just to post a file here is a simple function
Private Sub pvPostFile(sUrl As String, sFileName As String, Optional ByVal bAsync As Boolean)
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
End With
End Sub
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
You can switch to MSXML2.ServerXMLHTTP to be able to use its SetTimeouts method if your file is large enough and timeouts in 30 sec.
You can create a COM callable wrapper (CCW) for the RestSharp assembly - see this URL for details of how to do this:
http://msdn.microsoft.com/en-us/library/ms973802.aspx
Once it is registered, you can use RestSharp from VB6.
Is there any way to create an excel spreadsheets using VBScript? I can create a text file using a FileSystemObject and use any extension I want, but when I try and download this and it gives me the open in excel option a message then appears stating that it is in a different format, and that is what I want to avoid:
set fs=Server.CreateObject("Scripting.FileSystemObject")
set tfile=fs.CreateTextFile(Server.MapPath("xls/streamtest.xls"),true,false)
I know this is pushing text into the file in ASCII format.
Is there 'something' character sequence, specific formatting that I can use to get around all of this?
Thanks
The best and fastest way, without using Excel.application on the server, which is really not recommended, is to generate an Excel Xml file. The only feature you won't be able to do is insert a picture.
Unlike using html table, you'll be able to support native data in excel (like date), and you'll be able to format, insert formula, ...
Save your excel as Excel XML and see the generate XML file. This is little bit tricky, but works very well.
Microsoft .xlsx files are just a Zipped collection of xml files
That means that we can write out the xml files and folder structure as text files, the zip the folder and rename that zip file to .xlsx. Now we have a new, empty excel file. Here is my code to do just that without having to have MS Excel installed.
The ZipAFolder function has been modified from another stackoverflow question here
'
' Dependencies: ZipAFolder, moveFile, writeToFile, Environ, OpenWithExplorer, FileExists, FolderExists, ScriptEngine, MkDir
' Version: 1.0.0
' by jeremy.gerdes#navy.mil
' CC0 1.0 Universal (CC0 1.0) Public Domain Dedication
' [TODO] reset the file attributes of date - Created, Modified, and Accessed to 12/31/1979 11:00 PM (for eastern time zone) to all files
' Usage example
' BuildEmptyExcelFile GetCurrentFileFolder() & "\" & "anEmptyExcelFile.xlsx"
Public Sub BuildEmptyExcelFile(strNewExcelFile)
Dim strLocalAppTmp
strLocalAppTmp = Environ("LocalAppData") & "\" & "tmp"
MkDir strLocalAppTmp
Dim strTmpZipPath
strTmpZipPath = strLocalAppTmp & "\" & "buildEmptyExcelFile"
MkDir strTmpZipPath
WriteToFile strTmpZipPath & "\" & "[Content_Types].xml" , _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & _
"<Types xmlns=""http://schemas.openxmlformats.org/package/2006/content-types""><Default Extension=""rels"" ContentType=""application/vnd.openxmlformats-package.relationships+xml""/><Default Extension=""xml"" ContentType=""application/xml""/><Override PartName=""/xl/workbook.xml"" ContentType=""application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml""/><Override PartName=""/xl/worksheets/sheet1.xml"" ContentType=""application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml""/><Override PartName=""/xl/theme/theme1.xml"" ContentType=""application/vnd.openxmlformats-officedocument.theme+xml""/><Override PartName=""/xl/styles.xml"" ContentType=""application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml""/><Override PartName=""/docProps/core.xml"" ContentType=""application/vnd.openxmlformats-package.core-properties+xml""/><Override PartName=""/docProps/app.xml"" ContentType=""application/vnd.openxmlformats-officedocument.extended-properties+xml""/></Types>", _
False, True
MkDir strTmpZipPath & "\" & "_rels"
WriteToFile _
strTmpZipPath & "\" & "_rels" & "\" & ".rels" , _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?><Relationships xmlns=""http://schemas.openxmlformats.org/package/2006/relationships""><Relationship Id=""rId3"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties"" Target=""docProps/app.xml""/><Relationship Id=""rId2"" Type=""http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties"" Target=""docProps/core.xml""/><Relationship Id=""rId1"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"" Target=""xl/workbook.xml""/></Relationships>", _
False, True
MkDir strTmpZipPath & "\" & "docProps"
WriteToFile _
strTmpZipPath & "\" & "docProps" & "\" & "app.xml" , _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?><Properties xmlns=""http://schemas.openxmlformats.org/officeDocument/2006/extended-properties"" xmlns:vt=""http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes""><Application>Microsoft Excel</Application><DocSecurity>0</DocSecurity><ScaleCrop>false</ScaleCrop><HeadingPairs><vt:vector size=""2"" baseType=""variant""><vt:variant><vt:lpstr>Worksheets</vt:lpstr></vt:variant><vt:variant><vt:i4>1</vt:i4></vt:variant></vt:vector></HeadingPairs><TitlesOfParts><vt:vector size=""1"" baseType=""lpstr""><vt:lpstr>Sheet1</vt:lpstr></vt:vector></TitlesOfParts><Company>HPES NMCI NGEN</Company><LinksUpToDate>false</LinksUpToDate><SharedDoc>false</SharedDoc><HyperlinksChanged>false</HyperlinksChanged><AppVersion>16.0300</AppVersion></Properties>", _
False, True
WriteToFile _
strTmpZipPath & "\" & "docProps" & "\" & "core.xml" , _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?><cp:coreProperties xmlns:cp=""http://schemas.openxmlformats.org/package/2006/metadata/core-properties"" xmlns:dc=""http://purl.org/dc/elements/1.1/"" xmlns:dcterms=""http://purl.org/dc/terms/"" xmlns:dcmitype=""http://purl.org/dc/dcmitype/"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""><dc:creator>jeremy.gerdes</dc:creator><cp:lastModifiedBy>jeremy.gerdes</cp:lastModifiedBy><dcterms:created xsi:type=""dcterms:W3CDTF"">2021-04-09T02:10:55Z</dcterms:created><dcterms:modified xsi:type=""dcterms:W3CDTF"">2021-04-09T02:11:30Z</dcterms:modified></cp:coreProperties>", _
False, True
MkDir strTmpZipPath & "\" & "xl"
MkDir strTmpZipPath & "\" & "xl" & "\" & "theme"
WriteToFile _
strTmpZipPath & "\" & "xl" & "\" & "styles.xml", _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & _
"<styleSheet xmlns=""http://schemas.openxmlformats.org/spreadsheetml/2006/main"" xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006"" mc:Ignorable=""x14ac x16r2"" xmlns:x14ac=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac"" xmlns:x16r2=""http://schemas.microsoft.com/office/spreadsheetml/2015/02/main""><fonts count=""1"" x14ac:knownFonts=""1""><font><sz val=""11""/><color theme=""1""/><name val=""Calibri""/><family val=""2""/><scheme val=""minor""/></font></fonts><fills count=""2""><fill><patternFill patternType=""none""/></fill><fill><patternFill patternType=""gray125""/></fill></fills><borders count=""1""><border><left/><right/><top/><bottom/><diagonal/></border></borders><cellStyleXfs count=""1""><xf numFmtId=""0"" fontId=""0"" fillId=""0"" borderId=""0""/></cellStyleXfs><cellXfs count=""1""><xf numFmtId=""0"" fontId=""0"" fillId=""0"" borderId=""0"" xfId=""0""/></cellXfs><cellStyles count=""1""><cellStyle name=""Normal"" xfId=""0"" builtinId=""0""/></cellStyles>" & _
"<dxfs count=""0""/><tableStyles count=""0"" defaultTableStyle=""TableStyleMedium2"" defaultPivotStyle=""PivotStyleLight16""/><extLst><ext uri=""{EB79DEF2-80B8-43e5-95BD-54CBDDF9020C}"" xmlns:x14=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/main""><x14:slicerStyles defaultSlicerStyle=""SlicerStyleLight1""/></ext><ext uri=""{9260A510-F301-46a8-8635-F512D64BE5F5}"" xmlns:x15=""http://schemas.microsoft.com/office/spreadsheetml/2010/11/main""><x15:timelineStyles defaultTimelineStyle=""TimeSlicerStyleLight1""/></ext></extLst></styleSheet>", _
False, True
WriteToFile _
strTmpZipPath & "\" & "xl" & "\" & "workbook.xml", _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & _
"<workbook xmlns=""http://schemas.openxmlformats.org/spreadsheetml/2006/main"" xmlns:r=""http://schemas.openxmlformats.org/officeDocument/2006/relationships"" xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006"" mc:Ignorable=""x15"" xmlns:x15=""http://schemas.microsoft.com/office/spreadsheetml/2010/11/main""><fileVersion appName=""xl"" lastEdited=""6"" lowestEdited=""6"" rupBuild=""14420""/><workbookPr defaultThemeVersion=""164011""/><mc:AlternateContent xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006""><mc:Choice Requires=""x15""><x15ac:absPath url=""\\snnsvr045\NNSY Perm\T&I Lab\NNSY IT Assistant\Documentation\"" xmlns:x15ac=""http://schemas.microsoft.com/office/spreadsheetml/2010/11/ac""/></mc:Choice></mc:AlternateContent><bookViews><workbookView xWindow=""0"" yWindow=""210"" windowWidth=""15495"" windowHeight=""6435""/></bookViews><sheets><sheet name=""Sheet1"" sheetId=""1"" r:id=""rId1""/></sheets><calcPr calcId=""162913""/><extLst>" & _
"<ext uri=""{140A7094-0E35-4892-8432-C4D2E57EDEB5}"" xmlns:x15=""http://schemas.microsoft.com/office/spreadsheetml/2010/11/main""><x15:workbookPr chartTrackingRefBase=""1""/></ext></extLst></workbook>", _
False, True
MkDir strTmpZipPath & "\" & "xl" & "\" & "_rels"
WriteToFile _
strTmpZipPath & "\" & "xl" & "\" & "_rels" & "\" & "workbook.xml.rels", _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?><Relationships xmlns=""http://schemas.openxmlformats.org/package/2006/relationships""><Relationship Id=""rId3"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles"" Target=""styles.xml""/><Relationship Id=""rId2"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme"" Target=""theme/theme1.xml""/><Relationship Id=""rId1"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"" Target=""worksheets/sheet1.xml""/></Relationships>", _
False, True
MkDir strTmpZipPath & "\" & "xl" & "\" & "theme"
WriteToFile _
strTmpZipPath & "\" & "xl" & "\" & "theme" & "\" & "theme1.xml", _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & _
"<a:theme xmlns:a=""http://schemas.openxmlformats.org/drawingml/2006/main"" name=""Office Theme""><a:themeElements><a:clrScheme name=""Office""><a:dk1><a:sysClr val=""windowText"" lastClr=""000000""/></a:dk1><a:lt1><a:sysClr val=""window"" lastClr=""FFFFFF""/></a:lt1><a:dk2><a:srgbClr val=""44546A""/></a:dk2><a:lt2><a:srgbClr val=""E7E6E6""/></a:lt2><a:accent1><a:srgbClr val=""5B9BD5""/></a:accent1><a:accent2><a:srgbClr val=""ED7D31""/></a:accent2><a:accent3><a:srgbClr val=""A5A5A5""/></a:accent3><a:accent4><a:srgbClr val=""FFC000""/></a:accent4><a:accent5><a:srgbClr val=""4472C4""/></a:accent5><a:accent6><a:srgbClr val=""70AD47""/></a:accent6><a:hlink><a:srgbClr val=""0563C1""/></a:hlink><a:folHlink><a:srgbClr val=""954F72""/></a:folHlink></a:clrScheme><a:fontScheme name=""Office""><a:majorFont><a:latin typeface=""Calibri Light"" panose=""020F0302020204030204""/><a:ea typeface=""""/><a:cs typeface=""""/><a:font script=""Jpan"" typeface=""??????å? Light""/>" & _
"<a:font script=""Hang"" typeface=""?? ??""/><a:font script=""Hans"" typeface=""???? Light""/><a:font script=""Hant"" typeface=""?¼????w""/><a:font script=""Arab"" typeface=""Times New Roman""/><a:font script=""Hebr"" typeface=""Times New Roman""/><a:font script=""Thai"" typeface=""Tahoma""/><a:font script=""Ethi"" typeface=""Nyala""/><a:font script=""Beng"" typeface=""Vrinda""/><a:font script=""Gujr"" typeface=""Shruti""/><a:font script=""Khmr"" typeface=""MoolBoran""/><a:font script=""Knda"" typeface=""Tunga""/><a:font script=""Guru"" typeface=""Raavi""/><a:font script=""Cans"" typeface=""Euphemia""/><a:font script=""Cher"" typeface=""Plantagenet Cherokee""/><a:font script=""Yiii"" typeface=""Microsoft Yi Baiti""/><a:font script=""Tibt"" typeface=""Microsoft Himalaya""/><a:font script=""Thaa"" typeface=""MV Boli""/><a:font script=""Deva"" typeface=""Mangal""/><a:font script=""Telu"" typeface=""Gautami""/><a:font script=""Taml"" typeface=""Latha""/><a:font script=""Syrc"" typeface=""Estrangelo Edessa""/>" & _
"<a:font script=""Orya"" typeface=""Kalinga""/><a:font script=""Mlym"" typeface=""Kartika""/><a:font script=""Laoo"" typeface=""DokChampa""/><a:font script=""Sinh"" typeface=""Iskoola Pota""/><a:font script=""Mong"" typeface=""Mongolian Baiti""/><a:font script=""Viet"" typeface=""Times New Roman""/><a:font script=""Uigh"" typeface=""Microsoft Uighur""/><a:font script=""Geor"" typeface=""Sylfaen""/></a:majorFont><a:minorFont><a:latin typeface=""Calibri"" panose=""020F0502020204030204""/><a:ea typeface=""""/><a:cs typeface=""""/><a:font script=""Jpan"" typeface=""??????å?""/><a:font script=""Hang"" typeface=""?? ??""/><a:font script=""Hans"" typeface=""????""/><a:font script=""Hant"" typeface=""?¼????w""/><a:font script=""Arab"" typeface=""Arial""/><a:font script=""Hebr"" typeface=""Arial""/><a:font script=""Thai"" typeface=""Tahoma""/><a:font script=""Ethi"" typeface=""Nyala""/><a:font script=""Beng"" typeface=""Vrinda""/><a:font script=""Gujr"" typeface=""Shruti""/><a:font script=""Khmr"" typeface=""DaunPenh""/>" & _
"<a:font script=""Knda"" typeface=""Tunga""/><a:font script=""Guru"" typeface=""Raavi""/><a:font script=""Cans"" typeface=""Euphemia""/><a:font script=""Cher"" typeface=""Plantagenet Cherokee""/><a:font script=""Yiii"" typeface=""Microsoft Yi Baiti""/><a:font script=""Tibt"" typeface=""Microsoft Himalaya""/><a:font script=""Thaa"" typeface=""MV Boli""/><a:font script=""Deva"" typeface=""Mangal""/><a:font script=""Telu"" typeface=""Gautami""/><a:font script=""Taml"" typeface=""Latha""/><a:font script=""Syrc"" typeface=""Estrangelo Edessa""/><a:font script=""Orya"" typeface=""Kalinga""/><a:font script=""Mlym"" typeface=""Kartika""/><a:font script=""Laoo"" typeface=""DokChampa""/><a:font script=""Sinh"" typeface=""Iskoola Pota""/><a:font script=""Mong"" typeface=""Mongolian Baiti""/><a:font script=""Viet"" typeface=""Arial""/><a:font script=""Uigh"" typeface=""Microsoft Uighur""/><a:font script=""Geor"" typeface=""Sylfaen""/></a:minorFont></a:fontScheme>" & _
"<a:fmtScheme name=""Office""><a:fillStyleLst><a:solidFill><a:schemeClr val=""phClr""/></a:solidFill><a:gradFill rotWithShape=""1""><a:gsLst><a:gs pos=""0""><a:schemeClr val=""phClr""><a:lumMod val=""110000""/><a:satMod val=""105000""/><a:tint val=""67000""/></a:schemeClr></a:gs><a:gs pos=""50000""><a:schemeClr val=""phClr""><a:lumMod val=""105000""/><a:satMod val=""103000""/><a:tint val=""73000""/></a:schemeClr></a:gs><a:gs pos=""100000""><a:schemeClr val=""phClr""><a:lumMod val=""105000""/><a:satMod val=""109000""/><a:tint val=""81000""/></a:schemeClr></a:gs></a:gsLst><a:lin ang=""5400000"" scaled=""0""/></a:gradFill><a:gradFill rotWithShape=""1""><a:gsLst><a:gs pos=""0""><a:schemeClr val=""phClr""><a:satMod val=""103000""/><a:lumMod val=""102000""/><a:tint val=""94000""/></a:schemeClr></a:gs><a:gs pos=""50000""><a:schemeClr val=""phClr""><a:satMod val=""110000""/><a:lumMod val=""100000""/><a:shade val=""100000""/></a:schemeClr></a:gs>" & _
"<a:gs pos=""100000""><a:schemeClr val=""phClr""><a:lumMod val=""99000""/><a:satMod val=""120000""/><a:shade val=""78000""/></a:schemeClr></a:gs></a:gsLst><a:lin ang=""5400000"" scaled=""0""/></a:gradFill></a:fillStyleLst><a:lnStyleLst><a:ln w=""6350"" cap=""flat"" cmpd=""sng"" algn=""ctr""><a:solidFill><a:schemeClr val=""phClr""/></a:solidFill><a:prstDash val=""solid""/><a:miter lim=""800000""/></a:ln><a:ln w=""12700"" cap=""flat"" cmpd=""sng"" algn=""ctr""><a:solidFill><a:schemeClr val=""phClr""/></a:solidFill><a:prstDash val=""solid""/><a:miter lim=""800000""/></a:ln><a:ln w=""19050"" cap=""flat"" cmpd=""sng"" algn=""ctr""><a:solidFill><a:schemeClr val=""phClr""/></a:solidFill><a:prstDash val=""solid""/><a:miter lim=""800000""/></a:ln></a:lnStyleLst><a:effectStyleLst><a:effectStyle><a:effectLst/></a:effectStyle><a:effectStyle><a:effectLst/></a:effectStyle><a:effectStyle><a:effectLst>" & _
"<a:outerShdw blurRad=""57150"" dist=""19050"" dir=""5400000"" algn=""ctr"" rotWithShape=""0""><a:srgbClr val=""000000""><a:alpha val=""63000""/></a:srgbClr></a:outerShdw></a:effectLst></a:effectStyle></a:effectStyleLst><a:bgFillStyleLst><a:solidFill><a:schemeClr val=""phClr""/></a:solidFill><a:solidFill><a:schemeClr val=""phClr""><a:tint val=""95000""/><a:satMod val=""170000""/></a:schemeClr></a:solidFill><a:gradFill rotWithShape=""1""><a:gsLst><a:gs pos=""0""><a:schemeClr val=""phClr""><a:tint val=""93000""/><a:satMod val=""150000""/><a:shade val=""98000""/><a:lumMod val=""102000""/></a:schemeClr></a:gs><a:gs pos=""50000""><a:schemeClr val=""phClr""><a:tint val=""98000""/><a:satMod val=""130000""/><a:shade val=""90000""/><a:lumMod val=""103000""/></a:schemeClr></a:gs><a:gs pos=""100000""><a:schemeClr val=""phClr""><a:shade val=""63000""/><a:satMod val=""120000""/></a:schemeClr></a:gs></a:gsLst>" & _
"<a:lin ang=""5400000"" scaled=""0""/></a:gradFill></a:bgFillStyleLst></a:fmtScheme></a:themeElements><a:objectDefaults/><a:extraClrSchemeLst/><a:extLst><a:ext uri=""{05A4C25C-085E-4340-85A3-A5531E510DB2}""><thm15:themeFamily xmlns:thm15=""http://schemas.microsoft.com/office/thememl/2012/main"" name=""Office Theme"" id=""{62F939B6-93AF-4DB8-9C6B-D6C7DFDC589F}"" vid=""{4A3C46E8-61CC-4603-A589-7422A47A8E4A}""/></a:ext></a:extLst></a:theme>", _
False, True
MkDir strTmpZipPath & "\" & "xl" & "\" & "worksheets"
WriteToFile _
strTmpZipPath & "\" & "xl" & "\" & "worksheets" & "\" & "sheet1.xml", _
"<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & _
"<worksheet xmlns=""http://schemas.openxmlformats.org/spreadsheetml/2006/main"" xmlns:r=""http://schemas.openxmlformats.org/officeDocument/2006/relationships"" xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006"" mc:Ignorable=""x14ac"" xmlns:x14ac=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac""><dimension ref=""A1""/><sheetViews><sheetView tabSelected=""1"" workbookViewId=""0""/></sheetViews><sheetFormatPr defaultRowHeight=""15"" x14ac:dyDescent=""0.25""/><sheetData/><pageMargins left=""0.7"" right=""0.7"" top=""0.75"" bottom=""0.75"" header=""0.3"" footer=""0.3""/></worksheet>", _
False, True
ZipAFolder strTmpZipPath, _
strLocalAppTmp & "\" & "EmptyExcelFile.zip"
moveFile strLocalAppTmp & "\" & "EmptyExcelFile.zip", strNewExcelFile
End Sub
'Dependancies NONE
'Version 1.0.0
'By jeremy.gerdes#navy.mil
Public Sub moveFile(strSourcePath, strDestinationPath)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
'Does the source file exist?
If FileExists(strSourcePath) Then
'If the destination is a folder then move the file into the folder preserving the source name
If FolderExists(strDestinationPath) Then
strDestinationPath = strDestinationPath & "\" & fso.GetFileName(strSourcePath)
End If
'If the destination allready exists, attempt to delete it... this move method allways over writes
If FileExists(strDestinationPath) Then
fso.DeleteFile strDestinationPath, True
End If
'If the destination path doesn't exist attempt to make it
If Not FolderExists(fso.GetParentFolderName(strDestinationPath)) Then
MkDir (fso.GetParentFolderName(strDestinationPath))
End If
'Move the file
fso.moveFile strSourcePath, strDestinationPath
End If
End Sub
Public Sub WriteToFile(ByRef strFileName, ByRef strContent, ByRef fOpenFile, ByRef fOverwrite)
Dim tf ' As Object
Dim FSO ' As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFileName) Then
If fOverwrite Then
FSO.DeleteFile strFileName
End If
End If
Set tf = FSO.OpenTextFile(strFileName, 8, True)
tf.WriteLine strContent
tf.Close
If fOpenFile Then
OpenWithExplorer strFileName
End If
'Clean up
Set tf = Nothing
Set FSO = Nothing
End Sub
Sub ZipAFolder (sFolder, zipFile)
'From /a/15143587/1146659
With CreateObject("Scripting.FileSystemObject")
zipFile = .GetAbsolutePathName(zipFile)
sFolder = .GetAbsolutePathName(sFolder)
With .CreateTextFile(zipFile, True)
.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, chr(0))
End With
End With
With CreateObject("Shell.Application")
.NameSpace(zipFile).CopyHere .NameSpace(sFolder).Items
Do Until .NameSpace(zipFile).Items.Count = _
.NameSpace(sFolder).Items.Count
WScript.Sleep 200
Loop
End With
End Sub
Public Sub OpenWithExplorer(ByRef strFilePath)
Dim wshShell
Set wshShell = CreateObject("WScript.Shell")
wshShell.Exec ("Explorer.exe " & strFilePath)
Set wshShell = Nothing
End Sub
Public Function Environ(ByRef strName)
'Replaces VBA.Envrion Public Function with wscript version for use in all VB engines
Dim wshShell: Set wshShell = CreateObject("WScript.Shell")
Dim strResult: strResult = wshShell.ExpandEnvironmentStrings("%" & strName & "%")
'wshShell.ExpandEnvironmentStrings behaves differently than VBA.Environ when no environment variable is found,
' conforming all results to return nothing if no result was found, like VBA.Environ
If strResult = "%" & strName & "%" Then
Environ = vbNullString
Else
Environ = strResult
End If
'cleanup
Set wshShell = Nothing
End Function
' Return true if file exists and false if file does not exist
Public Function FileExists(ByVal strPath) ' As String) As Boolean
Dim FSO 'As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FileExists = FSO.FileExists(strPath)
' Clean up
Set FSO = Nothing
End Function
Public Function FolderExists(ByVal strPath) 'As String) As Boolean
Dim FSO ' As Object
' Note I used to use the vba.Dir Public Function but using that Public Function
' will lock the folder and prevent it from being deleted.
Set FSO = CreateObject("Scripting.FileSystemObject")
FolderExists = FSO.FolderExists(strPath)
' Clean up
Set FSO = Nothing
End Function
Function MkDir(strPath)
' Version: 1.0.3
' Dependancies: NONE
' Returns: True if no errors, i.e. folder path allready existed, or was able to be created without errors
' Usage Example: MkDir Environ("temp") & "\" & "opsRunner"
' Emulates linux 'MkDir -p' command: creates folders without complaining if it allready exists
' Superceeds the the VBA.MkDir function, but requires that drive be included in strPath
' By jeremy.gerdes#navy.mil
Dim fso ' As Scripting.FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
If Not fso.FolderExists(strPath) Then
On Error Resume Next
Dim fRestore ' As Boolean
fRestore = False
'Handle Network Paths
If Left(strPath, 2) = "\\" Then
strPath = Right(strPath, Len(strPath) - 2)
fRestore = True
End If
Dim arryPaths 'As Variant
arryPaths = Split(strPath, "\")
'Restore Server file path prefix
If fRestore Then
arryPaths(0) = "\\" & arryPaths(0)
End If
Dim intDir ' As Integer
Dim strBuiltPath ' As String
For intDir = LBound(arryPaths) To UBound(arryPaths)
strBuiltPath = strBuiltPath & arryPaths(intDir) & "\"
If Not fso.FolderExists(strBuiltPath) Then
fso.CreateFolder strBuiltPath
End If
Next
End If
MkDir = (Err.Number = 0)
'cleanup
Set fso = Nothing
End Function
'Dependencies: NONE
'--- This function modified from: https://www.reddit.com/r/vba/comments/aom8xs/how_to_tell_if_script_is_running_in_vba_vbscript/ei0z2ll?utm_source=share&utm_medium=web2x&context=3
'--- Returns a string containing which script engine this is running in. Modified to test that wscript has a property 'Version' to allow for wscript emulation in the VBIDE
'--- Will return either "VBS","VBA", or "HTA".
Function ScriptEngine()
On Error Resume Next
ScriptEngine = "VBA"
Dim tmp
tmp = wscript.Version
If Err.Number = 0 Then
ScriptEngine = "VBS"
End If
Err.Clear
ReDim window(0)
If Err.Number = 501 Then
ScriptEngine = "HTA"
End If
On Error GoTo 0
End Function
'Dependencies: ScriptEngine
Function GetCurrentFileFolder()
Select Case ScriptEngine()
Case "VBS"
GetCurrentFileFolder = Left(wscript.ScriptFullName, Len(wscript.ScriptFullName) - Len(wscript.ScriptName) - 1)
Case "VBA"
Select Case Application.Name
Case "Microsoft Word"
GetCurrentFileFolder = ThisDocument.Path
Case "Microsoft Access"
GetCurrentFileFolder = CurrentProject.Path
Case "Microsoft Excel"
GetCurrentFileFolder = ThisWorkbook.Path
End Select
'Not going to bother checking for other VBA contexts like powerpoint, visio, ms project or autocad.
Case "HTA"
'----------------------------------------------------------------------
' - There are several methods to get the current directory of the HTA -
'----------------------------------------------------------------------
'From testing don't use the following
'This method drops the server path for network paths
'strPath = Left(Document.Location.pathname, InStrRev(Document.Location.pathname, "\") - 1) & "\Main.hta"
'This method works fine if the HTA directly executed,
'but if explorer.exe or cscript.exe executes the hta this method returns the %windir% dictory
'Dim objScripShell
'Set objScripShell = CreateObject("WScript.Shell")
'strPath = objScripShell.CurrentDirectory & "\Main.hta"
Dim strPath
strPath = jsUrlDecode(Document.Location.href)
strPath = Replace(strPath, "/", "\")
strPath = Left(strPath, InStrRev(strPath, "\") - 1)
'URLs that begin with a drive letter will begin with 'file:\\\' Check this first
If Left(strPath, 8) = "file:\\\" Then
strPath = Right(strPath, Len(strPath) - 8)
End If
'URLs that begin with a server name will begin with 'file:'
If Left(strPath, 5) = "file:" Then
strPath = Right(strPath, Len(strPath) - 5)
End If
GetCurrentFileFolder = strPath
End Select
End Function
'BuildEmptyExcelFile GetCurrentFileFolder & "\" & "anEmptyExcelFile.xlsx"
I agree with the comments above. I have always done this using Response.ContentType and Response.AppendHeader
Response.ContentType = "application/vnd.ms-excel"
Response.AppendHeader "content-disposition", "filename=MySpreadsheet.xls"
If Excel is installed and accessible on the server and sFSpec is the full (server mapped, accessible) file spec of the (empty) .xls you want to create, then
Dim oExcel : Set oExcel = [Server.]CreateObject( "Excel.Application" )
oExcel.Workbooks.Add.SaveAs sFSpec
oExcel.Quit
should work. If you can't use "Excel.Application", you may use ADO by opening a Excel connection and execute a suitable CREATE TABLE statement.
ADDED
The low tech approach would be to use an empty .xls stolen from some workstation as a template; but you can create an .xls on the fly:
Dim sFSpec : sFSpec = resolvePath("..\data\byado.xls")
If goFS.FileExists(sFSpec) Then goFS.DeleteFile sFSpec
Dim oXDb : Set oXDb = CreateObject("ADODB.Connection")
Dim sCS : sCS = Join(Array(_
"Provider=Microsoft.Jet.OLEDB.4.0" _
, "Data Source=" & sFSpec _
, "Extended Properties=""" _
& Join(Array( _
"Excel 8.0" _
, "HDR=Yes" _
, "IMEX=0" _
), ";" ) _
& """" _
), ";")
oXDb.Open sCS
oXDb.Execute "CREATE TABLE [WhatEver] (DontCare INTEGER)"
oXDb.Close
If goFS.FileExists(sFSpec) Then WScript.Echo "qed"
(You may have to tinker with the "Excel !Version!"; the "IMEX=0" is important)
I answered this on a another question.
correct formatting for excel spreadsheet
You should be able to use CreateObject("Excel.Application") on your server if office (at least Excel) is installed.
Xls (and the other types of Excel 2007/2010 are binary fiels that you can not easily create like that, you need to use Com objects to create and manipulate them. Here an example from the scripting guys http://blogs.technet.com/b/heyscriptingguy/archive/2005/01/31/how-can-i-make-changes-to-and-then-re-save-an-existing-excel-spreadsheet.aspx
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = FALSE
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Cells(1, 1).Value = Now
objWorkbook.SaveAs("C:\Scripts\Test.xls")
objExcel.Quit
see http://msdn.microsoft.com/en-us/library/aa223697(v=office.11).aspx for a list of vba functions you can use
The code below works. But if I comment out the line Dim objRequest As MSXML2.XMLHTTP and uncomment the line Dim objRequest As Object it fails with the error message :
The parameter is incorrect
Why, and what (if anything) can I do about it?
Public Function GetSessionId(strApiId, strUserName, strPassword) As String
Dim strPostData As String
Dim objRequest As MSXML2.XMLHTTP
'Dim objRequest As Object '
strPostData = "api_id=" & strApiId & "&user=" & strUserName & "&password=" & strPassword
Set objRequest = New MSXML2.XMLHTTP
With objRequest
.Open "POST", "https://api.clickatell.com/http/auth", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send strPostData
GetSessionId = .responseText
End With
End Function
Corey, yes, I know I would have to do that in order for my code to work without a reference to the MSXML type library. That's not the issue here. The code fails when using Dim objRequest As Object regardless of whether I use
Set objRequest = NEW MSXML2.XMLHTTP with the reference, or
Set objRequest = CreateObject("MSXML2.XMLHTTP") without the reference.
For some reason, this works:
Dim strPostData As String
Dim objRequest As Object
strPostData = "api_id=" & strApiId & "&user=" & strUserName & "&password=" & strPassword
Set objRequest = New MSXML2.XMLHTTP
With objRequest
.Open "POST", "https://api.clickatell.com/http/auth", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send (strPostData)
GetSessionId = .responseText
End With
Instead of building the URL-encoded strPostData via string concatenation, it's strongly advisable to use a URL encoding function:
strPostData = "api_id=" & URLEncode(strApiId) & _
"&user=" & URLEncode(strUserName) & _
"&password=" & URLEncode(strPassword)
A couple of choices for a URLEncode() function in VBA are in this thread: How can I URL encode a string in Excel VBA?
If you use the Dim objRequest As Object then you would need to code:
Set objRequest = CreateObject("MSXML2.XMLHTTP")
I realise this is nearly identical to the code from Tomalek above (all credit due to you!), but this question helped me towards a full solution to a problem I had (Excel submitting to PHP server, then dealing with response)...so in case this is of any help to anyone else:
Sub Button1_Click2()
Dim objXMLSendDoc As Object
Set objXMLSendDoc = New MSXML2.DOMDocument
objXMLSendDoc.async = False
Dim myxml As String
myxml = "<?xml version='1.0'?><Request>Do Something</Request>"
If Not objXMLSendDoc.LoadXML(myxml) Then
Err.Raise objXMLSendDoc.parseError.ErrorCode, , objXMLSendDoc.parseError.reason
End If
Dim objRequest As MSXML2.XMLHTTP
Set objRequest = New MSXML2.XMLHTTP
With objRequest
.Open "POST", "http://localhost/SISADraftCalcs/Test2.php", False
.setRequestHeader "Content-Type", "application/xml;charset=UTF-16"
.setRequestHeader "Cache-Control", "no-cache"
.send objXMLSendDoc
End With
Dim objXMLDoc As MSXML2.DOMDocument
Set objXMLDoc = objRequest.responseXML
If objXMLDoc.XML = "" Then
objXMLDoc.LoadXML objRequest.responseText
If objXMLDoc.parseError.ErrorCode <> 0 Then
MsgBox objXMLDoc.parseError.reason
End If
End If
Dim rootNode As IXMLDOMElement
Set rootNode = objXMLDoc.DocumentElement
MsgBox rootNode.SelectNodes("text").Item(0).text
End Sub