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.