Сообщения

Проблема периодически возникает и всё время приходится её решать.
Поставил Windows 11. Здесь простой правкой реестра уже не обойтись. Windows 11 перестаёт открывать файлы через книгу или ярлык книги. Только через запуск приложения.

Долго мучал ИИ, прежде чем получил готовое решение. Приведу его здесь. Решение для Excel 2003

Создаём .reg файл для правки реестра:

Код Выделить Развернуть

Windows Registry Editor Version 5.00

[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate]
@="Microsoft Excel Worksheet (Separate Instance)"

[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell]

[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell\open]

[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell\open\command]
@="\"C:\\Program Files (x86)\\Microsoft Office\\OFFICE11\\EXCEL.EXE\" /x \"%1\""
Кликаем на файл. В реестр добавятся новые ветки-клоны стандартной Excel.Sheet.8 (Excel 2003)
Запускаем cmd в режиме Администратора.
Выполняем
assoc .xls=Excel.Sheet.8.Separate
Тем самым меняем действия приложения Excel, ассоциированные с файлами .xls
Если нужно восстановить способ открытия Excel обратно, в cmd запускаем
assoc .xls=Excel.Sheet.8

У меня сработало.

Периодически возвращаюсь к этому решению.
Чтобы не создавать ярлык, можно внести правку в реестре.
Для Excel 2003
в реестре
HKEY_CLASSES_ROOT\Excel.Sheet.8\shell\Open\command

безымянный параметр, который имеет путь к файлу EXCEL.exe записать следующим образом
"C:\Program Files\Microsoft Office\Office11\EXCEL.EXE" /e "%1"

Дмитрий, здравствуйте.
Кажется с новым оформлением сайта есть баги. Я не нашел личного кабинета и возможность оставить обратную связь, поэтому решил создать новую тему. Удалите её.

1. Я хотел подредактировать своё сообщение, которое находится ниже данного поста. Нет кнопки редактировать, хотя к моему сообщению нет ни одного ответа. Новый сайт не видит меня как автора предыдущего сообщения? (Данное сообщение редактировать получается) Скрин с отсутствие кнопки прилагаю.


2. Я решил проверить под каким логином меня видит система или найти хоть какой-то личный кабинет. Это сделать невозможно. Интерфейс не отображает данной информации и гиперссылок на личный кабинет. Скрин прилагаю.


3. Скрины, прикреплённые к сообщение невозможно увеличить. Текст на скринах нечитаем.
4. Из-за отсутствия личного кабинета непонятно как связаться с администратором сервиса.

Добрый день.
Есть ресурс kdb-gw.prod.kitco.com к которому я хочу сделать POST запрос  для получения биржевой цены на родий.
Код для скачивания такой

Код (vb) Выделить Развернуть


Public Function get_Rh_fromKITCO() As String
'Подгрузка с kitco.com данных о ценах на Rh

Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest
Dim body As String '
Dim URL As String 'Адрес сервера, к которому осуществляется запрос
Dim textResponse As String 'Ответ сервера в текстовом виде
Dim RegExp As Object 'Объект для работы с регулярными выражениями при парсинге страницы
Dim resultRegExp As Object 'Результат работы регулярного выражения
Dim bid As Double, ask As Double


URL = "https://kdb-gw.prod.kitco.com"
Set http = CreateObject("MSXML2.XMLHTTP")

body = "{""query"":""fragment MetalFragment on Metal { ID symbol currency name results { ...MetalQuoteFragment } } " & _
     "fragment MetalQuoteFragment on Quote { ID ask bid change changePercentage close high low mid open originalTime timestamp unit } " & _
     "query MetalQuote( $symbol: String! $currency: String! $timestamp: Int ) " & _
     "{ GetMetalQuoteV3( symbol: $symbol currency: $currency timestamp: $timestamp ) " & _
     "{ ...MetalFragment } }"",""variables"":{""symbol"":""RH"",""currency"":""USD"",""timestamp"":1718003520},""operationName"":""MetalQuote""}"


http.Open "POST", URL, False 'False - синхронное соединение

On Error GoTo ext:
http.Send (body)

textResponse = http.responseText

