I am trying to get an FTP Download operation to work with VBA Excel (on Excel 2013 x64, Windows 7 SP1 x64). I found some code that maps to the WinInet API and I can successfully upload files using the PutFile function but I am looking to get a GetFile function to work as well.
To get working what I have so far, I used the following: second answer here, and this link. I've been mostly using the second answer from SO to get PutFile to work. I had to make some changes to the original code to make it compatible with 32 bit and 64 bit systems.
You can see my progress here.
What I am looking to do is make an easy to use Sub that calls this declaration:
Private Declare Function FtpGetFile Lib "WinInet" Alias "FtpGetFileA" (ByVal hFtp As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
I.E. a Sub like this:
Public Sub GetFile(RemoteFilename As String, LocalFilename As String)
If FtpGetFile(' what arguments do I put here ') = 0 Then
Err.Raise vbObjectError + 1, , LastError
End If
End Sub
I am struggling because I am not very familiar with the WinInet API and am having difficulty parsing the required arguments and what are the appropriate variables to pass for those arguments.
This should get you started on the right path, based on the example provided.
In your class module:
Public Sub GetFile(RemoteFilename As String, NewFilename As String)
If FtpGetFile(m_hFtp, RemoteFilename, NewFilename, False, 0, FTP_TRANSFER_TYPE_BINARY, 0) = 0 Then
Err.Raise vbObjectError + 1, , LastError
End If
End Sub
How to call it:
Sub DownloadFile()
Dim ftp As New CFtp
ftp.Connect "serverAddress", "username", "password"
ftp.GetFile "nameOfFileOnServer.txt", "C:\SomePath\nameOfNewFile.txt"
ftp.Disconnect
End Sub
The parameters specify some attributes to associate with the downloaded file. For example, fFailIfExists is a Boolean that describes whether or not to throw an exception if it is trying to overwrite a local file that already exists. The other flags specify attributes to attach to the file it creates.
Related
I am using vba code to open an access database from another access database using the following codes
Public Declare Function ShellExecuteA Lib "shell32.dll" _
(ByVal hWnd As Long, ByVal strOperation As String, _
ByVal strFile As String, ByVal strParameters As String, ByVal strDirectory As _
String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Dim lngreturn As Long
lngreturn = ShellExecuteA(GetDesktopWindow(), "OPEN", strFilePath, "", "", vbNormalFocus)
It works fine except that it keeps opening new instances of the database even if there is one already open in the background. I need codes to bring the opened database to the foreground. NB:- I have used AppActivate and it does not work because I am already in msaccess and the other database that I want to bring to the foreground is also in access.
Set an Application title for the second database in File - Options - Current database.
Then use that title with AppActivate.
Alternatively, instead of using ShellExecuteA, build a full command line (including the path to msaccess.exe), and use the Shell() function to start the second database:
Runs an executable program and returns a Variant (Double) representing the program's task ID if successful
Store this task ID in a public or static variable, and use it with AppActivate.
I cobbled this test procedure together in Outlook 2013 from other posts.
It should display a popup box, and then close after 3 seconds.
It never closes.
Sub MessageBoxTimer()
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 3
Select Case InfoBox.Popup("Click OK (this window closes automatically after 3 seconds).", _
AckTime, "This is your Message Box", 0)
Case 1, -1
Exit Sub
End Select
End Sub
Some research suggests that this may be a bug in some MS Office applications. I'm basing this on the fact that this and this don't seem to say anything which suggests you're using the command in the wrong way, and this shows that other users have managed to get precisely this code to work.
I tested this on my Windows PC running Excel with Office 365 and have had the same issue as you - the message box is displayed, but not closed. I found a suggested workaround here, and the discussion on that page may be of some interest to you (particularly one user's description of trying to submit a bug report to Microsoft about VBA). The solution, proposed by a user called ウィンドウズスクリプトプログラマ, is to make a call through to the native user32.dll by declaring an external function - this page has some examples of how to call C dlls with VBA.The MessageBoxTimeout function is said to be undocumented by Microsoft, but you can find out a lot about it here.
The other option, which worked for me, is run a vbscript call to Shell.Popup with mshta.exe:
Function Test()
Dim Shell
Set Shell = CreateObject("WScript.Shell")
Shell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(""Test"",3,""Message""))"
End Function
To get this to work with more complex messages, you may need to escape some characters. There is another SO question here which shows other uses for mshta's ability to execute vbscript in a shell/ console.
Finally, as was suggested by one user, you could simply create a custom user form with a doevents loop that counts down and then closes itself.
The WScript.Shell .Popup seems to be hit or miss in Office VBA.
If you are looking for a MsgBox that works in Office VBA and supports a timeout, I posted another method that uses a Windows API call. It supports timeout, carriage returns, and return values. You can find the code at this link. I did not think it was proper etiquette to post it again here.
Note that the mshta method mentioned by #Orphid does not support carriage returns and always shows the message on the primary monitor.
Yes, I can confirm that result: the 'Timeout' on the WsShell.Popup function is no longer working in Office.
It took me a while to notice, because popup dialogs with a 'cancel' button seem to be affected less. So this might be a usable workaround for you:
Dim msg AS String
Dim Title as String
msg ="Click 'Ok' or 'Cancel' (this window closes automatically after 3 seconds)."
Title = Application.name & ": Message Box test"
Select Case InfoBox.Popup(msg, AckTime, Title, vbQuestion + vbOkCancel)
If that doesn't work, you're going to need a much longer explanation: reimplementing the 'Timeout' using an API Timer Callback. As the author of that answer, I should warn you that this is using a sledgehammer to crack a nut after attempting the task with a prolonged naval bombardment.
I have tried the following code to control VBA msg box auto closer after 40 sec. You can try also it. It will work for you.
'The first part
#If Win64 Then '64?
Private Declare PtrSafe Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
#Else
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
#End If
'The second part
Sub btnMsgbox(message As String)
Call MsgBoxTimeout(0, message, "", vbInformation, 0, 40000)
End Sub
I am new to VB and is working on VB6 to VB.net migration. There is one API call which appends a prefix in temporary file name.
I have added the dll as
<DllImport("kernel32")> _
Private Shared Function GetTempFileName(ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
End Function
When I am calling this:
test = GetTempFileName(My.Application.Info.DirectoryPath, Prefix, 0, m_sTempfile)
It throws an exception:
An unhandled exception of type 'System.AccessViolationException' occurred in Forum.exe
Additional information: Attempted to read or write protected memory. This is often an indication that other memory is corrupt.
I tried using Path.GetTempFileName() but I might need to perform several manipulation to get the file name prefixed with specific word and located to specific location.
I crossed checked the values and they are NOT bad data.
I tried mutiple resolutions, but none of it worked.
Can someone help in this? Thanks in advance!
Pinvoke declarations need to be rewritten when you move them to VB.NET. Many differences, like Long needs to be Integer and if the winapi function returns a string then you need to use StringBuilder instead of String. Required because String is an immutable type.
Proper declaration is:
<DllImport("kernel32", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function GetTempFileName(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Integer, _
ByVal lpTempFileName As StringBuilder) As Integer
End Function
And a proper call looks like:
Dim buffer As New StringBuilder(260)
If GetTempFileName("c:\temp", "xyz", 0, buffer) = 0 Then
Throw New System.ComponentModel.Win32Exception()
End If
Dim filename = buffer.ToString()
The pinvoke.net website tends to be a half-decent resource for pinvoke declarations. Not for this one though, the VB.NET version is pretty fumbled.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 9 years ago.
Improve this question
I love Ghostscript. You can use it to convert pdf's to graphics files, split and/or merge pdf files, make thumbnails, and a whole bunch of other stuff. And, it's free, open-source software!
There are scads of posts on web sites on how to use Ghostscript from the command line for all sorts of platforms. But, I could never find a simple vb.net dll wrapper that used the Ghostscript dll (gsdll32.dll) instead of starting a process to run the Ghostscript command line app.
So, I came up with this code. I am posting it here in hopes that others can avoid the frustration I felt looking for something simple and straight forward. It avoids those goofy arrays of byte array objects you see in some code. It has minimal error handling, but that can be added to suit your application.
Put this code in a module named "GhostscriptDllLib".
Option Explicit On
Imports System.Runtime.InteropServices
'--- Simple VB.Net wrapper for Ghostscript gsdll32.dll
' (Tested using Visual Studio 2010 and Ghostscript 9.06)
Module GhostscriptDllLib
Private Declare Function gsapi_new_instance Lib "gsdll32.dll" _
(ByRef instance As IntPtr, _
ByVal caller_handle As IntPtr) As Integer
Private Declare Function gsapi_set_stdio Lib "gsdll32.dll" _
(ByVal instance As IntPtr, _
ByVal gsdll_stdin As StdIOCallBack, _
ByVal gsdll_stdout As StdIOCallBack, _
ByVal gsdll_stderr As StdIOCallBack) As Integer
Private Declare Function gsapi_init_with_args Lib "gsdll32.dll" _
(ByVal instance As IntPtr, _
ByVal argc As Integer, _
<MarshalAs(UnmanagedType.LPArray, ArraySubType:=UnmanagedType.LPStr)> _
ByVal argv() As String) As Integer
Private Declare Function gsapi_exit Lib "gsdll32.dll" _
(ByVal instance As IntPtr) As Integer
Private Declare Sub gsapi_delete_instance Lib "gsdll32.dll" _
(ByVal instance As IntPtr)
'--- Run Ghostscript with specified arguments
Public Function RunGS(ByVal ParamArray Args() As String) As Boolean
Dim InstanceHndl As IntPtr
Dim NumArgs As Integer
Dim StdErrCallback As StdIOCallBack
Dim StdInCallback As StdIOCallBack
Dim StdOutCallback As StdIOCallBack
NumArgs = Args.Count
StdInCallback = AddressOf InOutErrCallBack
StdOutCallback = AddressOf InOutErrCallBack
StdErrCallback = AddressOf InOutErrCallBack
'--- Shift arguments to begin at index 1 (Ghostscript requirement)
ReDim Preserve Args(NumArgs)
System.Array.Copy(Args, 0, Args, 1, NumArgs)
'--- Start a new Ghostscript instance
If gsapi_new_instance(InstanceHndl, 0) <> 0 Then
Return False
Exit Function
End If
'--- Set up dummy callbacks
gsapi_set_stdio(InstanceHndl, StdInCallback, StdOutCallback, StdErrCallback)
'--- Run Ghostscript using specified arguments
gsapi_init_with_args(InstanceHndl, NumArgs + 1, Args)
'--- Exit Ghostscript
gsapi_exit(InstanceHndl)
'--- Delete instance
gsapi_delete_instance(InstanceHndl)
Return True
End Function
'--- Delegate function for callbacks
Private Delegate Function StdIOCallBack(ByVal handle As IntPtr, _
ByVal Strz As IntPtr, ByVal Bytes As Integer) As Integer
'--- Dummy callback for standard input, standard output, and errors
Private Function InOutErrCallBack(ByVal handle As IntPtr, _
ByVal Strz As IntPtr, ByVal Bytes As Integer) As Integer
Return 0
End Function
End Module
The gsdll32.dll file must be where Windows can find it, best in "\Windows\System32" (or "\Windows\SysWOW64" on a 64-bit machine) or in the same folder as your assembly. It's not the type of dll that has to be registered (in fact, it cannot be registered).
You can then run Ghostscript using a parameter array like this (this sample converts a pdf file to a high quality png file):
Dim PdfFilePath As String = "<Your pdf file path>"
Dim PngFilePath As String = "<Your png file path>"
RunGS("-q", "-dNOPAUSE", "-dBATCH", "-dSAFER", "-sDEVICE=png16m", _
"-r600", _"-dDownScaleFactor=6", "-dTextAlphaBits=4", "-dGraphicsAlphaBits=4", _
"-sPAPERSIZE=letter", "-sOutputFile=" & PngFilePath, PdfFilePath)
Or you can run the code using a string array like this (better if arguments are generated dynamically at run time):
Dim PdfFilePath As String = "<Your pdf file path>"
Dim PngFilePath As String = "<Your png file path>"
Dim Args() As String = {"-q", "-dNOPAUSE", "-dBATCH", "-dSAFER", _
"-sDEVICE=png16m", "-r600", "-dDownScaleFactor=6", "-dTextAlphaBits=4", _
"-dGraphicsAlphaBits=4", "-sPAPERSIZE=letter", _
"-sOutputFile=" & PngFilePath, PdfFilePath}
RunGS(Args)
Notes:
Do not enclose input or output file names (paths) in quotes as you
would for the command line application
Do not escape back-slashes (i.e. "c:path\file.pdf" is ok, "c:path\\file.pdf" is not)
Do not use the Ghostscript "-o" switch; use "sOutputFile="
I have code that needs to run on both Excel 2003 and Excel 2007, and there are a few spots where changes in the versions cause the code to halt. I tried separating these lines out with If-Else statements, but the code won't compile on either because it doesn't recognize the code used for the other. Is there any way I could tell one version to ignore a block of code, similar to a C or C++-style #ifdef, in VBA?
This is a good starting point, but it won't work with the version of Excel that its running on, since that can only be figured out at run-time, not compile time.
If you need to branch your code based on information only discoverable at run time you might consider late binding as a solution. There are two ways you can sneak around version problems.
The first way can be used if you need to Access a property or method that only exists in certain versions, you can use CallByName. The advantage of call by name is that it allows you to preserve early binding (and intellisense) for your objects as much as possible.
To give an example, Excel 2007 has a new TintAndShade property. If you wanted to change the color of a range, and for Excel 2007 also ensure TintAndShade was set to 0 you would run into trouble because your code won't compile in Excel 2003 which does not have TintAndShade as a property of the range object. If you access the property that you know is not in all versions using CallByName, you code will compile in all versions fine, but only run in the versions you specify. See below:
Sub Test()
ColorRange Selection, Excel.Application.version, 6
End Sub
Sub ColorRange(rng As Excel.Range, version As Double, ParamArray args() As Variant)
With rng.Interior
.colorIndex = 6
.Pattern = xlSolid
If version >= 12# Then
'Because the property name is stored in a string this will still compile.
'And it will only get called if the correct version is in use.
CallByName rng.Interior, "TintAndShade", VbLet, 0
End If
End With
End Sub
The second way is for classes that have to be instantiated via "New" and don't even exist in old versions. You won't run into this problem with Excel, but I will give a quickie demo so you can see what I mean:
Imagine that you wanted to do File IO, and for some bizarre reason not all of the computers had the Microsoft Scripting Runtime on them. But for some equally bizarre reason you wanted to make sure it was used whenever it was available. If set a reference to it and use early binding in your code, the code won't compile on systems that don't have the file. So you use late binding instead:
Public Sub test()
Dim strMyString As String
Dim strMyPath As String
strMyPath = "C:\Test\Junk.txt"
strMyString = "Foo"
If LenB(Dir("C:\Windows\System32\scrrun.dll")) Then
WriteString strMyPath, strMyString
Else
WriteStringNative strMyPath, strMyString
End If
End Sub
Public Sub WriteString(ByVal path As String, ByVal value As String)
Dim fso As Object '<-Use generic object
'This is late binding:
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile(path, True, False).Write value
End Sub
Public Sub WriteStringNative(ByVal path As String, ByVal value As String)
Dim lngFileNum As Long
lngFileNum = FreeFile
If LenB(Dir(path)) Then Kill path
Open path For Binary Access Write Lock Read Write As #lngFileNum
Put #lngFileNum, , value
Close #lngFileNum
End Sub
There is a comprehensive list of all Adds and Changes to Excel Object Model since 2003:
http://msdn.microsoft.com/en-us/library/bb149069.aspx
For changes between 1997 and 2000 go here:
http://msdn.microsoft.com/en-us/library/aa140068(office.10).aspx
Yes it is possible to do conditional compilation in Excel VBA. Below is a brief resource and some example code:
Conditional Compilation
#If Win32 Then
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
#End If
Can you post the offending lines of code?
If it is a constant like vbYes or xlFileFormat or whatever, use the corresponding numeric value.
Show me what you got, I'll see if I can refactor it.
Bill