Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Макрос из Excel для ответа на письмо в Outlook, Ответ на письмо в Outlook из макроса в Excel с сохранением данных письма, на которое происходит ответ
 
Спасибо, ваш код работает отлично)
Изменено: elena_VVV - 15.01.2020 19:33:25
Макрос из Excel для ответа на письмо в Outlook, Ответ на письмо в Outlook из макроса в Excel с сохранением данных письма, на которое происходит ответ
 
если законспектировать строку ".Body = "blah blah hello world"  '" то эти все данные формируются автоматически, пример на скрине ( во вложении). Если я добавляю ответ с помощью .body, то эти все данные исчезают, как их сохранить и добавить текст ответа?
Изменено: elena_VVV - 12.01.2020 23:50:23
Макрос из Excel для ответа на письмо в Outlook, Ответ на письмо в Outlook из макроса в Excel с сохранением данных письма, на которое происходит ответ
 
Друзья всем привет, помогите пожалуйста с такой проблемой: есть макрос, который ищет письмо по указанной теме во всех входящих папках Outlook, затем отвечает на найденное письмо с определенным текстом, в который будет состоять в том числе из переменной равной теме письма. Когда я вставляю тело письма "".Body = "blah blah hello world" весь текст предыдущего стирается, остается только   "blah blah hello world. Как оставить весь текст предыдущего письма и поля  From..., СС.. и т. д предыдущего письма, которые автоматически формируется если отвечаешь на какое-либо письмо?
Всем спасибо за помощь)
Код
Public Sub Example(ByVal Tema As String)
    
    Dim OutApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder

    Set OutApp = New Outlook.Application 'активируем почту
    Set Namespace = OutApp.GetNamespace("MAPI") 'доступ ко всем данным Outlook, хранящимся в почтовых хранилищах пользователя.
'    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Inbox = Namespace.GetDefaultFolder(olFolderInbox) 'возвращается папка в коллекции папок

'   запускаем функцию - ищет письма с определенной темой во всех входящих с подпапками
    LoopFolders Inbox, Tema

    Set Inbox = Nothing
    
    MsgBox "Поиск писем закончен"
    
End Sub

Private Function LoopFolders(ByVal ParentFldr As Outlook.MAPIFolder, ByVal Tema As String)

    'тема письма, которую ищем
    Dim Subject As String
        Subject = Tema

'    Фильтр поиска по теме
    Dim Filter As String
    Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " >= '01/01/1900' And " & _
                       Chr(34) & "urn:schemas:httpmail:datereceived" & _
                       Chr(34) & " < '12/31/2100' And " & _
                       Chr(34) & "urn:schemas:httpmail:subject" & _
                       Chr(34) & "Like '%" & Subject & "%'"

    Dim Items As Outlook.Items
    Set Items = ParentFldr.Items.Restrict(Filter) 'возвращая новую коллекцию, содержащую все элементы из исходного объекта, которые совпадают с фильтром
        Items.Sort "[ReceivedTime]", False 'Сортирует коллекцию элементов по указанному свойству, по возрастанию
     
'    Если письмо с указанной темой было найдено
    If Items.Count <> 0 Then
        Found = True
        ' Для найденного письма формируем ответное письмо
        For Each itm In Items
          Set ReplyAll = itm.ReplyAll 'ответить всем в письме
            With ReplyAll
                .SentOnBehalfOfName = "#*@*.ru" ' Поле "От" если необходимо отправить письмо от рассылки
                .To = "#*@*.ru" 'Поле "Кому"
                .CC = "#*@*.ru" 'Поле "Копия"
                .Body = "blah blah hello world"  'вставить заготовку тескта-ответа
                .Display 'показать письмо
            End With
        Next
    End If
    
'    myOlApp.Quit
'    Set myOlApp = Nothing
    

    Dim SubFldr As Outlook.MAPIFolder
'   //Рекурсировать через SubFldrs
    If ParentFldr.Folders.Count > 0 Then
        For Each SubFldr In ParentFldr.Folders
            LoopFolders SubFldr, Tema
            Debug.Print SubFldr.Name
        Next
    End If
   
End Function
Изменено: elena_VVV - 12.01.2020 21:27:14
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Спасибо Владимир за помощь, у проблема решилась с вот этим кодом:

Вставляю в модуль:
'Используем вызовы API Windows для переноса данных в буфер обмена
Код
#If VBA7 Then
   Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
 Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
 Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
 Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
 Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
 Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
 Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As LongPtr
 Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
 Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
 Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
 Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
 #Else
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If

Public Sub SetClipboard(sUniText As String)
#If Win64 Then
    Dim iStrPtr As LongPtr
    Dim iLen As LongPtr
    Dim iLock As LongPtr
#Else
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
#End If
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Вызываю функцию:

'Вызываем функцию которая копирует данные
SetClipboard Text
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Всем спасибо за помощь, буду пробовать описанные методы, надеюсь, что-нибудь поможет
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Как я поняла ошибка плавающая, у некоторых пользователей она возникает периодически, у некоторых ее нет совсем. Можно ли изменить способ переноса текста в буфер на другой более стабильный без таких побочных ошибок как квадраты