Set RegExp = CreateObject("VBScript.RegExp") 'Создаём объект для работы с регулярными выражениями
RegExp.Global = False 'Ищем первое совпадение

RegExp.Pattern = """bid\\""\:(\d+\.?\d*)" 'Шаблон для поиска цены предложения. Парсер сайта заменяет двоеточие и открывающую скобку на грустный смайлик.
Set resultRegExp = RegExp.Execute(textResponse)
bid = resultRegExp(0).SubMatches(0)

RegExp.Pattern = """ask\\""\:(\d+\.?\d*)" 'Шаблон для поиска цены предложения. Парсер сайта заменяет двоеточие и открывающую скобку на грустный смайлик.
Set resultRegExp = RegExp.Execute(textResponse)
ask = resultRegExp(0).SubMatches(0)


get_Rh_fromKITCO = WorksheetFunction.Min(bid, ask)



Exit Function
ext:
    'Выход из функции по ошибки
    get_Rh_fromKITCO = Err.Description
End Function



Код возвращает ошибку: "Ошибка скачивания указанного ресурса".

Изучение информации о ресурсе показало, что сервис работает по протоколу TLS 1.3
Ошибка работы протоколов при запросах достаточно распространённая. Объект MSXML2.XMLHTTP настраивается в "Свойствах обозревателя" Internet Explorer включением соответствующих галок сертификатов безопасности.
К сожалению у меня операционка windows 7 и TLS 1.3 невозможно включить, так как он отсутствует в опциях.

И да, IE 11  не хочет открывать https://kdb-gw.prod.kitco.com/ из браузерной строки, хотя Chrome и даже Microsoft Edge нормально открывают этот ресурс.
Замена MSXML2.XMLHTTP на WinHttp.WinHttpRequest.5.1 ничего не даёт. Та же ошибка, сформулированная по другому: "Ошибка поддержки безопасных каналов"

1. Существуют ли способы для парсинга страниц на VBA подключать не библиотеки Internet Explorer, а хотя бы COM-объекты Microsoft Edge (если есть такие)?
Вариант с Selenium возможен, но трудоёмок при портировании книги Excel на другие машины. Нужно искать и инсталлить совместимые версии библиотек.

2. Может можно поставить какие-то патчи или сертификаты на Win7, чтобы TLS 1.3 заработал? Другие же браузеры работают нормально с этим ресурсом.

В последнее время проблем с TLS 1.3 встречается всё чаще. Например, Telegram API работает по этому протоколу и из VBA невозможно без танцев с бубном отправить в телеграм-бот сообщение.

Я для себя нашел кривое решение. На своём удалённом хосте написал php-скрипт

Код (php) Выделить Развернуть


<?php
//Серверный модуль для обхода ограничений кросс-доменных запросов


$html = "incorrect request";

header('Access-Control-Allow-Origin: *');
header('Access-Control-Allow-Credentials: true');
header('Access-Control-Allow-Headers: X-Requested-With');
header('Content-type: text/html; charset=utf-8');


//Получен запрос на чтение HTML по адресу url
$url = 'https://kdb-gw.prod.kitco.com';

$body='{"query":"fragment MetalFragment on Metal { ID symbol currency name results { ...MetalQuoteFragment } } fragment MetalQuoteFragment on Quote { ID ask bid change changePercentage close high low mid open originalTime timestamp unit } query MetalQuote( $symbol: String! $currency: String! $timestamp: Int ) { GetMetalQuoteV3( symbol: $symbol currency: $currency timestamp: $timestamp ) { ...MetalFragment } }","variables":{"symbol":"RH","currency":"USD","timestamp":'.time().'},"operationName":"MetalQuote"}';

$ch = curl_init($url);
curl_setopt($ch, CURLOPT_HTTPHEADER, array('Content-Type:application/json'));
curl_setopt($ch, CURLOPT_POST, 1);
curl_setopt($ch, CURLOPT_POSTFIELDS, $body); 
curl_setopt($ch, CURLOPT_RETURNTRANSFER, true);
curl_setopt($ch, CURLOPT_SSL_VERIFYPEER, false);
curl_setopt($ch, CURLOPT_HEADER, false);
$res = curl_exec($ch);
curl_close($ch);
 
