Делаем скриншутер!

[DeMONiZ]

Хочу сделать программу которая фотографировала бы формы программ!
Интересует вопрос возможно ли картинки сохранять в jpg и как все же делать фото формы или элеметов формы?
Я так полагаю без хендлов тут не обойтись.

Мой исходный код:

Код: Выделить всё

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Const SRCCOPY = &HCC0020


Private Sub Command1_Click()
h = GetDC(0)
BitBlt Picture1.hDC, 0, 0, Screen.Width, Screen.Height, h, 0, 0, SRCCOPY
   Picture1.Picture = Picture1.Image
SavePicture Picture1.Picture, "C:\Test.bmp"
End Sub


[vladikcomper]

Интересует вопрос возможно ли картинки сохранять в jpg?

Есть одна очень интересная библа PicSave.dll.
Вот объявления ее функций:

Код: Выделить всё

Public Declare Sub ConvertToJpeg Lib "PicSave.dll" (ByVal PicHDC As Long, ByVal FileName As String, ByVal JpegQuality As Integer, ByVal Width As Long, ByVal Height As Long)
Public Declare Sub ConvertToMetaFile Lib "PicSave.dll" (ByVal PicHDC As Long, ByVal FileName As String, ByVal Width As Long, ByVal Height As Long)
Public Declare Sub MetaFileToBitMap Lib "PicSave.dll" (ByVal FileNameMetaFile As String, ByVal FileNameBitMap As String)


Среди них есть и функция сохранения в Jpeg с настройкой качества.
Еще у меня есть модули для сохранения в TGA, PSD и PNG.

[Debugger]

В кирпичах есть сохранялка в JPG с выбранным качеством.

[vladikcomper]

Для захвата формы потребуется форма Main и некий рисунок tempPic. Функция subActWindow снимает активное окно и сохраняет его изображение на tempPic.

