I made a simple VBA code that go to a link and download a Excel file, the link is an intermediate HTML page which then downloads the file, i just need to access, but now i need to save it. I am a noob at VBA, can anyone help me? Follow the code Bellow
Private pWebAddress As String
Public Declare PtrSafe Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Sub NewShell(cmdLine As String, lngWindowHndl As Long)
ShellExecute lngWindowHndl, "open", cmdLine, "", "", 1
End Sub
Public Sub WebPage()
Let pWebAddress = "https://imea.com.br/imea-site/arquivo-externo?categoria=relatorio-de-mercado&arquivo=cup-milho&numeropublicacao=4"
Call NewShell(pWebAddress, 3)
i Have already researched a lot, but none of the ones i have seen had be of help.
UPDATE
With the help of Tim, i sucessfully made the vba code, it was simple.
Dim wb As Workbook
Set wb = Workbooks.Open("PastTheLinkHere")
wb.SaveAs "PastTheDestinationHere"
wb.Close
End Sub
What i really needed was to make the link a direct link, and with help of Tim it was easy. Thank you Tim.
This URL:
https://imea.com.br/imea-site/arquivo-externo?categoria=relatorio-de-mercado&arquivo=cup-milho&numeropublicacao=4
leads to a page with this javascript which builds the final URL:
methods: {
laodMetadata() {
const urlParams = new URLSearchParams(window.location.search);
this.categoria = urlParams.get("categoria");
this.safra = urlParams.get("safra");
this.arquivo = urlParams.get("arquivo");
this.numeropublicacao = urlParams.get("numeropublicacao");
},
async loadData() {
this.loading = true;
const url = "https://publicacoes.imea.com.br";
this.url = url;
if (this.categoria != null)
this.url = this.url + `/${this.categoria}`;
if (this.safra != null) this.url = this.url + `/${this.safra}`;
if (this.arquivo != null) this.url = this.url + `/${this.arquivo}`;
if (this.numeropublicacao != null)
this.url = this.url + `/${this.numeropublicacao}`;
return this.url;
},
The final URL is then:
https://publicacoes.imea.com.br/relatorio-de-mercado/cup-milho/4
So this works and opens the Excel file directly in Excel:
Workbooks.Open "https://publicacoes.imea.com.br/relatorio-de-mercado/cup-milho/4"
You could translate that js into VBA to make a function which would translate the first URL into the second one.
Function tester()
Dim url As String
url = "https://imea.com.br/imea-site/arquivo-externo?" & _
"categoria=relatorio-de-mercado&arquivo=cup-milho&numeropublicacao=4"
Debug.Print MapToDownloadUrl(url)
End Function
Function MapToDownloadUrl(url As String) As String
Dim urlNew As String, dict As Object, e
Set dict = ParseQuerystring(url)
If dict Is Nothing Then Exit Function
urlNew = "https://publicacoes.imea.com.br"
For Each e In Array("categoria", "arquivo", "numeropublicacao")
If dict.exists(e) Then urlNew = urlNew & "/" & dict(e)
Next e
MapToDownloadUrl = urlNew
End Function
'Parse out the querystring parameters from a URL as a dictionary
Function ParseQuerystring(url) As Object
Dim dict As Object, arr, arrQs, e
arr = Split(url, "?")
If UBound(arr) > 0 Then
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = 1 'case-insensitive
arrQs = Split(arr(1), "&")
For Each e In arrQs
If InStr(e, "=") > 0 Then
arr = Split(e, "=")
If UBound(arr) = 1 Then dict.Add arr(0), arr(1)
End If
Next e
Set ParseQuerystring = dict
End If
End Function
Related
I have the below code to open a file location FOLDER, however I would like to open the file itself instead of folder location.
Can someone suggest what should I change in the code.
Private Sub File_locationButton_Click()
Dim filePath
filePath = File_Location
Shell "C:\WINDOWS\explorer.exe """ & filePath & "", vbNormalFocus
End Sub
You can use ShellExecute, so:
Private Sub File_locationButton_Click()
Dim filePath
filePath = File_Location
OpenDocumentFile filePath
End Sub
which calls:
Option Compare Database
Option Explicit
' API declarations for OpenDocumentFile.
' Documentation:
' https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shellexecutea
'
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "USER32" () _
As Long
' ShowWindow constants (selection).
' Documentation:
' https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow
'
Private Const SwShowNormal As Long = 1
Private Const SwShowMinimized As Long = 2
Private Const SwShowMaximized As Long = 3
' Open a document file using its default viewer application.
' Optionally, the document can be opened minimised or maximised.
'
' Returns True if success, False if not.
' Will not raise an error if the path or file is not found.
'
' 2022-03-02. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function OpenDocumentFile( _
ByVal File As String, _
Optional ShowCommand As Long = SwShowNormal) _
As Boolean
Const OperationOpen As String = "open"
Const MinimumSuccess As Long = 32
' Shall not have a value for opening a document.
Const Parameters As String = ""
Dim Handle As Long
Dim Directory As String
Dim Instance As Long
Dim Success As Boolean
Handle = GetDesktopWindow
Directory = Environ("Temp")
Instance = ShellExecute(Handle, OperationOpen, File, Parameters, Directory, ShowCommand)
' If the function succeeds, it returns a value greater than MinimumSuccess.
Success = (Instance > MinimumSuccess)
OpenDocumentFile = Success
End Function
The following code gives me the error system.argumentexception an element with the same key already exists. When I use in the the Friend Sub Test the following line instead: 'Dim str_rootdirectory As String = Directory.GetCurrentDirectory() ' "C:\TEMP" it works. Whats the difference?
My VB.NET code:
Public Class Form1
Public Sub recur_getdirectories(ByVal di As DirectoryInfo)
For Each directory As DirectoryInfo In di.GetDirectories()
'get each directory and call the module main to get the security info and write to json
Call Module1.Main(directory.FullName)
recur_getdirectories(directory)
Next
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim rootDirectory As String = TextBox1.Text.Trim()
Dim di As New DirectoryInfo(rootDirectory)
'get directories recursively and work with each of them
recur_getdirectories(di)
End Sub
End Class
Public Module RecursiveEnumerableExtensions
Iterator Function Traverse(Of T)(ByVal root As T, ByVal children As Func(Of T, IEnumerable(Of T)), ByVal Optional includeSelf As Boolean = True) As IEnumerable(Of T)
If includeSelf Then Yield root
Dim stack = New Stack(Of IEnumerator(Of T))()
Try
stack.Push(children(root).GetEnumerator())
While stack.Count <> 0
Dim enumerator = stack.Peek()
If Not enumerator.MoveNext() Then
stack.Pop()
enumerator.Dispose()
Else
Yield enumerator.Current
stack.Push(children(enumerator.Current).GetEnumerator())
End If
End While
Finally
For Each enumerator In stack
enumerator.Dispose()
Next
End Try
End Function
End Module
Public Module TestClass
Function GetFileSystemAccessRule(d As DirectoryInfo) As IEnumerable(Of FileSystemAccessRule)
Dim ds As DirectorySecurity = d.GetAccessControl()
Dim arrRules As AuthorizationRuleCollection = ds.GetAccessRules(True, True, GetType(Security.Principal.NTAccount))
For Each authorizationRule As FileSystemAccessRule In arrRules
Dim strAclIdentityReference As String = authorizationRule.IdentityReference.ToString()
Dim strInheritanceFlags As String = authorizationRule.InheritanceFlags.ToString()
Dim strAccessControlType As String = authorizationRule.AccessControlType.ToString()
Dim strFileSystemRights As String = authorizationRule.FileSystemRights.ToString()
Dim strIsInherited As String = authorizationRule.IsInherited.ToString()
Next
' This function should return the following values, because they should be mentoined in the JSON:
' IdentityReference = strAclIdentityReference
' InheritanceFlags = strInheritanceFlags
' AccessControlType = strAccessControlType
' FileSystemRights = strFileSystemRights
' IsInherited = strIsInherited
Return ds.GetAccessRules(True, True, GetType(System.Security.Principal.NTAccount)).Cast(Of FileSystemAccessRule)()
End Function
Friend Sub Test(ByVal curDirectory As String)
'Dim str_rootdirectory As String = Directory.GetCurrentDirectory() ' "C:\TEMP"
Dim str_rootdirectory As String = curDirectory
Dim di As DirectoryInfo = New DirectoryInfo(str_rootdirectory)
Dim directoryQuery = RecursiveEnumerableExtensions.Traverse(di, Function(d) d.GetDirectories())
Dim list = directoryQuery.Select(
Function(d) New With {
.directory = d.FullName,
.permissions = {
GetFileSystemAccessRule(d).ToDictionary(Function(a) a.IdentityReference.ToString(), Function(a) a.FileSystemRights.ToString())
}
}
)
Dim json = JsonConvert.SerializeObject(list, Formatting.Indented)
File.WriteAllText("ABCD.json", json)
End Sub
End Module
Public Module Module1
Public Sub Main(ByVal curDirectory As String)
Console.WriteLine("Environment version: " & Environment.Version.ToString())
Console.WriteLine("Json.NET version: " & GetType(JsonSerializer).Assembly.FullName)
Console.WriteLine("")
Try
TestClass.Test(curDirectory)
Catch ex As Exception
Console.WriteLine("Unhandled exception: ")
Console.WriteLine(ex)
Throw
End Try
End Sub
End Module
My example folder structure:
Folder: "C:\Temp"
Permissions: SecurityGroup-A has Fullcontrol,
SecurityGroup-B has Modify permission
Folder: "C:\Temp\Folder_A"
Permissions: SecurityGroup-C has Fullcontrol
But this is only an example of two folders. In real, it will run over several hundered folders with sub-folders. Accordingly the JSON will extend.
My json output expectation:
[{
"directory": "C:\\TEMP",
"permissions": [{
"IdentityReference": "CONTOSO\\SecurityGroup-A",
"AccessControlType": "Allow",
"FileSystemRights": "FullControl",
"IsInherited": "TRUE"
}, {
"IdentityReference": "CONTOSO\\SecurityGroup-B",
"AccessControlType": "Allow",
"FileSystemRights": "Modify",
"IsInherited": "False"
}
]
}, {
"directory": "C:\\TEMP\\Folder_A",
"permissions": [{
"IdentityReference": "CONTOSO\\SecurityGroup-C",
"AccessControlType": "Allow",
"FileSystemRights": "Full Control",
"IsInherited": "False"
}
]
}
]
Your current JSON uses static property names for the [*].permissions[*] objects so there is no need to try to convert a list of them into a dictionary with variable key names via ToDictionary():
' This is not needed
.permissions = {
GetFileSystemAccessRule(d).ToDictionary(Function(a) a.IdentityReference.ToString(), Function(a) a.FileSystemRights.ToString())
}
Instead, convert each FileSystemAccessRule into some appropriate DTO for serialization. An anonymous type object works nicely for this purpose:
Public Module DirectoryExtensions
Function GetFileSystemAccessRules(d As DirectoryInfo) As IEnumerable(Of FileSystemAccessRule)
Dim ds As DirectorySecurity = d.GetAccessControl()
Dim arrRules As AuthorizationRuleCollection = ds.GetAccessRules(True, True, GetType(Security.Principal.NTAccount))
Return arrRules.Cast(Of FileSystemAccessRule)()
End Function
Public Function SerializeFileAccessRules(ByVal curDirectory As String, Optional ByVal formatting As Formatting = Formatting.Indented)
Dim di As DirectoryInfo = New DirectoryInfo(curDirectory)
Dim directoryQuery = RecursiveEnumerableExtensions.Traverse(di, Function(d) d.GetDirectories())
Dim list = directoryQuery.Select(
Function(d) New With {
.directory = d.FullName,
.permissions = GetFileSystemAccessRules(d).Select(
Function(a) New With {
.IdentityReference = a.IdentityReference.ToString(),
.AccessControlType = a.AccessControlType.ToString(),
.FileSystemRights = a.FileSystemRights.ToString(),
.IsInherited = a.IsInherited.ToString()
}
)
}
)
Return JsonConvert.SerializeObject(list, formatting)
End Function
End Module
Public Module RecursiveEnumerableExtensions
' Translated to vb.net from this answer https://stackoverflow.com/a/60997251/3744182
' To https://stackoverflow.com/questions/60994574/how-to-extract-all-values-for-all-jsonproperty-objects-with-a-specified-name-fro
' which was rewritten from the answer by Eric Lippert https://stackoverflow.com/users/88656/eric-lippert
' to "Efficient graph traversal with LINQ - eliminating recursion" https://stackoverflow.com/questions/10253161/efficient-graph-traversal-with-linq-eliminating-recursion
Iterator Function Traverse(Of T)(ByVal root As T, ByVal children As Func(Of T, IEnumerable(Of T)), ByVal Optional includeSelf As Boolean = True) As IEnumerable(Of T)
If includeSelf Then Yield root
Dim stack = New Stack(Of IEnumerator(Of T))()
Try
stack.Push(children(root).GetEnumerator())
While stack.Count <> 0
Dim enumerator = stack.Peek()
If Not enumerator.MoveNext() Then
stack.Pop()
enumerator.Dispose()
Else
Yield enumerator.Current
stack.Push(children(enumerator.Current).GetEnumerator())
End If
End While
Finally
For Each enumerator In stack
enumerator.Dispose()
Next
End Try
End Function
End Module
Demo fiddle here (which unfortunately does not work on https://dotnetfiddle.net because of security restrictions on client code but should be runnable in full trust).
I have an ssis package with an existing vb script task to send emails.
I am rewriting it in c#.
The vb version works, the c# version doesn't but it doesn't fail or error either, that I can see.
If I put a breakpoint in both, when I run the package to debug, it breaks in the vb script but not the c# script.
I have included the code for each below.
They are very similar so I am wondering if there is a task setting that controls this that I am overlooking.
Thanks in advance
The vb script is as follows.
...
Public Sub Main()
Dim htmlMessageFrom As String = Dts.Variables("SSISErrorEmailFrom").Value.ToString
Dim htmlMessageTo As String = Dts.Variables("SSISErrorEmailTo").Value.ToString
Dim htmlMessageSubject As String = Dts.Variables("SSISErrorEmailSubject").Value.ToString
Dim htmlMessageBody As String = Dts.Variables("SSISErrorEmailBody").Value.ToString
Dim SSISErrorTable As String = Dts.Variables("SSISErrorTable").Value.ToString
Dim smtpConnectionString As String = DirectCast(Dts.Connections("SMTP Connection").AcquireConnection(Dts.Transaction), String)
Dim smtpServer As String = "smtprelay.white01.babcockgroup.co.uk"
htmlMessageBody = htmlMessageBody.Replace("###subject###", htmlMessageSubject)
htmlMessageBody = htmlMessageBody.Replace("###SSISErrorTable###", SSISErrorTable)
SendMailMessage(
htmlMessageFrom, htmlMessageTo,
htmlMessageSubject, htmlMessageBody,
True, smtpServer)
Dts.TaskResult = ScriptResults.Success
End Sub
Private Sub SendMailMessage(
ByVal From As String, ByVal SendTo As String,
ByVal Subject As String, ByVal Body As String,
ByVal IsBodyHtml As Boolean, ByVal Server As String)
Dim htmlMessage As MailMessage
Dim mySmtpClient As SmtpClient
htmlMessage = New MailMessage(
From, SendTo, Subject, Body)
htmlMessage.IsBodyHtml = IsBodyHtml
mySmtpClient = New SmtpClient(Server)
mySmtpClient.Credentials = CredentialCache.DefaultNetworkCredentials
mySmtpClient.Send(htmlMessage)
End Sub
...
The c# scipt is as follows
...
public void Main()
{
sendEmail();
}
private void sendEmail()
{
var noBytes = new byte[0];
// TODO: Add your code here
try
{
string SSISErrorEmailTo = Dts.Variables["SSISErrorEmailTo"].Value.ToString();
string SSISErrorEmailFrom = Dts.Variables["SSISErrorEmailFrom"].Value.ToString();
string SSISErrorEmailSubject = Dts.Variables["SSISErrorSubject"].Value.ToString();
string SSISErrorEmailBody = Dts.Variables["SSISErrorEmailBody"].Value.ToString();
string SSISErrorTable = Dts.Variables["SSISErrorTable"].Value.ToString();
SSISErrorEmailBody.Replace("###subject###", SSISErrorEmailSubject);
SSISErrorEmailBody.Replace("###SSISErrorTable###", SSISErrorTable);
string SmtpServer = "smtprelay.white01.babcockgroup.co.uk";
MailMessage msg = new MailMessage(SSISErrorEmailFrom, SSISErrorEmailTo, SSISErrorEmailSubject, SSISErrorEmailBody);
msg.IsBodyHtml = true;
SmtpClient smtpClient = new SmtpClient(SmtpServer);
smtpClient.Credentials = CredentialCache.DefaultNetworkCredentials;
smtpClient.Send(msg);
Dts.TaskResult = (int)ScriptResults.Success;
Dts.Log("OnError script completed", -1, noBytes);
}
catch (Exception e)
{
Dts.TaskResult = (int)ScriptResults.Failure;
Dts.Log(e.InnerException.Message, -1, noBytes);
}
}
...
Does anyone know of a way when using InternetExplorer.Application of using the FileDownload Event and what is possible with it? I'm trying to detect when IE is downloading a file so that when the file download is done the file is handled automatically.
There is a DownloadBegin and a DownloadComplete Events but this look to be talking about when navigating to a URL and not an accual file download.
You should be able to confirm the status of the download process.
Option Explicit
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub DownloadFileAPI()
Dim strURL As String
Dim LocalFilePath As String
Dim DownloadStatus As Long
strURL = "http://data.iana.org/TLD/tlds-alpha-by-domain.txt"
LocalFilePath = "C:\Test\TEST2_tlds-alpha-by-domain.txt"
DownloadStatus = URLDownloadToFile(0, strURL, LocalFilePath, 0, 0)
If DownloadStatus = 0 Then
MsgBox "File Downloaded. Check in this path: " & LocalFilePath
Else
MsgBox "Download File Process Failed"
End If
End Sub
Sub DownloadFile()
Dim WinHttpReq As Object
Dim oStream As Object
Dim myURL As String
Dim LocalFilePath As String
myURL = "http://data.iana.org/TLD/tlds-alpha-by-domain.txt"
LocalFilePath = "C:\Test\TEST_tlds-alpha-by-domain.txt"
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "", "" '("username", "password")
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile LocalFilePath, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
I had tried the previous answer. Everything works fine until my data which extracted from server in the form of Json is giving me a key with multiple objects
Excel VBA: Parsed JSON Object Loop
something like this
{"messageCode":null,"responseStatus":"success","message":null,"resultObject":null,"resultObject2":[{"fxCcyPair":"USD"}, {"fxCcyPair":"EUR"},{"fxCcyPair":"JPY"},{"fxCcyPair":"GBD"}],"resultObject3":null,"resultObject4":null}
How can I get the value in "resultObject2"? as there is no key for me to refer and I am not able to loop the object out from it.
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
ScriptEngine.AddCode "function getSentenceCount(){return obj.sentences.length;}"
ScriptEngine.AddCode "function getSentence(i){return obj.sentences[i];}"
End Sub
Public Function DecodeJsonString(ByVal JsonString As String)
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim index As Integer
Dim Key As Variant
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
index = 0
For Each Key In KeysObject
KeysArray(index) = Key
Debug.Print Key
index = index + 1
Next
GetKeys = KeysArray
End Function
Thanks
This is a bit more manageable I think (based on S Meaden's answer at your linked question)
Sub TestJSONParsingWithVBACallByName()
Dim oScriptEngine As ScriptControl
Set oScriptEngine = New ScriptControl
oScriptEngine.Language = "JScript"
Dim objJSON As Object, arr As Object, el
'I pasted your JSON in A1 for testing...
Set objJSON = oScriptEngine.Eval("(" + Range("A1").Value + ")")
Debug.Print VBA.CallByName(objJSON, "responseStatus", VbGet)
'get the array associated with "resultObject2"
Set arr = VBA.CallByName(objJSON, "resultObject2", VbGet)
Debug.Print VBA.CallByName(arr, "length", VbGet) 'how many elements?
'loop over the array and print each element's "fxCcyPair" property
For Each el In arr
Debug.Print VBA.CallByName(el, "fxCcyPair", VbGet)
Next el
End Sub
Output:
success
4
USD
EUR
JPY
GBD