$res = json_encode($res, JSON_UNESCAPED_UNICODE);
print_r($res);


и делаю запрос из VBA к https://glpa.catalyst.by/stat/php/vpn-kitco-rh.php , который данные возвращает в читаемом для Internet Explorer виде.

Код (vb) Выделить Развернуть


Public Function get_Rh_fromKITCO2() As String
'Подгрузка с kitco.com данных о ценах на Rh
'Возврат через глобальную коллекцию currencies
Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest

Dim URL As String 'Адрес сервера, к которому осуществляется запрос
Dim textResponse As String 'Ответ сервера в текстовом виде
Dim RegExp As Object 'Объект для работы с регулярными выражениями при парсинге страницы
Dim resultRegExp As Object 'Результат работы регулярного выражения
Dim bid As Double, ask As Double


URL = "https://glpa.catalyst.by/stat/php/vpn-kitco-rh.php"
Set http = CreateObject("MSXML2.XMLHTTP")

http.Open "GET", URL, False 'False - синхронное соединение
http.setRequestHeader "Content-Type", "application/json; charset=utf-8"

On Error GoTo ext:
http.Send

textResponse = http.responseText

Set RegExp = CreateObject("VBScript.RegExp") 'Создаём объект для работы с регулярными выражениями
RegExp.Global = False 'Ищем первое совпадение

RegExp.Pattern = """bid\\""\:(\d+\.?\d*)" 'Шаблон для поиска цены предложения. Парсер сайта заменяет двоеточие и открывающую скобку на грустный смайлик.
Set resultRegExp = RegExp.Execute(textResponse)
bid = resultRegExp(0).SubMatches(0)

RegExp.Pattern = """ask\\""\:(\d+\.?\d*)" 'Шаблон для поиска цены предложения. Парсер сайта заменяет двоеточие и открывающую скобку на грустный смайлик.
Set resultRegExp = RegExp.Execute(textResponse)
ask = resultRegExp(0).SubMatches(0)


get_Rh_fromKITCO = WorksheetFunction.Min(bid, ask)



Exit Function
ext:
    'Выход из функции по ошибке
    get_Rh_fromKITCO = err.Description
End Function


Есть ли более оптимальные решения описанной проблемы?

Здравствуйте.
Есть ли у VBA Excel какой-нибудь удобный инструмент для работы с Git ?
Пока в лоб вижу варианты: экспорт в проекта в файл каждый модуль по отдельности. В терминале коммитить и пушить на удалённый сервер. Или обратное действие: модули качаются с удалённого сервера, импортируются вручную каждый отдельно и потом только работа с ними.
Крайне неудобно.

[admin]Название темы должно быть максимально информативным, таким, чтобы уже из названия темы другим пользователям была приблизительно понятна Ваша проблема п.п. 4.2. и 4.14. Правил форума Сейчас название изменил я - в следующий раз просто удалю[/admin]

Ещё одну странность обнаружил.
Пробовал внутри одного и того же модуля передавать по ссылке переменную, проверить как можно возвращать ошибку
Вот таким кодом

Код (vb) Выделить Развернуть


Public Sub Test(ByRef err_obj As String)
Dim a

err_obj = "0"
On Error GoTo Ext
a = 6 / 0
Exit Sub
Ext:
'Аварийный выход по ошибке
   
    err_obj = err.Description

End Sub

Public Sub testStart()
Dim e As String

e = "1"
Test (e)
End Sub


Запускаю testStart
Проверяю как изменится значение переменной е внутри testStart, которая ушла по ссылке в процедуру test. Никак. Осталось точно такое же значение - 1, как и до вызова процедуры.
Почему???

Попробовал такой вариант.
Код во внешнем приложении VB6

Код (vb) Выделить Развернуть


Public Sub Test()
'Тестирование получения ошибки от приложения
Dim excel As Object
Dim wb As Object 'Книга Excel
Dim app_err As ErrObject

On Error GoTo Recalc_exit
Set excel = CreateObject("Excel.Application")
excel.Visible = True
Set wb = excel.Workbooks.Open(filename:=ExcelDBApp, ReadOnly:=True)
excel.displayAlerts = False


Call excel.run(wb.name & "!test", app_err)  'Проверка получения кода ошибки по ссылке на объект ошибки
wb.Close savechanges:=False
excel.quit
Exit Sub

