Почтовая рассылка, но с архивацией / Microsoft Office

ReSQL.ru

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Новые сообщения | Избранное

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Почтовая рассылка, но с архивацией

4 сообщений из 4, страница 1 из 1

Почтовая рассылка, но с архивацией

#34778992

kyber

Гость

Привет всем. Собс-но, задача рядовая и часто обсуждаемая - рассылка по почте из Экселя. Написал процедуру, которая создает в аутлуке сообщение (предпочитаю потом его самому осознанно отправить), но вкладывает в него архивированный файл. На практике архив во вложении оказывается пустой:( Я так понимаю, это из-за многозадачности - rar.exe не успевает завершиться до создания сообщения:

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.

Const SW_SHOW =  1 

Public 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 Sub SendFile(AFileName As String, AEMail As String, myOlApp As Variant)
    Dim ArcName As String
    Dim myItem As Variant
    
    ArcName = Left(AFileName, Len(AFileName) -  3 ) & "rar"
    ShellExecute Application.hwnd, "open", "C:\Program files\WinRAR\rar.exe", "a -m5 -ep """ & ArcName & """ """ & AFileName & """", "", SW_SHOW
    
    Set myItem = myOlApp.CreateItem(olMailItem)
    With myItem
       .BodyFormat = olFormatHTML
       .HTMLBody = "<html><body><p>Здравствуйте.<p>Бла-бла-бла</body></html>"
       .Subject = Left(Dir(AFileName), Len(Dir(AFileName)) -  4 )
       .Attachments.Add ArcName
       .Recipients.Add AEMail
       .Display
    End With
End Sub

Короче, нужно либо дождаться завершения процесса (я так понимаю, использовать CreateProcess, а не ShellExecute???), либо придумать что-то другое... Всем участвующим огромное спасибо!

...

Рейтинг:

0 / 0

05.09.2007, 18:24:19

| Ответить | Цитировать | Написать

Почтовая рассылка, но с архивацией

#34779269

vbapro

Участник

Сообщения: 1 112

Рейтинг: 0 / 0

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.

Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAddress As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
    
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long


Private Sub WaitActive(TaskID)
Dim hProc As Long
Dim lExitCode As Long
Dim Msg As String
Const ACCESS_TYPE = &H400
Const STILL_ACTIVE = &H103

On Error GoTo ERR
    
    hProc = OpenProcess(ACCESS_TYPE, False, TaskID)
    Application.Cursor = xlWait
    Do
        GetExitCodeProcess hProc, lExitCode
        DoEvents
    Loop While lExitCode = STILL_ACTIVE
    Application.Cursor = xlDefault
EXIT_SUB:

Exit Sub

ERR:
    
If ERR.Number <>  0  Then
    Msg = "Error # " & Str(ERR.Number) & " was generated by " _
            & ERR.Source & Chr( 13 ) & ERR.Description
    MsgBox Msg, , "Error", ERR.HelpFile, ERR.HelpContext
End If
GoTo EXIT_SUB
End Sub



Const SW_SHOW =  1 

Public 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 Sub SendFile(AFileName As String, AEMail As String, myOlApp As Variant)
    Dim ans
    Dim ArcName As String
    Dim myItem As Variant
    
    ArcName = Left(AFileName, Len(AFileName) -  3 ) & "rar"
    ans = ShellExecute(Application.hwnd, "open", "C:\Program files\WinRAR\rar.exe", "a -m5 -ep """ & ArcName & """ """ & AFileName & """", "", SW_SHOW)
    
    WaitActive ans

    Set myItem = myOlApp.CreateItem(olMailItem)
    With myItem
       .BodyFormat = olFormatHTML
       .HTMLBody = "<html><body><p>Здравствуйте.<p>Бла-бла-бла</body></html>"
       .Subject = Left(Dir(AFileName), Len(Dir(AFileName)) -  4 )
       .Attachments.Add ArcName
       .Recipients.Add AEMail
       .Display
    End With
End Sub

...

Рейтинг:

0 / 0

05.09.2007, 19:44:42

| Ответить | Цитировать | Написать

Почтовая рассылка, но с архивацией

#34779274

vbapro

Участник

Сообщения: 1 112

Рейтинг: 0 / 0

Предыдущее сообщение поспешило опубликоваться :), хотя в основе пойдет. Вот поточнее:

Код: plaintext

Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAddress As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
    
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long

Public 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

Const SW_SHOW =  1 

Private Sub WaitActive(TaskID)
Dim hProc As Long
Dim lExitCode As Long
Dim Msg As String
Const ACCESS_TYPE = &H400
Const STILL_ACTIVE = &H103

On Error GoTo ERR
    
    hProc = OpenProcess(ACCESS_TYPE, False, TaskID)
    Application.Cursor = xlWait
    Do
        GetExitCodeProcess hProc, lExitCode
        DoEvents
    Loop While lExitCode = STILL_ACTIVE
    Application.Cursor = xlDefault
EXIT_SUB:

Exit Sub

ERR:
    
If ERR.Number <>  0  Then
    Msg = "Error # " & Str(ERR.Number) & " was generated by " _
            & ERR.Source & Chr( 13 ) & ERR.Description
    MsgBox Msg, , "Error", ERR.HelpFile, ERR.HelpContext
End If
GoTo EXIT_SUB
End Sub


Private Sub SendFile(AFileName As String, AEMail As String, myOlApp As Variant)
    Dim ans
    Dim ArcName As String
    Dim myItem As Variant
    
    ArcName = Left(AFileName, Len(AFileName) -  3 ) & "rar"
    ans = ShellExecute(Application.hwnd, "open", "C:\Program files\WinRAR\rar.exe", "a -m5 -ep """ & ArcName & """ """ & AFileName & """", "", SW_SHOW)
    
    WaitActive ans

    Set myItem = myOlApp.CreateItem(olMailItem)
    With myItem
       .BodyFormat = olFormatHTML
       .HTMLBody = "<html><body><p>Здравствуйте.<p>Бла-бла-бла</body></html>"
       .Subject = Left(Dir(AFileName), Len(Dir(AFileName)) -  4 )
       .Attachments.Add ArcName
       .Recipients.Add AEMail
       .Display
    End With
End Sub

...

Рейтинг:

0 / 0

05.09.2007, 19:48:13

| Ответить | Цитировать | Написать

Почтовая рассылка, но с архивацией

#34792609

kyber

Гость

Огромное спасибо!!! Все работает, как надо!

...

Рейтинг:

0 / 0

11.09.2007, 19:14:42

| Ответить | Цитировать | Написать

4 сообщений из 4, страница 1 из 1

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Почтовая рассылка, но с архивацией

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?fid=61&msg=34779269&tid=2182305]:	0ms
get settings:	7ms
get forum list:	10ms
check forum access:	2ms
check topic access:	2ms
track hit:	60ms
get topic data:	7ms
get forum data:	2ms
get page messages:	43ms
get tp. blocked users:	1ms
others:	219ms

total:	353ms

	Необходимые cookie
	Cookie для сбора статистики
	Cookie для маркетинга и рекламы