'chamada a funcao
PrintScreen 1
Function PrintScreen(ByVal typePrintScreen As Integer)
Select Case typePrintScreen
Case 1
'--- Inicialização dos objetos para HardCopy
Clipboard.Clear
Clipboard.SetData mainCaptureScreen()
'abre excel para receber bmp da area de transferencia
'SE O ARQUIVO NÃO EXISTIR VC DEVE CRIAR ANTES
Shell "C:PrintScreen.xls", vbNormalFocus
End Select
End Function
Function mainCaptureScreen() As Picture
Dim hWndScreen As Long
' Get a handle to the desktop window
hWndScreen = GetDesktopWindow()
' Chama CaptureWindow para capturar todo o desktop identificado pelo handle
' e retorna o objeto Picture resultante
Set mainCaptureScreen = mainCaptureWindow(hWndScreen, False, 0, 0, _
Screen.Width Screen.TwipsPerPixelX, _
Screen.Height Screen.TwipsPerPixelY)
End Function
Public Function mainCaptureWindow(ByVal hWndSrc As Long, _
ByVal Client As Boolean, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
' Dependendo do parametro Client pega o device context apropriado
If Client Then
hDCSrc = GetDC(hWndSrc) ' Pega device context para a area cliente
Else
hDCSrc = GetWindowDC(hWndSrc) ' Pega device context para toda janela
End If
' Cria device context na memória para o processo de copia
hDCMemory = CreateCompatibleDC(hDCSrc)
' Cria o bitmap e armazena na memória DC
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Pega propriedades da tela
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Propriedade Raster
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palete
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Tamanho do palete
' Se tela possui palete executa copia
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Cria uma copia do sistema de palete
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, _
LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Seleciona novo palete na memória DC
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
' Copia da imagem da tela na memória DC
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
LeftSrc, TopSrc, vbSrcCopy)
' Aquisição da nova copia da tela na memória DC
hBmp = SelectObject(hDCMemory, hBmpPrev)
' Se a tela possui palete retorna o sistema de palete adquirido anteriormente
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
' Release the device context resources back to the system
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
' Chama CreateBitmapPicture para criar o objeto picture
' do bitmap e o handle do palete. Retorna o objeto picture.
Set mainCaptureWindow = mainCreateBitmapPicture(hBmp, hPal)
Exit Function
End Function
Public Function mainCreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
' IPicture necessita de uma referência para "Standard OLE Types"
Dim IPic As IPicture
Dim IID_IDispatch As GUID
' Preenche a estrutura IDispatch Interface ID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Preenche Pic com partes necessárias
With Pic
.Size = Len(Pic) ' Comprimento da estrutura
.Type = vbPicTypeBitmap ' Tipo da Picture (bitmap)
.hBmp = hBmp ' Handle para bitmap
.hPal = hPal ' Handle para palete (pode ser null)
End With
' Cria o objeto Picture
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
' Retorna o novo objeto Picture
Set mainCreateBitmapPicture = IPic
End Function
esta macro deve ser criada no arquivo excel vba
Sub auto_open()
' Debug.Assert False
'--- Desabilita as mensagens de alerta do Excel
Application.DisplayAlerts = False
'--- Adiciona uma nova planilha
Application.Sheets.Add
'--- Configura a página
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.393700787401575)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
' .PrintQuality = 300
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.MinPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 90
End With
'--- Insere a figura
ActiveSheet.Paste
'--- Imprime a figura
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
'--- Deleta a planilha
ActiveWindow.SelectedSheets.Delete
'--- Fecha o Aplicativo
Application.Quit
End Sub