Recalc_exit:
wb.Close
excel.quit

'Уведомление об ошибке в телегу
   If Len(AdminTelegramID) > 0 Then
       SendTelegramMessage "Ошибка при пересчёте и обновлении базы данных \n \n" & Err.Description, _
           AdminTelegramID
   End If

End Sub


Код вызываемой процедуры на VBA

Код (vb) Выделить Развернуть


Public Sub Test(Optional ByRef err_obj As ErrObject)
Dim a

Set err_obj = Err
On Error GoTo Ext
a = 6 / 0
Exit Sub
Ext:
'Аварийный выход по ошибке

End Sub



Возвращается объект с ошибкой 0.
Возможно ексель её сбрасывае в ноль? Попробовать с полным копированием объекта вернуть?

Здесь вариантов не много - в любом случае надо хранить информацию и имени процедуры и номере(типе) ошибки где-то "извне": либо в отдельном текстовом файле, либо в реестре.
Перед запуском из внешней процедуры очищать эти данные, чтобы не было ошибочных записей.

А если как-нибудь так?
Вызываю код в приложении VB6

Код (vb) Выделить Развернуть

Set app_err = excel.run(wb.name & "!test")

Вызываемая функция, возвращающая объект ошибки

Код (vb) Выделить Развернуть


Public Function Test() As ErrObject
Dim a
Set Test = Err 'по умолчанию код ошибки 0
On Error GoTo Ext
a = 6 / 0
Exit Function
Ext:
   Set Test = Err
End Function


Можно ли вообще получить  от ActiveX функции ответ? Потестил. VBA ошибку генерирует, ответ в функции в виде объекта ошибки отправляет, а VB6 получает пустой объект с ошибкой ноль

Или есть возможность достучаться до глобальной переменной книги Excel?

Добрый день.
У меня код на VB6 открывает книгу Excel и вызывает в ней серию макросов

Код (vb) Выделить Развернуть

Public Sub RecalculateDB()
'Пересчёт цен в базе данных
Dim excel As Object
Dim wb As Object 'Книга Excel

On Error GoTo Recalc_exit
Set excel = CreateObject("Excel.Application")
excel.Visible = True
Set wb = excel.Workbooks.Open(filename:=ExcelDBApp, ReadOnly:=True)
excel.run (wb.name & "!RecalculatePrice") 'Пересчёт локальной базы данных
excel.run (wb.name & "!CreateReserveDB") 'Создание резервной копии пересчитанных данных
excel.run (wb.name & "!UploadCalcFile") 'Переносим файл калькуляции на интернет-сервер

'Сразу после пересчета закидываем обновленнные данные по базе в интернет. True - отправить уведомление в телеграм,
'False - не отображать MsgBox об успешности операции обновления данных в интернете
excel.run wb.name & "!CreateSafetySQLScript", True, False

wb.Close
excel.quit
Exit Sub
Recalc_exit:
'Ошибка пересчёта базы данных
    If Len(AdminTelegramID) > 0 Then
        SendTelegramMessage "Ошибка при пересчёте и обновлении базы данных \n \n" & Err.Description, _
            AdminTelegramID
    End If
End Sub


Иногда на стороне макросов появляются ошибки, связанные с работой сети. Если обработать ошибку в процедуре VBA, то внешнее приложение её не замечает. Если не обрабатывать, то код зависает вместе с выводом Alerta: Debug / End и ждёт действий пользователя. При этом код висит.
Как корректно обработать ошибку в процедуре VBA и вернуть её внешнему приложению, чтобы внешнее приложение приняло сообщение об ошибке и корректно закрыло книгу?

В идеале мне от VBA хотелось бы получить возможности регулярок как на Java Script. Соглашусь, там тоже от браузера к браузеру могут быть отличия. В практическом плане то, что вшито в VBScript regexp - очень даже круто. Я вообще раньше парсил всё вручную и наличие регулярок для VBA для меня приятное открытие. Пока ещё как следует VBScript regexp я не пользовал, знакомлюсь с документацией.
За ответ спасибо.

