'Declare long
Dim lng_resolveTimeout, lng_connectTimeout, lng_sendTimeout,
lng_receiveTimeout As Long
'Declare integer
Dim int_serverCredentials As Integer
'Declare variants
Dim var_submitObject As Variant
'Set values
int_serverCredentials = 0
lng_resolveTimeout = 120000 'miliseconds = 2 minutes
lng_connectTimeout = 1200000
lng_sendTimeout = 1200000
lng_receiveTimeout = 1200000
'Create HTTP object
Set var_submitObject = CreateObject("WinHTTP.WinHTTPRequest.5.1")
Call var_submitObject.SetTimeouts(lng_resolveTimeout,
lng_connectTimeout, lng_sendTimeout, lng_receiveTimeout)
'Standards for this post
%REM
Content-Type: multipart/form-data; boundary={boundary}
{boundary}
Content-Disposition: form-data; name="data"; filename="{filename}"
Content-Type: text/plain
{contents}
{boundary}--
%END REM
'Set post parameters
Call var_submitObject.open("POST", str_url, False)
Call var_submitObject.setRequestHeader("Accept", "application/xml")
Call var_submitObject.setRequestHeader("Authorization", "Basic " & str_auth)
Call var_submitObject.setRequestHeader("Content-Type", "multipart/form-data; boundary=b1")
str_boundary = |--b1| & Chr(13) &_
|Content-Disposition: form-data; name="data"; filename="name.txt"| & Chr(13) &_
|Content-Type: text/plain| & Chr(13) &_
str_fileContent & |b1--|
'Send the HTTP request
Call var_submitObject.Send(str_boundary)
'Wait for the answer and set object as returned value for further validation
Call var_submitObject.WaitForResponse
Set submitHTTP = var_submitObject
'Clear memory
Set var_submitObject = Nothing
Questions:
How to specify the "boundary" and send the file content correctly as a TXT file upload?
How to specify the line break for this boundary content?
Re the EOL question, you specify Chr(13) but that's not a complete line-feed in Windows (I assume you're using Windows based on the winhttp tag you also mention). An EOL entity in Windows is CR + LF where a carriage return is Chr(13) and a line-feed is Chr(10).
With regards text, you specify that in your content-type.
Related
I am working on a project and I am writing to a file from another file, but I want a .VBS file to say it like TTS. here is the code for that... But
Dim message, sapi
Set sapi=CreateObject("This Text")
sapi.Speak message
And then the words "This Text" will come out of the speakers.
But, I don't want the words "This Text" to come out, I want it to say the words inside a .txt file (tts_text.txt)
So it needs to read a text file and store that in a variable and then the tts should read and say the variable.
Use this to read/learn about the objects and their capabilities:
Option Explicit
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim goVC : Set goVC = CreateObject("SAPI.SpVoice")
goVC.Speak goFS.OpenTextFile(WScript.ScriptFullName).ReadAll()
You can give a try for this vbscript example :
Option Explicit
Dim Contents,File,message
File = "c:\tts_text.txt"
Contents = "It didn’t work after mass shootings at a nightclub in Orlando,"&_
"college campuses in Virginia and Oregon, a church in Charleston,"&_
"or at a movie theater and high school in Colorado."&_
"Or after two lawmakers survived assassination attempts." & vbcrlf &_
"But after a gunman killed 58 people and wounded more than 500 at a Las Vegas concert," & vbcrlf &_
"Democrats are going to try again to revamp the nation’s gun laws."
' We write this contents to the file
WriteTextFile Contents, file, 0
' We read the file contents and we store it into a variable message
message = ReadFileText(File)
' Now we can speak this message with SAPI object
Speak_from_File message
'**********************************************************
Sub Speak_from_File(message)
Dim Voice
Set Voice = CreateObject("SAPI.SpVoice")
Voice.Volume = 100
Voice.Rate = 0
Voice.Speak message
End Sub
'**********************************************************
Sub WriteTextFile(sContent, sPath, lFormat)
'lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath,2,True,lFormat)
.WriteLine sContent
.Close
End With
End Sub
'**********************************************************
Function ReadFileText(sFile)
Dim objFSO,oTS,sText
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oTS = objFSO.OpenTextFile(sFile,1)
sText = oTS.ReadAll
oTS.close
set oTS = nothing
Set objFSO = nothing
ReadFileText = sText
End Function
'**********************************************************
Gday all,
I'm trying to send a Report from Microsoft Access to a Client.
So i have a client table with the client details including an email address etc..
And in my form i am using a button linked to a macro that creates the report and sends it via email using "EMailDatabaseObject"
However this way i cannot select the email address from the list in my clients section i have to type one in the macro builder or leave blank and get prompted for it.
Is there anyway that i could have a Select Query linked to the "to" section of EMailDatabaseObject?
Or is there another way i should be trying to do this?
Have a look at this:
Public Sub cmdTerms_Click()
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim KnownAs As String
Dim Eml As String
Dim Text As String
Dim PathName As String
Dim PathName2 As String
Dim Quest As Integer
Dim rs As DAO.Recordset
DoCmd.TransferText acExportMerge, "", "qryTerms", conAddrPth & "\DataSource.txt", True, "", 1252
Me.DocName = conAddrPth & "\DBS Service Agreement.docm"
OpenWordDoc
KnownAs = DLookup("Fname", "qryTerms")
Eml = DLookup("Email", "qryTerms")
Text = "Dear " & KnownAs & vbCr & vbCr & "I'd be grateful if you would read the attached Code of Practice and " & _
"Service Level Agreement." & vbCr & vbCr & _
"If you are happy with these terms please complete, sign and return pages one and " & _
"two of the attachment. " & vbCr & vbCr & "Please let me know if you have any questions or concerns." & vbCr & vbCr & _
"With best wishes." & vbCr & vbCr & EmailSig
PathName = conAddrPth & "\DBS Service Agreement.pdf"
Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.To = Eml
.Subject = "DBS Checking Service"
.Body = Text
.NoAging = True
.Attachments.Add PathName
.Display (True)
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
It's something I use. The above would be a procedure on your form. The form would have data such as the address etc. I would employ Word Mail Merge to make a report (or letter). It would be just as easy to send a report if necessary.
Best way to do this is in VBA, you can convert your report creation macro to VBA code and add this after the generated code
Dim vRecipient As String
Dim vMsg As String
Dim vSubject As String
vMsg = " Your Message here... "
vSubject = " Your Subject here... "
vRecipient = "x#x.xxx" 'probably it is best to select from some listbox
DoCmd.SendObject acSendReport, " rptYourReport ", acFormatPDF, vRecipient, , , vSubject, vMsg, False
Also you can see here
I have a bunch of sql files with queries that need no be run on my local database each time there are some changes in those files.
We use classic ASP code to run these files in a loop written on VBScript, like this:
Dim arrSqlLines()
i = 0
set t = fso.OpenTextFile(filePath, 1, false)
Do Until t.AtEndOfStream
Redim Preserve arrSqlLines(i)
arrSqlLines(i) = t.ReadLine
i = i + 1
Loop
t.close
For Each sqlLine in arrSqlLines
sqlLine = Trim(sqlLine)
sqlBatch = Trim(sqlBatch & sqlLine) & vbCrLf
Call dbexecConnection(sqlBatch, objDbConnection)
Next
Function dbexecConnection(sql, objConnExec)
dim cmdTemp
on Error Resume Next
set cmdTemp=Server.CreateObject("ADODB.Command")
set cmdTemp.ActiveConnection=objConnExec
cmdTemp.CommandText = sql
cmdTemp.Execute
if err.number<>0 Then
if Session("SkipError") <> -1 Then
response.write "Error in dbexecute: " & sql & "<br/>"
response.write "Error=(" & err.description & ")"
response.End
end If
end If
on error goto 0
End Function
The problem is that if a sql file is ecoded in UTF-8 without BOM it runs it OK, but if any file is encoded in UTF-8 format, it produces an error:
For example, this very sql file starts like this:
SET QUOTED_IDENTIFIER ON
GO
IF OBJECT_ID('RPM_GET_ACTUAL_COST_FOR_EPIC') IS NOT NULL
DROP Function [RPM_GET_ACTUAL_COST_FOR_EPIC]
GO
CREATE Function [RPM_GET_ACTUAL_COST_FOR_EPIC]
(
#EpicID as int,
#RateType as Int, -- 1 for Blended, 2 for CostCenter
#CalcType as Int -- 1 for by Hours or 2 for Points
)
returns float
BEGIN
declare #Cost float
declare #CostX float
declare #ItStorys TABLE (
StorylD int,
State int,
DemoStatus int,
Dfficulty int,
Feature int,
TeamID int,
TrackType int,
Iteration int
)
insert into #tStorys(StoryID, State, DemoStatus, Dfficulty, Feature, TeamID, TrackType, Iteration)
I cannot guarantee that all files will be encoded in UTF-8 without BOM so I have to find the way to make it run correctly files with UTF-8 as well. how can i possibly do that?
It is certain that FileSystemObject does not handle UTF-8 but Unicode and ANSI.
ADODB.Stream can handle a lot of character sets including utf-8 so you can use it instead.
Replace your code up to the first For with the following.
Dim arrSqlLines
With Server.CreateObject("Adodb.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile filePath
If .EOS Then
'an empty array if file is empty
arrSqlLines = Array()
Else
'to obtain an array of lines like you desire
'remove carriage returns (vbCr) if exist
'and split the text by using linefeeds (vbLf) as delimiter
arrSqlLines = Split(Replace(.ReadText, vbCr, ""), vbLf)
End If
.Close
End With
Just need to tell Classic ASP and IIS that you are wanting to process the ASP page using UTF-8.
First save the ASP page making sure it is saved using Code Page 65001 (if using Visual Studio this can be done through the Advanced Save Options menu option).
Then modify the ASP page to include the following initial lines.
<%#Language="VBScript" CodePage = 65001 %>
<%
'Assuming this is the whole script the above line MUST always
'be the very first line in the source file.
'Tell ASP strings should be returned UTF-8 encoded.
Response.CodePage = 65001
'Tell the Browser to expect UTF-8 encoded data.
Response.Charset = "UTF-8"
Dim arrSqlLines()
i = 0
set t = fso.OpenTextFile(filePath, 1, false)
Do Until t.AtEndOfStream
Redim Preserve arrSqlLines(i)
arrSqlLines(i) = t.ReadLine
i = i + 1
Loop
t.close
For Each sqlLine in arrSqlLines
sqlLine = Trim(sqlLine)
sqlBatch = Trim(sqlBatch & sqlLine) & vbCrLf
Call dbexecConnection(sqlBatch, objDbConnection)
Next
Function dbexecConnection(sql, objConnExec)
dim cmdTemp
on Error Resume Next
set cmdTemp=Server.CreateObject("ADODB.Command")
set cmdTemp.ActiveConnection=objConnExec
cmdTemp.CommandText = sql
cmdTemp.Execute
if err.number<>0 Then
if Session("SkipError") <> -1 Then
response.write "Error in dbexecute: " & sql & "<br/>"
response.write "Error=(" & err.description & ")"
response.End
end If
end If
on error goto 0
End Function
%>
Useful Links
Convert UTF-8 String Classic ASP to SQL Database
I have a lot of files stored as attached files in an Access db. I am going to move data to an SQL server and for that purpose I need to extract the attached files and turn them into file system files.
This snippet works fine for images and pdf files but not for Office documents like Word or Excel. I assume it has something to do with encoding, but I have no clues. Any ideas?
Dim dbs As Database
Dim rs As Recordset
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("table1")
With rs
Do While Not .EOF
Set rsRec = rs.Fields("AttFiles").Value
While Not rsRec.EOF
NameOfFile = "C:\temp\" & rsFil.Fields("FileName")
Open NameOfFile For Binary Access Write As #1
Put #1, , rsRec.Fields("FileData").Value
Close #1
rsRec.MoveNext
Wend
.MoveNext
Loop
End With
rs.Close
dbs.Close
If the File is actually an attachment type, then you might as well use the Recordset2 of the Microsoft Access Object Library. Something like,
Public Sub exportDocument(tableName As String, fieldName As String, uniqueID As Long)
On Error GoTo Err_SaveImage
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Dim saveAsName As String
Set rsParent = CurrentDb.OpenRecordset("SELECT " & tableName & ".* " & _
"FROM " & tableName & " WHERE " & tableName & "." & fieldName & " = " & uniqueID)
Set rsChild = rsParent.Fields("fileData").Value
If rsChild.RecordCount <> 0 Then
If Dir(Environ("userprofile") & "\My Documents\tmp\", vbDirectory) <> "." Then MkDir Environ("userprofile") & "\My Documents\tmp\"
saveAsName = Environ("userprofile") & "\My Documents\tmp\" & rsChild.Fields("FileName")
rsChild.Fields("fileData").SaveToFile saveAsName
FollowHyperlink saveAsName
End If
Exit_SaveImage:
Set rsChild = Nothing
Set rsParent = Nothing
Exit Sub
Err_SaveImage:
If Err = 3839 Then
Resume Next
Else
MsgBox "Some Other Error occured!" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description, vbCritical
Resume Exit_SaveImage
End If
End Sub
The above code will save the files to a location specified in saveAsName. I have specific unique ID in the WHERE condition. If you want to export all documents, you can alter the code accordingly, but might have to loop through the recordset. I hope this helps !
I am trying to look through an array for values using InStr. However, I am getting false positives and false negatives.
I.e. there will be a string match and no match will be reported or no match reported even though the string matches exactly.
It requires Outlook. It converts the highlighted emails into a text file placed in the specified path. It then searches the text file for the delimeter by reading the text into an array and searching the array contents. However, as mentioned, even when the substring is in the array, InStr returns false positives and false negatives. I have tried binary and textual comparison methods and various comparison strings.
Any ideas?
Notes: 1)after becoming frustrated with InStr, I attempted to use an if then statement to compare the array to the delimeter string, which is what is shown in the last lines of my code.
2)i have set the delimeter as "xxxxx" which you can see in the lines following the set of objfile.write commands.
3)I have tried to use both text and binary comparison modes with the instr function
3) Ultimate goal:
a)Extract highlighted emails from outlook and combine into one text file.
b)Sort the delimited text file based on the text of the email (if text between delimiters contains y, put into array y, if x...etc.)
c)print arrays into email in my specified order (e.g. x, y, z)
this is because the emails arrive at different times each day, but must be organized into the same order each day for the final summary email.
Thanks.
Below is my code:
Sub MergeTextFromSelectedEmailsIntoTextFile()
Dim objFS As New Scripting.FileSystemObject, objFile As Scripting.TextStream
Dim objItem As Object, strFile As String
Dim wrapArray() As String
If ActiveExplorer.Selection.Count = 0 Then Exit Sub
strFile = InputBox("Please enter the full path and file name for the merged text:" _
, "Enter File Name")
Set objFile = objFS.CreateTextFile(strFile, False)
If objFile Is Nothing Then
MsgBox "Error creating file '" & strFile & "'.", vbOKOnly + vbExclamation _
, "Invalid File"
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
objFile.Write vbCr
objFile.Write (vbCr & Chr(10) & Chr(13) & ("xxxxx") & Chr(13) & Chr(13) & vbCr & vbLf)
objFile.Write (vbCr & vbLf & objItem.Body)
objFile.Write (vbCr & vbLf & Chr(13))
Next
objFile.Close
'Define variables for writing to array
Dim i As Integer
Set objFile = objFS.OpenTextFile(strFile, ForReading)
'write file contents to array
Do Until objFile.AtEndOfStream
ReDim Preserve wrapArray(i)
wrapArray(i) = objFile.ReadLine
i = i + 1
Loop
Dim xxxxx As String
xxxxx = xxxxx
'check each array index for contents
'note i have tried
''if instr(0, wraparray(i), "xxxxx",0) then msgBox "FoundDelim at line " & i
For i = LBound(wrapArray()) To UBound(wrapArray())
If wrapArray(i) = "xxxxx" Then MsgBox "FoundDelim! at line " & i
Next i
Note that InStr returns an integer, so testing the result of the function as a boolean should result in inconsistent behavior. Try this:
If InStr(wrapArray(i),"xxxxx") > 0 Then
MsgBox "FoundDelim! at line " & i
End If