Макрос в PowerPoint / Visual Basic

ReSQL.ru

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Новые сообщения | Избранное

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Макрос в PowerPoint

24 сообщений из 24, страница 1 из 1

Макрос в PowerPoint

#39063572

oracletbm

Гость

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

Такая задача-загадка: есть JPG-картинка. Нужно её переконвертить в WMF-формат.
Программа Microsoft PowerPoint позволяет сохранить рисунок из презентации в WMF-формате.

Запускаю макрос-рекордер в 2013 офисе:
1. Добавляю картинку
2. Сохраняю в WMF-формат

Получается такой код:
ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="d:\1.jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0).Select
ActivePresentation.SaveAs FileName:="d:\2.wmf", FileFormat:=ppSaveAsMetaFile, EmbedTrueTypeFonts:=msoFalse

При этом картинка сохранена в файл d:\2.wmf один-в-один, как jpg-картинка. Т.е. идеально то, что нужно...

Далее создаю такой макрос, вызываю его и в результате:
1. картинка формируется размером не как первичная jpg-картинка, а размером с лист презентации, который существенно больше
2. WMF-файл создаётся не с тем именем, который передаётся, а "Слайд1.WMF". При этом файл создаётся в папке "d:\2\". Т.е. всё что до .wmf почему обрабатывается как имя папки.

Уважаемые знатоки!
Может кто встречался с этим? Как в макросе написать то. что происходит при ручном сохранении?
Т.е. как сохранить только картинку, а не весь слайд. И как задать имя файла то, которое мне нужно, а не хрень по-умолчанию...

Помогите, плиз...

...

Рейтинг:

0 / 0

28.09.2015, 20:06

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39063575

oracletbm

Гость

Запускаю макрос-рекордер в 2013 офисе:

Не в 2013 конечно, а в 2003 ...

...

Рейтинг:

0 / 0

28.09.2015, 20:08

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39063776

oracletbm

Гость

С размером картинки справиться удалось путём установки листа презентации размером с картинку (хотя это всё некрасивое решение - танцы с бубнами)...
Имя файла не удаётся передать - PowerPoint считывает только папку...
Может какой служебный символ нужно использовать, чтобы пояснить программе, что нужно именно такое имя файла?

...

Рейтинг:

0 / 0

29.09.2015, 09:13

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39063937

Игорь Горбонос

Участник

Откуда: Днепропетровск

Сообщения: 4 416

Рейтинг: 0 / 0

oracletbm,

покажи код макроса, который вызываешь, а не который тебе записал макрорекодер

...

Рейтинг:

0 / 0

29.09.2015, 11:04

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39064282

13-й квартал

Гость

oracletbm,

многакодамодуль modBitmap2EMFPicture

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.

'Модуль для загрузки (растровых) изображений в файловых форматах, поддерживаемых
'GDI+, из потоковых источников данных.

Option Explicit

Private Enum BOOL
   FALSE_BOOL = 0
   TRUE_BOOL = 1
End Enum

Private Enum CLIPFORMAT 'Predefined Clipboard Formats
   CF_TEXT = 1
   CF_BITMAP = 2
   CF_METAFILEPICT = 3
   CF_SYLK = 4
   CF_DIF = 5
   CF_TIFF = 6
   CF_OEMTEXT = 7
   CF_DIB = 8
   CF_PALETTE = 9
   CF_PENDATA = 10
   CF_RIFF = 11
   CF_WAVE = 12
   CF_UNICODETEXT = 13
   CF_ENHMETAFILE = 14
   CF_HDROP = 15
   CF_LOCALE = 16
   CF_MAX = 17
   CF_OWNERDISPLAY = &H80
   CF_DSPTEXT = &H81
   CF_DSPBITMAP = &H82
   CF_DSPMETAFILEPICT = &H83
   CF_DSPENHMETAFILE = &H8E
   '"Public" formats don't get GlobalFree()'d
   CF_PublicFIRST = &H200
   CF_PublicLAST = &H2FF
   '"GDIOBJ" formats do get DeleteObject()'d
   CF_GDIOBJFIRST = &H300
   CF_GDIOBJLAST = &H3FF
   'Registered formats
   CF_RegisteredFIRST = &HC000&
   CF_RegisteredLAST = &HFFFF&
End Enum

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpsz As Long, rguid As GUID) As Long
Private Const IIDSTR_IPictureDisp$ = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = -1
   PICTYPE_NONE = 0
   PICTYPE_BITMAP = 1
   PICTYPE_METAFILE = 2
   PICTYPE_ICON = 3
   PICTYPE_ENHMETAFILE = 4
End Enum

Private Type PICTDESCEMF
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hEMF As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   pPictDesc As Any, riid As GUID, _
   ByVal fOwn As BOOL, ppvObj As IPictureDisp) As Long


Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As BOOL

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE = 4           '  Horizontal size in millimeters
   VERTSIZE = 6           '  Vertical size in millimeters
   HORZRES = 8            '  Horizontal width in pixels
   VERTRES = 10           '  Vertical width in pixels
   LOGPIXELSX = 88        '  Logical pixels/inch in X
   LOGPIXELSY = 90        '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long

Private Enum MapMode
   MM_ANISOTROPIC = 8 ' Map mode anisotropic
End Enum
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As MapMode) As MapMode

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As BOOL
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As BOOL


Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
Private Type BLENDFUNCTIONBYVAL
   Value As Long
End Type
Private Const AC_SRC_OVER = &H0
'Alpha format flags
Private Const AC_SRC_ALPHA = &H1
'Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
'Private Const AC_SRC_NO_ALPHA = &H2
'Private Const AC_DST_NO_PREMULT_ALPHA = &H10
'Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function AlphaBlend Lib "msimg32" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long) As BOOL


Private Enum GpStatus 'GDI+ Status
   OK = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
   ProfileNotFound = 21
End Enum

Private Enum GdiplusVersion
   Ver1 = 1
End Enum

Private Type GdiplusStartupInput
   GdiplusVersion As GdiplusVersion
   DebugEventCallback As Long
   SuppressBackgroundThread As BOOL
   SuppressExternalCodecs As BOOL
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   lToken As Long, lpInput As GdiplusStartupInput, _
   Optional ByRef lpOutput As Any) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal lToken As Long) As GpStatus

'Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
   ByVal wszFileName As Long, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" ( _
   ByVal pStream As IUnknown, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
   ByVal nBitmap As Long, hbmReturn As Long, _
   ByVal argbBackground As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal nImage As Long) As GpStatus

Public Enum PixelFormat
   PixelFormatUndefined = &H0&
   PixelFormatDontCare = PixelFormatUndefined
   PixelFormatMax = &HF&
   PixelFormat1_8 = &H100&
   PixelFormat4_8 = &H400&
   PixelFormat8_8 = &H800&
   PixelFormat16_8 = &H1000&
   PixelFormat24_8 = &H1800&
   PixelFormat32_8 = &H2000&
   PixelFormat48_8 = &H3000&
   PixelFormat64_8 = &H4000&
   PixelFormat16bppRGB555 = &H21005
   PixelFormat16bppRGB565 = &H21006
   PixelFormat16bppGrayScale = &H101004
   PixelFormat16bppARGB1555 = &H61007
   PixelFormat24bppRGB = &H21808
   PixelFormat32bppRGB = &H22009
   PixelFormat32bppARGB = &H26200A
   PixelFormat32bppPARGB = &HD200B
   PixelFormat48bppRGB = &H10300C
   PixelFormat64bppARGB = &H34400D
   PixelFormat64bppPARGB = &H1C400E
   PixelFormatGDI = &H20000
   PixelFormat1bppIndexed = &H30101
   PixelFormat4bppIndexed = &H30402
   PixelFormat8bppIndexed = &H30803
   PixelFormatAlpha = &H40000
   PixelFormatIndexed = &H10000
   PixelFormatPAlpha = &H80000
   PixelFormatExtended = &H100000
   PixelFormatCanonical = &H200000
End Enum
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" ( _
   ByVal nImage As Long, ImagePixFmt As PixelFormat) As GpStatus
Private Declare Function GdipGetImageWidth Lib "gdiplus" ( _
   ByVal nImage As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" ( _
   ByVal nImage As Long, Height As Long) As GpStatus


Private Type TQuadBytes
   bByte(0 To 3) As Byte