Добрый день.
Заинтересовался библиотеками для VBA, которые поддерживают работу с регулярными выражениями.
Гугл предлагает в основном библиотеку от Microsoft Internet Explorer 5.5
Как по мне, то для 2024-го года библиотека старовата. Хотя на безрыбье и это хлеб.
Может кто-нибудь знает более свежие библиотеки, которые можно подключить к VBA-проекту? Например какие-нибудь си-шные надстройки или т.п.?

Тема старая, но в связи с изменением Нацбанком Республики Беларусь работы API обновления курсов валют я решил эту тему немного освежить. Нацбанк в 2023 году изменил адреса серверов API.
У Нацбанка есть две технологии обращения к курсу валют. Одна через GET-запрос, вторая через отправку XML методом POST.
С учетом текущих изменений оба способа реализованы в функциях ниже.

Функция для скачивания курса валюты методом отправки XML. Второй аргумент - символьная запись валюты. На листе вызвать функцию для получения курса доллара можно так =NBRBCourse("18.07.2023";"USD")

Код (vb) Выделить Развернуть


Public Function NBRBCourse(MyDate As Date, CurrType As String) As Single
'Пользовательская функция, возвращает курс выбранной валюты на указанный день
'Коды ошибок:
' -1    такой валюты за такую дату не найдено
' -2    сайт Нацбанка загрузился с ошибкой

Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest
Dim XML As Variant 'Объект DOMDocument для получения XML
Dim Curr As Object 'Переменная с данными о валюте
Dim PostBody As String 'Запрос к веб-сервису в строковом виде
Dim res 'Ответ запроса XMLHttpRequest


Set http = CreateObject("MSXML2.XMLHttp")
Set XML = CreateObject("MSXML2.DOMDocument")

'Формируем запрос по шаблону с сайта Нацбанка http://www.nbrb.by/Services/ExRates.asmx?op=ExRatesDaily2
'Примеры написания запроса есть на форуме http://www.sql.ru/forum/22867/eshhe-raz-sql-xml?mid=128536#128536
PostBody = "<?xml version='1.0' encoding='utf-8'?>" & _
"<soap:Envelope xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance' xmlns:xsd='http://www.w3.org/2001/XMLSchema' xmlns:soap='http://schemas.xmlsoap.org/soap/envelope/'>" & _
 "<soap:Body>" & _
   "<ExRatesDaily2 xmlns='https://www.nbrb.by/'>" & _
     "<onDate>" & Format(MyDate, "YYYY-MM-DD") & "</onDate>" & _
   "</ExRatesDaily2>" & _
 "</soap:Body>" & _
"</soap:Envelope>"

'Преобразуем строковый запрос в XML
XML.LoadXML (PostBody)


'Создаем POST-запрос для сайта нацбанка.
'Структура заголовков расписана тут https://www.nbrb.by/Services/ExRates.asmx?op=ExRatesDaily2
http.Open "POST", "https://services.nbrb.by/ExRates.asmx", False 'False - синхронное соединение
http.setRequestHeader "Host", "services.nbrb.by" 'Задаем значение заголовка Host
http.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
On Error Resume Next
res = http.Send(XML)

If http.Status <> 200 Then
'Ответ на запрос получен с ошибкой
   NBRBCourse = -2
End If
Set XML = http.ResponseXML.getElementsByTagName("DailyExRatesOnDate") 'Получаем список валют нацбанка

For Each Curr In XML 'Проходим по всем валютам, загруженным в документе
   If Curr.ChildNodes(4).nodetypedvalue = CurrType Then
   'Валюта найдена
       NBRBCourse = CSng(Replace(Curr.ChildNodes(2).text, ".", ","))
       Exit Function
   End If
Next
NBRBCourse = -1 'Валюта не найдена

End Function



Вариант получения курса доллара методом отправки GET-запроса:

Код (vb) Выделить Развернуть


Public Function NBRBCourse2(MyDate As Date)
'Пользовательская функция, возвращает курс выбранной валюты на указанный день
'Коды ошибок:
' -1    такой валюты за такую дату не найдено
' -2    сайт Нацбанка загрузился с ошибкой

Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest
Dim text As Variant 'Получаемый текст со страницы
Dim pos As Long, lngth As Long 'Позиция в тексте при парсинге
Dim URL As String
Dim res