Код: Выделить всё

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function GetWindowPlacement Lib "user32" (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Type WINDOWPLACEMENT
        length As Long
        flags As Long
        showCmd As Long
        ptMinPosition As POINTAPI
        ptMaxPosition As POINTAPI
        rcNormalPosition As RECT
End Type
Dim wp As WINDOWPLACEMENT

Sub SetFoneWin(ByVal hwnd As Long)
    Dim hCurrWnd As Long
    Dim iMyTID As Long
    Dim iCurrTID As Long
   
    hCurrWnd = GetForegroundWindow()
    iMyTID = GetCurrentThreadId()
    iCurrTID = GetWindowThreadProcessId(hCurrWnd, 0)
    AttachThreadInput iMyTID, iCurrTID, True
    SetForegroundWindow (hwnd)
    AttachThreadInput iMyTID, iCurrTID, False
End Sub

Sub subActWindow()
Dim WHWND As Long
Dim r As RECT
Dim w As Long
Dim DeskDc As Long
Dim DeskHwnd As Long

    WHWND = GetForegroundWindow
    GetWindowRect WHWND, r
   
    If r.Right = 0 And r.Left = 0 And r.Bottom = 0 And r.Top = 0 Then
        w = GetWindow(GetDesktopWindow, GW_CHILD)
        w = GetWindow(w, GW_HWNDNEXT)
        SetFoneWin w
        WHWND = GetForegroundWindow
        GetWindowRect WHWND, r
    End If
   
    DeskHwnd = GetDesktopWindow()
    DeskDc = GetDC(DeskHwnd)
   
    GetWindowPlacement WHWND, wp
   
    If r.Left < 0 Then r.Left = 0
    If r.Top < 0 Then r.Top = 0
    If r.Right > scrCX(0) Then r.Right = scrCX(0)
    If r.Bottom > scrCY(0) Then r.Bottom = scrCY(0)
    If wp.flags = 2 Then
        If r.Left > 0 Then r.Left = r.Left + 4
        If r.Top > 0 Then r.Top = r.Top + 4
        r.Right = r.Right - 4
        r.Bottom = r.Bottom - 4
    End If
   
    Main.tempPic.Picture = LoadPicture
    Main.tempPic.Height = (r.Bottom - r.Top) * Screen.TwipsPerPixelY
    Main.tempPic.Width = (r.Right - r.Left) * Screen.TwipsPerPixelX
   
    BitBlt Main.tempPic.hdc, 0, 0, r.Right - r.Left, r.Bottom - r.Top, DeskDc, r.Left, r.Top, vbSrcCopy
   
    ReleaseDC DeskHwnd, DeskDc
End Sub

Function scrCX(Optional in_Twips As Integer) As Long
    scrCX = IIf(in_Twips > 0, GetSystemMetrics(78) * Screen.TwipsPerPixelX, GetSystemMetrics(78))
End Function

Function scrCY(Optional in_Twips As Integer) As Long
    scrCY = IIf(in_Twips > 0, GetSystemMetrics(79) * Screen.TwipsPerPixelY, GetSystemMetrics(79))
End Function


[DeMONiZ]

Интересная штука но немного нето.....надо как то доработать чтоб по указанноому хендлу фоткала.
будем копать этот код может чего и накопаем.

[Andrey Fedorov]

Интересная штука но немного нето.....надо как то доработать чтоб по указанноому хендлу фоткала.
будем копать этот код может чего и накопаем.

Оно совсем не сложно - приходилось делать. Причем делая первый раз переусложнил, сейчас бы сделал лучше и проще.

Формы программ лучше сохранять в PNG - нет потерь в качестве и как правило получается меньший размер чем у JPG-ов (если, конечно, сама форма не перегружена, к примеру, теми же фотографиями).

[DeMONiZ]

Покажи если не сложно свой вариант.

[DeMONiZ]

что то у меня не получается ....

[awl100Alex]

DeMONiZ
Когда-то тоже делал такую штуку, но гораздо проще. Посмотри во вложении...
И никаких дополнительных библиотек не надо! Все выполняется через GDIPlus прямо в VB. Идея взята от сюда...
http://bbs.vbstreets.ru/viewtopic.php?f=51&t=36812
Там вот только изменил значение ClsID декодера для сохранение файлов в формате PNG, как советует Andrey Fedorov, действительно качество не теряется.
Ну а так чтобы прямо элементы форм фотографировать, даже не знаю, но думаю геморройное это дело зачем оно тебе???

[DeMONiZ]

Ну как зачем к примеру создал программу и сделать ее скрин именно формы программы! на всех других я зык видел примеры такого а на vb6 нету!

[DeMONiZ]

Задам вопрос по другому можно ли сделать так еслии программа есть на экране то фоткать ее если нет то нет??

[MIT]

Можно. Делай.

[DeMONiZ]

А подсказку можно дать как это сделать? или какой нибудь пример?

[MIT]

Мне кажется, или тебе уже дали два примера?
Да, а что ты сам сделал для преодаления проблемы? (Только не говори, что "аж написал здесь вопрос")

[DeMONiZ]

Спасибо! Знал бы как сделал совета у тебя прошу вот ты говоришь два примера дак подскажи я не прошу тебе за меня код писать.....

[iGrok]

Спасибо! Знал бы как сделал совета у тебя прошу вот ты говоришь два примера дак подскажи я не прошу тебе за меня код писать.....

Что тебе подсказать? Там пример был от vladikcomper. Чем он тебя не устраивает?

[DeMONiZ]

Всем спасибо все свободны разобрался и сделал! сделал то что первоначально хотел!

[DeMONiZ]

Это пример который дал vladikcomper. С примером разобрался добился нужного результата а вот сохранить картинку из рикчебокса не получается или она сохраняется пустой или же пише ошибку.

Код: Выделить всё

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function GetWindowPlacement Lib "user32" (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Type WINDOWPLACEMENT
        length As Long
        flags As Long
        showCmd As Long
        ptMinPosition As POINTAPI
        ptMaxPosition As POINTAPI
        rcNormalPosition As RECT
End Type
Dim wp As WINDOWPLACEMENT

Sub SetFoneWin(ByVal hwnd As Long)
    Dim hCurrWnd As Long
    Dim iMyTID As Long
    Dim iCurrTID As Long
   
    hCurrWnd = GetForegroundWindow()
    iMyTID = GetCurrentThreadId()
    iCurrTID = GetWindowThreadProcessId(hCurrWnd, 0)
    AttachThreadInput iMyTID, iCurrTID, True
    SetForegroundWindow (hwnd)
    AttachThreadInput iMyTID, iCurrTID, False
End Sub

Sub subActWindow()
Dim WHWND As Long
Dim r As RECT
Dim w As Long
Dim DeskDc As Long
Dim DeskHwnd As Long

    WHWND = GetForegroundWindow
    GetWindowRect WHWND, r
   
    If r.Right = 0 And r.Left = 0 And r.Bottom = 0 And r.Top = 0 Then
        w = GetWindow(GetDesktopWindow, GW_CHILD)
        w = GetWindow(w, GW_HWNDNEXT)
        SetFoneWin w
        WHWND = GetForegroundWindow
        GetWindowRect WHWND, r
    End If
   
    DeskHwnd = GetDesktopWindow()
    DeskDc = GetDC(DeskHwnd)
   
    GetWindowPlacement WHWND, wp
   
    If r.Left < 0 Then r.Left = 0
    If r.Top < 0 Then r.Top = 0
    If r.Right > scrCX(0) Then r.Right = scrCX(0)
    If r.Bottom > scrCY(0) Then r.Bottom = scrCY(0)
    If wp.flags = 2 Then
        If r.Left > 0 Then r.Left = r.Left + 4
        If r.Top > 0 Then r.Top = r.Top + 4
        r.Right = r.Right - 4
        r.Bottom = r.Bottom - 4
    End If
   
    Main.tempPic.Picture = LoadPicture
    Main.tempPic.Height = (r.Bottom - r.Top) * Screen.TwipsPerPixelY
    Main.tempPic.Width = (r.Right - r.Left) * Screen.TwipsPerPixelX
   
    BitBlt Main.tempPic.hdc, 0, 0, r.Right - r.Left, r.Bottom - r.Top, DeskDc, r.Left, r.Top, vbSrcCopy
   
    ReleaseDC DeskHwnd, DeskDc
End Sub

Function scrCX(Optional in_Twips As Integer) As Long
    scrCX = IIf(in_Twips > 0, GetSystemMetrics(78) * Screen.TwipsPerPixelX, GetSystemMetrics(78))
End Function

Function scrCY(Optional in_Twips As Integer) As Long
    scrCY = IIf(in_Twips > 0, GetSystemMetrics(79) * Screen.TwipsPerPixelY, GetSystemMetrics(79))
End Function


делаю так:

Код: Выделить всё

Private Sub Command1_Click()
subActWindow
Main.tempPic.Picture = Main.tempPic.Image
SavePicture Main.tempPic.Image, "C:\Test.bmp"
End Sub


Картинка как бы появляется в пикчебоксе и пропадает почему то, то есть я получаю в результате простое фото пикчебокса а не элемента экрана.
Подскажите где я делаю что то не так?

[DeMONiZ]

Вот код чуть чуть переделал убрал лишнее проблема в том же не получается сохранить картинку...

Код: Выделить всё

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Sub Command1_Click()

Dim r As RECT

    WHWND = 3277556 ' õåíäë ýëåìåíòà
    GetWindowRect WHWND, r
   
    DeskHwnd = GetDesktopWindow()
    DeskDc = GetDC(DeskHwnd)
   
    Main.tempPic.Picture = LoadPicture
    Main.tempPic.Height = (r.Bottom - r.Top) * Screen.TwipsPerPixelY
    Main.tempPic.Width = (r.Right - r.Left) * Screen.TwipsPerPixelX
    BitBlt Main.tempPic.hdc, 0, 0, r.Right - r.Left, r.Bottom - r.Top, DeskDc, r.Left, r.Top, vbSrcCopy


    Text1.Text = WHWND
End Sub

Private Sub Command2_Click()
tempPic.Picture = tempPic.Image
SavePicture tempPic.Image, "C:\Test.bmp"
End Sub




[iGrok]

Вот код чуть чуть переделал убрал лишнее проблема в том же не получается сохранить картинку...

Ну а awl100Alex выкладывал пример, где картинки сохранялись... Неужели у тебя не получается их совместить?

[DeMONiZ]

В bmp сохранить хочу для начала а уж потом и сделаю как там. Выше код посмоти почему не сохраняет пожалусто! (он сохранет картинку с пустым пикчебоксом то есть когда я жму на кнопку по которой сохраняю то изображение из пикчебокса пропадает вот и получается что сохраняю пустоту и не могу понять почему)
Вот например первый пример которым я открывал тему там практически тоже самое сохраняет а тут нет.

[iGrok]

В bmp сохранить хочу для начала а уж потом и сделаю как там. Выше код посмоти почему не сохраняет пожалусто! (он сохранет картинку с пустым пикчебоксом то есть когда я жму на кнопку по которой сохраняю то изображение из пикчебокса пропадает вот и получается что сохраняю пустоту и не могу понять почему)
Вот например первый пример которым я открывал тему там практически тоже самое сохраняет а тут нет.

tempPic.Autoredraw=true

[DeMONiZ]

iGrok спасибо заработало!

[kibernetics]

DeMONiZ, ты ещё проверяй, есть ли веб-камера, и собирай шоты юзеров
А что? У меня в буке есть камера, и фик его знает, может уже есть софт, который сливает всё что видит моя camera.

[DeMONiZ]

Программа делается исключительно для меня. И цель программы уже реализована прктически в полном виде. Программа делается для управлениия одной программой с сотового телефона!

[Andrey Fedorov]

Спасибо! Знал бы как сделал совета у тебя прошу вот ты говоришь два примера дак подскажи я не прошу тебе за меня код писать.....

Держи мой старинный код. Не идеал, но скриншоты окон делает и сохраняет. Может найдешь там то что сгодится.