برنامه ای برای عکس گرفتن از دسکتاپ

[M.T.P]

تابع زیر یک کنترل PictureBox رو میگیره و عکس Desktop رو بهش میده.


Option Explicit

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowDC 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 BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Function SnapShot(ByVal CPictureBox As PictureBox) As Long
On Error GoTo 0
Dim CRect As RECT
Dim IntResult As Long
Dim IntScreenhwnd As Long
Dim IntScreenDC As Long
Dim IntScreenWidth As Long
Dim IntScreenHeight As Long

IntScreenhwnd = GetDesktopWindow()
Call GetWindowRect(IntScreenhwnd, CRect)
IntScreenWidth = (CRect.Right - CRect.Left)
IntScreenHeight = (CRect.Bottom - CRect.Top)

CPictureBox.Cls
CPictureBox.Picture = Nothing
CPictureBox.AutoRedraw = True
CPictureBox.Move CPictureBox.Left, CPictureBox.Top, CPictureBox.ScaleX(IntScreenWidth, vbPixels, vbTwips), CPictureBox.ScaleY(IntScreenHeight, vbPixels, vbTwips)

IntScreenDC = GetWindowDC(IntScreenhwnd)
IntResult = BitBlt(CPictureBox.hdc, 0, 0, IntScreenWidth, IntScreenHeight, IntScreenDC, 0, 0, vbSrcCopy)
Call ReleaseDC(IntScreenhwnd, IntScreenDC)
CPictureBox.Picture = CPictureBox.Image

SnapShot = IntResult
End Function

[setroyd]

Dim hwnd As Long
hwnd = GetDesktopWindow()
Dim hdc As Long
hdc = GetDC(hwnd)
a = a + 1
Picture1.AutoRedraw = True
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
BitBlt Picture1.hdc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, hdc, 0, 0, SRCCOPY
SavePicture Picture1.Image, "c:\" & a & ".bmp"


اینم یکم سبکتر و خلوتر

[just4froum]

البته برای کامل کردن گفته های جناب setroyd این چند خط رو قبل از کد ایشون بزنید (برای کسانی که خوب بلد نیستند با api کار کنند مثل خودم)



Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long

[hasht.rood]

كار نميكنه

[just4froum]

حق با شماست

کد آقای setroyd یه مشکل کوچیک داشت که بنده با اجازه درستش کردم. راستی این کد هردفعه عکسگرفته شده از دسکتاپ را در C ذخیره میکند.

یک picturebox در فرم خود بگذارید و هروقت خواستید از صفحه عکس بگیرد بر روی picturebox خالی کلیک کنید.



Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long


Private Sub Picture1_Click()
Dim hwnd As Long
hwnd = GetDesktopWindow()
Dim hdc As Long
hdc = GetDC(hwnd)
a = a + 1
Picture1.AutoRedraw = True
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
BitBlt Picture1.hdc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, hdc, 0, 0, vbSrcCopy
Me.Left = 0
Me.Top = 0
Me.Width = Screen.Width
Me.Height = Screen.Height
SavePicture Picture1.Image, "c:\" & a & ".bmp"
End Sub

[setroyd]

Dim hwnd As Long
hwnd = GetDesktopWindow()
Dim hdc As Long
hdc = GetDC(hwnd)
a = a + 1
Picture1.AutoRedraw = True
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
BitBlt Picture1.hdc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, hdc, 0, 0, vbSrcCopy

SavePicture Picture1.Image, "c:\" & a & ".bmp"

کد درست بود من بجای vbsrccopy از const api استفاده کرده بودم که در بالا نذاشته بودم همین ربطی به تغییر اندازه ی فرم نداره . موفق باشید .

Private Const SRCCOPY = &HCC0020 اگر این رو در قبلی add کنید کار میکنه یا از vbsrccopy استفاده کنید

[just4froum]

کد درست بود من بجای vbsrccopy از const api استفاده کرده بودم که در بالا نذاشته بودم همین ربطی به تغییر اندازه ی فرم نداره .اینو میدونم جناب setroyed همانطور که میبینید من هم آن قسمت را درست کردم و تغییر فرم را برای این اضافه کردم که مثلا می خواستم یکم خلاق باشم.

[setroyd]

اینم بد نیست ولی سری رو که درد نمیکنه دستمال نبندی بهتر نیست !:چشمک: کلا سعی کنید از زیاده نویسی و بیخود بودن کد جلوگیری کنید من برای همین این کد رو گذاشتم .

[just4froum]

اینم بد نیست ولی سری رو که درد نمیکنه دستمال نبندی بهتر نیست !:چشمک: کلا سعی کنید از زیاده نویسی و بیخود بودن کد جلوگیری کنید من برای همین این کد رو گذاشتم .

حتما سعی می کنم از تجربه بسیار شما جناب setroyd نهایت استفاده را ببرم.

[m2011kh]

سلام دوستان.
ببخشید که بعد از یک سال این تاپیکو دوباره بالا میارم.
ولی دارم رو یه پروژه ای کار میکنم که الان به مشکل برخوردم.من باید بعد از هر بار کلیک کردن کاربر عکس بگیرم و همه عکس هارو از ایمیلی به ایمیل دیگری بفرستم.
ولی مشکل اینجاست که اگه طرف 1000 تا کلیک کنه یه چیزی حدود 2 گیگ فایل عکس میشه اگه هم با وینرر فشرده کنم بازم حدودا 100 مگا بایت میشه.با اینکه نمیتونم از کامپوننت استفاده کنم.و برای زیپ کردن فایل ها معمولا به کامپوننت نیاز هست.طرف نمیتونه روزی 100 مگابایت رو ارسال کنه که غالبا خیلی بیشتر از اینا میشه.

اگه راهنمایی کنید ممنون میشم.

[arash.arya43]

بچه ها میشه پروژه کنین بزارین من هر کاری میکنم نمیشه.فقط چیز اضافه نباشه یه دگمه باشه که روش کلیک شد عکس رو تو یه مسیری سیوکنه ممنون:افسرده:

123644

[just4froum]

با سلام :

تنها چیزی که به ذهن من میرسه اینه که شما picturebox رو بر روی فرمتون قرار ندادید !

[arash.arya43]

اره درسته.چون می خوام بعد از تبدیل به فایل اگزه.با یه کلیک تو مسیر دلخواهم عکس سیوبشه دیگه بقیه چیزا معلوم نباشه:لبخندساده:

[just4froum]

با سلام :

نمیدونم این کد از نظر علمی چقدر درسته ولی ببین کارتو راه میندازه ؟


Private Declare Function GetDesktopWindow Lib "user32" () As LongPrivate Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long



Private Sub Form_Load()
LockWindowUpdate Me.hwnd
Call Capture("F:\Test2.bmp")
End Sub


Private Sub Capture(SavePath As String)
Dim hwnd As Long
hwnd = GetDesktopWindow()
Dim hdc As Long
hdc = GetDC(hwnd)
Picture1.AutoRedraw = True
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
BitBlt Picture1.hdc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, hdc, 0, 0, vbSrcCopy
Me.Left = 0
Me.Top = 0
Me.Width = Screen.Width
Me.Height = Screen.Height
Picture1.Left = 0
Picture1.Top = 0
SavePicture Picture1.Image, SavePath
Unload Me
End Sub


Private Sub Form_Unload(Cancel As Integer)
LockWindowUpdate 0
End Sub

[VG1234]

سلام - دوستان براتون پروژه را برای تصویر برداری از دسکتاپ قرار دادم که صد در صد کار میکنه.

http://s5.picofile.com/file/8142755776/Aks.rar.html