URL = "https://api.nbrb.by/exrates/rates/431?ondate=" & Format(MyDate, "YYYY-MM-DD") '431 - код доллара на сайте Нацбанка
   
On Error Resume Next
Set http = CreateObject("MSXML2.XMLHttp")
If err <> 0 Then
   Set http = CreateObject("MSXML.XMLHTTPRequest")
End If
http.Open "GET", URL, False 'False - синхронное соединение
http.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
http.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" 'Сбрасываю кэш
http.setRequestHeader "Accept-Encoding", "gzip, deflate, br"
http.setRequestHeader "Sec-Fetch-User", "?1"
http.setRequestHeader "Sec-Fetch-Dest", "document"
http.setRequestHeader "Sec-Fetch-Mode", "navigate"
http.setRequestHeader "Sec-Fetch-Site", "none"
http.Send
   
   
If http.Status <> 200 Then
'Ответ на запрос получен с ошибкой
   NBRBCourse2 = -2
End If
text = http.ResponseText
   
pos = InStrRev(text, ":") + 1
If pos = 0 Then
   NBRBCourse2 = -1 'Валюта не найдена
   Exit Function
End If
   
lngth = Len(text) - pos
If lngth < 1 Then
   NBRBCourse2 = -1 'Валюта не найдена
   Exit Function
End If
   
NBRBCourse2 = CDbl(Replace(Mid(text, pos, lngth), ".", ","))
End Function


В коде по вашей ссылке есть один момент. Когда я преобразую диапазон в картинку, она уходит в буфер и эксель не возвращает ссылку на объект. Это первое. Далее идет создание объектов ChartObjects. Мне бы хотелось эту стадию не использовать, так как эксель со своими перегруженными объектами работает относительно медленно. Идеально обойтись средствами API.
На данный момент я нашел интересную ссылку вот здесь.
Через API можно получить ссылку на изображение в буфере и далее работать примерно так как в коде, который я уже приводил. Единственный момент - сохранение рисунка в виде .bmp - мне не нравится. Эти файлы занимают много места и работа с диском при конвертации .bmp файла в другой формат - тоже достаточно медленна операция. Хотелось бы сразу сохранять в виде .png или .gif. Excel методом .CopyPicture с параметрами по умолчанию в буфер картинку помещает в векторном виде, т.е. теоретически у неё должен быть очень маленький объем. Я немного почитал вот тут, из буфера можно достать объект с помощью соответствующих констант формата CF_..., но об этом упоминается только вскользь. Буду пока дальше разбираться.

Ваше предложение использовать ChartObject оставлю на потом, если другими способами не получится.

Кажется я частично решил проблему, но слегка по другому.
В примере моего кода лист Excel превращается в картинку, копируется в буфер, оттуда нужно сбросить его в файл.
То есть требовалось сбросить в файл скриншот листа.
5 лет назад я уже создавал тему для сканирования экрана в массив.
Пример рабочий и его можно использовать для моей задачи. Для сброса скриншота, хранящегося в массиве в файл нужно только правильно сохранить данные согласно спецификации BMP-файла. Немного погуглил, получилось.

Код свёрнут ниже. Часть задекларированных API в коде лишние, остались от предыдущего проекта, но в целом для офиса 2003 работает без ошибок. Процедура TestScanScreen

[spoiler]

Код (vb) Выделить Развернуть


Option Explicit
 
'Примеры декларации для некоторых API на офис х64 здесь: http://www.cadsharp.com/docs/Win32API_PtrSafe.txt
'-----------------------------------------------------------------------------------------------------------------------
'Функции для работы с экраном и координатами форм
'
#If VBA7 Then
    'Функция получения координат прямоугольника-контрола
    Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
     'Освобождение контекстного устройства после вызова GetDC
    Public Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    'Получить RGB-цвет пикселя по его координатам
    Public Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    'Отрисовать RGB-точку
    Public Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function SetPixelV Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    'Удаление контекстного устройства
    Public Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
     'Просканировать изображение в массив
    Public Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
     
#ElseIf Not Win64 Then 'Варинат для 2003 офиса на Win 32
 
    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
    Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