End Type
Private Type TLong
   lLong As Long
End Type


Private Function GdiErrorString(ByVal lError As GpStatus) As String
 Select Case lError
 Case GenericError:              GdiErrorString = "Generic error"
 Case InvalidParameter:          GdiErrorString = "Invalid parameter"
 Case OutOfMemory:               GdiErrorString = "Out of memory"
 Case ObjectBusy:                GdiErrorString = "Object busy"
 Case InsufficientBuffer:        GdiErrorString = "Insufficient buffer"
 Case NotImplemented:            GdiErrorString = "Not implemented"
 Case Win32Error:                GdiErrorString = "Win32 error"
 Case WrongState:                GdiErrorString = "Wrong state"
 Case Aborted:                   GdiErrorString = "Aborted"
 Case FileNotFound:              GdiErrorString = "File not found"
 Case ValueOverflow:             GdiErrorString = "Value overflow"
 Case AccessDenied:              GdiErrorString = "Access denied"
 Case UnknownImageFormat:        GdiErrorString = "Unknown image format"
 Case FontFamilyNotFound:        GdiErrorString = "Font family not found"
 Case FontStyleNotFound:         GdiErrorString = "Font style not found"
 Case NotTrueTypeFont:           GdiErrorString = "Not TrueType font"
 Case UnsupportedGdiplusVersion: GdiErrorString = "Unsupported GDI+ version"
 Case GdiplusNotInitialized:     GdiErrorString = "GDI+ not initialized"
 Case PropertyNotFound:          GdiErrorString = "Property not found"
 Case PropertyNotSupported:      GdiErrorString = "Property not supported"
 Case Else:                      GdiErrorString = "Unknown GDI+ error"
 End Select
End Function

Private Function GdipExec(ByVal lStatus As GpStatus) As GpStatus
 If lStatus <> OK Then MsgBox GdiErrorString(lStatus), vbExclamation, _
                              "GDI+ Error"
 GdipExec = lStatus
End Function


Public Function CreateIPictureDispFromHENHMETAFILE( _
   ByVal hEMF As Long, _
   Optional ByVal bPictureOwnsHandle As Boolean = True) As IPictureDisp
'Функция оборачивания EMF в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   hEMF - дескриптор (GDI-объекта типа OBJ_ENHMETAFILE);
'   bPictureOwnsHandle - режим дальнейшего владения дескриптором:
'      False - вызывающая сторона ответственна за действия с дескриптором;
'      True - создаваемый COM-объект ответственнен за действия с дескриптором,
'             в т. ч. за уничтожение GDI-объекта.
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCEMF
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_ENHMETAFILE
    .hEMF = hEMF
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, -bPictureOwnsHandle, _
                          CreateIPictureDispFromHENHMETAFILE
End Function


Public Function LoadBmpAsEmfPicture( _
   ByVal BmpSrc As IStreamSource, _
   Optional ByVal bAlpha As Byte = 255, _
   Optional ByVal EMFFileName As String = vbNullString) As IPictureDisp
'Основная функция модуля: загрузка (растрового) изображения, преобразование
'его в EMF, оборачивание в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   BmpSrc - потоковый источник данных в файловом формате изображений,
'            поддерживаемом GDI+;
'   bAlpha - необязательный параметр общей (полу-)прозрачности:
'            от 0 (полная прозрачность) до 255 (полная непрозрачность);
'   EMFFileName - необязательный параметр - имя создаваемого .emf-файла.
'            Если параметр не задан, .emf-файл не создаётся.
 Const HM_PER_INCH = 2540 'количество сотых миллиметра в дюйме
 Const HM_PER_MM = 100    'количество сотых миллиметра в миллиметре
 Dim GdipToken As Long
 Dim si As GdiplusStartupInput
 Dim nBitmap As Long
 Dim hBitmap As Long
 Dim pfPixFmt As PixelFormat
 Dim cxWidth As Long, cyHeight As Long
 Dim hicRef As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim rc As RECT
 Dim hdcMeta As Long
 Dim iWEX As Long, iWEY As Long
 Dim iVEX As Long, iVEY As Long
 Dim iGCD As Long
 Dim hdcMem As Long
 Dim hbmpOld As Long
 Dim hEMF As Long
 Dim bfBlend As BLENDFUNCTION
 Dim bfvBlend As BLENDFUNCTIONBYVAL

 If BmpSrc.Stream Is Nothing Then Exit Function

 si.GdiplusVersion = Ver1
 GdipExec GdiplusStartup(GdipToken, si, ByVal 0&)
 If GdipToken = 0 Then Exit Function
 GdipExec GdipCreateBitmapFromStream(BmpSrc.Stream, nBitmap)
 If nBitmap Then
    GdipExec GdipGetImagePixelFormat(nBitmap, pfPixFmt)
    Select Case pfPixFmt
    Case PixelFormat32bppARGB, PixelFormat24bppRGB, PixelFormat32bppRGB, _
         PixelFormat1bppIndexed, PixelFormat4bppIndexed, PixelFormat8bppIndexed
'Печально, но, похоже, декодер .bmp в GDI+ считает 32bppARGB-файлы как 32bppRGB,
'т.е. игнорирует альфа-канал. Для .png такой проблемы нет.
       GdipExec GdipGetImageWidth(nBitmap, cxWidth)
       GdipExec GdipGetImageHeight(nBitmap, cyHeight)
       GdipExec GdipCreateHBITMAPFromBitmap(nBitmap, hBitmap, &H0)
    Case Else
       MsgBox "Wrong image format!", vbExclamation
    End Select
    GdipExec GdipDisposeImage(nBitmap): nBitmap = 0
 End If
 GdipExec GdiplusShutdown(GdipToken): GdipToken = 0
 If hBitmap = 0 Then Exit Function
 
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 iWidthMM = GetDeviceCaps(hicRef, HORZSIZE)
 iHeightMM = GetDeviceCaps(hicRef, VERTSIZE)
 iWidthPels = GetDeviceCaps(hicRef, HORZRES)
 iHeightPels = GetDeviceCaps(hicRef, VERTRES)
 iDPIX = GetDeviceCaps(hicRef, LOGPIXELSX)
 iDPIY = GetDeviceCaps(hicRef, LOGPIXELSY)
 
 'Размеры в сотых долях миллиметра
 rc.Right = Int(cxWidth * HM_PER_INCH / iDPIX + 0.5)
 rc.Bottom = Int(cyHeight * HM_PER_INCH / iDPIY + 0.5)
 
 'Создаём "усовершенствованный" метафайл в памяти и на диске, если дано имя
 hdcMeta = CreateEnhMetaFile(hicRef, EMFFileName, rc, vbNullString)
 
 iGCD = GCD(HM_PER_INCH, HM_PER_MM)
 iWEY = HM_PER_MM \ iGCD
 iWEX = cxWidth * iWidthMM * iDPIX * iWEY
 iWEY = cyHeight * iHeightMM * iDPIY * iWEY
 iVEY = HM_PER_INCH \ iGCD
 iVEX = cxWidth * iWidthPels * iVEY
 iVEY = cyHeight * iHeightPels * iVEY
 iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
 SetMapMode hdcMeta, MM_ANISOTROPIC
 SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal 0&
 SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal 0&
 
 hdcMem = CreateCompatibleDC(hicRef)
 DeleteDC hicRef: hicRef = 0
 hbmpOld = SelectObject(hdcMem, hBitmap)

 bfBlend.BlendOp = AC_SRC_OVER
 bfBlend.BlendFlags = 0
 bfBlend.SourceConstantAlpha = bAlpha
 If pfPixFmt = PixelFormat32bppARGB Then bfBlend.AlphaFormat = AC_SRC_ALPHA
 LSet bfvBlend = bfBlend
 AlphaBlend hdcMeta, 0, 0, cxWidth, cyHeight, _
            hdcMem, 0, 0, cxWidth, cyHeight, bfvBlend.Value

 SelectObject hdcMem, hbmpOld: hbmpOld = 0
 DeleteDC hdcMem: hdcMem = 0
 DeleteObject hBitmap: hBitmap = 0
    
 hEMF = CloseEnhMetaFile(hdcMeta): hdcMeta = 0
 Set LoadBmpAsEmfPicture = CreateIPictureDispFromHENHMETAFILE(hEMF)
