I am trying to use my Epson TM U220 as I did before installing a new PC with WIN 7 64bit and Excel2010, no parallel port. In the past I used this simple code to open cash drawer:
Sub drawer_opener()
Open "LPT1" For Output As #1
Print #1, Chr(27) + Chr(112) + Chr(0) + Chr(25) + Chr(250)
Close #1
End Sub
Now I am using an adapter parallel-USB but with no response to opening cash drawer commnad after changing "LPT1" to "USB001" in code.
After some web research I found following code that is supposed to work, but it keeps popping error messages for one reason or the other.
I quote thread I found and give all the credit to "Mike"
quote
As you've discovered, that approach won't work on USB printers. Try
the following instead. I've assumed that the USB printer is set up as
your default printer (although it is possible to add code to look for
it if it is not) and of course you'll also need to check that your new
printer obeys the same control codes in the same way as your old one.
Mike
Option Explicit
Private Declare Function OpenPrinter Lib "winspool.drv" _
Alias "OpenPrinterA" (ByVal pPrinterName As String, _
phPrinter As Long, ByVal pDefault As Long) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" _
Alias "StartDocPrinterA" (ByVal hPrinter As Long, _
ByVal Level As Long, pDocInfo As DOCINFO) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long, pBuf As Any, _
ByVal cdBuf As Long, pcWritten As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Private Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Private Sub Command1_Click()
Dim printerHandle As Long, retVal As Long
Dim bytesWritten As Long, lDoc As Long
Dim s1 As String, MyDocInfo As DOCINFO
retVal = OpenPrinter(Printer.DeviceName, printerHandle, 0)
If retVal = 0 Then
MsgBox "Printer Not found"
Exit Sub
End If
MyDocInfo.pDocName = "Any Name"
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(printerHandle, 1, MyDocInfo)
Call StartPagePrinter(printerHandle)
s1 = Chr(27) + Chr(112) + Chr(0) + Chr(25) + Chr(250)
retVal = WritePrinter(printerHandle, ByVal s1, _
Len(s1), bytesWritten)
retVal = EndPagePrinter(printerHandle)
retVal = EndDocPrinter(printerHandle)
retVal = ClosePrinter(printerHandle)
End Sub
unquote
I kindly request that some expert of you guys would please try the code and see if it just doesnt work for Excel2010, if it is not actually VBA or what is the problem. Also if there is no hope via software (code) solution to send command to Epson printer and I have to install a parallel port in PC and start using a parallel-parallel cable as in the past.
Tks in advance, Gabriel
Simpler approach: Share your USB Printer, and then map the printer share to LPT1: via net use:
net use LPT1: \\.\PrinterShareName
This way you can try to make your old code work.
Related
I want to use something similar to
GetObject(,"Excel.Application") to get back the application I created.
I call CreateObject("Excel.Application") to create Excel instances. Later if the VBA project resets, due to debugging and coding, the Application object variables are lost but the Excel instances are running in the background. Kind of a memory leak situation.
I want to re-attach to either re-use (preferred way) or close them.
To list the running instances of Excel:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Test()
Dim xl As Application
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.ActiveWorkbook.FullName
Next
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function
This would be best as a comment on Florent B.'s very useful function that returns a collection of the open Excel instances, but I don't have sufficient reputation to add comments. In my tests, the collection contained "repeats" of the same Excel instances i.e. GetExcelInstances().Count was larger than it should have been. A fix for that is the use of the AlreadyThere variable in the version below.
Private Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Dim AlreadyThere As Boolean
Dim xl As Application
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
AlreadyThere = False
For Each xl In GetExcelInstances
If xl Is acc.Application Then
AlreadyThere = True
Exit For
End If
Next
If Not AlreadyThere Then
GetExcelInstances.Add acc.Application
End If
End If
Loop
End Function
#PGS62/#Philip Swannell has the correct answer for returning a Collection; I can iterate all instances; and it is brilliant, as #M1chael comment.
Let's not confuse Application objects with Workbook objects... ...Of
course it would be possible to write a nested loop that loops over the
workbooks collection of each application object
This is the nested loop implemented and fully functional:
Sub Test2XL()
Dim xl As Excel.Application
Dim i As Integer
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.Application.hwnd
Debug.Print "# workbooks: " & xl.Application.Workbooks.Count
For i = 1 To xl.Application.Workbooks.Count
Debug.Print "Workbook: " & xl.Application.Workbooks(i).Name
Debug.Print "Workbook path: " & xl.Application.Workbooks(i).path
Next i
Next
Set xl = Nothing
End Sub
And, for Word instances, the nested loop:
Sub Test2Wd()
Dim wd As Word.Application
Dim i As Integer
For Each wd In GetWordInstancesCol()
Debug.Print "Version: " & wd.System.Version
Debug.Print "# Documents: " & wd.Application.Documents.Count
For i = 1 To wd.Application.Documents.Count
Debug.Print "Document: " & wd.Application.Documents(i).Name
Debug.Print "Document path: " & wd.Application.Documents(i).path
Next i
Next
Set wd = Nothing
End Sub
For Word you have to use what is explained in the end of this thread
I use the following to check if two instances are running, and display a message. It could be altered to close other instance... This may be of help... I need code to return a specific instance, and return for use similar to GetObject(,"Excel.Application")... I don't think it possible though
If checkIfExcelRunningMoreThanOneInstance() Then Exit Function
In module (some of the declarations are possible used for other code):
Const MaxNumberOfWindows = 10
Const HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Global ret As Integer
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const VK_CAPITAL = &H14
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
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 EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Global ExcelWindowName$ 'Used to switch back to later
Function checkIfExcelRunningMoreThanOneInstance()
'Check instance it is 1, else ask user to reboot excel, return TRUE to abort
ExcelWindowName = excel.Application.Caption 'Used to switch back to window later
If countProcessRunning("excel.exe") > 1 Then
Dim t$
t = "Two copies of 'Excel.exe' are running, which may stop in cell searching from working!" & vbCrLf & vbCrLf & "Please close all copies of Excel." & vbCrLf & _
" (1 Then press Alt+Ctrl+Del to go to task manager." & vbCrLf & _
" (2 Search the processes running to find 'Excel.exe'" & vbCrLf & _
" (3 Select it and press [End Task] button." & vbCrLf & _
" (4 Then reopen and use PostTrans"
MsgBox t, vbCritical, ApplicationName
End If
End Function
Private Function countProcessRunning(ByVal sProcess As String) As Long
Const MAX_PATH As Long = 260
Dim lProcesses() As Long, lModules() As Long, N As Long, lRet As Long, hProcess As Long
Dim sName As String
countProcessRunning = 0
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If Len(sName) = Len(sProcess) Then
If sProcess = UCase$(sName) Then
countProcessRunning = countProcessRunning + 1
End If
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
The I found:
Dim xlApp As Excel.Application
Set xlApp = GetObject("ExampleBook.xlsx").Application
Which gets the object if you know the name of the sheet currently active in Excel instance. I guess this could be got from the application title using the first bit of code. In my app I do know the filename.
This can accomplish what you want.
Determine if an instance of Excel is open:
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
If an instance is running you can access it using the xlApp object. If an instance is not running you will get a run-time error (you might need/want an error handler). The GetObject function gets the first instance of Excel that had been loaded. You can do your job with it, and to get to others, you can close that one and then try GetObject again to get the next one, etc.
So you will be attaining your ok-but-second-preferred objective
(taken from http://excelribbon.tips.net/T009452_Finding_Other_Instances_of_Excel_in_a_Macro.html).
For attaining your preferred objective, I think that https://stackoverflow.com/a/3303016/2707864 shows you how.
Create an array of objects and store the newly created Excel.Application in the array. That way you can reference them as and when you need. Let's take a quick example:
In a module:
Dim ExcelApp(2) As Object
Sub Test()
Set ExcelApp(1) = CreateObject("Excel.Application")
ExcelApp(1).Visible = True
Set ExcelApp(2) = CreateObject("Excel.Application")
ExcelApp(2).Visible = True
End Sub
Sub AnotherTest()
ExcelApp(1).Quit
ExcelApp(2).Quit
End Sub
Run Test() macro and you should see two Excel Applications pop up. Then run AnotherTest() and the Excel Applications will quit. You can even set the array to Nothing after you are done.
You can get handle of running Excel applications using the script published on http://www.ozgrid.com/forum/showthread.php?t=182853. That should get you where you want to go.
You should use this code every time you need an Excel application object. This way, your code will only ever work with one application object or use a pre-existing one. The only way you could end up with more than one is if the user started more than one. This is both the code to open Excel and attach and reuse, like you want.
Public Function GetExcelApplication() As Object
On Error GoTo openExcel
Set GetExcelApplication = GetObject(, "Excel.Application")
Exit Function
openExcel:
If Err.Number = 429 Then
Set GetExcelApplication = CreateObject("Excel.Application")
Else
Debug.Print "Unhandled exception: " & Err.Number & " " & Err.Description
End If
End Function
If you wanted to close multiple instances you would need to call GetObject followed by .Close in a loop until it throws the error 429.
The details can be found in this Article
This is my first time asking for any help on stack overflow, let alone commenting so please be gentle with me :)
I am at a loss with this one, I will give as much information as possible.
Issue
I would like to preface, this code does not cause any crashes on the latest update of 0365, only on Version 1807 & earlier. It also does not crash on the 32 bit version at all which makes me think it's a 64 bit issue. My client cannot update from this version either so simply asking them to update is not going to be able to happen.
I have narrowed the crashing down to this particular section.
Public Function GetSpecialFolder(CSIDL As Long) As String
'*******************************************************************************
'* Function: GetSpecialFolder
'* Purpose: Wraps the apis to retrieve folders such as My Docs etc.
'*******************************************************************************
Dim idlstr As Long
Dim sPath As String
Dim IDL As ITEMIDLIST
Const MAX_LENGTH = 260
'Fill the IDL structure with the specified folder item.
On Error GoTo GetSpecialFolder_Error
idlstr = SHGetSpecialFolderLocation _
(0, CSIDL, IDL)
If idlstr = 0 Then
'Get the path from the IDL list, and return the folder adding final "\".
sPath = Space$(MAX_LENGTH)
**idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)**
If idlstr Then
GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) _
- 1) & "\"
End If
End If
procExit:
On Error Resume Next
Exit Function
GetSpecialFolder_Error:
CommonErrorHandler lngErrNum:=Err.Number, strErrDesc:=Err.Description, _
strProc:="GetSpecialFolder", strModule:="modWinAPI", lngLineNum:=Erl
Resume procExit
End Function
And here is the declaration
'File system
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare PtrSafe Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
Private Type ITEMIDLIST
mkid As ShortItemId
End Type
Private Type ShortItemId
cb As Long
abID As Byte
End Type
I have tried adding LongPtr as suggested in documents I've found online but it hasn't helped.
Can anyone help me?
Thanks!
SHGetSpecialFolderLocation does not fill in the memory you allocate for ITEMIDLIST like Declared function usually do, it allocates a new piece of memory that you are later required to free with CoTaskMemFree. That makes it pointless to declare ITEMIDLIST as a structure in VBA to begin with (and your declaration is wrong anyway, cb must be Integer, and abID is a variable-length byte array, not a single byte).
If you needed to do something with individual members of a structure allocated in this way, you would have to copy them out of the returned pointer with CopyMemory. Luckily, you don't need to do any of that because SHGetSpecialFolderLocation returns a pointer to PIDLIST_ABSOLUTE, and SHGetPathFromIDList accepts PCIDLIST_ABSOLUTE:
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As LongPtr, ByVal nFolder As Long, ByRef pIdl As LongPtr) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pIdl As LongPtr, ByVal pszPath As String) As Long
Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)
Public Function GetSpecialFolder(ByVal CSIDL As Long) As String
Dim retval As Long
Dim pIdl As LongPtr
Dim sPath As String
Const MAX_LENGTH = 260
retval = SHGetSpecialFolderLocation(0, CSIDL, pIdl)
If retval = 0 Then
sPath = Space$(MAX_LENGTH)
retval = SHGetPathFromIDList(pIdl, sPath)
If retval <> 0 Then
GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) & "\"
End If
CoTaskMemFree ByVal pIdl
End If
End Function
Note that it's pointless to have an On Error Goto in such function because Windows API generally do not raise exceptions, they return error codes. It would make sense if you used Err.Raise ... after finding out a return value indicates an error.
TBH, I have no clue how this was functioning correctly on a 32 bit build. The declarations for the two structures are incorrect. This one...
Private Type ShortItemId
cb As Long
abID As Byte
End Type
...is defined in the MS documentation as this:
typedef struct _SHITEMID {
USHORT cb;
BYTE abID[1];
} SHITEMID;
Note that abID is an array, and cb is an unsigned short (you can use an Integer for that in VBA, but it definitely is not a Long).
In addition, this structure (wrapped in the ITEMIDLIST) is not even supposed to be allocated by the caller, but must be freed by the caller:
It is the responsibility of the calling application to free the returned IDList by using CoTaskMemFree.
Re the pointers, the only pointers (that aren't being marshaled from String) are the
pidl parameter of SHGetSpecialFolderLocation and the pointer to ppidl in SHGetPathFromIDList. Note that you can't use a VBA defined struct, because you need to free the memory when you're done. Something like this will work:
Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As LongPtr) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)
Private Const S_OK As Long = 0
Private Const MAX_LENGTH = 260
Public Function GetSpecialFolder(ByVal CSIDL As Integer) As String
Dim result As Long
Dim path As String
Dim idl_ptr As LongPtr
'Fill the IDL structure with the specified folder item.
result = SHGetSpecialFolderLocation(0, CSIDL, idl_ptr)
If result = S_OK Then
'Get the path from the IDL list, and return the folder adding final "\".
path = Space$(MAX_LENGTH)
If SHGetPathFromIDList(idl_ptr, path) Then
GetSpecialFolder = Left$(path, InStr(path, vbNullChar) - 1) & "\"
End If
CoTaskMemFree idl_ptr
End If
End Function
Note that per the discussion in the comments, you could technically declare hwndOwner as LongPtr as well, but it shouldn't make any difference.
I'm trying to pull up the on-screen keyboard.
Here are my attempts so far:
' Only needed for Test3
Private Declare 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
Sub Test1()
' Run-time error'53':
' File Not found
Dim RetVal As Variant
RetVal = Shell("C:\WINDOWS\system32\osk.exe", 1)
End Sub
Sub Test2()
' Run-time error '432':
' File name or class name not found during Automation operation
ActiveWorkbook.FollowHyperlink Address:="C:\Windows\System32\osk.exe"
End Sub
Sub Test3()
' No error. Nothing happens at all
ShellExecute 0, vbNullString, "osk.exe", vbNullString, "C:\", 1
End Sub
Test2 from this forum.
Test3 from this forum.
I checked the path to osk.exe is correct.
I have a Surface laptop/tablet, so it has a touch screen and a "touch" keyboard (different from the osk). Is that what's causing the issue or possibly it's a Windows 10 thing?
On a 64-Bit OS try this
Option Explicit
Private Declare 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 Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
Private Sub RunOsk_on64Bit()
Const SW_SHOWNORMAL = 1
On Error Resume Next
Wow64EnableWow64FsRedirection False
ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
Wow64EnableWow64FsRedirection True
End Sub
Found here, this might the explanation, quote from the link
This is an issue with 64-bit OS, it affects any 64-bit version of Windows.
Basically you are calling osk.exe, but your program you are calling it
from is a 32-bit app. Windows won't allow you to call a 64-bit OSK.exe
from your program. The comments appear to miss your point here, anyone
can start osk.exe from Run, but call it from within a 32-bit
application won't work in 64-bit Windows.
I am developing software that uses the on-screen keyboard, the only
work around is Wow64DisableWow64FsRedirection.
Update: A "nicer" version might look like that
Option Explicit
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
Public Declare Function ShellExecuteEx Lib "shell32.dll" _
(lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function Wow64DisableWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Declare Function Wow64RevertWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Public Function KeyboardOpen()
Dim shInfo As SHELLEXECUTEINFO
Dim lngPtr As Long
With shInfo
.cbSize = Len(shInfo)
.lpFile = "C:\Windows\Sysnative\cmd.exe" 'best to use Known folders here
.lpParameters = "/c start osk.exe"
.lpDirectory = "C:\windows\system32" 'best to use Known folders here
.lpVerb = "open"
.nShow = 0
End With
Call Wow64DisableWow64FsRedirection(lngPtr)
Call ShellExecuteEx(shInfo)
Call Wow64RevertWow64FsRedirection(lngPtr)
End Function
Based on the information in MSDN it might be more reliable to use Wow64DisableWow64FsRedirection and Wow64RevertWow64FsRedirection functions instead.
So I wrote a 180 page program in VBA that is fairly robust and works great, except the clipboard doesn't work when running simultaneously with any VNC viewer (RealVNC, logmein, etc.) After digging around I found this was a somewhat known but rare issue, so Windows wrote API code to utilize getting data from and sending data to the clipboard:
http://msdn.microsoft.com/en-us/library/office/dn124100.aspx
Function ClipBoard_SetData(MyString As String) works fine with any data set I've tried. And Function ClipBoard_GetData() works fine with a small data set, but when I try it with a 80KB data set it crashes excel every time.
Any help with running VBA next to a VNC viewer or Win API code would be greatly appreciated. Here is WinAPI code:
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _
As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As _
Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
X = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function ClipBoard_GetData()
Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim MyString As String
Dim RetVal As Long
If OpenClipboard(0&) = 0 Then
MsgBox "Cannot open Clipboard. Another app. may have it open"
Exit Function
End If
' Obtain the handle to the global memory
' block that is referencing the text.
hClipMemory = GetClipboardData(CF_TEXT)
If IsNull(hClipMemory) Then
MsgBox "Could not allocate memory"
GoTo OutOfHere
End If
' Lock Clipboard memory so we can reference
' the actual data string.
lpClipMemory = GlobalLock(hClipMemory)
If Not IsNull(lpClipMemory) Then
MyString = Space$(MAXSIZE)
RetVal = lstrcpy(MyString, lpClipMemory)
RetVal = GlobalUnlock(hClipMemory)
' Peel off the null terminating character.
MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
Else
MsgBox "Could not lock memory to copy string from."
End If
OutOfHere:
RetVal = CloseClipboard()
ClipBoard_GetData = MyString
End Function
You allocate a string of MAXSIZE (4096) spaces and use lstrcpy to override it with the clipboard content. No surprise if Excel crash when there is 80k in the Clipboard. Use lstrlen to know the size of the actual content of the clipboard.
I want to print text line by line by passing raw text per line to dot matrix in vb.net. Is that Possible
Something like Printf in c
It is not my intention to provide The Answer, but as a supplementary answer -
The following is (unmanaged) VB6 code which does what you want but could easily be converted to be more .NET friendly:
Public Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pDocInfo As DOCINFO) As Long
Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long
Public Function PrintRawData(ByVal sPrinter As String, ByVal sDocName As String, ByVal sData As String) As Boolean
On Error GoTo PrintErr:
Dim lhPrinter As Long, lReturn As Long, lpcWritten As Long
Dim lDoc As Long, sWrittenData As String
Dim MyDocInfo As DOCINFO
Dim pOutput As Printer
Dim p As Printer
For Each p In Printers
If p.DeviceName = sPrinter Then
Set pOutput = p
GoTo StartPrinting
End If
Next p
MsgBox "Unable to find the specified printer [" & sPrinter & _
"] in the list of currently installed printers" & vbCrLf & _
"Printing will be aborted", vbCritical
Exit Function
StartPrinting:
lReturn = OpenPrinter(pOutput.DeviceName, lhPrinter, 0)
If lReturn = 0 Then
MsgBox "Print was unsuccessful. Make sure there is a printer installed on the port you are trying to print to"
Exit Function
End If
MyDocInfo.pDocName = sDocName
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
Call StartPagePrinter(lhPrinter)
sWrittenData = sData
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, Len(sWrittenData), lpcWritten)
lReturn = EndPagePrinter(lhPrinter) 'need this??
lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
Exit Function
PrintErr:
MsgBox "Print was unsuccessful. Make sure there is a printer installed on the port you are trying to print to"
Exit Function
End Function
To use it you need to install a printer that uses the correct port using any driver (I generally use the Generic / text Only Driver) and then call it as follows replacing the Hello with the data you want to send to the printer including control characters etc:
PrintRawData "Generic / Text Only", "My Document", "Hello"