#ElseIf Win64 Then 'Варинат для 32bit офиса на Win 64
     
    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongLong, lpRect As RECT) As LongLong
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As LongLong) As LongLong
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongLong, ByVal hdc As LongLong) As LongLong
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongLong, ByVal nIndex As LongLong) As LongLong
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongLong) As LongLong
    'Получить RGB-цвет пикселя по его координатам
    Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As LongLong, ByVal x As LongLong, ByVal y As LongLong) As LongLong
     
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As LongLong) As LongLong
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongLong
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As LongLong, ByVal x As LongLong, ByVal y As LongLong, ByVal nWidth As LongLong, ByVal nHeight As LongLong, ByVal hSrcDC As LongLong, ByVal XSrc As LongLong, ByVal YSrc As LongLong, ByVal dwRop As LongLong)
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongLong) As LongLong
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hObject As LongLong) As LongLong
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongLong) As LongLong
#End If
 
Public Type RECT 'Тип, хранящий координаты прямоугольника контрола
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
'Константы функции GetDeviceCaps параметра nIndex
Public Const LOGPIXELSX As Long = 88 'Число пикселей на горизонтальный логический дюйм
Public Const HORZSIZE As Long = 4& 'Размер по горизонтали в пикселях
Public Const VERTSIZE As Long = 6& 'Размер по вертикали в пикселях
Public Const HORZRES As Long = 8 'Разрешение по горизонтали в пикселях
Public Const VERTRES As Long = 10 'Разрешение по вертикали в пикселях
Public Const BITSPIXEL As Long = 12 'Глубина цвета в битах
Public Const VREFRESH As Long = 116 'Частота кадров монитора в герцах
 
'Константы функции GetSystemMetrics
Public Const SM_CXSCREEN As Long = 0 'Ширина экрана в пикселях
Public Const SM_CYSCREEN As Long = 1 'Высота экрана в пикселях
 
'Константа функции GetDIBits
Public Const DIB_RGB_COLORS = &H0 'RGB-палитра
 
'Типы и константы для получения информации в BITMAP вид
Public Type BITMAPINFOHEADER
   bmSize As Long
   bmWidth As Long
   bmHeight As Long
   bmPlanes As Integer
   bmBitCount As Integer
   bmCompression As Long
   bmSizeImage As Long
   bmXPelsPerMeter As Long
   bmYPelsPerMeter As Long
   bmClrUsed As Long
   bmClrImportant As Long
End Type
Public Type RGBTRIPLE
   Blue As Byte
   Green As Byte
   Red As Byte
   rgbReserved As Byte
End Type
Public Type BITMAPINFO
   bmHeader As BITMAPINFOHEADER
   bmColors As RGBTRIPLE
End Type
 
Public Type BITMAPFILEHEADER '14 байт
     bfType As Integer
     bfSize As Long
     bfReserved1 As Integer
     bfReserved2 As Integer
     bfOffBits As Long
End Type
 
'Способы копирования функцией BitBlt в параметре dwRop
Public Const SRCCOPY = &HCC0020 'Полное копирование
 
Public Const BI_RGB As Long = 0 'Картинка в виде несжатого растра
'------------------------------------------------------------------------------
 

Public Sub TestScanScreen()
'Функция сканирования экрана в массив Picture
#If VBA7 Then
    Dim hdc As LongPtr  'DC экрана
    Dim hTmpDC As LongPtr ' Временное DC для сканирования изображения
    Dim hTmpBmp  As LongPtr 'Указатель на совместимый точечный рисунок
#Else
    Dim hdc As Long  'DC экрана
    Dim hTmpDC As Long ' Временное DC для сканирования изображения
    Dim hTmpBmp  As Long 'Указатель на совместимый точечный рисунок
#End If


Dim ScreenH As Long, ScreenW As Long 'Разрешение экрана
Dim Picture() As RGBTRIPLE 'Массив, куда сканируется изображение
Dim Bitp As Long 'Глубина цвета в битах (12 или 24)
 
'Dim ScreenW As Long, ScreenH As Long 'Ширина и высота экрана
Dim BMP As BITMAPINFO 'Переменная, хранящая информацию о bmp рисунке
Dim BMPFileHeader As BITMAPFILEHEADER
Dim Res
Dim BytesPerScanLine As Long
 