End Function


Public Function GCD(ByVal a As Long, ByVal b As Long) As Long
'Функция нахождения НОД по алгоритму Евклида.
 Do While (a <> 0) And (b <> 0)
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function

модуль класса IStreamSource

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.

'Интерфейс источника потоковых данных.

Option Explicit

Public Property Get Stream() As IUnknown
 'Внимание! Чтобы не использовать внешнюю библиотеку типов, поток описывается
 'как COM-объект, реализующий интерфейс IUnknown. В классах, реализующих
 'интерфейс IStreamSource, следует результатом выполнения
 'Private Property Get IStreamSource_Stream возвращать ссылку на интерфейс
 'IStream (IID: 0000000C-0000-0000-C000-000000000046).
End Property

модуль класса CFileStream

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.

'Класс источника потоковых данных на основе (двоичного) файла.

Option Explicit

Private Enum STGM
   STGM_READ = &H0
   STGM_WRITE = &H1
   STGM_READWRITE = &H2
   STGM_SHARE_DENY_NONE = &H40
   STGM_SHARE_DENY_READ = &H30
   STGM_SHARE_DENY_WRITE = &H20
   STGM_SHARE_EXCLUSIVE = &H10
   STGM_PRIORITY = &H40000
   STGM_CREATE = &H1000
   STGM_CONVERT = &H20000
   STGM_FAILIFTHERE = &H0
   STGM_DIRECT1 = &H0
   STGM_TRANSACTED = &H10000
   STGM_NOSCRATCH = &H100000
   STGM_NOSNAPSHOT = &H200000
   STGM_SIMPLE = &H8000000
   STGM_DIRECT_SWMR = &H400000
   STGM_DELETEONRELEASE = &H4000000
End Enum
Private Declare Function SHCreateStreamOnFile Lib "shlwapi" _
   Alias "SHCreateStreamOnFileW" ( _
   ByVal pszFile As Long, ByVal grfMode As STGM, pStm As IUnknown) As Long
Private Const S_OK As Long = 0&


Implements IStreamSource

Private m_Stream As IUnknown

Private Property Get IStreamSource_Stream() As IUnknown
 Set IStreamSource_Stream = m_Stream
End Property

Public Function Init(ByVal FileName As String) As Boolean
'Конструктор.
 Dim hr As Long
 hr = SHCreateStreamOnFile(StrPtr(FileName), _
                           STGM_READ Or STGM_SHARE_DENY_WRITE, m_Stream)
 Init = hr = S_OK
End Function

Практический смысл кода в том, что в нём есть функция LoadBmpAsEmfPicture(), которая берёт поток данных, декодирует его как если бы это был файл в (растровом) графическом формате, и преобразует в EMF. Пример, как можно использовать:

Код: vbnet

1.
2.
3.
4.
5.
6.

 Dim stmFile As CFileStream
 Set stmFile = New CFileStream
 If stmFile.Init("C:\Temp\Picture.jpg") Then
    LoadBmpAsEmfPicture stmFile, , "C:\Temp\Picture.emf"
    'далее использование C:\Temp\Picture.emf
 End If

...

Рейтинг:

0 / 0

29.09.2015, 15:17

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39066626

oracletbm

Гость

Игорь Горбоносoracletbm,

покажи код макроса, который вызываешь, а не который тебе записал макрорекодер

Вот такой макрос пишет макрорекордер - соответственно его и использую

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="d:\1.jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0).Select
ActivePresentation.SaveAs FileName:="d:\1.wmf", FileFormat:=ppSaveAsMetaFile, EmbedTrueTypeFonts:=msoFalse

Т.к. такой макрос вызывает сохранение целого листа презентации, а не только картинки, то я дополнительно привожу размер листа к размеру картинки

Dim Width_ As Integer
Dim Height_ As Integer

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=file1_, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0).Select

Width_ = ActiveWindow.Selection.ShapeRange.Width
Height_ = ActiveWindow.Selection.ShapeRange.Height

With ActivePresentation.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideWidth = Width_
.SlideHeight = Height_
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With

With ActiveWindow.Selection.ShapeRange
.Fill.Transparency = 0#
.Height = Height_
.Width = Width_
.Left = 0#
.Top = 0#
End With

ActivePresentation.SaveAs FileName:=file2_, FileFormat:=ppSaveAsMetaFile, EmbedTrueTypeFonts:=msoFalse

...

Рейтинг:

0 / 0

02.10.2015, 08:04

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39066630

oracletbm

Гость

13-й кварталoracletbm,

многакодамодуль modBitmap2EMFPicture

Код: vbnet

'Модуль для загрузки (растровых) изображений в файловых форматах, поддерживаемых
'GDI+, из потоковых источников данных.

Option Explicit

Private Enum BOOL
   FALSE_BOOL = 0
   TRUE_BOOL = 1
End Enum

Private Enum CLIPFORMAT 'Predefined Clipboard Formats
   CF_TEXT = 1
   CF_BITMAP = 2
   CF_METAFILEPICT = 3
   CF_SYLK = 4
   CF_DIF = 5
   CF_TIFF = 6
   CF_OEMTEXT = 7
   CF_DIB = 8
   CF_PALETTE = 9
   CF_PENDATA = 10
   CF_RIFF = 11
   CF_WAVE = 12
   CF_UNICODETEXT = 13
   CF_ENHMETAFILE = 14
   CF_HDROP = 15
   CF_LOCALE = 16
   CF_MAX = 17
   CF_OWNERDISPLAY = &H80
   CF_DSPTEXT = &H81
   CF_DSPBITMAP = &H82
   CF_DSPMETAFILEPICT = &H83
   CF_DSPENHMETAFILE = &H8E
   '"Public" formats don't get GlobalFree()'d
   CF_PublicFIRST = &H200
   CF_PublicLAST = &H2FF
   '"GDIOBJ" formats do get DeleteObject()'d
   CF_GDIOBJFIRST = &H300
   CF_GDIOBJLAST = &H3FF
   'Registered formats
   CF_RegisteredFIRST = &HC000&
   CF_RegisteredLAST = &HFFFF&
End Enum

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpsz As Long, rguid As GUID) As Long
Private Const IIDSTR_IPictureDisp$ = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = -1
   PICTYPE_NONE = 0
   PICTYPE_BITMAP = 1
   PICTYPE_METAFILE = 2
   PICTYPE_ICON = 3
   PICTYPE_ENHMETAFILE = 4
End Enum

Private Type PICTDESCEMF
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hEMF As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   pPictDesc As Any, riid As GUID, _
   ByVal fOwn As BOOL, ppvObj As IPictureDisp) As Long


Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As BOOL

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE = 4           '  Horizontal size in millimeters
   VERTSIZE = 6           '  Vertical size in millimeters
   HORZRES = 8            '  Horizontal width in pixels
   VERTRES = 10           '  Vertical width in pixels
   LOGPIXELSX = 88        '  Logical pixels/inch in X
   LOGPIXELSY = 90        '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long

Private Enum MapMode
   MM_ANISOTROPIC = 8 ' Map mode anisotropic
End Enum
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As MapMode) As MapMode

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As BOOL
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As BOOL


Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
Private Type BLENDFUNCTIONBYVAL
   Value As Long
End Type
Private Const AC_SRC_OVER = &H0
'Alpha format flags
Private Const AC_SRC_ALPHA = &H1
'Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
'Private Const AC_SRC_NO_ALPHA = &H2
'Private Const AC_DST_NO_PREMULT_ALPHA = &H10
'Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function AlphaBlend Lib "msimg32" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long) As BOOL


Private Enum GpStatus 'GDI+ Status
   OK = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
   ProfileNotFound = 21
End Enum

Private Enum GdiplusVersion
   Ver1 = 1
End Enum

Private Type GdiplusStartupInput
   GdiplusVersion As GdiplusVersion
   DebugEventCallback As Long
   SuppressBackgroundThread As BOOL
   SuppressExternalCodecs As BOOL
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   lToken As Long, lpInput As GdiplusStartupInput, _
   Optional ByRef lpOutput As Any) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal lToken As Long) As GpStatus

'Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
   ByVal wszFileName As Long, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" ( _
   ByVal pStream As IUnknown, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
   ByVal nBitmap As Long, hbmReturn As Long, _
   ByVal argbBackground As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal nImage As Long) As GpStatus

