emax79
01-21-2014, 09:14 PM
Hello fellow engineers . I Have a MS Access database which has a web browser control incorporated within . I also have a get screen capture program for "excel" which works magnificent. I would like to incorporate these 2 functions into The Access . I would like to use my web browser control located in the access example to zoom into the picture of a house . Then capture that image and save it into access in the best usable format possible . I would really like if someone much more knowledgeable than myself could look at the excel vb code and say . Look here friend . Just change such and such on the Excel ScreenCapture vba example and that will convert it to a usable Access format . Both programs work perfect in there respected format . I would like to merge the 2 into Access .... I will enclose both examples and hope you kind people may Have a suggestion for me . Thank you in advance ....... Eric Maxfield
Option Explicit '########################################################################## ############# 'Module code for capturing a screen image (Print Screen) and pasting to a new workbook 'Created on November 14th, 2009, compiled by Zack Barresse 'Compiled utilizing the following resources: ' http://www.ac6la.com/makegif.html ' http://www.andreavb.com/tip090001.html '########################################################################## ############# Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source Private Type DEVMODE dmDeviceName As String * CCHDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type 'APIDeclare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Declare Function EmptyClipboard Lib "user32.dll" () As Long Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Declare Function CloseClipboard Lib "user32.dll" () As Long Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function BitBlt Lib "gdi32.dll" (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 Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function CountClipboardFormats Lib "user32" () As Long Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _ (ByVal lpDriverName As String, ByVal lpDeviceName As String, _ ByVal lpOutput As String, lpInitData As Long) As Long Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Sub GetPrintScreen() '##### SET SCREEN CAPTURE SIZES HERE Call CaptureScreen(0, 0, 800, 600) End Sub Public Sub ScreenToGIF_NewWorkbook() Dim wbDest As Workbook, wsDest As Worksheet Dim FromType As String, PicHigh As Single Dim PicWide As Single, PicWideInch As Single Dim PicHighInch As Single, DPI As Long Dim PixelsWide As Integer, PixelsHigh As Integer Call TOGGLEEVENTS(False) Call GetPrintScreen If CountClipboardFormats = 0 Then MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste" Goto EndOfSub End If 'Determine the format of the current clipboard contents. There may be multiple 'formats available but the Paste methods below will always (?) give priority 'to enhanced metafile (picture) if available so look for that first. If IsClipboardFormatAvailable(14) <> 0 Then FromType = "pic" ElseIf IsClipboardFormatAvailable(2) <> 0 Then FromType = "bmp" Else MsgBox "Clipboard does not contain a picture or bitmap to paste.", _ vbExclamation, "No Picture" Exit Sub End If Application.StatusBar = "Pasting from clipboard ..." Set wbDest = Workbooks.Add(xlWBATWorksheet) Set wsDest = wbDest.Sheets(1) wbDest.Activate wsDest.Activate wsDest.Range("B3").Activate 'Paste a picture/bitmap from the clipboard (if possible) and select it. 'The clipboard may contain both text and picture/bitmap format items. If so, 'using just ActiveSheet.Paste will paste the text. Using Pictures.Paste will 'paste a picture if a picture/bitmap format is available, and the Typename 'will return "Picture" (or perhaps "OLEObject"). If *only* text is available, 'Pictures.Paste will create a new TextBox (not a picture) on the sheet and 'the Typename will return "TextBox". (This condition now checked above.) On Error Resume Next 'just in case wsDest.Pictures.Paste.Select On Error Goto 0 'If the pasted item is an "OLEObject" then must convert to a bitmap 'to get the correct size, including the added border and matting. 'Do this via a CopyPicture-Bitmap and then a second Pictures.Paste. If TypeName(Selection) = "OLEObject" Then With Selection .CopyPicture Appearance:=xlScreen, Format:=xlBitmap .Delete ActiveSheet.Pictures.Paste.Select 'Modify the FromType (used below in the suggested file name) 'to signal that the original clipboard image is not being used. FromType = "ole object" End With End If 'Make sure that what was pasted and selected is as expected. 'Note this is the Excel TypeName, not the clipboard format. If TypeName(Selection) = "Picture" Then With Selection PicWide = .Width PicHigh = .Height .Delete End With Else 'Can get to here if a chart is selected and "Copy"ed instead of "Copy Picture"ed. 'Otherwise, ???. If TypeName(Selection) = "ChartObject" Then MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _ vbExclamation, "Got a Chart Copy, not a Chart Picture" Else MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _ vbExclamation, "Not a Picture" End If 'Clean up and quit. ActiveWorkbook.Close SaveChanges:=False Goto EndOfSub End If 'Add an empty embedded chart, sized as above, and activate it. 'Positioned at cell B3 just for convenient debugging and final viewing. 'Tip from Jon Peltier: Just add the embedded chart directly, don't use the 'macro recorder method of adding a new separate chart sheet and then relocating 'the chart back to a worksheet. With Sheets(1) .ChartObjects.Add(.Range("B3").Left, .Range("B3").Top, PicWide, PicHigh).Activate End With 'Paste the [resized] bitmap into the ChartArea, which creates ActiveChart.Shapes(1). On Error Resume Next ActiveChart.Pictures.Paste.Select On Error Goto 0 If TypeName(Selection) = "Picture" Then With ActiveChart 'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1). 'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ??? '''' .Shapes(1).IncrementLeft -1 '''' .Shapes(1).IncrementTop -4 'Remove chart border. This must be done *after* all positioning and sizing. ' .ChartArea.Border.LineStyle = 0 End With 'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG. PicWideInch = PicWide / 72 'points to inches ("logical", not necessarily physical) PicHighInch = PicHigh / 72 DPI = PixelsPerInch() 'typically 96 or 120 dpi for displays PixelsWide = PicWideInch * DPI PixelsHigh = PicHighInch * DPI Else 'Something other than a Picture was pasted into the chart. 'This is very unlikely. MsgBox "Clipboard corrupted, possibly by another task." End If EndOfSub: Call TOGGLEEVENTS(True) End Sub Public Sub TOGGLEEVENTS(blnState As Boolean) 'Originally written by Zack Barresse With Application .DisplayAlerts = blnState .EnableEvents = blnState .ScreenUpdating = blnState If blnState Then .CutCopyMode = False If blnState Then .StatusBar = False End With End Sub Public Function PixelsPerInch() As Long 'Get the screen resolution in pixels per inch. 'Under Excel 2000 and above could use Application.DefaultWebOptions.PixelsPerInch. Dim hdc As Long hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0) PixelsPerInch = GetDeviceCaps(hdc, 88) 'LOGPIXELSX = 88 = Logical pixels/inch in X DeleteDC (hdc) End Function 'Screen Capture Procedure, coordinates are expressed in pixelsPublic Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long) Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE srcDC = CreateDC("DISPLAY", "", "", dm) trgDC = CreateCompatibleDC(srcDC) BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height) SelectObject trgDC, BMPHandle BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY OpenClipboard 0& EmptyClipboard SetClipboardData 2, BMPHandle CloseClipboard DeleteDC trgDC ReleaseDC BMPHandle, srcDC End Sub
Option Explicit '########################################################################## ############# 'Module code for capturing a screen image (Print Screen) and pasting to a new workbook 'Created on November 14th, 2009, compiled by Zack Barresse 'Compiled utilizing the following resources: ' http://www.ac6la.com/makegif.html ' http://www.andreavb.com/tip090001.html '########################################################################## ############# Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source Private Type DEVMODE dmDeviceName As String * CCHDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type 'APIDeclare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Declare Function EmptyClipboard Lib "user32.dll" () As Long Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Declare Function CloseClipboard Lib "user32.dll" () As Long Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function BitBlt Lib "gdi32.dll" (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 Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function CountClipboardFormats Lib "user32" () As Long Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _ (ByVal lpDriverName As String, ByVal lpDeviceName As String, _ ByVal lpOutput As String, lpInitData As Long) As Long Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Sub GetPrintScreen() '##### SET SCREEN CAPTURE SIZES HERE Call CaptureScreen(0, 0, 800, 600) End Sub Public Sub ScreenToGIF_NewWorkbook() Dim wbDest As Workbook, wsDest As Worksheet Dim FromType As String, PicHigh As Single Dim PicWide As Single, PicWideInch As Single Dim PicHighInch As Single, DPI As Long Dim PixelsWide As Integer, PixelsHigh As Integer Call TOGGLEEVENTS(False) Call GetPrintScreen If CountClipboardFormats = 0 Then MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste" Goto EndOfSub End If 'Determine the format of the current clipboard contents. There may be multiple 'formats available but the Paste methods below will always (?) give priority 'to enhanced metafile (picture) if available so look for that first. If IsClipboardFormatAvailable(14) <> 0 Then FromType = "pic" ElseIf IsClipboardFormatAvailable(2) <> 0 Then FromType = "bmp" Else MsgBox "Clipboard does not contain a picture or bitmap to paste.", _ vbExclamation, "No Picture" Exit Sub End If Application.StatusBar = "Pasting from clipboard ..." Set wbDest = Workbooks.Add(xlWBATWorksheet) Set wsDest = wbDest.Sheets(1) wbDest.Activate wsDest.Activate wsDest.Range("B3").Activate 'Paste a picture/bitmap from the clipboard (if possible) and select it. 'The clipboard may contain both text and picture/bitmap format items. If so, 'using just ActiveSheet.Paste will paste the text. Using Pictures.Paste will 'paste a picture if a picture/bitmap format is available, and the Typename 'will return "Picture" (or perhaps "OLEObject"). If *only* text is available, 'Pictures.Paste will create a new TextBox (not a picture) on the sheet and 'the Typename will return "TextBox". (This condition now checked above.) On Error Resume Next 'just in case wsDest.Pictures.Paste.Select On Error Goto 0 'If the pasted item is an "OLEObject" then must convert to a bitmap 'to get the correct size, including the added border and matting. 'Do this via a CopyPicture-Bitmap and then a second Pictures.Paste. If TypeName(Selection) = "OLEObject" Then With Selection .CopyPicture Appearance:=xlScreen, Format:=xlBitmap .Delete ActiveSheet.Pictures.Paste.Select 'Modify the FromType (used below in the suggested file name) 'to signal that the original clipboard image is not being used. FromType = "ole object" End With End If 'Make sure that what was pasted and selected is as expected. 'Note this is the Excel TypeName, not the clipboard format. If TypeName(Selection) = "Picture" Then With Selection PicWide = .Width PicHigh = .Height .Delete End With Else 'Can get to here if a chart is selected and "Copy"ed instead of "Copy Picture"ed. 'Otherwise, ???. If TypeName(Selection) = "ChartObject" Then MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _ vbExclamation, "Got a Chart Copy, not a Chart Picture" Else MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _ vbExclamation, "Not a Picture" End If 'Clean up and quit. ActiveWorkbook.Close SaveChanges:=False Goto EndOfSub End If 'Add an empty embedded chart, sized as above, and activate it. 'Positioned at cell B3 just for convenient debugging and final viewing. 'Tip from Jon Peltier: Just add the embedded chart directly, don't use the 'macro recorder method of adding a new separate chart sheet and then relocating 'the chart back to a worksheet. With Sheets(1) .ChartObjects.Add(.Range("B3").Left, .Range("B3").Top, PicWide, PicHigh).Activate End With 'Paste the [resized] bitmap into the ChartArea, which creates ActiveChart.Shapes(1). On Error Resume Next ActiveChart.Pictures.Paste.Select On Error Goto 0 If TypeName(Selection) = "Picture" Then With ActiveChart 'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1). 'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ??? '''' .Shapes(1).IncrementLeft -1 '''' .Shapes(1).IncrementTop -4 'Remove chart border. This must be done *after* all positioning and sizing. ' .ChartArea.Border.LineStyle = 0 End With 'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG. PicWideInch = PicWide / 72 'points to inches ("logical", not necessarily physical) PicHighInch = PicHigh / 72 DPI = PixelsPerInch() 'typically 96 or 120 dpi for displays PixelsWide = PicWideInch * DPI PixelsHigh = PicHighInch * DPI Else 'Something other than a Picture was pasted into the chart. 'This is very unlikely. MsgBox "Clipboard corrupted, possibly by another task." End If EndOfSub: Call TOGGLEEVENTS(True) End Sub Public Sub TOGGLEEVENTS(blnState As Boolean) 'Originally written by Zack Barresse With Application .DisplayAlerts = blnState .EnableEvents = blnState .ScreenUpdating = blnState If blnState Then .CutCopyMode = False If blnState Then .StatusBar = False End With End Sub Public Function PixelsPerInch() As Long 'Get the screen resolution in pixels per inch. 'Under Excel 2000 and above could use Application.DefaultWebOptions.PixelsPerInch. Dim hdc As Long hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0) PixelsPerInch = GetDeviceCaps(hdc, 88) 'LOGPIXELSX = 88 = Logical pixels/inch in X DeleteDC (hdc) End Function 'Screen Capture Procedure, coordinates are expressed in pixelsPublic Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long) Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE srcDC = CreateDC("DISPLAY", "", "", dm) trgDC = CreateCompatibleDC(srcDC) BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height) SelectObject trgDC, BMPHandle BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY OpenClipboard 0& EmptyClipboard SetClipboardData 2, BMPHandle CloseClipboard DeleteDC trgDC ReleaseDC BMPHandle, srcDC End Sub