I regularly rely on external tools to create files from VBA: 7zip, scanning applications, etc. I need a reliable way to know when the file has finished writing and may be safely used for other operations (including passing it on to other external programs; e.g., email, etc.).
Here are the assumptions:
I have no control over the writing of the file
the file may or may not be on a network file server
I don't know the contents of the file before it's been written
Because I have no control over the writing of the file, I can't use CreateFile with FILE_FLAG_WRITE_THROUGH.
Because the files may be on a network file server, I am leery of the performance impact of using FlushFileBuffers. I'm also not sure it would do what I want.
Because I don't know the contents of the file ahead of time, I can't compare hashes to check the integrity of the file.
I've used simple techniques like using Dir() to ensure that a file exists, but that seems unreliable. I've also tried pausing then retrying an operation until it works or exceeds some timeout that I have set. I've also tried opening the file with an exclusive lock and catching the error to test whether the file is still in use.
These solutions have all worked to some degree, but they all seem less than ideal.
This is a generic problem that causes frequent headaches. The result is a race condition that is difficult to reproduce and troubleshoot. Is there a better approach than what I have already tried?
Update:
As #JasonFaulkner points out in the comments, without knowing the contents ahead of time, it's impossible to be 100% sure that the file has been successfully written. Short of that, I'd like the most efficient and reliable way to determine the following conditions have been met:
the file exists
there is no program accessing the file
there is no data in any cache waiting to be written to the physical disk
I've come up with the following procedure to check if a file is ready. I'm open to any suggestions for improvements or problems that I may have missed.
Currently this is implemented as a Sub that raises an error if the file is not ready and the retry attempts have been exhausted. If the file is ready, then the sub simply completes with no fanfare.
The following declarations go at the top of the module:
'----- VerifyFileReady declarations ----------------------------------------------------
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CreateFile Lib "kernel32" Alias _
"CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Const OPEN_EXISTING = 3
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_ALL = &H10000000
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" _
(ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hFile As Long) As Long
'perform 64-bit arithmetic (see: http://support.microsoft.com/kb/189862)
Private Type Curr64Bit
Value As Currency
End Type
Private Type LongsAs64Bit
LoValue As Long
HiValue As Long
End Type
'=======================================================================================
Here is the sub itself, along with a small helper function to perform file size comparisons for files that may be over 2GB in size:
'---------------------------------------------------------------------------------------
' Procedure : VerifyFileReady
' Author : Mike
' Date : 1/22/2015
' Purpose : Confirm that a file is ready for use; commonly used before passing a
' filename to an outside entity for processing (e.g., a PDF printer,
' compression utility, email, etc.)
' Parameters:
' FName The name of the file
' MinSizeInBytes The minimum file size before confirming a file is ready;
' by default, the file must be non-empty
' RetryAttempts The number of times to retry if a file is not ready
' DelayInMs The amount of time to sleep between retries
' FailureMsg Set to the reason the file is not ready; passed By Reference so that
' the most recent msg will be raised if necessary
'
' Notes - Acts as a gate: if the file is ready, the program continues on; otherwise
' an error is thrown after the number of retry ettampts is exhausted
' - To get the maximum program delay this function will cause, multiply the
' RetryAttempts by the DelayInMs; by default the program will delay a
' maximum of 5 seconds (10 attempts * 500 ms delay per retry attempt)
' - By ready for use, we mean the file meets the following criteria:
' o the file exists
' o the file is not locked by another process
' o the file buffers have been flushed
' o the file meets the minimum size in bytes (by default, it's not empty)
' - There's no way to *really* be sure that the file has been written to disk,
' so this function cannot guarantee transactional integrity
'---------------------------------------------------------------------------------------
'
Sub VerifyFileReady(ByVal FName As String, _
Optional ByVal MinSizeInBytes As Long = 1, _
Optional ByVal RetryAttempts As Integer = 10, _
Optional ByVal DelayInMs As Integer = 500, _
Optional ByRef FailureMsg As String = vbNullString)
Dim FileIsReady As Boolean
FileIsReady = True
On Error GoTo Err_VerifyFileReady
'FlushFileBuffers requires GENERIC_WRITE access
Dim DesiredAccess As Long
DesiredAccess = GENERIC_READ Or GENERIC_WRITE
'Open the file (CreateFile is a generic function that replaces the deprecated OpenFile)
Dim hFile As Long 'File Handle
Err.Clear 'explicitly flush the Err.LastDllError property
hFile = CreateFile(FName, DesiredAccess, 0, 0, OPEN_EXISTING, 0, 0)
Dim FileOpenFailed As Boolean
Const INVALID_HANDLE_VALUE = -1
FileOpenFailed = (hFile = INVALID_HANDLE_VALUE)
If FileOpenFailed Then
FileIsReady = False
Select Case Err.LastDLLError
Case 2: FailureMsg = "The system cannot find the file specified." 'ERROR_FILE_NOT_FOUND
Case 3: FailureMsg = "The system cannot find the path specified." 'ERROR_PATH_NOT_FOUND
Case 4: FailureMsg = "The system cannot open the file." 'ERROR_TOO_MANY_OPEN_FILES
Case 5: FailureMsg = "Access is denied." 'ERROR_ACCESS_DENIED
Case 15: FailureMsg = "The system cannot find the drive specified." 'ERROR_INVALID_DRIVE
Case 20: FailureMsg = "The system cannot find the device specified." 'ERROR_BAD_UNIT
Case 21: FailureMsg = "The device is not ready." 'ERROR_NOT_READY
Case 32: FailureMsg = "The process cannot access the file because it is being used by another process." 'ERROR_SHARING_VIOLATION
Case 33: FailureMsg = "The process cannot access the file because another process has locked a portion of the file." 'ERROR_LOCK_VIOLATION
Case Else: FailureMsg = "CreateFile function failed with error number " & Err.LastDLLError & "."
End Select
End If
If FileIsReady Then
'be sure the file has been physically written to disk
Dim FlushResults As Long
FlushResults = FlushFileBuffers(hFile)
Dim FlushFailed As Boolean
FlushFailed = (FlushResults = 0)
If FlushFailed Then
FileIsReady = False
Select Case Err.LastDLLError
Case 5: FailureMsg = "FlushFileBuffers function failed: Access is denied." 'ERROR_ACCESS_DENIED
Case Else: FailureMsg = "FlushFileBuffers function failed with error number " & Err.LastDLLError & "."
End Select
End If
End If
'check that the file meets the minimum size requirement
' (MinSizeInBytes parameter may not exceed 2GB, but actual
' file sizes beyond 2GB are allowed and will be treated correctly)
If FileIsReady And MinSizeInBytes > 0 Then
Dim FSize64 As Curr64Bit
Dim FileSizeLow As Long, FileSizeHigh As Long
FileSizeLow = GetFileSize(hFile, FileSizeHigh)
Const GetFileSizeError As Long = &HFFFFFFFF
If FileSizeLow = GetFileSizeError Then
FileIsReady = False
FailureMsg = "Error getting file size."
ElseIf TwoLongsTo64(FileSizeLow, FileSizeHigh).Value < TwoLongsTo64(MinSizeInBytes, 0).Value Then
FileIsReady = False
FailureMsg = "File smaller than minimum size of " & MinSizeInBytes & " byte(s)."
End If
End If
'close the handle or *we* will be the ones locking the file
If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile
If Not FileIsReady Then
FileNotReady:
If RetryAttempts > 0 Then
'we can't just raise an error or the Resume would send us back to the Err.Raise statement;
' instead we make a recursive call and decrement the RetryAttempts to prevent a stack overflow
Sleep DelayInMs
On Error GoTo 0 'prevent infinite recursion
VerifyFileReady FName, MinSizeInBytes, RetryAttempts - 1, DelayInMs, FailureMsg
Exit Sub
Else
On Error GoTo 0
Err.Raise vbObjectError + 44212312, "FileFunctions.VerifyFileReady", FailureMsg
End If
End If
Exit Sub
Err_VerifyFileReady:
FailureMsg = "Error " & Err.Number & ": " & Err.Description
Resume FileNotReady
End Sub
'64-bit arithmetic in VBA: http://support.microsoft.com/kb/189862
Function TwoLongsTo64(LowVal As Long, HighVal As Long) As Curr64Bit
Dim L As LongsAs64Bit
L.HiValue = HighVal
L.LoValue = LowVal
LSet TwoLongsTo64 = L
End Function
Related
I have 2 concerns, if someone can assist. I am new to VBA. I have a command print button on my excel sheet and I added the code listed below. When I click on the print button, I have the first page print twice but the rest of the pages print single which is what I want. How do I fix the code so it only prints once.
The other thing is when the print manager window opens for me to select a printer, I would like to have the code select single page print and not duplex printing. The printer default settings are set for duplex and I dont want to change that setting through windows but for the code to automatically select single sided prints.
Thank you,
Private Sub PrintAll_Click()
Dim rngOffenders As Range
Set rngOffenders = Worksheets("Names").Range("A2", Worksheets("Names").Range("A2").End(xlDown))
Dim willPrint As Boolean
willPrint = Application.Dialogs(xlDialogPrint).Show
If Not willPrint Then Exit Sub
Dim rng As Range
For Each rng In rngOffenders.Cells
Worksheets("Template").Range("LastName").Value = rng.Value
Calculate
Worksheets("Template").PrintOut
Next rng
End Sub
Regarding the duplicate printing, my guess, without testing, is that by Show the print dialog, you're invoking print against the first/active sheet once you press "OK". Then, as you iterate over rngOffenders.Cells, you're printing that sheet again. So, you could start at the second cell in rngOffenders to avoid that.
Dim i As Long
For i = 2 To rngOffenders.Cells.Count
Worksheets("Template").Range("LastName").Value = rngOffenders.Cells(i).Value
Calculate
Worksheets("Template").PrintOut
Next rng
For the printer settings, that is more complicated. See here:
The best way of doing this is by using API calls. The following article gives you a VB code sample which does this:
Q230743
Only one “problem” with this code: It is written for VB and uses Printer.DeviceName to return the name of the currently selected printer. In Word VBA, you need to substitute this with ActivePrinter. The problem is that the strings returned by these commands are slightly different, even though they both get the name of the printer from the name assigned in Control Panel | Printers. For instance.:
ActivePrinter: HP LaserJet 6L PCL on LPT1:
Printer.DeviceName: HP LaserJet 6L PCL
So you'll need to test and modify the code sample accordingly.
If you don't want to use API calls, however, you can install a duplicate printer driver with the duplex property set and print to that (by changing the ActivePrinter).
The linked KB article demonstrates (at length) how to set the printer to duplex printing. Most of the same code should be used for the inverse operation, you'd just need to figure out what value to pass for that property.
Test Procedure:
Place this in a standard module. Note the possible need to adjust the length of printer string (removing the port component e.g., "HP Ink Jet Fantastico on LP02", etc.)
Option Explicit
Sub test()
Dim pName As String
pName = ActivePrinter
' Note you may need to adjust this value to remove the port string component
pName = Left(pName, (Len(pName) - 9))
SetPrinterDuplex pName, 1 '1 = NOT duplex printing.
'Here you might want to actually print something, for example:
Worksheets("Template").PrintOut
End Sub
In a separate module, place all of the printer-related code. NB: I am on a machine with no printer access, so I am unable to test or further debug this solution.
Option Explicit
Public Type PRINTER_DEFAULTS
pDatatype As Long
pDevmode As Long
DesiredAccess As Long
End Type
Public Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Public Const DM_DUPLEX = &H1000&
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)
Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Public Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal Command As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
' ==================================================================
' SetPrinterDuplex
'
' Programmatically set the Duplex flag for the specified printer
' driver's default properties.
'
' Returns: True on success, False on error. (An error will also
' display a message box. This is done for informational value
' only. You should modify the code to support better error
' handling in your production application.)
'
' Parameters:
' sPrinterName - The name of the printer to be used.
'
' nDuplexSetting - One of the following standard settings:
' 1 = None
' 2 = Duplex on long edge (book)
' 3 = Duplex on short edge (legal)
'
' ==================================================================
Public Function SetPrinterDuplex(ByVal sPrinterName As String, _
ByVal nDuplexSetting As Long) As Boolean
Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim pinfo As PRINTER_INFO_2
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim yPInfoMemory() As Byte
Dim nBytesNeeded As Long
Dim nRet As Long, nJunk As Long
On Error GoTo cleanup
'#### I removed this block because it was preventing you from changing the duplex settings
' If (nDuplexSetting < 1) Or (nDuplexSetting > 3) Then
' MsgBox "Error: dwDuplexSetting is incorrect."
' Exit Function
' End If
'####
pd.DesiredAccess = PRINTER_ALL_ACCESS
nRet = OpenPrinter(sPrinterName, hPrinter, pd)
If (nRet = 0) Or (hPrinter = 0) Then
If Err.LastDllError = 5 Then
MsgBox "Access denied -- See the article for more info."
Else
MsgBox "Cannot open the printer specified " & _
"(make sure the printer name is correct)."
End If
Exit Function
End If
nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then
MsgBox "Cannot get the size of the DEVMODE structure."
GoTo cleanup
End If
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Cannot get the DEVMODE structure."
GoTo cleanup
End If
Call CopyMemory(dm, yDevModeData(0), Len(dm))
If Not CBool(dm.dmFields And DM_DUPLEX) Then
MsgBox "You cannot modify the duplex flag for this printer " & _
"because it does not support duplex or the driver " & _
"does not support setting it from the Windows API."
GoTo cleanup
End If
dm.dmDuplex = nDuplexSetting
Call CopyMemory(yDevModeData(0), dm, Len(dm))
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), _
DM_IN_BUFFER Or DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Unable to set duplex setting to this printer."
GoTo cleanup
End If
Call GetPrinter(hPrinter, 2, 0, 0, nBytesNeeded)
If (nBytesNeeded = 0) Then GoTo cleanup
ReDim yPInfoMemory(nBytesNeeded + 100) As Byte
nRet = GetPrinter(hPrinter, 2, yPInfoMemory(0), nBytesNeeded, nJunk)
If (nRet = 0) Then
MsgBox "Unable to get shared printer settings."
GoTo cleanup
End If
Call CopyMemory(pinfo, yPInfoMemory(0), Len(pinfo))
pinfo.pDevmode = VarPtr(yDevModeData(0))
pinfo.pSecurityDescriptor = 0
Call CopyMemory(yPInfoMemory(0), pinfo, Len(pinfo))
nRet = SetPrinter(hPrinter, 2, yPInfoMemory(0), 0)
If (nRet = 0) Then
MsgBox "Unable to set shared printer settings."
End If
SetPrinterDuplex = CBool(nRet)
cleanup:
If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)
End Function
You can print the first page twice like this:
Dim i As Long, k As Long
Dim lpc As Long
lpc = ActiveSheet.HPageBreaks.Count
For i = 1 To lpc + 1
If i = 1 Then
k = 2
Else
k = 1
End If
ActiveSheet.PrintOut from:=i, To:=i, Copies:=k
Next
In Word 2010, I'm trying to create a macro that sets the current printer to a specific color printer on our network, without making that printer the user's system default printer. I've hacked together some code below from samples I've found on the web. Everything works, except that the SetColorPrinterEast Sub changes the user's system default printer, which I do not want. I suspect the DoNotSetAsSysDefault in that sub is not working as intended, but I don't know what to do about it. See the comments in the code for further explanation. Any thoughts will be greatly appreciated. Thanks in advance!!!
'I found the code block below on the web. I don't understand it, but
'it seems to work properly with the "SetDefaultPrinter"
'Sub below to get the system default printer.
Public Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" _
(ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
' This code successfully sets the document to print from
' the system default printer.
Public Sub SetDefaultPrinter()
Dim strReturn As String
Dim intReturn As Integer
strReturn = Space(255)
intReturn = GetProfileString("Windows", ByVal "device", "", _
strReturn, Len(strReturn))
If intReturn Then
strReturn = UCase(Left(strReturn, InStr(strReturn, ",") - 1))
End If
With Dialogs(wdDialogFilePrintSetup)
.Printer = strReturn
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
' This code correctly sets the printer to a specific color printer
' on our network. The problem is that it makes that printer
' the user's system default printer. I would think that the
' .DoNotSetAsSysDefault = True line would solve this problem
' but still this sub changes the user's system default printer.
Public Sub SetColorPrinterEast()
With Dialogs(wdDialogFilePrintSetup)
.Printer = "\\[*NETWORK PATH*]\Color Printer East"
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
I had this same problem a few years back, got around it by storing the current default print in a variable, changing the default printer to the one I need, printing, then changing the default printer back to users original default.
This was designed and written for Word 2003 but has continued to work in Word 2010.
Here is the specific code I used:
'Define Printer to add and printer to delete
Const PrintPath = "\\prn001l0003\Colour04"
Const PrintDeletePath = "\\prn001l0003\Colour02"
' Used to see what printers are set up on the user, and to set a new network printer
Public Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, _
ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" (ByVal Ptr As Long) As Long
Const PRINTER_ENUM_CONNECTIONS = &H4
Const PRINTER_ENUM_LOCAL = &H2
Public Sub PrintLetter(ByRef LetterBrochures() As String)
'Print the document
Dim STDprinter As String
On Error Resume Next
Call CheckPrinterLoaded ' Get users loaded printers, remove any old printers used here,
' and add printer I want to users printers
STDprinter = Application.ActivePrinter ' store the current default printer
Application.ActivePrinter = PrintPath ' change default printer to want I want
On Error GoTo printLetterError
Application.DisplayAlerts = wdAlertsNone ' prevent Word showing any alert/warnings etc
With ActiveDocument ' first page is letterhead from tray 2, all others from tray 1, print
.PageSetup.FirstPageTray = 3 ' 3 = Tray 2 on MFLaser
.PageSetup.OtherPagesTray = 1 ' 1 = Tray 1 on MFLaser
.PrintOut Background:=False
End With
Application.DisplayAlerts = wdAlertsAll ' enable Word alets/warning etc
Application.ActivePrinter = STDprinter 'change back users default printer
Exit Sub
printLetterError:
MsgBox "Error printing letter" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"
ActiveDocument.Close False
End
End Sub
Public Function CheckPrinterLoaded()
'get users printers
'look for and delete defined printer, PrintDeletePath
'add printer I want to users printers, PrintPath
Dim StrPrinters As Variant, x As Long
Dim StrSetPrinter As String
Dim objNetwork
Set objNetwork = CreateObject("WScript.Network")
StrPrinters = ListPrinters
'Fist check whether the array is filled with anything, by calling another function, IsBounded.
If IsBounded(StrPrinters) Then
For x = LBound(StrPrinters) To UBound(StrPrinters)
If StrPrinters(x) = PrintDeletePath Then
objNetwork.RemovePrinterConnection PrintDeletePath
End If
Next x
objNetwork.AddWindowsPrinterConnection PrintPath
Else
MsgBox "No printers found"
End If
End Function
Private Function ListPrinters() As Variant
Dim bSuccess As Boolean
Dim iBufferRequired As Long
Dim iBufferSize As Long
Dim iBuffer() As Long
Dim iEntries As Long
Dim iIndex As Long
Dim strPrinterName As String
Dim iDummy As Long
Dim iDriverBuffer() As Long
Dim StrPrinters() As String
iBufferSize = 3072
ReDim iBuffer((iBufferSize \ 4) - 1) As Long
'EnumPrinters will return a value False if the buffer is not big enough
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
If Not bSuccess Then
If iBufferRequired > iBufferSize Then
iBufferSize = iBufferRequired
Debug.Print "iBuffer too small. Trying again with "; iBufferSize & " bytes."
ReDim iBuffer(iBufferSize \ 4) As Long
End If
'Try again with new buffer
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
End If
If Not bSuccess Then
'Enumprinters returned False
MsgBox "Error enumerating printers."
Exit Function
Else
'Enumprinters returned True, use found printers to fill the array
ReDim StrPrinters(iEntries - 1)
For iIndex = 0 To iEntries - 1
'Get the printername
strPrinterName = Space$(StrLen(iBuffer(iIndex * 4 + 2)))
iDummy = PtrToStr(strPrinterName, iBuffer(iIndex * 4 + 2))
StrPrinters(iIndex) = strPrinterName
Next iIndex
End If
ListPrinters = StrPrinters
End Function
Private Function IsBounded(vArray As Variant) As Boolean
'If the variant passed to this function is an array, the function will return True; otherwise it will return False
On Error Resume Next
IsBounded = IsNumeric(UBound(vArray))
End Function
I am trying to have my program check is a mapped network drive is actually connected, and change the curDrive variable based on the result. It works okay, but if the drive is still mapped and the drive is not available, there is a long delay while the program tries to connect (4-6 seconds). I tried two methods and both ways have this delay. I tried the following:
On Error GoTo switch
checker= Dir("F:\")
If checker= "" Then GoTo switch
curDrive = "F:\"
GoTo skip
switch:
curDrive = "C:\"
skip:
........
I also tried:
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
If .FolderExists("F:\Sample") Then
curDrive = "F:\"
Else
curDrive = "C:\"
End If
End With
Both have the same delay.
After much searching and brainstorming, I put together some info from here and from elsewhere and came up with a method that takes half a second. Basically, I'm pinging the server and reading the results from a text file. I'm also checking to make sure that the F: Drive (the server drive) is available (Someone can be on the server but hasn't set the F: Drive to the server).
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Sub CheckAllConnections()
ServerOn = ComputerIsOnline("server.mmc.local")
FDrive = CreateObject("scripting.filesystemobject").driveexists("F")
test = FDrive - 1
ProgramFolder = False
If ServerOn + FDrive = -2 Then
ProgramFolder = Len(Dir("F:\SampleProgram\")) > 0
End If
MsgBox ("Server connection is " & ServerOn & "." & Chr(10) & "F: Drive available is " & FDrive _
& Chr(10) & "The Program Folder availability is " & ProgramFolder)
End Sub
Public Function ComputerIsOnline(ByVal strComputerName As String) As Boolean
On Error Resume Next
Kill "C:\Logger.txt"
On Error GoTo ErrorHandler
ShellX = Shell("cmd.exe /c ping -n 1 " & strComputerName & " > c:\logger.txt", vbHide)
lPid = ShellX
lHnd = OpenProcess(&H100000, 0, lPid)
If lHnd <> 0 Then
lRet = WaitForSingleObject(lHnd, &HFFFF)
CloseHandle (lHnd)
End If
FileNum = FreeFile
Open "c:\logger.txt" For Input As #FileNum
strResult = Input(LOF(1), 1)
Close #FileNum
ComputerIsOnline = (InStr(strResult, "Lost = 0") > 0)
Exit Function
ErrorHandler:
ComputerIsOnline = False
Exit Function
End Function
Both show the same delay because both methods invoke the same underlying OS functionality to check for the presence of the network drive.
The OS is giving the external resource time to be available. I don't think you can do anything except await the timeout, if you want to know for sure.
If you know that, in your environment the OS timeout is just too long (e.g. "If it has not responded after 1 second, it will not respond), you could use a mechanism such as a timer to avoid waiting the full duration (set a 1 second timer when you start checking, if the timer fires and you still have no reply, the drive was not present).
There is no long delay when testing for a drive letter using the FileSystemObject and DriveExists:
Sub Tester()
Dim n As Integer
For n = 1 To 26
Debug.Print Chr(64 + n), HaveDrive(Chr(64 + n))
Next n
End Sub
Function HaveDrive(driveletter)
HaveDrive = CreateObject("scripting.filesystemobject").driveexists(driveletter)
End Function
I have an executable that I call using the shell command:
Shell (ThisWorkbook.Path & "\ProcessData.exe")
The executable does some computations, then exports results back to Excel. I want to be able to change the format of the results AFTER they are exported.
In other words, i need the Shell command first to WAIT until the executable finishes its task, exports the data, and THEN do the next commands to format.
I tried the Shellandwait(), but without much luck.
I had:
Sub Test()
ShellandWait (ThisWorkbook.Path & "\ProcessData.exe")
'Additional lines to format cells as needed
End Sub
Unfortunately, still, formatting takes place first before the executable finishes.
Just for reference, here was my full code using ShellandWait
' Start the indicated program and wait for it
' to finish, hiding while we wait.
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Const INFINITE = &HFFFF
Private Sub ShellAndWait(ByVal program_name As String)
Dim process_id As Long
Dim process_handle As Long
' Start the program.
On Error GoTo ShellError
process_id = Shell(program_name)
On Error GoTo 0
' Wait for the program to finish.
' Get the process handle.
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
Exit Sub
ShellError:
MsgBox "Error starting task " & _
txtProgram.Text & vbCrLf & _
Err.Description, vbOKOnly Or vbExclamation, _
"Error"
End Sub
Sub ProcessData()
ShellAndWait (ThisWorkbook.Path & "\Datacleanup.exe")
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
Try the WshShell object instead of the native Shell function.
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Long
errorCode = wsh.Run("notepad.exe", windowStyle, waitOnReturn)
If errorCode = 0 Then
MsgBox "Done! No error to report."
Else
MsgBox "Program exited with error code " & errorCode & "."
End If
Though note that:
If bWaitOnReturn is set to false (the default), the Run method returns immediately after starting the program, automatically returning 0 (not to be interpreted as an error code).
So to detect whether the program executed successfully, you need waitOnReturn to be set to True as in my example above. Otherwise it will just return zero no matter what.
For early binding (gives access to Autocompletion), set a reference to "Windows Script Host Object Model" (Tools > Reference > set checkmark) and declare like this:
Dim wsh As WshShell
Set wsh = New WshShell
Now to run your process instead of Notepad... I expect your system will balk at paths containing space characters (...\My Documents\..., ...\Program Files\..., etc.), so you should enclose the path in "quotes":
Dim pth as String
pth = """" & ThisWorkbook.Path & "\ProcessData.exe" & """"
errorCode = wsh.Run(pth , windowStyle, waitOnReturn)
What you have will work once you add
Private Const SYNCHRONIZE = &H100000
which your missing. (Meaning 0 is being passed as the access right to OpenProcess which is not valid)
Making Option Explicit the top line of all your modules would have raised an error in this case
Shell-and-Wait in VBA (Compact Edition)
Sub ShellAndWait(pathFile As String)
With CreateObject("WScript.Shell")
.Run pathFile, 1, True
End With
End Sub
Example Usage:
Sub demo_Wait()
ShellAndWait ("notepad.exe")
Beep 'this won't run until Notepad window is closed
MsgBox "Done!"
End Sub
Adapted from (and more options at) Chip Pearson's site.
The WScript.Shell object's .Run() method as demonstrated in Jean-François Corbett's helpful answer is the right choice if you know that the command you invoke will finish in the expected time frame.
Below is SyncShell(), an alternative that allows you to specify a timeout, inspired by the great ShellAndWait() implementation. (The latter is a bit heavy-handed and sometimes a leaner alternative is preferable.)
' Windows API function declarations.
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCodeOut As Long) As Integer
' Synchronously executes the specified command and returns its exit code.
' Waits indefinitely for the command to finish, unless you pass a
' timeout value in seconds for `timeoutInSecs`.
Private Function SyncShell(ByVal cmd As String, _
Optional ByVal windowStyle As VbAppWinStyle = vbMinimizedFocus, _
Optional ByVal timeoutInSecs As Double = -1) As Long
Dim pid As Long ' PID (process ID) as returned by Shell().
Dim h As Long ' Process handle
Dim sts As Long ' WinAPI return value
Dim timeoutMs As Long ' WINAPI timeout value
Dim exitCode As Long
' Invoke the command (invariably asynchronously) and store the PID returned.
' Note that this invocation may raise an error.
pid = Shell(cmd, windowStyle)
' Translate the PIP into a process *handle* with the
' SYNCHRONIZE and PROCESS_QUERY_LIMITED_INFORMATION access rights,
' so we can wait for the process to terminate and query its exit code.
' &H100000 == SYNCHRONIZE, &H1000 == PROCESS_QUERY_LIMITED_INFORMATION
h = OpenProcess(&H100000 Or &H1000, 0, pid)
If h = 0 Then
Err.Raise vbObjectError + 1024, , _
"Failed to obtain process handle for process with ID " & pid & "."
End If
' Now wait for the process to terminate.
If timeoutInSecs = -1 Then
timeoutMs = &HFFFF ' INFINITE
Else
timeoutMs = timeoutInSecs * 1000
End If
sts = WaitForSingleObject(h, timeoutMs)
If sts <> 0 Then
Err.Raise vbObjectError + 1025, , _
"Waiting for process with ID " & pid & _
" to terminate timed out, or an unexpected error occurred."
End If
' Obtain the process's exit code.
sts = GetExitCodeProcess(h, exitCode) ' Return value is a BOOL: 1 for true, 0 for false
If sts <> 1 Then
Err.Raise vbObjectError + 1026, , _
"Failed to obtain exit code for process ID " & pid & "."
End If
CloseHandle h
' Return the exit code.
SyncShell = exitCode
End Function
' Example
Sub Main()
Dim cmd As String
Dim exitCode As Long
cmd = "Notepad"
' Synchronously invoke the command and wait
' at most 5 seconds for it to terminate.
exitCode = SyncShell(cmd, vbNormalFocus, 5)
MsgBox "'" & cmd & "' finished with exit code " & exitCode & ".", vbInformation
End Sub
Simpler and Compressed Code with examples:
first declare your path
Dim path: path = ThisWorkbook.Path & "\ProcessData.exe"
And then use any one line of following code you like
1) Shown + waited + exited
VBA.CreateObject("WScript.Shell").Run path,1, True
2) Hidden + waited + exited
VBA.CreateObject("WScript.Shell").Run path,0, True
3) Shown + No waited
VBA.CreateObject("WScript.Shell").Run path,1, False
4) Hidden + No waited
VBA.CreateObject("WScript.Shell").Run path,0, False
I was looking for a simple solution too and finally ended up to make these two functions, so maybe for future enthusiast readers :)
1.) prog must be running, reads tasklist from dos, output status to
file, read file in vba
2.) start prog and wait till prog is closed with a wscript shell .exec waitonrun
3.) ask for confirmation to delete tmp file
Modify program name and path variables and run in one go.
Sub dosWOR_caller()
Dim pwatch As String, ppath As String, pfull As String
pwatch = "vlc.exe" 'process to watch, or process.exe (do NOT use on cmd.exe itself...)
ppath = "C:\Program Files\VideoLAN\VLC" 'path to the program, or ThisWorkbook.Path
pfull = ppath & "\" & pwatch 'extra quotes in cmd line
Dim fout As String 'tmp file for r/w status in 1)
fout = Environ("userprofile") & "\Desktop\dosWaitOnRun_log.txt"
Dim status As Boolean, t As Double
status = False
'1) wait until done
t = Timer
If Not status Then Debug.Print "run prog first for this one! then close it to stop dosWORrun ": Shell (pfull)
status = dosWORrun(pwatch, fout)
If status Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'2) wait while running
t = Timer
Debug.Print "now running the prog and waiting you close it..."
status = dosWORexec(pfull)
If status = True Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'3) or if you need user action
With CreateObject("wScript.Shell")
.Run "cmd.exe /c title=.:The end:. & set /p""=Just press [enter] to delete tmp file"" & del " & fout & " & set/p""=and again to quit ;)""", 1, True
End With
End Sub
Function dosWORrun(pwatch As String, fout As String) As Boolean
'redirect sdtout to file, then read status and loop
Dim i As Long, scatch() As String
dosWORrun = False
If pwatch = "cmd.exe" Then Exit Function
With CreateObject("wScript.Shell")
Do
i = i + 1
.Run "cmd /c >""" & fout & """ (tasklist |find """ & pwatch & """ >nul && echo.""still running""|| echo.""done"")", 0, True
scatch = fReadb(fout)
Debug.Print i; scatch(0)
Loop Until scatch(0) = """done"""
End With
dosWORrun = True
End Function
Function dosWORexec(pwatch As String) As Boolean
'the trick: with .exec method, use .stdout.readall of the WshlExec object to force vba to wait too!
Dim scatch() As String, y As Object
dosWORexec = False
With CreateObject("wScript.Shell")
Set y = .exec("cmd.exe /k """ & pwatch & """ & exit")
scatch = Split(y.stdout.readall, vbNewLine)
Debug.Print y.status
Set y = Nothing
End With
dosWORexec = True
End Function
Function fReadb(txtfile As String) As String()
'fast read
Dim ff As Long, data As String
'~~. Open as txt File and read it in one go into memory
ff = FreeFile
Open txtfile For Binary As #ff
data = Space$(LOF(1))
Get #ff, , data
Close #ff
'~~> Store content in array
fReadb = Split(data, vbCrLf)
'~~ skip last crlf
If UBound(fReadb) <> -1 Then ReDim Preserve fReadb(0 To UBound(fReadb) - 1)
End Function
I incorporated this into a routine, and it has worked fine (but not used very often) for several years - for which, many thanks !
But now I find it throws up an error :-
Run-time error '-2147024894 (80070002)':
Method 'Run' of object 'IWshSheB' failed
on the line -
ErrorCode = wsh.Run(myCommand, windowStyle, WaitOnReturn)
Very strange !
5 hours later !
I THINK the reason it fails is that dear MicroSoft ("dear" meaning expensive) has changed something radical - "Shell" USED to be "Shell to DOS", but has that been changed >=?
The "Command" that I want the Shell to run is simply DIR
In full, it is "DIR C:\Folder\ /S >myFIle.txt"
. . . . . . . . . . . . . . . . . . . . . .
An hour after that-
Yup !
I have "solved" it by using this Code, which works just fine :-
Sub ShellAndWait(PathFile As String, _
Optional Wait As Boolean = True, _
Optional Hidden As Boolean = True)
' Hidden = 0; Shown = 1
Dim Hash As Integer, myBat As String, Shown As Integer
Shown = 0
If Hidden Then Shown = 1
If Hidden <> 0 Then Hidden = 1
Hash = FreeFile
myBat = "C:\Users\Public\myBat.bat"
Open myBat For Output As #Hash
Print #Hash, PathFile
Close #Hash
With CreateObject("WScript.Shell")
.Run myBat, Shown, Wait
End With
End Sub
I would come at this by using the Timer function. Figure out roughly how long you'd like the macro to pause while the .exe does its thing, and then change the '10' in the commented line to whatever time (in seconds) that you'd like.
Strt = Timer
Shell (ThisWorkbook.Path & "\ProcessData.exe")
Do While Timer < Strt + 10 'This line loops the code for 10 seconds
Loop
UserForm2.Hide
'Additional lines to set formatting
This should do the trick, let me know if not.
Cheers, Ben.
I faced an error when upgrading VB6 code to VB.NET. The error occurs at
AddressOf WindowProc
AddressOf expression cannot be converted to 'Integer' because 'Integer' is not a delegate type
My declaration for SetWindowLong is:
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"(
ByVal hWnd As Integer,
ByVal nIndex As Integer,
ByVal dwNewLong As Integer) As Integer
variables:
Dim GWL_WNDPROC As Short = -4
Dim hWnd As Integer
Code for WindowProc:
Function WindowProc(ByVal hw As Integer, ByVal uMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
Dim x As Integer
Dim a As String
Dim wp As Short
Dim temp As Object
Dim ReadBuffer(1000) As Byte
'Debug.Print uMsg, wParam, lParam
Select Case uMsg
Case 1025
Debug.Print(VB6.TabLayout(uMsg, wParam, lParam))
Debug.Print(uMsg & " " & wParam & " " & lParam)
e_err = WSAGetAsyncError(lParam)
e_errstr = GetWSAErrorString(e_err)
If e_err <> 0 Then
Debug.Print("Error String returned -> " & e_err & " - " & e_errstr)
Debug.Print("Terminating....")
do_cancel = True
'Exit Function
End If
Select Case lParam
Case FD_READ 'lets check for data
x = recv(mysock, ReadBuffer(0), 1000, 0) 'try to get some
If x > 0 Then 'was there any?
'UPGRADE_ISSUE: Constant vbUnicode was not upgraded. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="55B59875-9A95-4B71-9D6A-7C294BF7139D"'
'default
'a = StrConv(System.Text.UnicodeEncoding.Unicode.GetString(ReadBuffer), vbUnicode) 'yep, lets change it to stuff we can understand
a = System.Text.UnicodeEncoding.Unicode.GetString(ReadBuffer) 'yep, lets change it to stuff we can understand
Debug.Print(a)
rtncode = Val(Mid(a, 1, 3))
'Debug.Print "Analysing code " & rtncode & "..."
Select Case rtncode
Case 354, 250
Progress = Progress + 1
Debug.Print(">>Progress becomes " & Progress)
Case 220
Debug.Print("Recieved Greenlight")
Green_Light = True
Case 221
Progress = Progress + 1
Debug.Print(">>Progress becomes " & Progress)
Case 550, 551, 552, 553, 554, 451, 452, 500
Debug.Print("There was some error at the server side")
Debug.Print("error code is " & rtncode)
do_cancel = True
End Select
End If
Case FD_CONNECT 'did we connect?
mysock = wParam 'yep, we did! yayay
'Debug.Print WSAGetAsyncError(lParam) & "error code"
'Debug.Print mysock & " - Mysocket Value"
Case FD_CLOSE 'uh oh. they closed the connection
Call closesocket(wp) 'so we need to close
End Select
End Select
'let the msg get through to the form
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
What is the reason for the error I get? How do I solve the problem?
Rather than trying to use P/Invoke to set the window procedure, have you looked at overriding your Form's WndProc method? It may take a little more work during the re-write, but you'll end up with better code. Example from the previous link:
Protected Overrides Sub WndProc(ByRef m As Message)
' Listen for operating system messages
Select Case (m.Msg)
' The WM_ACTIVATEAPP message occurs when the application
' becomes the active application or becomes inactive.
Case WM_ACTIVATEAPP
' The WParam value identifies what is occurring.
appActive = (m.WParam.ToInt32() <> 0)
' Invalidate to get new text painted.
Me.Invalidate()
End Select
MyBase.WndProc(m)
End Sub
You might also want to look in the System.Net.Sockets namespace for appropriate replacements for your current socket code.
I've also found an article ".NET Makes Window Subclassing Easy", which might be useful if, for instance, you don't own the window you're trying to subclass. Any way around though, the one way that's not recommended is by trying to override the Window Proc using SetWindowLong