▶ 뭉충닷컴
 
mungchung.com login
Site Search
My Space
주절주절...
공부방
쥔장소개
Board
자유게시판
유용한 정보
자료실
Programming
강좌 & Articles
Spring 3.0
프로그래밍 Tip
   -ASP
   -PHP
   -JavaScript
   -HTML
   -Java/JSP
   -Database
   -Crystal Report
   -Visual Basic
   -이클립스
   -리눅스
   -기타
Windows API (VB)
Spread Sheet 7.0
컴퓨터활용 Tip
Other things
StarCraft 전략
StarCraft 문서
김용(金庸)
Son Q & Dieda
AllAPI.net에서 지금까지 본 소스중 가장 긴 소스다. -_- 코드 분석하고 주석들 한글로 바꾸는 작업하려는게 엄두가 안난다. 그래서 그냥 보기좋게 코드 정리하고 샘플 예제파일 첨부해서 올린다. 캡쳐에 대한 여러가지 방식이 나와 있어 실제로 꽤나 유용할듯한 소스이다.



'--------------------------------------------------------------------------------------------------
// 폼
'--------------------------------------------------------------------------------------------------
' Capture the entire screen
Private Sub Command1_Click()
    Set Picture1.Picture = CaptureScreen()
End Sub

' Capture the entire form including title and border
Private Sub Command2_Click()
    Set Picture1.Picture = CaptureForm(Me)
End Sub

' Capture the client area of the form
Private Sub Command3_Click()
    Set Picture1.Picture = CaptureClient(Me)
End Sub

' Capture the active window after two seconds
Private Sub Command4_Click()
    MsgBox "Two seconds after you close this dialog " & "the active window will be captured."

    ' Wait for two seconds
    Dim EndTime As Date
    EndTime = DateAdd("s", 2, Now)
    Do Until Now > EndTime
        DoEvents
    Loop

    Set Picture1.Picture = CaptureActiveWindow()

    ' Set focus back to form
    Me.SetFocus
End Sub

' Print the current contents of the picture box
Private Sub Command5_Click()
    PrintPictureToFitPage Printer, Picture1.Picture
    Printer.EndDoc
End Sub

' Clear out the picture box
Private Sub Command6_Click()
    Set Picture1.Picture = Nothing
End Sub

' Initialize the form and controls
Private Sub Form_Load()
    Me.Caption = "Capture and Print Example"
    Command1.Caption = "&Screen"
    Command2.Caption = "&Form"
    Command3.Caption = "&Client"
    Command4.Caption = "&Active"
    Command5.Caption = "&Print"
    Command6.Caption = "C&lear"
    Picture1.AutoSize = True
End Sub



'--------------------------------------------------------------------------------------------------
// 모듈
'--------------------------------------------------------------------------------------------------
Option Explicit
Option Base 0

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type

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

#If Win32 Then

    Private Const RASTERCAPS As Long = 38
    Private Const RC_PALETTE As Long = &H100
    Private Const SIZEPALETTE As Long = 104
    
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
    Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
    Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long
    Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
    Private Declare Function GetForegroundWindow Lib "USER32" () As Long
    Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
    Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
    Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
    Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetDesktopWindow Lib "USER32" () As Long
    
    Private Type PicBmp
        Size As Long
        Type As Long
        hBmp As Long
        hPal As Long
        Reserved As Long
    End Type
    
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