Public Enum PixelFormat
   PixelFormatUndefined = &H0&
   PixelFormatDontCare = PixelFormatUndefined
   PixelFormatMax = &HF&
   PixelFormat1_8 = &H100&
   PixelFormat4_8 = &H400&
   PixelFormat8_8 = &H800&
   PixelFormat16_8 = &H1000&
   PixelFormat24_8 = &H1800&
   PixelFormat32_8 = &H2000&
   PixelFormat48_8 = &H3000&
   PixelFormat64_8 = &H4000&
   PixelFormat16bppRGB555 = &H21005
   PixelFormat16bppRGB565 = &H21006
   PixelFormat16bppGrayScale = &H101004
   PixelFormat16bppARGB1555 = &H61007
   PixelFormat24bppRGB = &H21808
   PixelFormat32bppRGB = &H22009
   PixelFormat32bppARGB = &H26200A
   PixelFormat32bppPARGB = &HD200B
   PixelFormat48bppRGB = &H10300C
   PixelFormat64bppARGB = &H34400D
   PixelFormat64bppPARGB = &H1C400E
   PixelFormatGDI = &H20000
   PixelFormat1bppIndexed = &H30101
   PixelFormat4bppIndexed = &H30402
   PixelFormat8bppIndexed = &H30803
   PixelFormatAlpha = &H40000
   PixelFormatIndexed = &H10000
   PixelFormatPAlpha = &H80000
   PixelFormatExtended = &H100000
   PixelFormatCanonical = &H200000
End Enum
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" ( _
   ByVal nImage As Long, ImagePixFmt As PixelFormat) As GpStatus
Private Declare Function GdipGetImageWidth Lib "gdiplus" ( _
   ByVal nImage As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" ( _
   ByVal nImage As Long, Height As Long) As GpStatus


Private Type TQuadBytes
   bByte(0 To 3) As Byte
End Type
Private Type TLong
   lLong As Long
End Type


Private Function GdiErrorString(ByVal lError As GpStatus) As String
 Select Case lError
 Case GenericError:              GdiErrorString = "Generic error"
 Case InvalidParameter:          GdiErrorString = "Invalid parameter"
 Case OutOfMemory:               GdiErrorString = "Out of memory"
 Case ObjectBusy:                GdiErrorString = "Object busy"
 Case InsufficientBuffer:        GdiErrorString = "Insufficient buffer"
 Case NotImplemented:            GdiErrorString = "Not implemented"
 Case Win32Error:                GdiErrorString = "Win32 error"
 Case WrongState:                GdiErrorString = "Wrong state"
 Case Aborted:                   GdiErrorString = "Aborted"
 Case FileNotFound:              GdiErrorString = "File not found"
 Case ValueOverflow:             GdiErrorString = "Value overflow"
 Case AccessDenied:              GdiErrorString = "Access denied"
 Case UnknownImageFormat:        GdiErrorString = "Unknown image format"
 Case FontFamilyNotFound:        GdiErrorString = "Font family not found"
 Case FontStyleNotFound:         GdiErrorString = "Font style not found"
 Case NotTrueTypeFont:           GdiErrorString = "Not TrueType font"
 Case UnsupportedGdiplusVersion: GdiErrorString = "Unsupported GDI+ version"
 Case GdiplusNotInitialized:     GdiErrorString = "GDI+ not initialized"
 Case PropertyNotFound:          GdiErrorString = "Property not found"
 Case PropertyNotSupported:      GdiErrorString = "Property not supported"
 Case Else:                      GdiErrorString = "Unknown GDI+ error"
 End Select
End Function

Private Function GdipExec(ByVal lStatus As GpStatus) As GpStatus
 If lStatus <> OK Then MsgBox GdiErrorString(lStatus), vbExclamation, _
                              "GDI+ Error"
 GdipExec = lStatus
End Function


Public Function CreateIPictureDispFromHENHMETAFILE( _
   ByVal hEMF As Long, _
   Optional ByVal bPictureOwnsHandle As Boolean = True) As IPictureDisp
'Функция оборачивания EMF в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   hEMF - дескриптор (GDI-объекта типа OBJ_ENHMETAFILE);
'   bPictureOwnsHandle - режим дальнейшего владения дескриптором:
'      False - вызывающая сторона ответственна за действия с дескриптором;
'      True - создаваемый COM-объект ответственнен за действия с дескриптором,
'             в т. ч. за уничтожение GDI-объекта.
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCEMF
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_ENHMETAFILE
    .hEMF = hEMF
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, -bPictureOwnsHandle, _
                          CreateIPictureDispFromHENHMETAFILE
End Function


Public Function LoadBmpAsEmfPicture( _
   ByVal BmpSrc As IStreamSource, _
   Optional ByVal bAlpha As Byte = 255, _
   Optional ByVal EMFFileName As String = vbNullString) As IPictureDisp
'Основная функция модуля: загрузка (растрового) изображения, преобразование
'его в EMF, оборачивание в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   BmpSrc - потоковый источник данных в файловом формате изображений,
'            поддерживаемом GDI+;
'   bAlpha - необязательный параметр общей (полу-)прозрачности:
'            от 0 (полная прозрачность) до 255 (полная непрозрачность);
'   EMFFileName - необязательный параметр - имя создаваемого .emf-файла.
'            Если параметр не задан, .emf-файл не создаётся.
 Const HM_PER_INCH = 2540 'количество сотых миллиметра в дюйме
 Const HM_PER_MM = 100    'количество сотых миллиметра в миллиметре
 Dim GdipToken As Long
 Dim si As GdiplusStartupInput
 Dim nBitmap As Long
 Dim hBitmap As Long
 Dim pfPixFmt As PixelFormat
 Dim cxWidth As Long, cyHeight As Long
 Dim hicRef As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim rc As RECT
 Dim hdcMeta As Long
 Dim iWEX As Long, iWEY As Long
 Dim iVEX As Long, iVEY As Long
 Dim iGCD As Long
 Dim hdcMem As Long
 Dim hbmpOld As Long
 Dim hEMF As Long
 Dim bfBlend As BLENDFUNCTION
 Dim bfvBlend As BLENDFUNCTIONBYVAL

 If BmpSrc.Stream Is Nothing Then Exit Function

 si.GdiplusVersion = Ver1
 GdipExec GdiplusStartup(GdipToken, si, ByVal 0&)
 If GdipToken = 0 Then Exit Function
 GdipExec GdipCreateBitmapFromStream(BmpSrc.Stream, nBitmap)
 If nBitmap Then
    GdipExec GdipGetImagePixelFormat(nBitmap, pfPixFmt)
    Select Case pfPixFmt
    Case PixelFormat32bppARGB, PixelFormat24bppRGB, PixelFormat32bppRGB, _
         PixelFormat1bppIndexed, PixelFormat4bppIndexed, PixelFormat8bppIndexed
