I have the following code developed in Visual Basic 6.0 (vb6) in which already managed to connect to the web service, but when I send the ZIP file into a byte array returns me an error telling me that the ZIP file is corrupt, obviously I'm not sending ZIP file correctly and that is the reason for the error.
Below the code I use.
Dim strFileName2 As String
Dim nFile As Integer
Dim strImage As String
Dim strBoundary As String
Dim AsmxUrl As String
Dim SoapActionUrl As String
Dim filebytes() As Byte
Dim Attachment() As Byte
SoapActionUrl = "https://www.sat.gob.mx/ol-ti-itcpgem-beta/billService"
AsmxUrl = "https://www.sat.gob.mx/ol-ti-itcpgem-beta/billService?wsdl"
strBoundary = "----=_Part_23_1578679283.1448552263862"
strFileName2 = "C:\20502264096-01-F001-9672.zip"
nFile = FreeFile()
Dim adostream As Object
adostream = CreateObject("ADODB.Stream")
adostream.Open()
adostream.Type = 1
adostream.LoadFromFile strFileName2
filebytes = adostream.Read
adostream.Close()
Open strFileName2 For Binary As #nFile
strImage = String(LOF(nFile), " ")
Get #nFile, , strImage
Close #nFile
'message head SOAP
Xml = "<soapenv:Envelope xmlns:soapenv='http://schemas.xmlsoap.org/soap/envelope/' " & _
"xmlns:ser='http://service.sat.gob.mx' " & _
"xmlns:wsse='http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd'> " & _
" <soapenv:Header> " & _
" <wsse:Security> " & _
" <wsse:UsernameToken> " & _
" <wsse:Username>USUSARIO</wsse:Username> " & _
" <wsse:Password>CONTRASENA</wsse:Password> " & _
" </wsse:UsernameToken> " & _
" </wsse:Security> " & _
" </soapenv:Header> " & _
" <soapenv:Body> " & _
" <ser:sendBill> " & _
" <!--Optional:--> " & _
" <fileName>20502264096-01-F001-9672.zip</fileName> " & _
" <!--Optional:--> " & _
" <contentFile><inc:Include href=""cid:20502264096-01-F001-9672.zip"" xmlns:inc=""http://www.w3.org/2004/08/xop/include""/></contentFile>" & _
" </ser:sendBill> " & _
" </soapenv:Body> " & _
"</soapenv:Envelope> "
'" <contentFile>cid:20502264096-01-F001-9672.zip</contentFile> " & _
'message attachment
Attachment = filebytes
'multipart message template
SendDataS = "--$boundary$" & Chr(10) & _
"Content-Type: application/xop+xml; charset=UTF-8; type=""text/xml""" & Chr(10) & _
"Content-Transfer-Encoding: 8bit" & Chr(10) & _
"Content-ID: <rootpart#soapui.org>" & Chr(10) & _
"" & Chr(10) & _
"$xml$" & Chr(10) & _
"--$boundary$" & Chr(10) & _
"Content-Type: application/zip; name=20502264096-01-F001-9672.zip" & Chr(10) & _
"Content-Transfer-Encoding: binary" & Chr(10) & _
"Content-ID: <20502264096-01-F001-9672.zip>" & Chr(10) & _
"Content-Disposition: attachment; name=""20502264096-01-F001-9672.zip""; filename=""20502264096-01-F001-9672.zip""" & Chr(10) & _
" " & Chr(10) & _
"$Attachment$" & Chr(10) & _
"--$boundary$" & "--"
'Create objects to DOMDocument and XMLHTTP
objDom = CreateObject("MSXML2.DOMDocument")
objXmlHttp = CreateObject("MSXML2.XMLHTTP")
strXmlHead = ""
strXmlBody = ""
'Load XMLHead
objDom.async = False
objDom.LoadXml Xml 'aqui carga el XML armado antes
strXmlHead = objDom.xml 'aqui lee el XML
MsgBox(objDom.xml)
'Load XMLbody
'objDom.async = False
'objDom.LoadXml Attachment
MsgBox(Attachment)
'strXmlBody = objDom.LoadXml
strXmlBody = Attachment
strXml = Replace(SendDataS, "$xml$", strXmlHead)
strXml = Replace(strXml, "$Attachment$", strXmlBody)
strXml = Replace(strXml, "$boundary$", strBoundary)
MsgBox(strXml)
Me.Text1.Text = strXml
'Open the webservice
objXmlHttp.Open("POST", AsmxUrl, False)
'Create headings
objXmlHttp.setRequestHeader("MIME-Version", "1.0")
objXmlHttp.setRequestHeader("Content-Type", "multipart/related; boundary=""" & strBoundary & """")
objXmlHttp.setRequestHeader("Accept", "application/soap+xml, application/dime, multipart/related, text/*")
objXmlHttp.setRequestHeader("SOAPAction", """" & SoapActionUrl & """")
objXmlHttp.setRequestHeader("Content-Length", Len(strXml))
objXmlHttp.setRequestHeader("Connection", "Close")
'Send XML command
objXmlHttp.send CStr(strXml) 'objDom.xml
'Get all response text from webservice
strRet = objXmlHttp.responseText
MsgBox(strRet)
Here is the code I use for posting to web server. Maybe you can get something for you...
Private Function mbPostFile(sRequest As String, sFileName As String, sExpectedNode As String, ByRef oNode As IXMLDOMNode) As Boolean
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim sPostData As String
Dim oStream As Object
On Error GoTo ErrorHandler
If Not mbCheckSession Then
Exit Function
End If
Set oStream = CreateObject("ADODB.STREAM")
oStream.Type = 1 'binary
Call oStream.Open
Call oStream.LoadFromFile(sFileName)
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
StrConv(oStream.Read, vbUnicode) & vbCrLf & _
"--" & STR_BOUNDARY & "--"
With moGetHttp
Call .Open("POST", msPortalUrl & sRequest & "&session=" & msSession, False)
Call .setRequestHeader("Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY)
Call .send(pvToByteArray(sPostData))
mbPostFile = mbCheckResult(.responseXML, sExpectedNode, oNode, True)
End With
Exit Function
ErrorHandler:
Call mShowError("mbPostFile")
End Function
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
Related
I have multiple inputs in columns from which I need to create table for each column which has headers, Create connection using power query, Using these connections I need to add to the power query, and export it to sheet2. I have attached sample excel sheet for reference. Below is the half code for the same, I am not pro in vba if any one could help in solving the same. Here is the link for the same which I need to automate.
data set
Option Explicit
Public Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject
Dim tableobjects As ListObject
Dim sName As String
Dim sFormula As String
Dim wq As WorkbookQuery
Dim bExists As Boolean
Dim vbAnswer As VbMsgBoxResult
Dim vbDataModel As VbMsgBoxResult
Dim i As Long
Dim j As Long
Dim k, l As Long
Dim dStart As Double
Dim dTime As Double
Dim CellAddr As String
Dim CellValue As String
Dim RangeAddr As String
Dim Temp As String
Dim TotalNumberInputs As Integer
Dim answer As Integer
Dim TableExists As Boolean
Dim ListObj As ListObject
Repeat:
TotalNumberInputs = InputBox("Enter the total inputs", "input int number")
If TotalNumberInputs = 0 Then
MsgBox "Invalid Input!!!"
answer = MsgBox("Invalid Input!!! Do you want to continue Macro?", vbQuestion + vbYesNo + vbDefaultButton2, "Next step")
If answer = vbYes Then
GoTo Repeat
Else
Exit Sub
End If
End If
'Set variables
dStart = Timer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'Check of table exist or else create table
For k = 1 To TotalNumberInputs
ws.Cells(1, k).Select
CellAddr = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False)
CellValue = Cells(1, l).Value ' "Table" & (k + "0") ' Selection.Value
On Error Resume Next
Set ListObj = ActiveSheet.ListObjects(CellValue)
On Error GoTo 0
If ListObj Is Nothing Then
Range(CellAddr).Select
Range(Selection, Selection.End(xlDown)).Select
RangeAddr = Selection.Address
Range(RangeAddr).Activate
ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=Range(RangeAddr), LinkSource:=False, XlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium28").Name = CellValue
Else
'If the table does exist clear filter from column C
' ActiveSheet.ListObjects(CellValue).Range.AutoFilter Field:=3
End If
Next k
l = 1
'Loop sheets and tables
' For Each ws In ActiveWorkbook.Worksheets
For Each lo In ws.ListObjects ' For j = 1 To TotalNumberInputs ' For Each lo In ws.ListObjects
sName = lo.Name ' ws.Cells(1, l).Value ' lo.Name
l = l + 1
sFormula = "Excel.CurrentWorkbook(){[Name=""" & sName & """]}[Content]"
'Check if query exists
bExists = False
For Each wq In wb.Queries
If InStr(1, wq.Formula, sFormula) > 0 Then
bExists = True
End If
Next wq
'Add query if it does not exist
If bExists = False Then
' Add a Query
wb.Queries.Add Name:=sName, Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Excel.CurrentWorkbook(){[Name=""" & sName & """]}[Content]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Source,{{""" & sName & """, type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type"""
'Add connection
wb.Connections.Add2 Name:="Query - " & sName, _
Description:="Connection to the '" & sName & "' query in the workbook.", _
ConnectionString:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & sName & ";Extended Properties=""""", _
CommandText:="SELECT * FROM [" & sName & "]", _
lCmdtype:=2, _
CreateModelConnection:=False, _
ImportRelationships:=False
'Count connections
i = i + 1
End If
Next lo ' Next j ' Next lo
'Next ws
'Calc run time
dTime = Timer - dStart
MsgBox i & " connections have been created in " & Format(dTime, "0.0") & " seconds.", vbOKOnly, "Process Complete"
End Sub
How do I save email (msg)?
This code creates a daily folder structure and saves email attachments but not the email itself.
Option Explicit
Public Sub saveAttachtoDisk(itm As Outlook.mailitem)
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
' Check for folder and create if needed
If Len(Dir("C:\Temp\" & Year(Date), vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date)
End If
If Len(Dir("C:\Temp\" & Year(Date) & "\" & Month(Date), _
vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date) & "\" & Month(Date)
End If
If Len(Dir("C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date), _
vbDirectory)) = 0 Then
MkDir "C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
End If
For Each objAtt In itm.Attachments
objAtt.SaveAsFile SaveFolder & "\" & Format(Date, "yyyymmdd") & "_" & _
objAtt.DisplayName
Next
Set objAtt = Nothing
End Sub
Try
Dim FileName As String
FileName = Format(Date, "yyyymmdd") & "_" & objAtt.DisplayName
itm.SaveAs SaveFolder & "\" & FileName & ".msg", olMsg
Also Replace invalid characters with empty strings, here I'm using Regex
For Each objAtt In itm.Attachments
Dim FileName As String
FileName = Format(Date, "yyyymmdd") & "_" & objAtt.DisplayName
objAtt.SaveAsFile SaveFolder & "\" & FileName
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Pattern = "[^\w\#-]"
.IgnoreCase = True
.Global = True
End With
FileName = RegEx.Replace(FileName, " ")
itm.SaveAs SaveFolder & "\" & FileName & ".msg", olMsg
Next
Now test your code with Selection.item(1)
Public Sub Test_Rule()
Dim olMsg As Outlook.mailitem
Set olMsg = ActiveExplorer.Selection.Item(1)
saveAttachtoDisk olMsg
End Sub
Call itm.SaveAs(..., olMsg) to save in the MSG format
So this is my situation:
User visits www.a.com where a cookie is set:
$.cookie('panelcookie', userid, {path: '/' });
When this user now visits www.b.com, where our tracking pixel is
<img src="http://www.a.com/trackpixel.asp" width=1 height=1>
, the pixel should write that userid to a log along with other info (the following is what I've come up with so far):
<%
Const ForAppending = 8
Const Create = true
Dim FSO
Dim TS
Dim Panelcookie
Dim MyFileName
Dim strLog
Dim cMyValue
MyFileName = Server.MapPath("asptrack.txt")
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
Set TS = FSO.OpenTextFile(MyFileName, ForAppending, Create)
' Store all the required information in a string Called strLog
strLog = "<br><P><B>" & NOW() & "</B> "
strLog = strLog & Request.ServerVariables("REMOTE_ADDR") & " "
strLog = strLog & Request.ServerVariables("HTTP_REFERER") & " "
strLog = strLog & "User has cookie? " & Request.Cookies("panelcookie") & " "
strLog = strLog & Request.ServerVariables("HTTP_USER_AGENT") & "<BR>"
' Write current information to Log Text File.
TS.write strLog
TS.Writeline ""
%>
How do I accomplish this?
I parse message data into a CSV file via Outlook rules.
How can I take the example below and store the text under "Customer Log Update:" into a string variable?
[Header Data]
Description: Problem: A2 - MI ERROR - R8036
Customer Log Update:
I'm having trouble with order #458362. I keep getting Error R8036, can you please assist?
Thanks!
View problem at http://...
[Footer Data]
Desired result to be stored into the string variable (note that the result may contain newlines):
I'm having trouble with order #458362. I keep getting Error R8036, can you please assist?
Thanks!
I haven't attempted to code anything pertaining to my question.
Function RegFind(RegInput, RegPattern)
Dim regEx As New VBScript_RegExp_55.RegExp
Dim matches, s
regEx.Pattern = RegPattern
regEx.IgnoreCase = True
regEx.Global = False
s = ""
If regEx.Test(RegInput) Then
Set matches = regEx.Execute(RegInput)
For Each Match In matches
s = Match.Value
Next
RegFind = s
Else
RegFind = ""
End If
End Function
Sub CustomMailMessageRule(Item As Outlook.MailItem)
MsgBox "Mail message arrived: " & Item.Subject
Const FileWrite = file.csv `file destination
Dim FF1 As Integer
Dim subj As String
Dim bod As String
On Error GoTo erh
subj = Item.Subject
'this gets a 15 digit number from the subject line
subj = RegFind(subj, "\d{15}")
bod = Item.Body
'following line helps formatting, lots of double newlines in my source data
bod = Replace(bod, vbCrLf & vbCrLf, vbCrLf)
'WRITE FILE
FF1 = FreeFile
Open FileWrite For Append As #FF1
Print #FF1, subj & "," & bod
Close #FF1
Exit Sub
erh:
MsgBox Err.Description, vbCritical, Err.Number
End Sub
While I would also go the more direct route like Jean-François Corbett did as the parsing is very simple, you could apply the Regexp approach as below
The pattern
Update:([\S\s]+)view
says match all characters between "Update" and "view" and return them as a submatch
This piece [\S\s] says match all non-whitespace or whitespace characters - ie everything.
In vbscript a . matches everything but a newline, hence the need for the [\S\s] workaround for this application
The submatch is then extracted by
objRegM(0).submatches(0)
Function ExtractText(strIn As String)
Dim objRegex As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.ignorecase = True
.Pattern = "Update:([\S\s]+)view"
If .test(strIn) Then
Set objRegM = .Execute(strIn)
ExtractText = objRegM(0).submatches(0)
Else
ExtractText = "No match"
End If
End With
End Function
Sub JCFtest()
Dim messageBody As String
Dim result As String
messageBody = "Description: Problem: A2 - MI ERROR - R8036" & vbCrLf & _
"Customer Log Update:" & _
"I 'm having trouble with order #458362. I keep getting Error R8036, can you please assist?" & vbCrLf & _
"Thanks!" & vbCrLf & _
"View problem at http://..."
MsgBox ExtractText(messageBody)
End Sub
Why not something simple like this:
Function GetCustomerLogUpdate(messageBody As String) As String
Const sStart As String = "Customer Log Update:"
Const sEnd As String = "View problem at"
Dim iStart As Long
Dim iEnd As Long
iStart = InStr(messageBody, sStart) + Len(sStart)
iEnd = InStr(messageBody, sEnd)
GetCustomerLogUpdate = Mid(messageBody, iStart, iEnd - iStart)
End Function
I tested it using this code and it worked:
Dim messageBody As String
Dim result As String
messageBody = "Description: Problem: A2 - MI ERROR - R8036" & vbCrLf & _
"Customer Log Update:" & vbCrLf & _
"I 'm having trouble with order #458362. I keep getting Error R8036, can you please assist?" & vbCrLf & _
"Thanks!" & vbCrLf & _
"View problem at http://..."
result = GetCustomerLogUpdate(messageBody)
Debug.Print result
I'm trying to figure this out and I just cannot get it to work, I'm stuck please help.
I have a .txt file that will look something like this
Example:
GA117.50.0117.50.0117.50.0IL16.08.08.00.016.00.0IN284.09.4274.60.0284.00.0KY137.60.0137.60.0137.60.0TN170.30.0170.30.0170.30.0US725.417.4708.00.0725.40.0TOTAL725.417.4708.00.0725.40.0
What I'm trying to do in classic-asp is to get the letters/word in a dim (and add a str before the letters/word) and the numbers as the value for that dim but only to the first period and 1 more number to the right after the period and then continue to the next letter/word.
so the final outcome would look something like this:
dim strGA
dim strIL
dim strIN
dim strKY
dim strTN
dim strUS
dim strTOTAL
strGA=117.5
strIL=16.0
strIN=284.0
strKY=137.6
strTN=170.3
strUS=725.4
strTOTAL=725.4
Thank you so much for any help with this problem/question.
Consider the following example.
May need to change the pattern according to the variable names.
Dim strTest
strTest = "GA117.50.0117.50.0117.50.0IL16.08.08.00.016.00.0IN284.09.4274.60.0284.00.0KY137.60.0137.60.0137.60.0TN170.30.0170.30.0170.30.0US725.417.4708.00.0725.40.0TOTAL725.417.4708.00.0725.40.0"
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "([a-z]+)(\d+\.\d)"
Dim collMatches
Set collMatches = re.Execute(strTest)
Dim iMatch, strDims, strAssocs
For Each iMatch In collMatches
strDims = strDims & "Dim str" & iMatch.SubMatches(0) & vbCrLf
strAssocs = strAssocs & "str" & iMatch.SubMatches(0) & " = " & iMatch.SubMatches(1) & vbCrLf
Next
Dim strExec
strExec = strDims & vbCrLf & strAssocs
'Dump
Response.Write "Dump:<hr /><pre>" & strExec & "<pre>"
ExecuteGlobal strExec 'Execute the code
'Test
With Response
.Write "Executed:<hr />"
.Write "strGA: " & strGA & "<br />"
.Write "strIL: " & strIL & "<br />"
.Write "strIN: " & strIN & "<br />"
.Write "strKY: " & strKY & "<br />"
.Write "strTN: " & strTN & "<br />"
.Write "strUS: " & strUS & "<br />"
.Write "strTOTAL:" & strTOTAL & "<br />"
End With