#ElseIf Win16 Then

    Private Const RASTERCAPS As Integer = 38
    Private Const RC_PALETTE As Integer = &H100
    Private Const SIZEPALETTE As Integer = 104
    
    Private Type RECT
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
    End Type
    
    Private Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer) As Integer
    Private Declare Function CreateCompatibleBitmap Lib "GDI" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
    Private Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal iCapabilitiy As Integer) As Integer
    Private Declare Function GetSystemPaletteEntries Lib "GDI" (ByVal hDC As Integer, ByVal wStartIndex As Integer, ByVal wNumEntries As Integer, lpPaletteEntries As PALETTEENTRY) As Integer
    Private Declare Function CreatePalette Lib "GDI" (lpLogPalette As LOGPALETTE) As Integer
    Private Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
    Private Declare Function BitBlt Lib "GDI" (ByVal hDCDest As Integer, ByVal XDest As Integer, ByVal YDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hDCSrc As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
    Private Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
    Private Declare Function GetForegroundWindow Lib "USER" Alias "GetActiveWindow" () As Integer
    Private Declare Function SelectPalette Lib "USER" (ByVal hDC As Integer, ByVal hPalette As Integer, ByVal bForceBackground As Integer) As Integer
    Private Declare Function RealizePalette Lib "USER" (ByVal hDC As Integer) As Integer
    Private Declare Function GetWindowDC Lib "USER" (ByVal hWnd As Integer) As Integer
    Private Declare Function GetDC Lib "USER" (ByVal hWnd As Integer) As Integer
    Private Declare Function GetWindowRect Lib "USER" (ByVal hWnd As Integer, lpRect As RECT) As Integer
    Private Declare Function ReleaseDC Lib "USER" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
    Private Declare Function GetDesktopWindow Lib "USER" () As Integer
    
    Private Type PicBmp
        Size As Integer
        Type As Integer
        hBmp As Integer
        hPal As Integer
        Reserved As Integer
    End Type
    
    Private Declare Function OleCreatePictureIndirect Lib "oc25.dll" (PictDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Integer, IPic As IPicture) As Integer

#End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
' - Creates a bitmap type Picture object from a bitmap and palette
'
' hBmp
' - Handle to a bitmap
'
' hPal
' - Handle to a Palette
' - Can be null if the bitmap doesn't use a palette
'
' Returns
' - Returns a Picture object containing the bitmap
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
#If Win32 Then
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim r As Long
#ElseIf Win16 Then
Public Function CreateBitmapPicture(ByVal hBmp As Integer, ByVal hPal As Integer) As Picture
    Dim r As Integer
#End If

    Dim Pic As PicBmp
    ' IPicture requires a reference to "Standard OLE Types"
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    
    With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With
    
    ' Fill Pic with necessary parts
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With
    
    ' Create Picture object
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    
    ' Return the new Picture object
    Set CreateBitmapPicture = IPic
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureWindow
' - Captures any portion of a window
'
' hWndSrc
' - Handle to the window to be captured
'
' Client
' - If True CaptureWindow captures from the client area of the
' window
' - If False CaptureWindow captures from the entire window
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
' - Specify the portion of the window to capture
' - Dimensions need to be specified in pixels
'
' Returns
' - Returns a Picture object containing a bitmap of the specified
' portion of the window that was captured
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''
'
#If Win32 Then
Public Function CaptureWindow(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
#ElseIf Win16 Then
Public Function CaptureWindow(ByVal hWndSrc As Integer, ByVal Client As Boolean, ByVal LeftSrc As Integer, ByVal TopSrc As Integer, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Integer
    Dim hBmp As Integer
    Dim hBmpPrev As Integer
    Dim r As Integer
    Dim hDCSrc As Integer
    Dim hPal As Integer
    Dim hPalPrev As Integer
    Dim RasterCapsScrn As Integer
    Dim HasPaletteScrn As Integer
    Dim PaletteSizeScrn As Integer
#End If
    Dim LogPal As LOGPALETTE

    ' Depending on the value of Client get the proper device context
    If Client Then
        hDCSrc = GetDC(hWndSrc) ' Get device context for client area
    Else
        hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window
    End If

    ' Create a memory device context for the copy process
    hDCMemory = CreateCompatibleDC(hDCSrc)
    ' Create a bitmap and place it in the memory DC
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    ' Get screen properties
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'capabilities
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'support
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
    ' palette
    
    ' If the screen has a palette make a copy and realize it
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        ' Create a copy of the system palette
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, _
        LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        ' Select the new palette into the memory DC and realize it
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)
    End If
    
    ' Copy the on-screen image into the memory DC
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
    LeftSrc, TopSrc, vbSrcCopy)
    
    ' Remove the new copy of the on-screen image
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    
    ' If the screen has a palette get back the palette that was
    ' selected in previously
    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)
    
    ' Call CreateBitmapPicture to create a picture object from the
    ' bitmap and palette handles. Then return the resulting picture
    ' object.
    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureScreen
' - Captures the entire screen
'
' Returns
' - Returns a Picture object containing a bitmap of the screen
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureScreen() As Picture
#If Win32 Then
    Dim hWndScreen As Long
#ElseIf Win16 Then
    Dim hWndScreen As Integer
#End If

    ' Get a handle to the desktop window
    hWndScreen = GetDesktopWindow()
    
    ' Call CaptureWindow to capture the entire desktop give the handle
    ' and return the resulting Picture object
    
    Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width Screen.TwipsPerPixelX, Screen.Height Screen.TwipsPerPixelY)
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureForm
' - Captures an entire form including title bar and border
'
' frmSrc
' - The Form object to capture
'
' Returns
' - Returns a Picture object containing a bitmap of the entire
' form
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureForm(frmSrc As Form) As Picture
    ' Call CaptureWindow to capture the entire form given it's window
    ' handle and then return the resulting Picture object
    Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureClient
' - Captures the client area of a form
'
' frmSrc
' - The Form object to capture
'
' Returns
' - Returns a Picture object containing a bitmap of the form's
' client area
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureClient(frmSrc As Form) As Picture
    ' Call CaptureWindow to capture the client area of the form given
    ' it's window handle and return the resulting Picture object
    Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureActiveWindow
' - Captures the currently active window on the screen
'
' Returns
' - Returns a Picture object containing a bitmap of the active
' window
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureActiveWindow() As Picture
#If Win32 Then
    Dim hWndActive As Long
    Dim r As Long
#ElseIf Win16 Then
    Dim hWndActive As Integer
    Dim r As Integer
#End If
    Dim RectActive As RECT

    ' Get a handle to the active/foreground window
    hWndActive = GetForegroundWindow()
    
    ' Get the dimensions of the window
    r = GetWindowRect(hWndActive, RectActive)
    
    ' Call CaptureWindow to capture the active window given it's
    ' handle and return the Resulting Picture object
    Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintPictureToFitPage
' - Prints a Picture object as big as possible
'
' Prn
' - Destination Printer object
'
' Pic
' - Source Picture object
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
    Const vbHiMetric As Integer = 8
    Dim PicRatio As Double
    Dim PrnWidth As Double
    Dim PrnHeight As Double
    Dim PrnRatio As Double
    Dim PrnPicWidth As Double
    Dim PrnPicHeight As Double
    
    ' Determine if picture should be printed in landscape or portrait
    ' and set the orientation
    If Pic.Height >= Pic.Width Then
        Prn.Orientation = vbPRORPortrait ' Taller than wide
    Else
        Prn.Orientation = vbPRORLandscape ' Wider than tall
    End If
    
    ' Calculate device independent Width to Height ratio for picture
    PicRatio = Pic.Width / Pic.Height
    
    ' Calculate the dimentions of the printable area in HiMetric
    PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
    PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
    ' Calculate device independent Width to Height ratio for printer
    PrnRatio = PrnWidth / PrnHeight
    
    ' Scale the output to the printable area
    If PicRatio >= PrnRatio Then
        ' Scale picture to fit full width of printable area
        PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
        PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
    Else
        ' Scale picture to fit full height of printable area
        PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
        PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
    End If
    
    ' Print the picture using the PaintPicture method
    Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub





Source Page : http://www.mentalis.org/tips/tip010.shtml
문서 첨부 제한 : 0Byte/ 2.00MB
파일 크기 제한 : 2.00MB (허용 확장자 : *.*)
List of Articles
번호 제목 글쓴이 날짜 조회 수
공지 본 게시물들은 AllAPI.net 에서 퍼온것을 수정한겁니다. 뭉충닷컴 2005-05-24 7581
44 스크롤바(ScrollBar) 구현하기 뭉충닷컴 2005-05-25 6272
43 모니터 스크린(Screen) 해상도 구하기 뭉충닷컴 2005-05-25 6628
» 전체화면, 현재 폼, 다른 활성화된 창 캡쳐(Capture)하기 and 프린트(Print) 하기 file 뭉충닷컴 2005-05-25 4974
41 이미지의 투명도(transparent) 설정 뭉충닷컴 2005-05-25 6011
40 이미지크기 늘리기 (이미지 크기 변환) 뭉충닷컴 2005-05-25 6115
39 마우스(Mouse)의 X축 Y축 좌표값 구하기 뭉충닷컴 2005-05-24 7017
38 마우스(Mouse)의 오른쪽/ 왼쪽 버튼 바꾸기 뭉충닷컴 2005-05-24 4279
37 마우스(Mouse)의 커서(Cursor) 숨기기/보이기 뭉충닷컴 2005-05-24 6189
36 리스트박스(ListBox) 위에 마우스 올려졌을때 항목 보여주기 뭉충닷컴 2005-05-24 5642
35 마우스(Mouse) 포인터를 컨트롤로 이동 시키기 뭉충닷컴 2005-05-24 5120
34 제목바(Title Bar) 없이 마우스로 폼 드래그해서 폼 이동시키기 뭉충닷컴 2005-05-24 4697
33 마우스(Mouse) 이동 뭉충닷컴 2005-05-24 4580
32 마우스(Mouse)의 버튼수 구하기 - 그 외 기타 시스템 정보 구하는 법 뭉충닷컴 2005-05-24 4515
31 마우스(Mouse)의 더클클릭(Double-Click) 시간 얻어오기 뭉충닷컴 2005-05-24 4246
30 마우스(Mouse)의 더블클릭(Double-Click) 시간 변경 뭉충닷컴 2005-05-24 4993
29 마우스 움직임을 폼안에서만 가능하도록 제한하기 뭉충닷컴 2005-05-24 4625
28 동영상(avi) 파일 재생하기 뭉충닷컴 2005-05-24 6836
27 자신의 PC에 사운드 카드가 설치되어있는지 여부 검사 뭉충닷컴 2005-05-24 4016
26 미디(MIDI) 파일, 웨이브(Wave) 파일 실행 시키기 뭉충닷컴 2005-05-24 5196