'Печально, но, похоже, декодер .bmp в GDI+ считает 32bppARGB-файлы как 32bppRGB,
'т.е. игнорирует альфа-канал. Для .png такой проблемы нет.
       GdipExec GdipGetImageWidth(nBitmap, cxWidth)
       GdipExec GdipGetImageHeight(nBitmap, cyHeight)
       GdipExec GdipCreateHBITMAPFromBitmap(nBitmap, hBitmap, &H0)
    Case Else
       MsgBox "Wrong image format!", vbExclamation
    End Select
    GdipExec GdipDisposeImage(nBitmap): nBitmap = 0
 End If
 GdipExec GdiplusShutdown(GdipToken): GdipToken = 0
 If hBitmap = 0 Then Exit Function
 
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 iWidthMM = GetDeviceCaps(hicRef, HORZSIZE)
 iHeightMM = GetDeviceCaps(hicRef, VERTSIZE)
 iWidthPels = GetDeviceCaps(hicRef, HORZRES)
 iHeightPels = GetDeviceCaps(hicRef, VERTRES)
 iDPIX = GetDeviceCaps(hicRef, LOGPIXELSX)
 iDPIY = GetDeviceCaps(hicRef, LOGPIXELSY)
 
 'Размеры в сотых долях миллиметра
 rc.Right = Int(cxWidth * HM_PER_INCH / iDPIX + 0.5)
 rc.Bottom = Int(cyHeight * HM_PER_INCH / iDPIY + 0.5)
 
 'Создаём "усовершенствованный" метафайл в памяти и на диске, если дано имя
 hdcMeta = CreateEnhMetaFile(hicRef, EMFFileName, rc, vbNullString)
 
 iGCD = GCD(HM_PER_INCH, HM_PER_MM)
 iWEY = HM_PER_MM \ iGCD
 iWEX = cxWidth * iWidthMM * iDPIX * iWEY
 iWEY = cyHeight * iHeightMM * iDPIY * iWEY
 iVEY = HM_PER_INCH \ iGCD
 iVEX = cxWidth * iWidthPels * iVEY
 iVEY = cyHeight * iHeightPels * iVEY
 iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
 SetMapMode hdcMeta, MM_ANISOTROPIC
 SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal 0&
 SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal 0&
 
 hdcMem = CreateCompatibleDC(hicRef)
 DeleteDC hicRef: hicRef = 0
 hbmpOld = SelectObject(hdcMem, hBitmap)

 bfBlend.BlendOp = AC_SRC_OVER
 bfBlend.BlendFlags = 0
 bfBlend.SourceConstantAlpha = bAlpha
 If pfPixFmt = PixelFormat32bppARGB Then bfBlend.AlphaFormat = AC_SRC_ALPHA
 LSet bfvBlend = bfBlend
 AlphaBlend hdcMeta, 0, 0, cxWidth, cyHeight, _
            hdcMem, 0, 0, cxWidth, cyHeight, bfvBlend.Value

 SelectObject hdcMem, hbmpOld: hbmpOld = 0
 DeleteDC hdcMem: hdcMem = 0
 DeleteObject hBitmap: hBitmap = 0
    
 hEMF = CloseEnhMetaFile(hdcMeta): hdcMeta = 0
 Set LoadBmpAsEmfPicture = CreateIPictureDispFromHENHMETAFILE(hEMF)
End Function


Public Function GCD(ByVal a As Long, ByVal b As Long) As Long
'Функция нахождения НОД по алгоритму Евклида.
 Do While (a <> 0) And (b <> 0)
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function

модуль класса IStreamSource

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.

'Интерфейс источника потоковых данных.

Option Explicit

Public Property Get Stream() As IUnknown
 'Внимание! Чтобы не использовать внешнюю библиотеку типов, поток описывается
 'как COM-объект, реализующий интерфейс IUnknown. В классах, реализующих
 'интерфейс IStreamSource, следует результатом выполнения
 'Private Property Get IStreamSource_Stream возвращать ссылку на интерфейс
 'IStream (IID: 0000000C-0000-0000-C000-000000000046).
End Property

модуль класса CFileStream

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.

'Класс источника потоковых данных на основе (двоичного) файла.

Option Explicit

Private Enum STGM
   STGM_READ = &H0
   STGM_WRITE = &H1
   STGM_READWRITE = &H2
   STGM_SHARE_DENY_NONE = &H40
   STGM_SHARE_DENY_READ = &H30
   STGM_SHARE_DENY_WRITE = &H20
   STGM_SHARE_EXCLUSIVE = &H10
   STGM_PRIORITY = &H40000
   STGM_CREATE = &H1000
   STGM_CONVERT = &H20000
   STGM_FAILIFTHERE = &H0
   STGM_DIRECT1 = &H0
   STGM_TRANSACTED = &H10000
   STGM_NOSCRATCH = &H100000
   STGM_NOSNAPSHOT = &H200000
   STGM_SIMPLE = &H8000000
   STGM_DIRECT_SWMR = &H400000
   STGM_DELETEONRELEASE = &H4000000
End Enum
Private Declare Function SHCreateStreamOnFile Lib "shlwapi" _
   Alias "SHCreateStreamOnFileW" ( _
   ByVal pszFile As Long, ByVal grfMode As STGM, pStm As IUnknown) As Long
Private Const S_OK As Long = 0&


Implements IStreamSource

Private m_Stream As IUnknown

Private Property Get IStreamSource_Stream() As IUnknown
 Set IStreamSource_Stream = m_Stream
End Property

Public Function Init(ByVal FileName As String) As Boolean
'Конструктор.
 Dim hr As Long
 hr = SHCreateStreamOnFile(StrPtr(FileName), _
                           STGM_READ Or STGM_SHARE_DENY_WRITE, m_Stream)
 Init = hr = S_OK
End Function

Код: vbnet

1.
2.
3.
4.
5.
6.

 Dim stmFile As CFileStream
 Set stmFile = New CFileStream
 If stmFile.Init("C:\Temp\Picture.jpg") Then
    LoadBmpAsEmfPicture stmFile, , "C:\Temp\Picture.emf"
    'далее использование C:\Temp\Picture.emf
 End If

Спасибо :-).
Но мне нужен именно формат WMF, а не EMF (его скорее всего просто не поймёт другая сторонняя программа).
А исправить внутри кода EMF на WMF я вряд ли смогу, т.к. VB не мой профиль...
Приведённый код я так понял загружает файл и конвертит в EMF-формат в памяти - а как его сохранить на диск?

...

Рейтинг:

0 / 0

02.10.2015, 08:11

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39066633

oracletbm

Гость

И ещё такой вопрос:
почему-то при выхове PowerPoint он отображается на панели задач.
Хотя я не ставлю флаг

Код: vbnet

objPowerPoint.Visible = msoTrue

При этом конструкция

Код: vbnet

objPowerPoint.Visible = msoFalse

вообще не поддерживается

Можно как-то скрыть PowerPoint, чтобы он работал в фоновом режиме, как Excel, Word, или это его особенность?

...

Рейтинг:

0 / 0

02.10.2015, 08:15

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39068966

oracletbm

Гость

oracletbmИ ещё такой вопрос:
почему-то при вызове PowerPoint он отображается на панели задач.
Хотя я не ставлю флаг

Код: vbnet

objPowerPoint.Visible = msoTrue

При этом конструкция

Код: vbnet

objPowerPoint.Visible = msoFalse

вообще не поддерживается

Можно как-то скрыть PowerPoint, чтобы он работал в фоновом режиме, как Excel, Word, или это его особенность?

