Send Raw Data to ZPL Printer using Visual Basic (MS Access 2000) - vba
This is all that I can find, none of them work.
Option Compare Database
Option Explicit
Private Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
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 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 Sub TEST()
Dim lhPrinter As Long
Dim lReturn As Long
Dim lpcWritten As Long
Dim lDoc As Long
Dim sWrittenData As String
Dim MyDocInfo As DOCINFO
lReturn = OpenPrinter("ZDesigner LP 2844", lhPrinter, 0)
If lReturn = 0 Then
MsgBox "The Printer Name you typed wasn't recognized."
Exit Sub
End If
MyDocInfo.pDocName = "AAAAAA"
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
Call StartPagePrinter(lhPrinter)
sWrittenData = "N" & vbFormFeed
sWrittenData = sWrittenData & "q609" & vbFormFeed
sWrittenData = sWrittenData & "Q203,26" & vbFormFeed
sWrittenData = sWrittenData & "B26,26,0,UA0,2,2,152,B," & Chr(34) & "603679025109" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,26,0,3,1,1,N," & Chr(34) & "SKU 6205518 MFG 6354" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,56,0,3,1,1,N," & Chr(34) & "2XIST TROPICAL BEACH" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,86,0,3,1,1,N," & Chr(34) & "STRIPE SQUARE CUT TRUNK" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,116,0,3,1,1,N," & Chr(34) & "BRICK" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,146,0,3,1,1,N," & Chr(34) & "X-LARGE" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "P1,1" & vbFormFeed
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), lpcWritten)
lReturn = EndPagePrinter(lhPrinter)
lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
End Sub
Method 2
Option Compare Database
Private Sub crtLabel()
Dim prtDevice As String
Dim strQuote As String
strQuote = Chr(34)
prtDevice = "ZDesigner LP 2844" ' whatever device Access currently has as the default. I have the user select a printer prior to printing, which sets the Access defaut printer
' open printer port
Open prtDevice For Output As #1
' initialize printer
Print #1, "OD" & vbCrLf
Print #1, "N" & vbCrLf
Print #1, "O" & vbCrLf
Print #1, "Q545,B12+23" & vbCrLf
Print #1, "q262" & vbCrLf
Print #1, "UN" & vbCrLf
Print #1, "rN" & vbCrLf
Print #1, "N" & vbCrLf
Print #1, "A4,94,3,3,1,1,N," & strQuote & "1803" & strQuote & vbCrLf
Print #1, "A36,74,3,3,1,1,N," & strQuote & "B" & strQuote & vbCrLf
Print #1, "A64,94,3,3,1,1,N," & strQuote & "079" & strQuote & vbCrLf
Print #1, "A112,8,0,2,1,1,N," & strQuote & strQuote & vbCrLf ' you can replace any string like "1803" with a string variable like SID or AID that gets passed to the sub
Print #1, "A112,32,0,3,1,1,N," & strQuote & strQuote & vbCrLf ' same here
Print #1, "A112,64,0,1,1,1,N," & strQuote & "04/13/2009" & strQuote & vbCrLf
Print #1, "A130,100,0,1,1,1,N," & strQuote & "SWAB, NASO" & strQuote & vbCrLf
Print #1, "A4,100,0,1,1,1,N," & strQuote & "C146536" & strQuote & vbCrLf
Print #1, "B53,130,0,1,1,0,47,N," & strQuote & "2009-06868" & strQuote & vbCrLf
Print #1, "A112,188,0,1,1,1,N," & strQuote & "" & strQuote & vbCrLf
Print #1, "P1,1" & vbCrLf
Print #1, "O" & vbCrLf
' close printer port
Close #1
End Sub
Nothing happens after running the function. It's like the printer is not touched at all by the code.
UPDATE
Method 1 is the closest thing I can get to printing the file. After executing the command, there is a printer icon at the status bar show that the printer has been called and receiving data from my code, but still, no printing at all. Help...
if it is mapped to a parallel or com port, you can open that directly:
open "LPT1:" For Output as #1
' or open "COM1:"
print #1, "SomeData"
Close #1
What I like to do is do something similar to your Method 2, but save it to a file (the raw printer data) and then do a file copy to the UNC path.
file copy "C:\label.txt" \computername\sharename
That works for me.
Okay so this is how I managed to get thing this work. Not a best option as I wanted but ... it works.
1) I use the same function, but written in C++, taken from here http://support.microsoft.com/kb/138594/EN-US
// RawDataToPrinter - sends binary data directly to a printer
//
// Params:
// szPrinterName - NULL terminated string specifying printer name
// lpData - Pointer to raw data bytes
// dwCount - Length of lpData in bytes
//
// Returns: TRUE for success, FALSE for failure.
//
BOOL RawDataToPrinter(LPSTR szPrinterName, LPBYTE lpData, DWORD dwCount)
{
HANDLE hPrinter;
DOC_INFO_1 DocInfo;
DWORD dwJob;
DWORD dwBytesWritten;
// Need a handle to the printer.
if( ! OpenPrinter( szPrinterName, &hPrinter, NULL ) )
return FALSE;
// Fill in the structure with info about this "document."
DocInfo.pDocName = "My Document";
DocInfo.pOutputFile = NULL;
DocInfo.pDatatype = "RAW";
// Inform the spooler the document is beginning.
if( (dwJob = StartDocPrinter( hPrinter, 1, (LPSTR)&DocInfo )) == 0 )
{
ClosePrinter( hPrinter );
return FALSE;
}
// Start a page.
if( ! StartPagePrinter( hPrinter ) )
{
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// Send the data to the printer.
if( ! WritePrinter( hPrinter, lpData, dwCount, &dwBytesWritten ) )
{
EndPagePrinter( hPrinter );
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// End the page.
if( ! EndPagePrinter( hPrinter ) )
{
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// Inform the spooler that the document is ending.
if( ! EndDocPrinter( hPrinter ) )
{
ClosePrinter( hPrinter );
return FALSE;
}
// Tidy up the printer handle.
ClosePrinter( hPrinter );
// Check to see if correct number of bytes were written.
if( dwBytesWritten != dwCount )
return FALSE;
return TRUE;
}
I got the file RAWPRN.EXE from there, put my EPL code in a txt file. Finally, use Shell to execute it
Dim RetVal
RetVal = Shell("cmd .exe /c C:\rawprint\RawPrint.exe ""ZDesigner LP 2844"" ""C:\eplcode.txt""", 1)
My solution for Zebra
Creating a generic/text printer in windows then sending to raw file to this printer
In Zebra printers advanced settings --> others,
there is a passthrough characters. You can send raw text with this to this printer.
I use this solution, works perfect.
make a generic text printer, following this recipe
Map the printer to LPT1, using "net use lpt1 \\computername\printername /persistent:yes
Send files to the printer, using:
VBA
Public function runCmd(cmd as String) as Boolean
Dim wsh As Object
Dim cmdToRun As String
Dim Sts As Integer
Set wsh = VBA.CreateObject("WScript.Shell")
cmdToRun = "cmd.exe /c " & Quote(cmd)
'Run & wait to complete
Sts = wsh.Run(cmdToRun, 0, 1)
If Sts = 0 Then
runCmd = True
Else
MsgBox cmd & vbCrLf & "Failed with error code " & Sts
End If
Set wsh = Nothing
End Function
Using cmd : : "cd {dir} & Print \D:LPT1 [file [file]]"
Related
Apply working Shell code in a different database
I have used the "Shell" function, in other Access databases, to open folders. With the same code structure I get the 5 error code of "Invalid procedure call or argument" Using shell function as follows: Dim FreightFile_Path As String FreightFile_Path = "S:\Supply Chain\Freight" Shell "explorer.exe" & " " & FreightFile_Path, vbNormalFocus I tried the double quotes and Chr(34)'s around them. I copied the code from one database (that it worked in) to another and it error-ed. Am I missing something I need to activate in MS Access? I checked the references in VBA and made sure they match. Things I tried: Call Shell("explorer.exe" & " " & Chr(34) & "S:\Shared" & Chr(34), vbNormalFocus) Shell "explorer.exe " & Chr(34) & FreightFile_Path & Chr(34), vbNormalFocus Shell "explorer.exe" & " " & FreightFile_Path, vbNormalFocus Dim retVal retVal = Shell("explorer.exe" & " " & FreightFile_Path, vbNormalNoFocus) Dim i As String i = "explorer.exe" & " " & FreightFile_Path Shell i, vbNormalFocus FreightFile_Path = "S:\Supply Chain\Freight" Shell "explorer.exe " & FreightFile_Path, vbNormalFocus Restarted the application, restarted the computer.
I just had the same problem. In my case, it turned out to be anti-virus that was blocking Shell. It just so happened that IT had put exceptions in place for my computer for one database but not the other. See my question and answer for more detail.
Try this: FreightFile_Path = "S:\Supply Chain\Freight" Shell "cmd /c start explorer.exe """ & FreightFile_Path & """" It is a bit of a workaround, but it works...
New try. Use a WinAPI call 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 lpnShowCmd As Long) As Long Public Sub ShellEx(ByVal Path As String, Optional ByVal Parameters As String, Optional ByVal HideWindow As Boolean) If Dir(Path) > "" Then ShellExecute 0, "open", Path, Parameters, "", IIf(HideWindow, 0, 1) End If End Sub Sub Test() FreightFile_Path = "S:\Supply Chain\Freight" ShellEx "c:\windows\explorer.exe", """" & FreightFile_Path & """" End Sub
Thank you everybody for the help. This might not really be an answer to the Shell problem, but it will work for opening a file path. Dim FreightFilePath As String FreightFilePath = "S:\Supply Chain\Freight" Application.FollowHyperLink FreightFilePath
Verify the number of copies that have prints
I have a table that when printed generates a record in a txt telling the user who printed it, on which machine, which printer, what was the document and when. But I would like to also record the number of copies, but I have no idea how. Code that takes information from the computer: Declare Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA" (ByVal lbbuffer As String, nSize As Long) Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long Function deMAQUINA() As String Dim Buffer As String * 256 Dim BuffLen As Long Dim lngX As Long Dim strCompName As String BuffLen = 255 If GetComputerName(Buffer, BuffLen) Then deMAQUINA = Left(Buffer, BuffLen) End Function Function deUSUARIO() As String Dim Buffer As String * 256 Dim BuffLen As Long BuffLen = 256 If GetUserName(Buffer, BuffLen) Then deUSUARIO = Left(Buffer, BuffLen - 1) End Function Code that registers: Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim vUsuario As String, vMaquina As String vUsuario = deUSUARIO() vMaquina = deMAQUINA() Open "\\Caminho\do\arquivo.txt" For Append As #2 Print #2, "O usuário: " & vUsuario & " | pela Máquina: " & vMaquina & " | pela impressora: " & ActivePrinter & " | Imprimiu o documento " & ActiveWorkbook.Name & "| no dia: " & Now Close #2 Open ActiveWorkbook.Path & "\OBSOLETO\" & Left(ActiveWorkbook.Name, 8) & ".txt" For Append As #3 Print #3, "O usuário: " & vUsuario & " | pela Máquina: " & vMaquina & " | pela impressora: " & ActivePrinter & " | Imprimiu o documento " & ActiveWorkbook.Name & "| no dia: " & Now Close #3 End Sub If anyone knows, could please help? I'm sorry, I had to translate, why no one knew how to respond on server BR
winsock connect function is working only on high speed connection
I'm using winsock in my VB6 application, this is my code: Private Sub Form_Load() With Winsock1 .Close .RemoteHost = Hostip .RemotePort = port number .Connect End With End Sub My problem is when I'm using a high speed connection (4G) the connection works fine but using other connections like (3G,wise...) it returns the following message: the attempt to connect timed out How do I remedy this?
It sounds like you need to set a longer connection timeout. There is no way to do this directly with the control. Below is a modified sample from a retired KB article. The orignal code does not include the SO_SNDTIMEO, or SO_RCVTIMEO options. Option Explicit ' Error returned by Winsock API. Const SOCKET_ERROR = -1 ' Level number for (get/set)sockopt() to apply to socket itself. Const SOL_SOCKET = 65535 ' Options for socket level. Const IPPROTO_TCP = 6 ' Protocol constant for TCP. ' option flags per socket Const SO_DEBUG = &H1& ' Turn on debugging info recording Const SO_ACCEPTCONN = &H2& ' Socket has had listen() - READ-ONLY. Const SO_REUSEADDR = &H4& ' Allow local address reuse. Const SO_KEEPALIVE = &H8& ' Keep connections alive. Const SO_DONTROUTE = &H10& ' Just use interface addresses. Const SO_BROADCAST = &H20& ' Permit sending of broadcast msgs. Const SO_USELOOPBACK = &H40& ' Bypass hardware when possible. Const SO_LINGER = &H80& ' Linger on close if data present. Const SO_OOBINLINE = &H100& ' Leave received OOB data in line. Const SO_DONTLINGER = Not SO_LINGER Const SO_EXCLUSIVEADDRUSE = Not SO_REUSEADDR ' Disallow local address reuse. ' Additional options. Const SO_SNDBUF = &H1001& ' Send buffer size. Const SO_RCVBUF = &H1002& ' Receive buffer size. Const SO_ERROR = &H1007& ' Get error status and clear. Const SO_TYPE = &H1008& ' Get socket type - READ-ONLY. ' TCP Options Const TCP_NODELAY = &H1& ' Turn off Nagel Algorithm. ' linger structure Private Type LINGER_STRUCT l_onoff As Integer ' Is linger on or off? l_linger As Integer ' Linger timeout in seconds. End Type 'timeout structure Private Type TIMEOUT_STRUCT tv_sec As Long 'seconds tv_usec As Long 'milliseconds End Type 'Timeout options Const SO_SNDTIMEO = &H1005& 'send timeout Const SO_RCVTIMEO = &H1006& 'receive timeout ' Winsock API declares Private Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long Private Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long Private Sub Command1_Click() ' Read all the options and present in a message box. Dim socket As Long socket = Winsock1.SocketHandle If socket = 0 Then MsgBox "No Socket" Else MsgBox "Socket Options:" & vbCrLf & _ " SO_DEBUG: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_DEBUG)) & vbCrLf & _ " SO_ACCEPTCONN: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_ACCEPTCONN)) & vbCrLf & _ " SO_REUSEADDR: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_REUSEADDR)) & vbCrLf & _ " SO_KEEPALIVE: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_KEEPALIVE)) & vbCrLf & _ " SO_DONTROUTE: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_DONTROUTE)) & vbCrLf & _ " SO_BROADCAST: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_BROADCAST)) & vbCrLf & _ " SO_USELOOPBACK: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_USELOOPBACK)) & vbCrLf & _ " SO_LINGER: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_LINGER)) & vbCrLf & _ " SO_OOBINLINE: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_OOBINLINE)) & vbCrLf & _ " SO_DONTLINGER: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_DONTLINGER)) & vbCrLf & _ " SO_EXCLUSIVEADDRUSE: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_EXCLUSIVEADDRUSE)) & vbCrLf & _ " SO_SNDBUF: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_SNDBUF)) & vbCrLf & _ " SO_RCVBUF: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_RCVBUF)) & vbCrLf & _ " SO_ERROR: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_ERROR)) & vbCrLf & _ " SO_TYPE: " & CStr(GetSocketOption(socket, SOL_SOCKET, SO_TYPE)) & vbCrLf & vbCrLf & _ "TCP Options:" & vbCrLf & _ " TCP_NODELAY: " & CStr(GetSocketOption(socket, IPPROTO_TCP, TCP_NODELAY)) End If End Sub Private Sub Command2_Click() Dim lResult As Long ' Results of 1st option. Dim tout As TIMEOUT_STRUCT If (Winsock1.Protocol = sckTCPProtocol) Then tout.tv_sec = 10 tout.tv_usec = 0 lResult = setsockopt(Winsock1.SocketHandle, SOL_SOCKET, SO_SNDTIMEO, tout, LenB(tout)) If (lResult = SOCKET_ERROR) Then MsgBox "Error setting SO_SNDTIMEO option: " & Translate_DLL_Error(Err.LastDllError) Else MsgBox "SO_SNDTIMEO option set." End If End If End Sub Public Function GetSocketOption(lSocket As Long, lLevel As Long, lOption As Long) As Long Dim lResult As Long ' Result of API call. Dim lBuffer As Long ' Buffer to get value into. Dim lBufferLen As Long ' len of buffer. Dim linger As LINGER_STRUCT ' Linger requires a structure so we will get that option differently. If (lOption <> SO_LINGER) And (lOption <> SO_DONTLINGER) Then lBufferLen = LenB(lBuffer) lResult = getsockopt(lSocket, lLevel, lOption, lBuffer, lBufferLen) Else lBufferLen = LenB(linger) lResult = getsockopt(lSocket, lLevel, lOption, linger, lBufferLen) lBuffer = linger.l_onoff End If If (lResult = SOCKET_ERROR) Then GetSocketOption = Err.LastDllError Else GetSocketOption = lBuffer End If End Function Private Sub Form_Load() Winsock1.Bind 8377 ' Set up socket enough to get nonzero socket. handle End Sub You can find the original article at https://support.microsoft.com/en-us/kb/237688
Print array in text body of CDO email
I have successfully loaded an array myArray(30,1) with data and would like to print the data in the text body of the CDO email.This is the section of code that works fine (it has been is service for months) before I attempt to print the array in the text body. You can see I was simply passing the variables Fullname and Amt: Set iMsg = CreateObject("CDO.Message") With iMsg Set .Configuration = iConf .To = "MC123#gmail.com" .From = """ME Report Error"" <MC124#gmail.com>" .Subject = "Current Period Monthly Report variance" .TextBody = "Hello," & vbNewLine & vbNewLine & _ "Please review the variances to NAV in the following report:" & vbNewLine & vbNewLine & _ "Report Location: " & FullName & vbNewLine & vbNewLine & _ "Variance amount: " & Amt & vbNewLine .Send End With Set iMsg = Nothing Now when I attempt loop through my array in the text body I get an error: Set iMsg = CreateObject("CDO.Message") With iMsg Set .Configuration = iConf .To = "MC123#gmail.com" .From = """ME Report Error"" <MC124#gmail.com>" .Subject = "Current Period Monthly Report variance" .TextBody = "Hello," & vbNewLine & vbNewLine & _ ERROR ------------ > & For x = LBound(myArray, 1) To UBound(myArray, 1) For y = LBound(myArray, 2) To UBound(myArray, 2) ThisWorkbook.Sheets("Sheet1").Cells(x + 1, y + 1) = myArray(x, y) Next y Next x .Send End With Set iMsg = Nothing I know the syntax inside of the loops is incorrect. I used that to drop the array into a spreadsheet (which worked fine). But I was hoping a slight modification would allow me to put it into the email text body, however it is simply not liking me placing code there it seems. The error I am receiving is "Compile Error: Expected: Expression" The error falls on the & on the first line below the .TextBody line. I am not conviced this goal is even possible. I may have to print the array in a spreadsheet and email it as an attachment, but would much prefer to have it print in the text body. Much appreciated!
Place outside of compiling body of email: For x = LBound(myArray, 1) To UBound(myArray, 1) For y = LBound(myArray, 2) To UBound(myArray, 2) ThisWorkbook.Sheets("Sheet1").Cells(x + 1, y + 1) = myArray(x, y) Next y Next x Copy Range to Clipboard: ThisWorkbook.Sheets("Sheet1").Range(ThisWorkbook.Sheets("Sheet1").Cells(1+LBound(myArray, 1),1+LBound(myArray, 2)),ThisWorkbook.Sheets("Sheet1").Cells(1+UBound(myArray, 1),1+UBound(myArray, 2))).Copy Then you can get your data off the clipboard: "Hello," & vbNewLine & vbNewLine & ClipBoard_GetData() But first you need to place the function declaration at the top of your code outside of any function or sub: Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function GetClipboardData Lib "User32" (ByVal wFormat As _ Long) As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _ dwBytes As Long) As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 Function ClipBoard_GetData() As String 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
To insert double quote (") in a string with vba you need to use 4 double quote: MyName = "Fred " & """" & "Flinstone" & """" The string value will be [Fred "Flinstone"]
You have two ampersands in a row. ... & _ & ... An underscore is removed by the physical line parser, so the logical line parser sees ... & & ... & concatinates strings _ continues a logical line on the next physical line
Email Terminal Shortcut
I need to change this VBA code for class. I'm looking at this tutorial http://spreadsheetpage.com/index.php/tip/sending_personalized_email_from_excel/ and instead of Outlook, I want to use Apple Mail stmp["mailto:"] functions directly from excel. I have the subject and message portion down, but all I want to know if I can run this script directly from terminal if we save this properly? And also can you annotate where I need to make specific changes pertaining to my email. 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 SendEMail() Dim Email As String, Subj As String Dim Msg As String, URL As String Dim r As Integer, x As Double For r = 2 To 4 'data in rows 2-4 ' Get the email address Email = Cells(r, 2) ' Message subject Subj = "Your Annual Bonus" ' Compose the message Msg = "" Msg = Msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf Msg = Msg & "I am pleased to inform you that your annual bonus is " Msg = Msg & Cells(r, 3).Text & "." & vbCrLf & vbCrLf Msg = Msg & "William Rose" & vbCrLf Msg = Msg & "President" ' Replace spaces with %20 (hex) Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20") Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20") ' Replace carriage returns with %0D%0A (hex) Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A") ' Create the URL URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg ' Execute the URL (start the email client) ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus ' Wait two seconds before sending keystrokes Application.Wait (Now + TimeValue("0:00:02")) Application.SendKeys "%s" Next r End Sub
In Windows, you can save a VBA application as a .vbs file and run it from the command prompt or from Windows Explorer. There might be errors, if you have Excel specific functions, or if the VB versions aren't the same, but in general it will run.