Marcus, Scott (GEAE, RHI Consulting)
scott.marcus at ae.ge.com
Wed Apr 2 11:51:33 CST 2003
Try this, it waits for a shelled process to finish before moving on... (watch
for line wrap)
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName
As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long,
ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal
dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory
As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As
PROCESS_INFORMATION) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As
Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Sub ShellAndWait(sCmdLine As String)
Dim lR As Long 'Return
Dim uProc As PROCESS_INFORMATION
Dim uStart As STARTUPINFO
' Initialize the STARTUPINFO structure:
uStart.cb = Len(uStart)
' Start the shelled application:
lR = CreateProcessA(sCmdLine, vbNullString, 0&, 0&, 1&,
NORMAL_PRIORITY_CLASS, 0&, 0&, uStart, uProc)
' Wait for the shelled application to finish:
lR = WaitForSingleObject(uProc.hProcess, INFINITE)
lR = CloseHandle(uProc.hProcess)
End Sub
Hope this helps. If anything is missing, let me know. I cut and pasted this from
a project.
Scott
-----Original Message-----
From: Mike and Doris Manning [mailto:mikedorism at ntelos.net]
Sent: Wednesday, April 02, 2003 12:45 PM
To: accessd at databaseadvisors.com
Subject: RE: [AccessD] Email attachment problem
Sure... I've been trying DoEvents but that hasn't worked. I've checked the file
size after the ".Attachments.Add" line and it shows 64B when the file size is
really 23KB.
Public Function SendSafeEmail(SendTo As String, SendSubj As String, _
SendBody As String, SendEdit As Boolean, _
Optional SendCC As String, _
Optional FilePath As String, _
Optional strAttach As String)
On Error GoTo ErrorHandler
Dim oMail As Object
Dim oSpace As Object
Dim oFoldr As Object
Dim oItem As Object
Dim oSafe As Object
Dim oRecip As Object
Dim oDeliver As Object
Dim bolOpen As Boolean
Dim aryRecip() As String
Dim intRecip As Integer
Dim aryFileList() As String
Dim intFilelist As Integer
Dim strFileName As String
Dim lcv As Integer
Dim strSMTP As String
bolOpen = IsOutlookOpen
Set oMail = CreateObject("Outlook.Application")
Set oSpace = oMail.GetNamespace("MAPI")
Set oFoldr = oSpace.GetDefaultFolder(olFolderOutbox)
Set oItem = oMail.CreateItem(olMailItem)
Set oSafe = CreateObject("Redemption.SafeMailItem")
oSafe.Item = oItem
With oSafe
'Add the TO names
If SendTo <> vbNullString Then
If InStr(1, SendTo, ";", vbTextCompare) > 0 Then
If Right(SendTo, 1) <> ";" Then SendTo = SendTo & ";"
aryRecip = Split(SendTo, ";")
intRecip = UBound(aryRecip) - 1
For lcv = 0 To intRecip
.Recipients.Add aryRecip(lcv)
Next lcv
Erase aryRecip
.Recipients.ResolveAll
Else
.Recipients.Add SendTo
.Recipients.ResolveAll
End If
End If
'Add the CC names
If SendCC <> vbNullString Then
If InStr(1, SendCC, ";", vbTextCompare) > 0 Then
If Right(SendTo, 1) <> ";" Then SendTo = SendTo & ";"
aryRecip = Split(SendCC, ";")
intRecip = UBound(aryRecip) - 1
For lcv = 0 To intRecip
.Recipients.Add aryRecip(lcv)
Next lcv
.Recipients.ResolveAll
Else
.Recipients.Add SendCC
.Recipients.ResolveAll
End If
End If
'Add the rest of the information
.Subject = SendSubj
.Body = SendBody
'Add Attachments
If strAttach <> vbNullString Then
If InStr(1, strAttach, ";", vbTextCompare) > 0 Then
If Right(strAttach, 1) <> ";" Then
strAttach = strAttach & ";"
End If
aryFileList = Split(strAttach, ";")
intFilelist = UBound(aryFileList) - 1
For lcv = 0 To intFilelist
strFileName = FilePath & aryFileList(lcv)
.Attachments.Add strFileName
DoEvents
Next lcv
End If
End If
DoEvents
If SendEdit = True Then
DoEvents
.Save
DoEvents
.Display
Exit Function
Else
.Send
End If
End With
Set oDeliver = CreateObject("Redemption.MAPIUtils")
oDeliver.DeliverNow
oDeliver.Cleanup
If bolOpen = False Then
oMail.Quit
End If
Set oDeliver = Nothing
Set oSafe = Nothing
Set oItem = Nothing
Set oFoldr = Nothing
Set oSpace = Nothing
Set oMail = Nothing
Exit Function
ErrorHandler:
Call HandleErrors(Err, strMyName, "SendSafeEmail")
End Function
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of John Ruff
Sent: Wednesday, April 02, 2003 12:35 PM
To: accessd at databaseadvisors.com
Subject: RE: [AccessD] Email attachment problem
Can we see your email code?
John V. Ruff - The Eternal Optimist :-)
Always Looking For Contract Opportunities
"Commit to the Lord whatever you do,
and your plans will succeed." Proverbs 16:3
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Mike and Doris
Manning
Sent: Wednesday, April 02, 2003 9:25 AM
To: accessd at databaseadvisors.com
Subject: [AccessD] Email attachment problem
We have been working on building our own internal PDF Document Solution using
PDF995. We can get the PDF files to create perfectly exactly where we want them
to. The problem we now have is with our email code we built using Redemption.
The PDF original is 23KB but only 64B of that is making it to the email as an
attachment.
Does anybody have any thoughts on how we could slow the code down so that the
entire attachment would be added? I'm trying to avoid using a message box, if
at all possible.
Doris Manning
Database Administrator
Hargrove Inc.
www.hargroveinc.com
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://databaseadvisors.com/pipermail/accessd/attachments/20030402/139f1cc7/attachment-0001.html>