Мне казалось вопрос элементарный... :(
Реально видать PowerPoint в фоновом режиме работать не хочет - всегда виден, т.е. теоретически любой пользователь, если начнёт кликать мышью, то может случайно помешать заложенной логике работы... :((
Странно это всё.

...

Рейтинг:

0 / 0

06.10.2015, 08:19

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39069002

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

http://stackoverflow.com/questions/18667195/how-can-i-programmatically-open-powerpoint-without-seeing-the-window
https://social.msdn.microsoft.com/Forums/vstudio/en-US/04493177-0cc6-42f1-8fb0-7d43d4f6dcba/how-can-i-programmatically-open-powerpoint-without-seeing-the-window?forum=vbgeneral

...

Рейтинг:

0 / 0

06.10.2015, 09:28

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39069597

oracletbm

Гость

i45 http://stackoverflow.com/questions/18667195/how-can-i-programmatically-open-powerpoint-without-seeing-the-window
https://social.msdn.microsoft.com/Forums/vstudio/en-US/04493177-0cc6-42f1-8fb0-7d43d4f6dcba/how-can-i-programmatically-open-powerpoint-without-seeing-the-window?forum=vbgeneral

Спасибо огромное!

Стал использовать такую команду:

Код: vbnet

Set objTemplate = objPowerPoint.Presentations.Open(filename:="d:\sklad 2000\template\fas_obl.ppt", WithWindow:=False)

Но к сожалению, решение одной проблемы сразу создало другие => в данном случае если создавать приложение без окна, то и все обращения к окну становятся некорректными и вызывают ошибки...

В частности команда

Код: vbnet

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=file1_, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0).Select

вылетает с ошибкой...

И подмена ActiveWindow на

Код: vbnet

pp.windows(1).

также не проходит, т.к. судя по всему не создаётся вообще окно как объект...
А как же тогда использовать методы окна?
А получается если окно создать, то оно будет видимым...

Какой-то замкнутый круг.
Неужели нет какого-нибудь очевидного решения?

...

Рейтинг:

0 / 0

06.10.2015, 16:24

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39069620

13-й квартал

Гость

oracletbmНо мне нужен именно формат WMF, а не EMF (его скорее всего просто не поймёт другая сторонняя программа)."... и тут из-за угла выезжает танк!" Что же это за загадочная программа, которой нужен растр, завёрнутый в WMF?
Вот и проверьте, принимает ли она EMF. Раньше дёргаться нет смысла. По двум причинам. Первая очевидна; вторая почти смешна, не будь она реальной: даже внутри Microsoft вопрос размера WMF/EMF трактуется по-разному разными группами разработчиков, не говоря уже о сторонних конторах.oracletbmА исправить внутри кода EMF на WMF я вряд ли смогу, т.к. VB не мой профиль...VB тут мало при чём, он "клей" между вызовами системных функций.oracletbmПриведённый код я так понял загружает файл и конвертит в EMF-формат в памяти - а как его сохранить на диск?Вот зачем в функцию передаётся путь к .emf-файлу, по-вашему?

...

Рейтинг:

0 / 0

06.10.2015, 16:38

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39070025

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

oracletbm,

Попытайтесь либо обойтись без Selection, либо посмотреть, применимо ли Selection не только к окнам.

...

Рейтинг:

0 / 0

07.10.2015, 02:33

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39070903

oracletbm

Гость

13-й кварталoracletbm,

многакодамодуль modBitmap2EMFPicture

Код: vbnet

'Модуль для загрузки (растровых) изображений в файловых форматах, поддерживаемых
'GDI+, из потоковых источников данных.

Option Explicit

Private Enum BOOL
   FALSE_BOOL = 0
   TRUE_BOOL = 1
End Enum

Private Enum CLIPFORMAT 'Predefined Clipboard Formats
   CF_TEXT = 1
   CF_BITMAP = 2
   CF_METAFILEPICT = 3
   CF_SYLK = 4
   CF_DIF = 5
   CF_TIFF = 6
   CF_OEMTEXT = 7
   CF_DIB = 8
   CF_PALETTE = 9
   CF_PENDATA = 10
   CF_RIFF = 11
   CF_WAVE = 12
   CF_UNICODETEXT = 13
   CF_ENHMETAFILE = 14
   CF_HDROP = 15
   CF_LOCALE = 16
   CF_MAX = 17
   CF_OWNERDISPLAY = &H80
   CF_DSPTEXT = &H81
   CF_DSPBITMAP = &H82
   CF_DSPMETAFILEPICT = &H83
   CF_DSPENHMETAFILE = &H8E
   '"Public" formats don't get GlobalFree()'d
   CF_PublicFIRST = &H200
   CF_PublicLAST = &H2FF
   '"GDIOBJ" formats do get DeleteObject()'d
   CF_GDIOBJFIRST = &H300
   CF_GDIOBJLAST = &H3FF
   'Registered formats
   CF_RegisteredFIRST = &HC000&
   CF_RegisteredLAST = &HFFFF&
End Enum

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpsz As Long, rguid As GUID) As Long
Private Const IIDSTR_IPictureDisp$ = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = -1
   PICTYPE_NONE = 0
   PICTYPE_BITMAP = 1
   PICTYPE_METAFILE = 2
   PICTYPE_ICON = 3
   PICTYPE_ENHMETAFILE = 4
End Enum

Private Type PICTDESCEMF
   cbSizeOfStruct As Long
   PictType As PICTYPE
   hEMF As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   pPictDesc As Any, riid As GUID, _
   ByVal fOwn As BOOL, ppvObj As IPictureDisp) As Long


Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As BOOL

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As BOOL

Private Enum DeviceCapIndex
   HORZSIZE = 4           '  Horizontal size in millimeters
   VERTSIZE = 6           '  Vertical size in millimeters
   HORZRES = 8            '  Horizontal width in pixels
   VERTRES = 10           '  Vertical width in pixels
   LOGPIXELSX = 88        '  Logical pixels/inch in X
   LOGPIXELSY = 90        '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapIndex) As Long

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long

Private Enum MapMode
   MM_ANISOTROPIC = 8 ' Map mode anisotropic
End Enum
Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As MapMode) As MapMode

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As BOOL
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As BOOL


Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
Private Type BLENDFUNCTIONBYVAL
   Value As Long
End Type
Private Const AC_SRC_OVER = &H0
'Alpha format flags
Private Const AC_SRC_ALPHA = &H1
'Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
'Private Const AC_SRC_NO_ALPHA = &H2
'Private Const AC_DST_NO_PREMULT_ALPHA = &H10
'Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function AlphaBlend Lib "msimg32" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long) As BOOL


Private Enum GpStatus 'GDI+ Status
   OK = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
   ProfileNotFound = 21
End Enum

Private Enum GdiplusVersion
   Ver1 = 1
End Enum

Private Type GdiplusStartupInput
   GdiplusVersion As GdiplusVersion
   DebugEventCallback As Long
   SuppressBackgroundThread As BOOL
   SuppressExternalCodecs As BOOL
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   lToken As Long, lpInput As GdiplusStartupInput, _
   Optional ByRef lpOutput As Any) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal lToken As Long) As GpStatus

'Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
   ByVal wszFileName As Long, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" ( _
   ByVal pStream As IUnknown, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
   ByVal nBitmap As Long, hbmReturn As Long, _
   ByVal argbBackground As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal nImage As Long) As GpStatus

Public Enum PixelFormat
   PixelFormatUndefined = &H0&
   PixelFormatDontCare = PixelFormatUndefined
   PixelFormatMax = &HF&
   PixelFormat1_8 = &H100&
   PixelFormat4_8 = &H400&
   PixelFormat8_8 = &H800&
   PixelFormat16_8 = &H1000&
   PixelFormat24_8 = &H1800&
   PixelFormat32_8 = &H2000&
   PixelFormat48_8 = &H3000&
   PixelFormat64_8 = &H4000&
   PixelFormat16bppRGB555 = &H21005
   PixelFormat16bppRGB565 = &H21006
   PixelFormat16bppGrayScale = &H101004
   PixelFormat16bppARGB1555 = &H61007
   PixelFormat24bppRGB = &H21808
   PixelFormat32bppRGB = &H22009
   PixelFormat32bppARGB = &H26200A
   PixelFormat32bppPARGB = &HD200B
   PixelFormat48bppRGB = &H10300C
   PixelFormat64bppARGB = &H34400D
   PixelFormat64bppPARGB = &H1C400E
   PixelFormatGDI = &H20000
   PixelFormat1bppIndexed = &H30101
   PixelFormat4bppIndexed = &H30402
   PixelFormat8bppIndexed = &H30803
   PixelFormatAlpha = &H40000
   PixelFormatIndexed = &H10000
   PixelFormatPAlpha = &H80000
   PixelFormatExtended = &H100000
   PixelFormatCanonical = &H200000
End Enum
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" ( _
   ByVal nImage As Long, ImagePixFmt As PixelFormat) As GpStatus
Private Declare Function GdipGetImageWidth Lib "gdiplus" ( _
   ByVal nImage As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" ( _
   ByVal nImage As Long, Height As Long) As GpStatus


Private Type TQuadBytes
   bByte(0 To 3) As Byte
End Type
Private Type TLong
   lLong As Long
End Type


Private Function GdiErrorString(ByVal lError As GpStatus) As String
 Select Case lError
 Case GenericError:              GdiErrorString = "Generic error"
 Case InvalidParameter:          GdiErrorString = "Invalid parameter"
 Case OutOfMemory:               GdiErrorString = "Out of memory"
 Case ObjectBusy:                GdiErrorString = "Object busy"
 Case InsufficientBuffer:        GdiErrorString = "Insufficient buffer"
 Case NotImplemented:            GdiErrorString = "Not implemented"
 Case Win32Error:                GdiErrorString = "Win32 error"
 Case WrongState:                GdiErrorString = "Wrong state"
 Case Aborted:                   GdiErrorString = "Aborted"
 Case FileNotFound:              GdiErrorString = "File not found"
 Case ValueOverflow:             GdiErrorString = "Value overflow"
 Case AccessDenied:              GdiErrorString = "Access denied"
 Case UnknownImageFormat:        GdiErrorString = "Unknown image format"
 Case FontFamilyNotFound:        GdiErrorString = "Font family not found"
 Case FontStyleNotFound:         GdiErrorString = "Font style not found"
 Case NotTrueTypeFont:           GdiErrorString = "Not TrueType font"
 Case UnsupportedGdiplusVersion: GdiErrorString = "Unsupported GDI+ version"
 Case GdiplusNotInitialized:     GdiErrorString = "GDI+ not initialized"
 Case PropertyNotFound:          GdiErrorString = "Property not found"
 Case PropertyNotSupported:      GdiErrorString = "Property not supported"
 Case Else:                      GdiErrorString = "Unknown GDI+ error"
 End Select
