I need to use FTP Command Function from wininet.dll to send some FTP command. It's working when I use QUIT command. But when I try to use for example LS or DIR I get response 0.
Private Declare Function FtpCommand Lib "wininet.dll" Alias "FtpCommandA" (ByVal hConnect As Long, ByVal fExpectResponse As Long, ByVal dwFlags As Long, ByVal lpszCommand As String, ByVal dwContext As Long, phFtpCommand As Long) As Long
Private Function test()
Dim Success As Long
Dim iRet As Integer
Dim lngInet As Long
Dim lngInetConn As Long
Dim sCommand As String
Dim test44 As Long
sCommand = "DIR"
Dim test5 As Long
Dim lError As Long
Dim strBuffer As String
Dim lBufferSize As Long
Dim retVal As Long
lngInet = InternetOpen("MyFTP Control", 1, vbNullString, vbNullString, 0) 'Open connection with fpt
If lngInet = 0 Then
iRet = MsgBox("bad")
Else
lngInetConn = InternetConnect(lngInet, Server.Value, 0, _
User.Value, Pass.Value, 1, 0, 0) 'Connect to server
If lngInetConn > 0 Then
Login = True
blnRC = FtpCommand(lngInetConn, True, FTP_TRANSFER_TYPE_ASCII, sCommand, test44, test5)
retVal = InternetGetLastResponseInfo(lError, strBuffer, lBufferSize)
Else
Login = False
LoginError
End If
End If
InternetCloseHandle (lngInet) 'Close Ftp I thnik is not necessary
InternetCloseHandle (lngInetConn) 'Close Connection I thnik is not necessary
End Function
There's no DIR or LS commands in FTP. There's LIST command (or MLSD or NLST).
Do not use FtpCommand function anyway.
Use FtpFindFirstFile and InternetFindNextFile instead.
Related
I'm trying to simplify a report template by writing VBA code that checks an Excel Workbook and fills in the Word document.
The code fails to terminate the Excel.exe process in Task Manager.
I tried solutions proposed here, other forums and in Microsoft's documentation. I gather it has to do with COM objects still existing when running the Application.Quit method but can't figure out where those come from.
When reducing the code down to it's most basic components there's no Excel.exe process still in Task Manager:
Private Sub Hämta_Click()
Dim XL As Excel.Application
Set XL = New Excel.Application
XL.Quit
Set XL = Nothing
End Sub
But as soon as I add to it, Excel.exe keeps running in Task Manager:
Private Sub Hämta_Click()
Dim XL As Excel.Application
Set XL = New Excel.Application
Dim wkb As Excel.Workbook
Set wkb = XL.Workbooks.Open("C:\Example.xls")
wkb.Close (False)
Set wkb = Nothing
XL.Quit
Set XL = Nothing
End Sub
I also tried this code with the same result:
Private Sub Hämta_Click()
Dim XL As Object
Set XL = CreateObject("Excel.Application")
Dim wkb As Object
Set wkb = XL.Workbooks.Open("K:\Uppdrag.xls")
wkb.Close (False)
Set wkb = Nothing
XL.Quit
Set XL = Nothing
End Sub
The above two macros keep creating instances of Excel.exe which are not closed.
I've seen examples where code snippets are included that kills the process via Task Manager, but I don't understand the reason for the above not working.
The only workaround I found is to not include the XL.Quit method and instead set XL.Visible = True and let the user manually close the window.
Based on the comments it does not seem to be possible to find the root cause why the newly created excel instance cannot be finished in a "normal" way.
Based on the code here one can just kill the process
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Type LUID
LowPart As Long
HighPart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
Function ProcessTerminate(Optional lProcessID As Long, Optional lHwndWindow As Long) As Boolean
Dim lhwndProcess As Long
Dim lExitCode As Long
Dim lRetVal As Long
Dim lhThisProc As Long
Dim lhTokenHandle As Long
Dim tLuid As LUID
Dim tTokenPriv As TOKEN_PRIVILEGES, tTokenPrivNew As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long
Const PROCESS_ALL_ACCESS = &H1F0FFF, PROCESS_TERMINATE = &H1
Const ANYSIZE_ARRAY = 1, TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8, SE_DEBUG_NAME As String = "SeDebugPrivilege"
Const SE_PRIVILEGE_ENABLED = &H2
On Error Resume Next
If lHwndWindow Then
'Get the process ID from the window handle
lRetVal = GetWindowThreadProcessId(lHwndWindow, lProcessID)
End If
If lProcessID Then
'Give Kill permissions to this process
lhThisProc = GetCurrentProcess
OpenProcessToken lhThisProc, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, lhTokenHandle
LookupPrivilegeValue "", SE_DEBUG_NAME, tLuid
'Set the number of privileges to be change
tTokenPriv.PrivilegeCount = 1
tTokenPriv.TheLuid = tLuid
tTokenPriv.Attributes = SE_PRIVILEGE_ENABLED
'Enable the kill privilege in the access token of this process
AdjustTokenPrivileges lhTokenHandle, False, tTokenPriv, Len(tTokenPrivNew), tTokenPrivNew, lBufferNeeded
'Open the process to kill
lhwndProcess = OpenProcess(PROCESS_TERMINATE, 0, lProcessID)
If lhwndProcess Then
'Obtained process handle, kill the process
ProcessTerminate = CBool(TerminateProcess(lhwndProcess, lExitCode))
Call CloseHandle(lhwndProcess)
End If
End If
On Error GoTo 0
End Function
And you just use the code like that
Sub TestIt()
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
' Do something with xlApp
'Terminate the process
ProcessTerminate , xlApp.hwnd
End Sub
Try to declare and use a workbooks variable then set it to nothing at the end of your code
I would like to write a simple macro to lift all sheet protection at once. It work's fine. But i would like to make 2 options of it.
1st to use inputbox to write password. Simple
2nd where I need your help, is to use Windows User names to define which are allowed to unprotect it without password (password is in code already defined).
How to use Environ.user to define which user can use that macro?
For example user: 1st "hackla" and 2nd "klaud"
My basic code looks so:
Sub TabelleEntsperren()
Dim strPassw As String
Dim wSheet As Worksheet
strPassw = "Athens"
For Each wSheet In ActiveWorkbook.Worksheets
wSheet.Unprotect Password:=strPassw
Next wSheet
End Sub
Do you mean something like this?
Sub TabelleEntsperren()
Const strPassw As String = "yourPassword"
Const usr1 As String = "hackla"
Const usr2 As String = "klaud"
Dim wSheet As Worksheet
Dim isTrustedUser As Boolean
Dim currentUsr As String
currentUsr = Environ("username")
isTrustedUser = currentUsr = usr1 Or currentUsr = usr2
For Each wSheet In ActiveWorkbook.Worksheets
If isTrustedUser Then wSheet.Unprotect Password:=strPassw
Next wSheet
End Sub
Option Explicit
'Private API declarations
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#Else
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBudffer As String, nSize As Long) As Long
#End If
'To get the computer name
Public Function getActiveComputerName() As String
Dim cn As String, ls As Long, res As Long
cn = String(1024, 0)
ls = 1024
res = GetComputerName(cn, ls)
If res <> 0 Then
getActiveComputerName = Mid$(cn, 1, InStr(cn, Chr$(0)) - 1)
Else
getActiveComputerName = ""
End If
End Function
'To get the identifier for the active user
Public Function getActiveUserName() As String
Dim cn As String, ls As Long, res As Long
cn = String(1024, 0)
ls = 1024
res = GetUserName(cn, ls)
If res <> 0 Then
getActiveUserName = Mid$(cn, 1, InStr(cn, Chr$(0)) - 1)
Else
getActiveUserName = ""
End If
End Function
I have an application that is opened overnight by a batch job. The Workbook_Open event triggers a series of other workbooks to be updated using this code:
arrUpdateList = Array(DOWNLOAD_A, _
TRDUPDATE, _
CITUPDATE, _
FVUPDATE, _
FSUPDATE)
ThisWorkbook.Worksheets("Start").Activate
For i = LBound(arrUpdateList) To UBound(arrUpdateList)
Call UpdateItem(arrUpdateList(i))
Stop
Next i
Note: the variables in the array are simply file paths to excel documents.
Since approx. a week ago the process gets hung up because the first workbook that is opened doesn't close itself anymore. The first workbook (DOWNLOAD_A) contains the following code in its Workbook_Open event, which if i open the file manually, works perfectly.
Private Sub Workbook_Open()
Call DownloadFileAPI
DoEvents
Application.DisplayAlerts = False
Application.Quit
End Sub
How can I fix this problem? I have only been able to narrow the problem down to the fact that somehow excel doesn't close the workbook, because it either goes into an infinite loop, or the calling application somehow looses the reference. What can I do to further debug this?
For completeness's sake, here is the code in the calling workbook (the one being called up by the batchjob to kick off the process):
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret&
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
'Shelled application needs to have an applicatin.quit command to close itself
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
As requested the other relevant procedures:
Public Sub UpdateItem(ByVal sItem As String)
Dim arr As Variant
Dim retval As Long
Dim CurrentDay As String
CurrentDay = DateValue(Now()) & " "
'Arr is split to check if there is a time value transferred
arr = Split(sItem, "|")
If UBound(arr) > 0 Then
'CDate converts the date time into a date; then if the time of the same day has already
'expired, there will be no wait. If the date time is still to come, the process will wait
Application.Wait CDate(CurrentDay & arr(1))
End If
'Log start
Call Writelog("Start: " & arr(0))
'Start process with shellwait (what if error occurs?)
retval = ExecCmd("excel.exe " & arr(0))
DoEvents
'Log end
Call Writelog("End: " & arr(0))
Erase arr
End Sub
The problem was caused by an add-in (Thomson Reuters EIKON). It could only be resolved by completely removing the COM add-in from Excel.
I was able to resolved the issue together with a colleague. The question of how I could have further debugged this is probably best answered remains.
I'll take a stab at it though, and say, I should have continued to strip away other code that also ran ontop of excel, until reaching a completely prestine Excel Version.
I have an issue with counting the right number of opened workbooks.
Concretely, I have a big excel file with my database. I have other data (sports results) from a software, and I export them. So I have my database opened, and dozens of other workbooks ("Workbook1", "Workbook2", ...), with one workbook per tournament.
My final goal is to loop workbook by workbook to copy/paste the data in my database.
But when I use MsgBox(workbooks.counts), it only returns "1".
Do you have any idea why ? What am I missing ?
Thanks in advance,
I don't know if you're still interested but I took some code from the web many moons ago (apologies, I don't have the reference any more) and modified it for the purposes of acquiring all workbooks in all Excel instances.
It may be of use to you or others. APIs are declared for 32 bit so you'll have to modify them if necessary.
Option Explicit
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Sub RunMe()
Dim bks As Collection
Set bks = GetAllWorkbooks
MsgBox bks.Count
End Sub
Private Function GetAllWorkbooks() As Collection
Dim id As GUID
Dim hWnd As Long
Dim hDesk As Long
Dim hXL As Long
Dim obj As Object
Dim app As Application
Dim wb As Workbook
Set GetAllWorkbooks = New Collection
'Define GUID values
'hard codes IDispatch {00020400-0000-0000-C000-000000000046}
With id
.Data1 = 132096
.Data4(0) = 192
.Data4(7) = 70
End With
'Loop through excel window handles to find applications
hWnd = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWnd > 0
hDesk = FindWindowEx(hWnd, 0&, "XLDESK", vbNullString)
hXL = FindWindowEx(hDesk, 0&, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hXL, &HFFFFFFF0, id, obj) = &H0 Then
'Populate return collection with the workbooks
Set app = obj.Application
For Each wb In app.Workbooks
GetAllWorkbooks.Add wb
Next
End If
hWnd = FindWindowEx(0&, hWnd, "XLMAIN", vbNullString)
Loop
End Function
Since Windows updates occurred, an API call to ShellExecuteEx(sExecuteInfo) crashes, saying:
unhandled exception at 0x75F7A529 (shell32.dll) Access violation
reading location 0x68686903
I have no clue what is wrong here, can you help me please?
Definition :
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
Hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Private Const STILL_ACTIVE As Long = &H103 ' Constant for the lpExitCode parameter of the GetExitCodeProcess API function.
Private Declare PtrSafe Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long
Code:
Private Function ShellAndWait(ByVal szProgram As String, Optional ByVal szOptions As String, Optional ByVal iWindowState As Integer = vbHide) As Boolean
Dim lTaskID As Long
Dim lReturn As Long
Dim lExitCode As Long
Dim lResult As Long
Dim bShellAndWait As Boolean
Dim hInstance As Object
Dim lPriority As Long
On Error GoTo ErrorHandler
Dim sExecuteInfo As SHELLEXECUTEINFO
sExecuteInfo.cbSize = Len(sExecuteInfo)
sExecuteInfo.lpVerb = "open"
sExecuteInfo.lpFile = szProgram
sExecuteInfo.lpParameters = szOptions
sExecuteInfo.nShow = &H7 ' Parameter SW_SHOWMINNOACTIVE, (0x7) , displays the window as a minimized window. The active window remains active.
sExecuteInfo.fMask = &H8140 ' Parameter SEE_MASK_NO_CONSOLE (0x00008000), use to inherit the parent's console for the new process instead of having it create a new console
' Parameter SEE_MASK_NOASYNC (0x00000100), wait for the execute operation to complete before returning.
' Parameter SEE_MASK_NOCLOSEPROCESS (0x00000040), puts process id back in sExecuteInfo.hProcess
lPriority = &H100000 'PROCESS_MODE_BACKGROUND_BEGIN
lReturn = ShellExecuteEx(sExecuteInfo)
'Loop while the shelled process is still running.
Do
'lExitCode will be set to STILL_ACTIVE as long as the shelled process is running.
lResult = GetExitCodeProcess(sExecuteInfo.hProcess, lExitCode)
DoEvents
'iCount = iCount + 1
'Application.StatusBar = Str(iCount) + " iteration waited"
Loop While lExitCode = STILL_ACTIVE
bShellAndWait = True
Exit Function
ErrorHandler:
sErrMsg = Err.Description
bShellAndWait = False
End Function
Use way recommended by Microsoft.
MSDN article "Determine When a Shelled Process Ends" recommends approach through different API call and I can confirm it is working reliably. I'm posting code module (adopted from code in the article) here.
The following VBA module uses API call CreateProcessA(), waits for application to finish and returns ERRORLEVEL code as result:
Option Explicit
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Function ExecCmd(CommandLine As String) As Long
Dim proc As PROCESS_INFORMATION
Dim Start As STARTUPINFO
Dim ret As Long
' Initialize the STARTUPINFO structure:
Start.cb = Len(Start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, CommandLine, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, Start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
If you store all the code as for example ShellExecModule, then you can call it as
Dim errorLevelValue As Long
errorLevelValue = ShellExecModule.ExecCmd(CommandLine)