hdc = GetDC(Application.hwnd) 'Получаем весь экран рабочего стола
ScreenW = GetDeviceCaps(hdc, HORZRES) 'Ширина экрана в пикселях
ScreenH = GetDeviceCaps(hdc, VERTRES) 'Выстоа экрана в пикселях
 
Bitp = GetDeviceCaps(hdc, BITSPIXEL) 'Получаем глубину цвета
hTmpDC = CreateCompatibleDC(hdc) 'Создаем DC, совместимую с экранной областью
hTmpBmp = CreateCompatibleBitmap(hdc, ScreenW, ScreenH) 'Создаю холст экрана

'Объектом для TmpDC выбираем растровый рисунок (варианты: кисть, шрифт, перо...)
Res = SelectObject(hTmpDC, hTmpBmp)
 
'Попиксельное копирование изображения из DC экрана во временное DC памяти (hTmpDC)
'первая пара 0,0 - координаты X,Y блока изображения получателя
'ScreenW, ScreenH - ширина и высота копируемого изображения
'последняя пара 0,0 - координаты X,Y блока изображения источника
'SRCCOPY - полное копирование без обработки
Res = BitBlt(hTmpDC, 0, 0, ScreenW, ScreenH, hdc, 0, 0, SRCCOPY)
 
With BMP.bmHeader
   .bmSize = Len(BMP.bmHeader) 'Размер блока .bmHeader в байтах
   .bmBitCount = Bitp 'Цветовая палитра ресунка
   .bmClrImportant = 0
   .bmClrUsed = 0
   .bmCompression = BI_RGB 'Без сжатия
   .bmHeight = -ScreenH
   .bmWidth = ScreenW 'Ширина рисунка
   .bmPlanes = 1 'Количество битовых плоскостей
   BytesPerScanLine = ((((.bmWidth * .bmBitCount) + 31) / 32) * 4)
   .bmSizeImage = 0 'BytesPerScanLine * Abs(.bmHeight)
   .bmXPelsPerMeter = 0
   .bmYPelsPerMeter = 0
End With
 
'Определяем размеры массива под сканирование экрана
ReDim Picture(0 To ScreenW - 1, 0 To ScreenH - 1)

'Получаем попиксельную информацию с экрана в массив
Res = GetDIBits(hTmpDC, hTmpBmp, 0, ScreenH, Picture(0, 0), BMP, DIB_RGB_COLORS)
If Res = 0 Then
    Stop
End If

'Создаём заголовок файла BMP
With BMPFileHeader
    .bfType = &H4D42 ' "BM"
    .bfSize = Len(BMP.bmHeader) + Len(BMPFileHeader) + ScreenW * ScreenH * Len(Picture(0, 0))
    .bfReserved1 = 0
    .bfReserved2 = 0
    .bfOffBits = Len(BMP.bmHeader) + Len(BMPFileHeader)
End With


Open "D:\2.bmp" For Binary Access Write As #1
Put #1, , BMPFileHeader
Put #1, , BMP.bmHeader
Put #1, , Picture
Close #1


DeleteObject hTmpBmp 'Освобождаю системные ресурсы, занятые под точечный рисунок
DeleteDC hTmpDC 'Удаляем временно созданный DC
ReleaseDC 0, hdc 'Освобождаем контекстное DC
End Sub


[/spoiler]


В принципе это не совсем то, что изначально заявлено в теме, но примерно ясно в каком направлении копать. Получить бинарные данные на bmp рисунок и сохранить их в том же порядке как в этом коде. Потом можно при желании сконвертировать файл в другой формат.

Добрый день.
Я могу поместить диапазон range  в виде картинки в буфер обмена следующим кодом

Код (vb) Выделить Развернуть

Public Sub ScrnToGif()
'Сохраняем скриншот в виде gif файла
Dim lastrow As Long
Dim ws As Worksheet, rng As Range

Set ws = Worksheets(1)
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).row + 3
Set rng = Range(ws.Cells(1,1), ws.Cells(lastrow, 10))
rng.CopyPicture

End Sub

А как теперь сохранить картинку, которая находится в буфере сразу в файл, например gif или png? Не могу найти, наверняка есть какой-нибудь ActiveX метод