Формируемые комментарии в texbox содержат различные символы - []#;,. цифры, текст на английском и русском, даты может это тоже как-то влияет
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Небольшой пример, т.к. у меня Windows 7, данная проблема у меня не воспроизводится(
VBA. При вставке данных из буфера обмена вставляются 2 квадрата
 
Доброго всем дня.
Возникла проблема, которая возникает только  у пользователей с Windows 10, в Windows 7 все работает. Есть userfom c кнопками, на которые зашиты коды, которые копируют данные из texbox в буфер обмена и затем данные вставляются в другую программу. Ниже коды которые пробовали, но с ними все равно у кого-то появляются сразу квадраты при вставке, у кого-то периодически. Помогите понять в чем проблема и как можно ее решить.

Первый вариант кода:
Код
 'Создание и VBA-наименование объекта "DataObject".
    Dim myDataObject As New MSForms.DataObject

    'Очистка DataObject.
    myDataObject.Clear

    'Копирование текста в DataObject.
    myDataObject.SetText Text:=TextBox9.Text

    myDataObject.PutInClipboard

Второй вариант кода:
Код
Dim txt$ 'переменная будет хранить комментарий
txt = TextBox18.Text

'Вызываем процедуру которая копирует данные
Call copytext(ByVal txt$)

'Функция копирования
Private Sub SetClipboardText(ByVal txt$)
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText txt$
    .PutInClipboard
    End With
End Sub

'Процедура копирования по принципу ctr+C
Private Sub copytext(ByVal txt$)
    SetClipboardText (txt)
End Sub
В макросе: пропускать диалоговые сообщения "Файл уже используется"
 
Попробовала включить функцию, но почему-то после 1 прохода цикла, статус открываемого файла запоминается и больше не меняется при переходе к другим файлам, то есть если в первом проходе цикла rFiles был со статусом true, то  при следующих проходах всем документам тоже IsOpen(rFiles) = true, помогите пож-та как сделать, чтобы функция работала правильно:
Код
Function IsOpen(File$) As Boolean Dim FN%
 FN = FreeFile
 On Error Resume Next
 Open File For Random Access Read Write Lock Read Write As #FN
Close #FN
 IsOpen = Err
End Function
 
Sub Test()
 Debug.Print IsOpen("....xlsx")
End Sub
 
Sub Get_All_File_from1()
 
 
'убрать окно с  ПредупреждениеОКонфиденциальнойИнформации
ActiveWorkbook.RemovePersonalInformation = 0
If ActiveWorkbook.RemovePersonalInformation Then
    ActiveWorkbook.RemovePersonalInformation = False
End If
 'Отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
 
    
    Dim sFolder As String, sFiles As String, m As Range, s As Integer, i As Integer, wbReturn As Workbook, rFiles As String
'    Адрес папки, где все файлы сотрудников
    sFolder = "..."
    
    sFiles = Dir(sFolder & "*.xlsx")
    
    rFiles = sFolder & sFiles
    
    
    Do While sFiles <> ""
    
    If IsOpen(rFiles) = False Then
    
            'открываем книги сотрудников
            Workbooks.Open sFolder & sFiles
            n = ActiveWorkbook.Name
            'действия с файлом
            ActiveWorkbook.Sheets(1).Select
            
        If Not IsEmpty(Range("A2")) Then
                FinalRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
                FinalColumn = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
                Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Copy
        
            'Активация книги "..."
            Workbooks("....xlsm").Worksheets("...").Activate
            'Определение следующей пустой строки в файле "..."
            NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
            Rows(NextRow).Select
                    ActiveSheet.Paste
                    
            ' Активация листа"
            Worksheets("...").Activate
            'Определение следующей пустой строки в файле "..."
            NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
            Rows(NextRow).Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    
            'Переход к активной книге сотрудников и удаление добавленных строк
            Workbooks(n).Activate
            ActiveWorkbook.Sheets(1).Select
            Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Select
            Selection.Delete
            'Закрытие файлов сотрудников и сохранение
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        
    Else: ActiveWorkbook.Close
 
    End If
    
End If
 
        sFiles = Dir
    Loop
    
'   Удаление записей по меткам
 
Workbooks("....xlsm").Worksheets("...").Activate
 
i = 1
 
    Do While Cells(i, 1) <> Empty
        If (Cells(i, 9).Value) Like "*новое...*" Or (Cells(i, 9).Value) Like "*последний...*" Then
'            MsgBox Cells(i, 1).Value
            If (Cells(i, 9).Value) Like "*новое...*" Then a1 = Cells(i, 1).Value
            If (Cells(i, 9).Value) Like "*последний...*" Then a2 = Cells(i, 1).Value
        End If
 
            b = 1
            Do While Cells(b, 1) <> Empty
 
                If (Cells(b, 1).Value) = a1 And Not (Cells(b, 9).Value) Like "*новое...*" And Not (Cells(b, 9).Value) Like "*последний...*" Then
                    Rows(b).Delete
                    b = b - 1
                End If
                
                If (Cells(b, 1).Value) = a2 Then
                    Rows(b).Delete
                    b = b - 1
                End If
 
            b = b + 1
            Loop
 
    i = i + 1
    Loop
'
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
 
    Workbooks("....xlsm").Close True 'Если поставить False - книга будет закрыта без сохранения
    
End Sub
Изменено: elena_VVV - 01.11.2018 21:25:20
В макросе: пропускать диалоговые сообщения "Файл уже используется"
 
Добрый день.

Помогите пожалуйста, есть следующая проблема. В коде есть цикл, который открывает все файлы экселевские в папке на редактирование, также с этими файлами иногда могут работать еще одни пользователи, в моменты когда они заняли файл на редактирование, чтобы цикл не останавливался, а шел дальше, то есть системно прописать на системное сообщение Excel "Файл уже используется...", чтобы выбиралось "отмена", либо чтобы данное окно игнорировалось и цикл шел дальше. Только начинаю изучать и писать на VBA, опыта очень мало, помогите пожалуйста
Страницы: 1
Наверх