Страницы: 1
RSS
Вставка рисунка из буффера обмена
 
Здравствуйте. Нужно вставлять рисунок из буффера обмена (копируется PrintScreen) через VBA, а как узнать что находится в буффере именно рисунок?
 
Узнать просто - достаточно проверить тип содержимого буфера обмена:  
 
Делается это при помощи WinAPI-функций примерно так:  
 
 
Function GetPicturePath() As String  
   On Error Resume Next  
   PicPath = GetPathForTemporaryFiles  
   PicPath = PicPath & "Picture" & Format(Now, "DD-MMM-YYYY_HH-NN-SS") & ".bmp"  
 
   Dim PShape As Shape, hStrPtr As Long, Hndl As Long  
 
   If Not CBool(OpenClipboard(0&)) Then  
       MsgBox "Не удалось открыть буфер"  
       GoTo NextSh  
   End If  
   hStrPtr = GetClipboardData(CF_ENHMETAFILE) ' ПРОВЕРКА НА НАЛИЧИЕ РИСУНКА В БУФЕРЕ ОБМЕНА  
   If Not CBool(hStrPtr) Then  
       MsgBox "Не удалось получить дескриптор"  
       GoTo CloseClip  
   End If  
   PicPath = PicPath & "Picture" & hStrPtr & ".emf"  
   Hndl = CopyEnhMetaFileA(hStrPtr, PicPath) ' КОПИРУЕМ РИСУНОК В ФАЙЛ  
   If Hndl = 0 Then  
       MsgBox "Не удалось создать файл"  
       GoTo CloseClip  
   Else  
       GetPicturePath = PicPath  
   End If  
   Call DeleteEnhMetaFile(Hndl)  
CloseClip:  
   CloseClipboard  
NextSh:        'очистка буфера обмена  
 
End Function  
 
 
Пример можно найти здесь:    
http://www.programmersforum.ru/showthread.php?t=54492
 
Как я понял эта функция:  
hStrPtr = GetClipboardData(CF_ENHMETAFILE) ' ПРОВЕРКА НА НАЛИЧИЕ РИСУНКА В БУФЕРЕ ОБМЕНА  
 
А как декларировать API функцию?
 
По рабоче-крестьянски :)  
Попытаться вставить содержимое буфера на текущий лист как рисунок. Если это только проверка, удалить вставленный рисунок.  
 
Sub Макрос1()  
Application.ScreenUpdating = False  
On Error Resume Next  
ActiveSheet.PasteSpecial Format:="Рисунок", Link:=False, DisplayAsIcon:=False  
If Err Then  
   Err.Clear  
   MsgBox "В буфере - не рисунок!", vbExclamation  
Else  
   Selection.Delete 'при необходимости - удалить рисунок  
   MsgBox "В буфере рисунок!", vbInformation  
End If  
Application.ScreenUpdating = True  
End Sub
 
Спасибо. Разобрался, и с проверкой типа через API то же
Страницы: 1
Читают тему
Наверх