Hola gente, mil disculpas que escriba más sobre la captura de pantalla con vb6, estuve mirando `hay infinidades de ejemplos pero con todos me sucede exactamente lo mismo.... cuanto un poco, estoy viendo la posibildad de realizar una aplicación de control remoto algo parecida, al TeamViewer o al VNC,, en vb6. Capturo la pantalla con vb6, y la envio a un servidor ftp, pero tengo varios porblemas, por un lado el envio de la imagen es lento, depende de muchas cosas....
Al capturar la pantalla, esta no se "refresca" lo que hace es copiar una y otra vez la misma imagen con algunos cambios hacia la derecha, osea que queda horrible, una imagen apenas perceptible.... estoy tratando de que se vea lo mas real posible, no se si me explico??? o sea lo que quiero hacer es ver por decir algo una imagen "en tiempo real" de lo que pasa en una computadora en china, desde la mia en casa, aclaro que no es con fines maliciosos, ni maleficos...
pongo un codigo que me funciono bien, pero la imagen resultante se copia una y otra vez a la derecha, y queda horrible..
en un formulario: colocar 1 picture, 1 timer (para capturar cada cierto tiempo)
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Form_Load()
GdipInitialized = False
' GDI+ initialisieren
If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
GdipInitialized = True
Else
MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
' ist GDI+ Initialisiert
If GdipInitialized = True Then
' GDI+ beenden
Call Execute(ShutDownGDIPlus)
End If
End Sub
Private Sub Timer1_Timer()
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture1.Move 0, 0, Screen.Width, Screen.Height
StretchBlt Picture1.hdc, 0, 0, Screen.Width, Screen.Height, GetDC(0), 0, 0, Screen.Width, Screen.Height, vbSrcCopy
If GdipInitialized Then SavePictureAsPNG Picture1.image, "C:\Pantalla.png"
End Sub
y en un modulo
'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.
'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!
Option Explicit
' ----==== GDI+ Konstanten ====----
Public Const GdiPlusVersion As Long = 1
Private Const mimePNG As String = "image/png"
' ----==== Sonstige Typen ====----
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt As Long
End Type
' ----==== GDI+ Typen ====----
Private Type ImageCodecInfo
Clsid As GUID
FormatID As GUID
CodecNamePtr As Long
DllNamePtr As Long
FormatDescriptionPtr As Long
FilenameExtensionPtr As Long
MimeTypePtr As Long
flags As Long
Version As Long
SigCount As Long
SigSize As Long
SigPatternPtr As Long
SigMaskPtr As Long
End Type
Private Type GdiplusStartupOutput
NotificationHook As Long
NotificationUnhook As Long
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
' ----==== GDI+ Enumerationen ====----
' GDI+ Status
Public Enum Status
OK = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(ByVal FileName As Long, ByRef Bitmap As Long) As Status
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
(ByVal hbm As Long, ByVal hPal As Long, _
ByRef Bitmap As Long) As Status
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal Bitmap As Long, ByRef hbmReturn As Long, _
ByVal background As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Status
Private Declare Function GdipGetImageEncoders Lib "gdiplus" _
(ByVal numEncoders As Long, ByVal Size As Long, _
ByRef Encoders As Any) As Status
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" _
(ByRef numEncoders As Long, ByRef Size As Long) As Status
Private Declare Function GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long) As Status
Private Declare Function GdiplusStartup Lib "gdiplus" _
(ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
Optional ByRef lpOutput As Any) As Status
Private Declare Function GdipSaveImageToFile Lib "gdiplus" _
(ByVal image As Long, ByVal FileName As Long, _
ByRef clsidEncoder As GUID, _
ByRef encoderParams As Any) As Status
' ----==== OLE API Deklarationen ====----
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _
(lpPictDesc As PICTDESC, riid As IID, _
ByVal fOwn As Boolean, lplpvObj As Object)
' ----==== Kernel API Deklarationen ====----
Private Declare Function lstrcpyW Lib "kernel32" _
(lpString1 As Any, lpString2 As Any) As Long
Private Declare Function lstrlenW Lib "kernel32" _
(lpString As Any) As Long
' ----==== Variablen ====----
Dim GdipToken As Long
Public GdipInitialized As Boolean
'------------------------------------------------------
' Funktion : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
' GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Public Function Execute(ByVal lReturn As Status) As Status
Dim lCurErr As Status
If lReturn = Status.OK Then
lCurErr = Status.OK
Else
lCurErr = lReturn
MsgBox GdiErrorString(lReturn) & " GDI+ Error:" _
& lReturn, vbOKOnly, "GDI Error"
End If
Execute = lCurErr
End Function
'------------------------------------------------------
' Funktion : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
'------------------------------------------------------
Private Function GdiErrorString(ByVal lError As Status) As String
Dim s As String
Select Case lError
Case GenericError: s = "Generic Error."
Case InvalidParameter: s = "Invalid Parameter."
Case OutOfMemory: s = "Out Of Memory."
Case ObjectBusy: s = "Object Busy."
Case InsufficientBuffer: s = "Insufficient Buffer."
Case NotImplemented: s = "Not Implemented."
Case Win32Error: s = "Win32 Error."
Case WrongState: s = "Wrong State."
Case Aborted: s = "Aborted."
Case FileNotFound: s = "File Not Found."
Case ValueOverflow: s = "Value Overflow."
Case AccessDenied: s = "Access Denied."
Case UnknownImageFormat: s = "Unknown Image Format."
Case FontFamilyNotFound: s = "FontFamily Not Found."
Case FontStyleNotFound: s = "FontStyle Not Found."
Case NotTrueTypeFont: s = "Not TrueType Font."
Case UnsupportedGdiplusVersion: s = "Unsupported Gdiplus Version."
Case GdiplusNotInitialized: s = "Gdiplus Not Initialized."
Case PropertyNotFound: s = "Property Not Found."
Case PropertyNotSupported: s = "Property Not Supported."
Case Else: s = "Unknown GDI+ Error."
End Select
GdiErrorString = s
End Function
'------------------------------------------------------
' Funktion : GetEncoderClsid
' Beschreibung : Ermittelt die Clsid des Encoders
' Übergabewert : mimeType = mimeType des Encoders
' pClsid = CLSID des Encoders (in/out)
' Rückgabewert : True = Ermitteln erfolgreich
' False = Ermitteln fehlgeschlagen
'------------------------------------------------------
Private Function GetEncoderClsid(mimeType As String, _
pClsid As GUID) As Boolean
Dim Num As Long
Dim Size As Long
Dim pImageCodecInfo() As ImageCodecInfo
Dim j As Long
Dim buffer As String
Call GdipGetImageEncodersSize(Num, Size)
If (Size = 0) Then
' fehlgeschlagen
GetEncoderClsid = False
Exit Function
End If
ReDim pImageCodecInfo(0 To Size \ Len(pImageCodecInfo(0)) - 1)
Call GdipGetImageEncoders(Num, Size, pImageCodecInfo(0))
For j = 0 To Num - 1
buffer = _
Space$(lstrlenW(ByVal pImageCodecInfo(j).MimeTypePtr))
Call lstrcpyW(ByVal StrPtr(buffer), _
ByVal pImageCodecInfo(j).MimeTypePtr)
If (StrComp(buffer, mimeType, vbTextCompare) = 0) Then
pClsid = pImageCodecInfo(j).Clsid
Erase pImageCodecInfo
' erfolgreich
GetEncoderClsid = True
Exit Function
End If
Next j
Erase pImageCodecInfo
' fehlgeschlagen
GetEncoderClsid = False
End Function
'------------------------------------------------------
' Funktion : HandleToPicture
' Beschreibung : Umwandeln eines Bitmap Handle
' in ein StdPicture Objekt
' Übergabewert : hGDIHandle = Bitmap Handle
' ObjectType = Bitmaptyp
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function HandleToPicture(ByVal hGDIHandle As Long, _
ByVal ObjectType As PictureTypeConstants, _
Optional ByVal hPal As Long = 0) As StdPicture
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
' Initialisiert die PICTDESC Structur
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = ObjectType
.hgdiObj = hGDIHandle
.hPalOrXYExt = hPal
End With
' Initialisiert das IPicture Interface ID
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Erzeugen des Objekts
OleCreatePictureIndirect tPictDesc, IID_IPicture, _
True, oPicture
' Rückgabe des Pictureobjekts
Set HandleToPicture = oPicture
End Function
'------------------------------------------------------
' Funktion : LoadPicturePlus
' Beschreibung : Lädt ein Bilddatei per GDI+
' Übergabewert : Pfad\Dateiname der Bilddatei
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Public Function LoadPicturePlus( _
ByVal sFileName As String) As StdPicture
Dim lBitmap As Long
Dim hBitmap As Long
' Öffnet die Bilddatei in lBitmap
If Execute(GdipCreateBitmapFromFile(StrPtr(sFileName), _
lBitmap)) = OK Then
' Handle der Bitmap ermitteln lBitmap -> hBitmap
If Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _
hBitmap, 0)) = OK Then
' Erzeugen des StdPicture Objekts von hBitmap
Set LoadPicturePlus = HandleToPicture(hBitmap, _
vbPicTypeBitmap)
End If
' Lösche lBitmap
Call Execute(GdipDisposeImage(lBitmap))
End If
End Function
'------------------------------------------------------
' Funktion : SavePictureAsPNG
' Beschreibung : Speichert ein StdPicture Objekt
' per GDI+ als PNG
' Übergabewert : Pic = StdPicture Objekt
' FileName = Pfad\Dateiname.png
' Rückgabewert : True = speichern erfolgreich
' False = speichern fehlgeschlagen
'------------------------------------------------------
Public Function SavePictureAsPNG(ByVal Pic As StdPicture, _
ByVal sFileName As String) As Boolean
Dim lBitmap As Long
Dim tPicEncoder As GUID
' Erzeugt eine GDI+ Bitmap vom
' StdPicture Handle -> lBitmap
If Execute(GdipCreateBitmapFromHBITMAP( _
Pic.Handle, 0, lBitmap)) = OK Then
' Ermitteln der CLSID vom mimeType Encoder
If GetEncoderClsid(mimePNG, tPicEncoder) = True Then
' Speichert lBitmap als PNG
If Execute(GdipSaveImageToFile(lBitmap, _
StrPtr(sFileName), tPicEncoder, ByVal 0)) = OK Then
' speichern erfolgreich
SavePictureAsPNG = True
Else
' speichern nicht erfolgreich
SavePictureAsPNG = False
End If
Else
' speichern nicht erfolgreich
SavePictureAsPNG = False
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
End If
' Lösche lBitmap
Call Execute(GdipDisposeImage(lBitmap))
End If
End Function
'------------------------------------------------------
' Funktion : StartUpGDIPlus
' Beschreibung : Initialisiert GDI+ Instanz
' Übergabewert : GDI+ Version
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Public Function StartUpGDIPlus(ByVal GdipVersion As Long) As Status
' Initialisieren der GDI+ Instanz
Dim tGdipStartupInput As GDIPlusStartupInput
Dim tGdipStartupOutput As GdiplusStartupOutput
tGdipStartupInput.GdiPlusVersion = GdipVersion
StartUpGDIPlus = GdiplusStartup(GdipToken, _
tGdipStartupInput, tGdipStartupOutput)
End Function
'------------------------------------------------------
' Funktion : ShutDownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Public Function ShutDownGDIPlus() As Status
' Beendet GDI+ Instanz
ShutDownGDIPlus = GdiplusShutdown(GdipToken)
GdipInitialized = False
End Function
'aclaro que este codigo no es mio... lo encontre aqui si no me falla la memoria,
http://leandroascierto.com/foro/index.php?topic=154.msg676#msg676 ¿que me recomiendan? ¿alguien ha hecho algo parecido? no creo ser el único por lo que he visto...
si alguien puede aportar una palabra, le agradezco muchísimo!!! hace meses y meses que pienso y pienso....
saludos cordiales!!!