End Function

Private Function GdipExec(ByVal lStatus As GpStatus) As GpStatus
 If lStatus <> OK Then MsgBox GdiErrorString(lStatus), vbExclamation, _
                              "GDI+ Error"
 GdipExec = lStatus
End Function


Public Function CreateIPictureDispFromHENHMETAFILE( _
   ByVal hEMF As Long, _
   Optional ByVal bPictureOwnsHandle As Boolean = True) As IPictureDisp
'Функция оборачивания EMF в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   hEMF - дескриптор (GDI-объекта типа OBJ_ENHMETAFILE);
'   bPictureOwnsHandle - режим дальнейшего владения дескриптором:
'      False - вызывающая сторона ответственна за действия с дескриптором;
'      True - создаваемый COM-объект ответственнен за действия с дескриптором,
'             в т. ч. за уничтожение GDI-объекта.
 Dim IID_IPictureDisp As GUID
 Dim PictDesc As PICTDESCEMF
 With PictDesc
    .cbSizeOfStruct = Len(PictDesc)
    .PictType = PICTYPE_ENHMETAFILE
    .hEMF = hEMF
 End With
 CLSIDFromString StrPtr(IIDSTR_IPictureDisp), IID_IPictureDisp
 OleCreatePictureIndirect PictDesc, IID_IPictureDisp, -bPictureOwnsHandle, _
                          CreateIPictureDispFromHENHMETAFILE
End Function


Public Function LoadBmpAsEmfPicture( _
   ByVal BmpSrc As IStreamSource, _
   Optional ByVal bAlpha As Byte = 255, _
   Optional ByVal EMFFileName As String = vbNullString) As IPictureDisp
'Основная функция модуля: загрузка (растрового) изображения, преобразование
'его в EMF, оборачивание в COM-объект, поддерживающий интерфейс IPictureDisp.
'Параметры:
'   BmpSrc - потоковый источник данных в файловом формате изображений,
'            поддерживаемом GDI+;
'   bAlpha - необязательный параметр общей (полу-)прозрачности:
'            от 0 (полная прозрачность) до 255 (полная непрозрачность);
'   EMFFileName - необязательный параметр - имя создаваемого .emf-файла.
'            Если параметр не задан, .emf-файл не создаётся.
 Const HM_PER_INCH = 2540 'количество сотых миллиметра в дюйме
 Const HM_PER_MM = 100    'количество сотых миллиметра в миллиметре
 Dim GdipToken As Long
 Dim si As GdiplusStartupInput
 Dim nBitmap As Long
 Dim hBitmap As Long
 Dim pfPixFmt As PixelFormat
 Dim cxWidth As Long, cyHeight As Long
 Dim hicRef As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim rc As RECT
 Dim hdcMeta As Long
 Dim iWEX As Long, iWEY As Long
 Dim iVEX As Long, iVEY As Long
 Dim iGCD As Long
 Dim hdcMem As Long
 Dim hbmpOld As Long
 Dim hEMF As Long
 Dim bfBlend As BLENDFUNCTION
 Dim bfvBlend As BLENDFUNCTIONBYVAL

 If BmpSrc.Stream Is Nothing Then Exit Function

 si.GdiplusVersion = Ver1
 GdipExec GdiplusStartup(GdipToken, si, ByVal 0&)
 If GdipToken = 0 Then Exit Function
 GdipExec GdipCreateBitmapFromStream(BmpSrc.Stream, nBitmap)
 If nBitmap Then
    GdipExec GdipGetImagePixelFormat(nBitmap, pfPixFmt)
    Select Case pfPixFmt
    Case PixelFormat32bppARGB, PixelFormat24bppRGB, PixelFormat32bppRGB, _
         PixelFormat1bppIndexed, PixelFormat4bppIndexed, PixelFormat8bppIndexed
'Печально, но, похоже, декодер .bmp в GDI+ считает 32bppARGB-файлы как 32bppRGB,
'т.е. игнорирует альфа-канал. Для .png такой проблемы нет.
       GdipExec GdipGetImageWidth(nBitmap, cxWidth)
       GdipExec GdipGetImageHeight(nBitmap, cyHeight)
       GdipExec GdipCreateHBITMAPFromBitmap(nBitmap, hBitmap, &H0)
    Case Else
       MsgBox "Wrong image format!", vbExclamation
    End Select
    GdipExec GdipDisposeImage(nBitmap): nBitmap = 0
 End If
 GdipExec GdiplusShutdown(GdipToken): GdipToken = 0
 If hBitmap = 0 Then Exit Function
 
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 iWidthMM = GetDeviceCaps(hicRef, HORZSIZE)
 iHeightMM = GetDeviceCaps(hicRef, VERTSIZE)
 iWidthPels = GetDeviceCaps(hicRef, HORZRES)
 iHeightPels = GetDeviceCaps(hicRef, VERTRES)
 iDPIX = GetDeviceCaps(hicRef, LOGPIXELSX)
 iDPIY = GetDeviceCaps(hicRef, LOGPIXELSY)
 
 'Размеры в сотых долях миллиметра
 rc.Right = Int(cxWidth * HM_PER_INCH / iDPIX + 0.5)
 rc.Bottom = Int(cyHeight * HM_PER_INCH / iDPIY + 0.5)
 
 'Создаём "усовершенствованный" метафайл в памяти и на диске, если дано имя
 hdcMeta = CreateEnhMetaFile(hicRef, EMFFileName, rc, vbNullString)
 
 iGCD = GCD(HM_PER_INCH, HM_PER_MM)
 iWEY = HM_PER_MM \ iGCD
 iWEX = cxWidth * iWidthMM * iDPIX * iWEY
 iWEY = cyHeight * iHeightMM * iDPIY * iWEY
 iVEY = HM_PER_INCH \ iGCD
 iVEX = cxWidth * iWidthPels * iVEY
 iVEY = cyHeight * iHeightPels * iVEY
 iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
 SetMapMode hdcMeta, MM_ANISOTROPIC
 SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal 0&
 SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal 0&
 
 hdcMem = CreateCompatibleDC(hicRef)
 DeleteDC hicRef: hicRef = 0
 hbmpOld = SelectObject(hdcMem, hBitmap)

 bfBlend.BlendOp = AC_SRC_OVER
 bfBlend.BlendFlags = 0
 bfBlend.SourceConstantAlpha = bAlpha
 If pfPixFmt = PixelFormat32bppARGB Then bfBlend.AlphaFormat = AC_SRC_ALPHA
 LSet bfvBlend = bfBlend
 AlphaBlend hdcMeta, 0, 0, cxWidth, cyHeight, _
            hdcMem, 0, 0, cxWidth, cyHeight, bfvBlend.Value

 SelectObject hdcMem, hbmpOld: hbmpOld = 0
 DeleteDC hdcMem: hdcMem = 0
 DeleteObject hBitmap: hBitmap = 0
    
 hEMF = CloseEnhMetaFile(hdcMeta): hdcMeta = 0
 Set LoadBmpAsEmfPicture = CreateIPictureDispFromHENHMETAFILE(hEMF)
End Function


Public Function GCD(ByVal a As Long, ByVal b As Long) As Long
'Функция нахождения НОД по алгоритму Евклида.
 Do While (a <> 0) And (b <> 0)
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function

модуль класса IStreamSource

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.

'Интерфейс источника потоковых данных.

Option Explicit

Public Property Get Stream() As IUnknown
 'Внимание! Чтобы не использовать внешнюю библиотеку типов, поток описывается
 'как COM-объект, реализующий интерфейс IUnknown. В классах, реализующих
 'интерфейс IStreamSource, следует результатом выполнения
 'Private Property Get IStreamSource_Stream возвращать ссылку на интерфейс
 'IStream (IID: 0000000C-0000-0000-C000-000000000046).
End Property

модуль класса CFileStream

Код: vbnet

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.

'Класс источника потоковых данных на основе (двоичного) файла.

