Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
29.03.2024, 14:01:05

Войти
Хотите поблагодарить участника за дельный совет? Нажмите [Повысить]. Так вы заслуженно поднимите репутацию активному участнику.
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Скриншот в Excel
Страниц: [1]   Вниз
Печать
Автор Тема: Скриншот в Excel  (Прочитано 2121 раз)
0 Пользователей и 1 Гость смотрят эту тему.
TumJan
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 2


Просмотр профиля E-mail
« : 01.03.2023, 20:23:37 »

Добрый вечер!

Прошу помочь. Код работает, но скриншот пустой белый фон. Подскажите что нужно в коде сделать:

Код: (vb)
Private Sub CommandButton2_Click()
 Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Ошибка! Не корректный диапазон.", vbCritical
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Paste
            .Export Filename:="C:\Distr\Горный\1.jpg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 02.03.2023, 07:53:16 »

TumJan, так на сайте приведено решение, которое работает: Сохранение выделенной картинки в файл
после .ChartArea.Border.LineStyle = 0
необходимо просто добавить: .Parent.Select
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
TumJan
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 2


Просмотр профиля E-mail
« Ответ #2 : 02.03.2023, 16:37:36 »

Подскажите, в этом коде файл прикрепляется как вложение, как можно сделать чтобы в теле письма появлялся, а не как вложение.

[code=vbPrivate Sub CommandButton1_Click()
If InputBox("Ââåäèòå ïàðîëü") 2023 Then MsgBox "Ïîäóìàé õîðîøî, Ãîðíûé äèñïåò÷åð!": Exit Sub
Dim sName As String, wsTmpSh As Worksheet, S, sss
Dim rr As Range

Application.ScreenUpdating = False
Set rr = Range("B5:AN81")
rr.CopyPicture xlPrinter
Set wsTmpSh = ThisWorkbook.Sheets.Add
wsTmpSh.PasteSpecial
Selection.Copy
sName = ThisWorkbook.Path & "" & "_" & Date - 1 & "_" & Hour(Time) & "_" & Minute(Time) & "_" & Second(Time) '"
With wsTmpSh.ChartObjects.Add(0, 0, rr.Width, rr.Height).Chart
.ChartArea.Border.LineStyle = 0
.Parent.Select
.Paste
.Export Filename:="C:\Distr\Ãîðíûé\1.jpg", FilterName:="JPG"
.Parent.Delete
End With
Application.DisplayAlerts = False
wsTmpSh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon "2", , True, True
Set OutMail = OutApp.CreateItem(olMailItem)
OutMail.Save
OutMail.To = ""
OutMail.Subject = "Ïðîèçâîäèòåëüíîñòü áóðîâûõ ñòàíêîâ"
OutMail.Body = "Çäðàâñòâóéòå! Íàïðàâëÿåì Ñâîäíóþ âåäîìîñòü ïðîèçâîäèòåëüíîñòè áóðîâûõ ñòàíêîâ çà ñóòêè."
OutMail.Attachments.Add "C:\Distr\Ãîðíûé\1.jpg"
OutMail.Send
End Sub][/code]
Записан
Vladimir S
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля
« Ответ #3 : 04.03.2023, 21:18:11 »

Копируйте свой код при русской клавиатуре, а затем выделите и нажмите VB code в окне ответить. В данный момент можно исправить.
Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru