если законспектировать строку ".Body = "blah blah hello world" '" то эти все данные формируются автоматически, пример на скрине ( во вложении). Если я добавляю ответ с помощью .body, то эти все данные исчезают, как их сохранить и добавить текст ответа?
Друзья всем привет, помогите пожалуйста с такой проблемой: есть макрос, который ищет письмо по указанной теме во всех входящих папках 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
Спасибо Владимир за помощь, у проблема решилась с вот этим кодом:
Вставляю в модуль: 'Используем вызовы 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
Как я поняла ошибка плавающая, у некоторых пользователей она возникает периодически, у некоторых ее нет совсем. Можно ли изменить способ переноса текста в буфер на другой более стабильный без таких побочных ошибок как квадраты
Формируемые комментарии в texbox содержат различные символы - []#;,. цифры, текст на английском и русском, даты может это тоже как-то влияет
Доброго всем дня. Возникла проблема, которая возникает только у пользователей с 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
Помогите пожалуйста, есть следующая проблема. В коде есть цикл, который открывает все файлы экселевские в папке на редактирование, также с этими файлами иногда могут работать еще одни пользователи, в моменты когда они заняли файл на редактирование, чтобы цикл не останавливался, а шел дальше, то есть системно прописать на системное сообщение Excel "Файл уже используется...", чтобы выбиралось "отмена", либо чтобы данное окно игнорировалось и цикл шел дальше. Только начинаю изучать и писать на VBA, опыта очень мало, помогите пожалуйста