Option Explicit

Private Enum STGM
   STGM_READ = &H0
   STGM_WRITE = &H1
   STGM_READWRITE = &H2
   STGM_SHARE_DENY_NONE = &H40
   STGM_SHARE_DENY_READ = &H30
   STGM_SHARE_DENY_WRITE = &H20
   STGM_SHARE_EXCLUSIVE = &H10
   STGM_PRIORITY = &H40000
   STGM_CREATE = &H1000
   STGM_CONVERT = &H20000
   STGM_FAILIFTHERE = &H0
   STGM_DIRECT1 = &H0
   STGM_TRANSACTED = &H10000
   STGM_NOSCRATCH = &H100000
   STGM_NOSNAPSHOT = &H200000
   STGM_SIMPLE = &H8000000
   STGM_DIRECT_SWMR = &H400000
   STGM_DELETEONRELEASE = &H4000000
End Enum
Private Declare Function SHCreateStreamOnFile Lib "shlwapi" _
   Alias "SHCreateStreamOnFileW" ( _
   ByVal pszFile As Long, ByVal grfMode As STGM, pStm As IUnknown) As Long
Private Const S_OK As Long = 0&


Implements IStreamSource

Private m_Stream As IUnknown

Private Property Get IStreamSource_Stream() As IUnknown
 Set IStreamSource_Stream = m_Stream
End Property

Public Function Init(ByVal FileName As String) As Boolean
'Конструктор.
 Dim hr As Long
 hr = SHCreateStreamOnFile(StrPtr(FileName), _
                           STGM_READ Or STGM_SHARE_DENY_WRITE, m_Stream)
 Init = hr = S_OK
End Function

Код: vbnet

1.
2.
3.
4.
5.
6.

 Dim stmFile As CFileStream
 Set stmFile = New CFileStream
 If stmFile.Init("C:\Temp\Picture.jpg") Then
    LoadBmpAsEmfPicture stmFile, , "C:\Temp\Picture.emf"
    'далее использование C:\Temp\Picture.emf
 End If

Я не совсем понял как приведённый код добавить в модули EXCEL.
Если просто всё копирую и добавляю в новый модуль, то возникают ошибки компиляции..
Там где написано "Модуль modBitmap2EMFPicture" - это нужно создать новый модуль и вставить код или можно весь код в модуль запихнуть - но почему тогда ошибки компиляции выходят?

Вот эта вот процедура

Код: vbnet

1.
2.
3.
4.
5.
6.
7.

Public Property Get Stream() As IUnknown
 'Внимание! Чтобы не использовать внешнюю библиотеку типов, поток описывается
 'как COM-объект, реализующий интерфейс IUnknown. В классах, реализующих
 'интерфейс IStreamSource, следует результатом выполнения
 'Private Property Get IStreamSource_Stream возвращать ссылку на интерфейс
 'IStream (IID: 0000000C-0000-0000-C000-000000000046).
End Property

она так и должна быть или здесь нужно что-то где то учесть и написать свой код?

Может есть живой файл EXCEL с работающим макросом?
Или поясните, плиз, как этот код доработать и использовать, чтобы он работал?

...

Рейтинг:

0 / 0

07.10.2015, 15:44

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071035

Игорь Горбонос

Участник

Откуда: Днепропетровск

Сообщения: 4 416

Рейтинг: 0 / 0

oracletbm,

там где много кода написано:
13-й кварталмодуль класса IStreamSource
это значит нужно создать класс и дать ему имя IStreamSource

...

Рейтинг:

0 / 0

07.10.2015, 17:35

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071052

13-й квартал

Гость

oracletbm,

...

Рейтинг:

0 / 0

07.10.2015, 17:47

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071114

oracletbm

Гость

13-й кварталoracletbm,

Спасибо большое за файл. Проверил - работает :-)
Правда качество конвертации немного хуже чем в PowerPoint, но это не важно.
Ещё раз спасибо.

13-й кварталoracletbmНо мне нужен именно формат WMF, а не EMF (его скорее всего просто не поймёт другая сторонняя программа)."... и тут из-за угла выезжает танк!" Что же это за загадочная программа, которой нужен растр, завёрнутый в WMF?
Вот и проверьте, принимает ли она EMF. Раньше дёргаться нет смысла. По двум причинам. Первая очевидна; вторая почти смешна, не будь она реальной: даже внутри Microsoft вопрос размера WMF/EMF трактуется по-разному разными группами разработчиков, не говоря уже о сторонних конторах.

Программа эта покупная для изготовления мебельных фасадов. Туда требуется передать чертёж для бирки с присадками. И в программе к сожалению статично прописано смотреть только формат WMF. При этом программа к сожалению смотрит не только на расширение файла, но и его структуру (также пробовали JPG-расширение подменить на WMF).
При этом если пользоваться ручными режимами работы программы, то она понимает почти все графические форматы - но почему-то заложили для автоматической подгрузки использовать только формат WMF.
Попробую передавать EMF-файл с расширением .WMF => может из-за близости форматов воспримет за подходящий и подгрузит...

...

Рейтинг:

0 / 0

07.10.2015, 18:17

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071250

oracletbm

Гость

i45oracletbm,

Попытайтесь либо обойтись без Selection, либо посмотреть, применимо ли Selection не только к окнам.

Спасибо.

Получилось загрузить картинку такой конструкцией:

Код: vbnet

1.
2.

ppp As PowerPoint.Presentation
ppp.Slides(1).Shapes.AddPicture(FileName:=file1_, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0).Select

Но данная конструкция также вызывает ошибку из-за наличия .Select
Подскажите как мне извлечь идентификатор объекта-картинки, чтобы можно было изменить свойства рисунка после загрузки

У объекта .AddPictur e много свойств и методов, но который из них вернёт мне ссылку на сам объект с загруженной картинкой?
Чтобы можно было, например, изменить размер картинки.

...

Рейтинг:

0 / 0

07.10.2015, 20:53

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071351

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

oracletbm,

Нет необходимости использовать Select.

...

Рейтинг:

0 / 0

07.10.2015, 23:09

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071585

oracletbm

Гость

i45oracletbm,

Нет необходимости использовать Select.

А как получить идентификатор созданного объекта с картинкой?

Такая команда даёт ошибку

Код: vbnet

1.
2.

sp As Object
sp = ppp.Slides(1).Shapes.AddPicture(FileName:=file1_, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)

Мне нужно получить размер картинки...
Ближайшее, что я нашёл - это

Код: vbnet

ppp.Slides(1).Shapes.Range.Width

но там явно нее размер картинки лежит...

...

Рейтинг:

0 / 0

08.10.2015, 10:10

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071657

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

oracletbm,

Используйте Dim и Set

...

Рейтинг:

0 / 0

08.10.2015, 10:56

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071661

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

oracletbm,

И раннее связывание конечно.

...

Рейтинг:

0 / 0

08.10.2015, 10:58

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071676

i45

Участник

Сообщения: 8 244

Рейтинг: 0 / 0

oracletbm,

Посмотрите, объект какого класса возвращает метод AddPicture. Может быть это будет класс Shape.
Объявите этот объект (например Dim oMyPic As Shape), а потом Set oMyPic = ppp.Slides(1).Shapes.AddPicture(.....)

...

Рейтинг:

0 / 0

08.10.2015, 11:08

| Ответить | Цитировать | Написать

Макрос в PowerPoint

#39071828

oracletbm

Гость

i45oracletbm,

Посмотрите, объект какого класса возвращает метод AddPicture. Может быть это будет класс Shape.
Объявите этот объект (например Dim oMyPic As Shape), а потом Set oMyPic = ppp.Slides(1).Shapes.AddPicture(.....)

Всё получилось.
Узнал про команду Set :-)

Спасибо за советы, помощь и терпение.

...

Рейтинг:

0 / 0

08.10.2015, 12:41

| Ответить | Цитировать | Написать

24 сообщений из 24, страница 1 из 1

Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Макрос в PowerPoint

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?fid=60&msg=39070025&tid=2155774]:	0ms
get settings:	10ms
get forum list:	10ms
check forum access:	3ms
check topic access:	3ms
track hit:	34ms
get topic data:	9ms
get forum data:	2ms
get page messages:	55ms
get tp. blocked users:	1ms
others:	300ms

total:	427ms