Esta sección te permite ver todos los mensajes escritos por este usuario. Ten en cuenta que sólo puedes ver los mensajes escritos en zonas a las que tienes acceso en este momento.
Private Declare Function PrintWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function IsIconic Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function UpdateWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function PrintWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Const WM_SYSCOMMAND As Long = &H112
Private Const SC_RESTORE As Long = &HF120&
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal mHbm As Long, ByVal mhPal As Long, ByRef mBitmap As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, Id As GUID) As Long
Private Sub Form_Load()
Shell "calc.exe" 'esto es solo un ejemplo
End Sub
Private Sub Command1_Click()
Dim hWnd As Long
Dim DestPath As String
DestPath = "C:\Captura1.jpg" 'Destino donde se guardara la imagen
hWnd = FindWindow(vbNullString, "Calculadora") ' handle de la ventana mediante su caption.
If (hWnd <> 0) And (LenB(DestPath) > 0) Then
If CaptureWindow(hWnd, DestPath) Then ' funcion para capturar y guardar la ventana como una imagen.jpg
Me.Picture = LoadPicture(DestPath) ' leemos la image para mostrar el resultado.
End If
End If
End Sub
Private Function CaptureWindow(hWnd As Long, ByVal DestPath As String) As Boolean
Dim tRECT As RECT
Dim lWidth As Long, lHeight As Long
Dim DC As Long
Dim hDCMemory As Long
Dim hBmp As Long
Dim OldhBmp As Long
'Si la ventana esta minimizada la restaura
If IsIconic(hWnd) Then
SendMessage hWnd, WM_SYSCOMMAND, SC_RESTORE, ByVal 0&
DoEvents
End If
'le peta una refrescada
UpdateWindow hWnd
'obtiene las medidas
GetWindowRect hWnd, tRECT
lWidth = tRECT.Right - tRECT.Left
lHeight = tRECT.Bottom - tRECT.Top
'creamos un bitmap y un hdc
DC = GetDC(hWnd)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, lWidth, lHeight)
SelectObject hDCMemory, hBmp
ReleaseDC hWnd, hdc
'imprimimos la ventana en el hdc
PrintWindow hWnd, hDCMemory, 0
'---------- Rutina para guardar el bmp como un jpg mediante GDI Plus
Dim gToken As Long
Dim gdiSI As GDIPlusStartupInput
Dim hImage As Long
Dim tEncoder As GUID
Dim tParams As EncoderParameters
Dim JPG_Quality As Long
JPG_Quality = 80
gdiSI.GdiPlusVersion = &H1
GdiplusStartup gToken, gdiSI
If gToken Then
If GdipCreateBitmapFromHBITMAP(hBmp, 0&, hImage) = 0 Then
CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
With tParams
.Count = 1
.Parameter(0).NumberOfValues = 1&
.Parameter(0).Type = 4&
.Parameter(0).Value = VarPtr(JPG_Quality)
CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
End With
If GdipSaveImageToFile(hImage, StrPtr(DestPath), tEncoder, ByVal tParams) = 0 Then
CaptureWindow = True
End If
GdipDisposeImage hImage
End If
GdiplusShutdown gToken
End If
'-----------
'Liberamos los objetos GDI
DeleteObject SelectObject(hDCMemory, OldhBmp)
DeleteDC hDCMemory
End Function
Option Explicit
Private Sub Form_Load()
Dim G As Double, M As Double, S As Double
DecimalToGMS 32.4525, G, M, S
Debug.Print G, M, S '32.4525 = 32 Grados,27 Minutos,9 Segundos
DecimalToGMS 61.0125731667, G, M, S
Debug.Print G, M, S '61.0125731667 = 61 Grados,0 Minutos,45.2633999976 Segundos
End Sub
Private Function DecimalToGMS(Value As Double, Grado As Double, Minuto As Double, Segundo As Double)
Dim Absolute As Double
Dim sRet As String
Dim lPos As Long
Dim pEntera As Double, pDecimal As Double
Absolute = Abs(Value)
pEntera = Fix(Absolute)
pDecimal = Absolute - pEntera
Grado = pEntera
Absolute = pDecimal * 60
pEntera = Fix(Absolute)
pDecimal = Absolute - pEntera
If pEntera <> Absolute Then
Minuto = pEntera
End If
Segundo = pDecimal * 60
End Function MsgBox VarType(999)
MsgBox vbInteger
B = 999# * 999#
Cita de: imoen en 25 Enero 2013, 12:32 PM
LeandroA, siento decirte que tu código es el mas lento de todo, o al menos eso creo , pq recorres el campo de datos 2 veces , aunque vallas haciendo los saltos de 3 y 5 ademas que los bucles for son quizá los mas lentos , eso combinado con que calculas el modulo te ponen en el codigo mas lento.
Citar
Tiempo BlackZeroX V2 951,788 msec
Resultado BlackZeroX V2 233168
Tiempo BlackZeroX V1 1.537,512 msec
Resultado BlackZeroX V1 233168
Tiempo 7913 6.466,132 msec
Resultado 7913 233168
Tiempo dany 6.169,530 msec
Resultado dany 233168
Tiempo Spyke1 3.692,984 msec
Resultado Spyke1 233168
Tiempo Argentina 60,390 msec
Resultado Argentina 233168
Tiempo LeandroA 1.336,028 msec
Resultado LeandroA 233168
Tiempo BlackZeroX V3 53,147 msec
Resultado BlackZeroX V3 233168