The Frog
unread,Dec 17, 2012, 5:44:14 AM12/17/12You do not have permission to delete messages in this group
Either email addresses are anonymous for this group or you need the view member email addresses permission to view the original message
to
OK, I have found the code I was looking for. If you can produce a snapshot report file then this will extract the EMF images for you and dump them into powerpoint. I havent used this in a while as 2007+ dont seem to support these snapshot reports. This might be of some help to you..... place the code below into a .bas file (make a text file with the code in it and rename the .txt to .bas) then you can import it into Access from the VBA editor.
Cheers
The Frog
'______________________________________________________________________
Attribute VB_Name = "Push_PPT"
Option Compare Database
Option Explicit
Private Declare Function SetupDecompressOrCopyFile _
Lib "setupAPI" _
Alias "SetupDecompressOrCopyFileA" ( _
ByVal SourceFileName As String, _
ByVal TargetFileName As String, _
ByVal CompressionType As Integer) As Long
Private Declare Function GetTempPath _
Lib "kernel32" _
Alias "GetTempPathA" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName _
Lib "kernel32" _
Alias "GetTempFileNameA" ( _
ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function SetEnhMetaFileBits _
Lib "gdi32" ( _
ByVal cbBuffer As Long, _
lpData As Byte) As Long
Private Declare Function OpenClipboard _
Lib "user32" ( _
ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard _
Lib "user32" () As Long
Private Declare Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard _
Lib "user32" () As Long
Private Declare Function SetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Const emfSIG = &H464D4520
Private Const emfVER = &H10000
Private Const emfCID = 14
Private Const ppLayoutBlank = 12
Private Const msoTrue = -1
Private Const ppPasteEnhancedMetafile = 2
Private Const ppViewSlide = 1
Private Const msoAlignCenters = 1
Private Const msoAlignMiddles = 4
Private Const msoFileDialogSaveAs = 2
Sub test_1()
Dim TempPath As String 'location of temp directory
Dim SnapFile As String 'the original snapshot
Dim DataFile As String 'the decompressed snapshot
Dim Length As Long 'return value for API calls
Dim Fnum As Long 'to hold freefile number for direct file access
Dim Flen As Long 'length of the file
Dim Fpos As Long 'position in the file
Dim Fsig As Long 'variable for holding EMF signature bytes
Dim Fver As Long 'variable for holding EMF version bytes
Dim Fbyt As Long 'variable for holding EMF byte length
Dim emfStart As Long 'variable for holding the start position of an EMF
Dim bArray(0 To 3) As Byte 'byte array for holding our retreived searches
Dim emfArray() As Byte 'byte array for holding the entire EMF image
Dim Pages As Long 'how many pages in the report
Dim i As Long 'general purpose variable
Dim z As Long 'general purpose variable
Dim h As Long 'memory handle value for clipboard goes here
Dim L As Integer 'for holding left margin value
Dim R As Integer 'right margin value
Dim T As Integer 'top margin value
Dim B As Integer 'bottom margin value
Dim ppApp As Object 'PowerPoint application object
Dim ppPrs As Object 'Powerpoint presentation object
Dim ppSld As Object 'Powerpoint slide object
Dim ppSdg As Object 'Powerpoint SaveAs dialog box
'L = Round(CCur(Left(GetOption("Left Margin"), Len(GetOption("Left Margin")) - 2)) * 100, 1)
'R = Round(CCur(Left(GetOption("Right Margin"), Len(GetOption("Right Margin")) - 2)) * 100, 1)
'T = Round(CCur(Left(GetOption("Top Margin"), Len(GetOption("Top Margin")) - 2)) * 100, 1)
'B = Round(CCur(Left(GetOption("Bottom Margin"), Len(GetOption("Bottom Margin")) - 2)) * 100, 1)
TempPath = Space(256) 'initialise string
Length = GetTempPath(256, TempPath) 'get the path and length
TempPath = Left(TempPath, Length) & Chr(0) 'cleanup the string (null terminated)
SnapFile = Space(256) 'initialise string
Length = GetTempFileName(TempPath, vbNullString, 0, SnapFile) 'get filename
SnapFile = Left(SnapFile, InStr(SnapFile, Chr(0)) - 1) 'cleanup filename
Call Kill(SnapFile) 'kill the temp file the process made
DataFile = Left(SnapFile, Len(SnapFile) - 3) & "emf" 'create the output filename for decompression
DoCmd.OutputTo acOutputReport, _
"Erfüllungsgrad Total nach Kunden", _
"SnapshotFormat(*.snp)", _
SnapFile 'produce the snapshot to SnapFile
SetupDecompressOrCopyFile SnapFile, DataFile, 0& 'decompress SnapFile to DataFile
Call Kill(SnapFile) 'SnapFile no longer needed
Fnum = FreeFile 'get a file access number
Open DataFile For Binary As Fnum 'open the file with the EMF's
Flen = LOF(Fnum) 'store how big the file is
Seek Fnum, Flen - 503 'total number of pages stored here
Get Fnum, , bArray 'get the 4 bytes starting at our position
CopyMemory Pages, bArray(0), 4 'place the bytes into a variable we can use
Seek Fnum, 1 'go back to the start of the file for searching
Fpos = 0 'set start value
Fsig = 0 'set start value
Fver = 0 'set start value
If Pages = 0 Then GoTo Shutdown 'Nothing to push to PowerPoint
Set ppApp = CreateObject("PowerPoint.Application") 'Create the PowerPoint app object we will manipulate
ppApp.Presentations.Add 'Add our presentation we will populate with slides
Set ppPrs = ppApp.Presentations.Item(1) 'Set a reference to our newly made empty presentation
ppApp.Visible = True 'This seems to only work as long as you can see the app
ppApp.ActiveWindow.ViewType = ppViewSlide 'and only if the view is set to this when visible!!! (weird)
For i = 1 To Pages 'for each report page we want an EMF
Do While Fpos < Flen 'do while file position is less than the length of the file
Get Fnum, , bArray 'read 4 bytes
CopyMemory Fsig, bArray(0), 4 'place into a usable variable
If Fsig = emfSIG Then 'compare the value against our EMF signature
Get Fnum, , bArray 'read the next 4 bytes
CopyMemory Fver, bArray(0), 4 'copy the version info to a variable
If Fver = emfVER Then 'check if the signatures match
Get Fnum, , bArray 'read the next 4 bytes
CopyMemory Fbyt, bArray(0), 4 'copy the length info to a variable
If i = 1 Then
emfStart = Fpos - 35 - 4 'EMF header block start position
Else
emfStart = Fpos - 40 - 4 'the first seems to have a different offset at the start
End If
Seek Fnum, emfStart 'move to the start of the emf
ReDim emfArray(Fbyt - 1) 'resize the array to hold the entire emf
Get Fnum, , emfArray 'read the emf into the array
h = SetEnhMetaFileBits(UBound(emfArray) + 1, emfArray(0)) 'get our handle to a memory metafile
If OpenClipboard(0&) <> 0 Then 'try and open the clipboard
Call EmptyClipboard 'clear out the clipboard
z = SetClipboardData(emfCID, h) 'push the emf to the clipboard
z = CloseClipboard 'close the clipboard leaving the data there
End If 'end of open clipboard if statement
Set ppSld = ppPrs.Slides.Add(i, ppLayoutBlank) 'create a new slide for each page
ppSld.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).select 'paste the image to the slide from the clipboard
'With ppSld.Shapes(1) 'crop the image to remove the paper margins
' .PictureFormat.CropLeft = L 'and just keep the 'inside' of the report
' .PictureFormat.CropTop = T
' .PictureFormat.CropRight = r
' .PictureFormat.CropBottom = B
'End With
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 'align the image to the centre
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 'align the middles (I forget which is horizontal and vertical)
End If 'end of emfVER IF statement
End If 'end of emfSIG IF statement
Fpos = Fpos + 4 'increment our position in the file
Loop 'end of Fpos to Flen loop
Next i 'end of Pages loop
Set ppSdg = ppApp.FileDialog(Type:=msoFileDialogSaveAs) 'let the user choose the save file
If ppSdg.Show = -1 Then ppPrs.saveas (ppSdg.SelectedItems(1)) 'save the presentation
Shutdown:
Close Fnum 'close the datafile
Call Kill(DataFile) 'DataFile no longer needed
Set ppSdg = Nothing 'release powerpoint object references
Set ppSld = Nothing
Set ppPrs = Nothing
ppApp.Quit 'and quit the app
Set ppApp = Nothing 'and release the app reference
End Sub