Trucos para Visual Basic

[MaN!FesT]

Bueno otra vez molestando yo aqui dejo unos codigos que tal vez les ayuden en un futuro:

Aplicar transparencia a un formulario

Nota: Sólo funcióna en plataformas Windows 2000 para arriba

En un módulo:

Código:

Option Explicit

'Declaración del Api SetLayeredWindowAttributes que establece la transparencia al form

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long ' SI
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

'Declaración del Api SetWindowLong necesaria para aplicar un estilo al form antes de usar el Api anterior

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'solo funciona en xp o 2000 ya que poseen alpha blending
Private Const GWL_EXSTYLE = (-20) ' SI
Private Const LWA_ALPHA = &H2 ' SI
Private Const WS_EX_LAYERED = &H80000 ' SI
Public juegacontrapc As Boolean

'Función de ajuste para saber si formulario ya es transparente. Se le para el Hwnd del formulario en cuestión

Public Function isTransparent(ByVal hWnd As Long) As Boolean
On Error Resume Next
Dim Msg As Long
Msg = GetWindowLong(hWnd, GWL_EXSTYLE)
If (Msg And WS_EX_LAYERED) = WS_EX_LAYERED Then
isTransparent = True
Else
isTransparent = False
End If
If Err Then
isTransparent = False
End If
End Function

'Función que aplica la transparencia, se le pasa el hwnd del form y un valor de 0 a 255
Public Function MakeTransparent(ByVal hWnd As Long, Perc As Integer) As Long
Dim Msg As Long
On Error Resume Next
If Perc < 0 Or Perc > 255 Then
MakeTransparent = 1
Else
Msg = GetWindowLong(hWnd, GWL_EXSTYLE)
Msg = Msg Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, Msg
SetLayeredWindowAttributes hWnd, 0, Perc, LWA_ALPHA
MakeTransparent = 0
End If

If Err Then
MakeTransparent = 2
End If

End Function

 

Ahora colocar un control Scrollbar Horizontal llamado HScroll1 para graduar la transparencia.

En El formulario:

Código:

Private Sub Form_Load()

'Le establecemos un valor por defecto a la barra apenas carga el form
HScroll1.Value = 150
End Sub

Private Sub HScroll1_Change()

'Llamamos a la función pasandole el handle del form y el valor de la transparencia, que es el de la barra
MakeTransparent Me.hWnd, CByte(HScroll1.Value)

End Sub

[MaN!FesT]

Desactivar Ctrl+Alt+Sup en Xp y Nt

Colocar 2 Command llamados CmdActiva y CmdDesactiva:

En un Formulario:

Código:

BOTON PARA DESACTIVAR Ctrl+Alt+Sup:

Private Sub cmdDesactiva_Click()
CreateIntegerKey "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableTaskmgr", "1"
End Sub

'BOTON PARA Activar Ctrl+Alt+Sup:

Private Sub cmdActivar_Click()
CreateIntegerKey "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableTaskmgr", "0"
End Sub

Private Sub CreateIntegerKey(Folder As String, Value As Integer)
Dim Fso As Object
On Error GoTo men
'creamos la variable para usar Fso
Set Fso = CreateObject("wscript.shell")
'Grabamos el valor en el registro con el método regWrite
Fso.RegWrite Folder, Value, "REG_DWORD"

'Eliminamos la variable Fso
Set Fso = Nothing


Exit Sub
'error
men:
MsgBox Err.Description: Resume Next
End Sub

¿Como para que nos podrá servir?

[MaN!FesT]

Descargar una imagen de una Url y mostrarlo en un PictureBox

Colocar 1 PictureBox:

Código:

'Funcion API URLDownloadToFile
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Sub Form_Load()
'Descargamos el archivo de imagen al disco para después cargarla. El parametro1 es la url y el segundo es el path donde se guarda

URLDownloadToFile 0, "http://www.pbs.org/deepspace/images/einstein.gif", App.Path & "\imagen.gif", 0, 0

'Mostramos la imagen en el Picture1
Picture1 = LoadPicture(App.Path + "\imagen.gif ")
Picture1.AutoSize = True

'Eliminamos la imagen descargada anteriormente
Kill App.Path & "\imagen.gif"
End Sub

Bueno descargamos una imagen y se vera en el picture box.

[MaN!FesT]

Deshabilitar Ctrl+ALt+Sup y Alt+Tab en Win 98

Colocar 2 CommandButton, Command1 y Command2:

Código:

Private Const SPI_SCREENSAVERRUNNING = 97&

Private Declare Function SystemParametersInfo Lib "User32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Any, _
ByVal fuWinIni As Long) As Long

Private Sub Form_Load()

Command1.Caption = "Deshabilitar"
Command2.Caption = "Habilitar"

End Sub

Private Sub Form_Unload(Cancel As Integer)
Command2_Click
End Sub

Private Sub Command1_Click()

Dim lngRet As Long
Dim blnOld As Boolean
lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, _
blnOld, 0&)

End Sub

Private Sub Command2_Click()

Dim lngRet As Long
Dim blnOld As Boolean
lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, _
blnOld, 0&)

End Sub

[MaN!FesT]

Registrar el ejecutable para que inicie con Windows

Colocar 2 Command. El Command1 graba la entrada en el registro y el Command2 la elimina:

Código:

Dim Objeto As Object 'Variable de objeto para yusar con Fso
Dim resultado As Variant
Private Sub Command1_Click()
'grabamos la clave con el método RegWrite
Objeto.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
deshabilitabotones
End Sub

Private Sub Command2_Click()
'Borramos la clave con el método RegDelete
Objeto.RegDelete ("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName)

deshabilitabotones
End Sub

Private Sub Form_Load()
'Creamos e instanciamos una variable para poder usar las funciones de FileSystemObject
Set Objeto = CreateObject("WScript.Shell")
End Sub

Private Sub Form_Unload(Cancel As Integer)
'eliminamos la variable de objeto
Set Objeto = Nothing
End Sub

Private Sub deshabilitabotones()
Command2.Enabled = Not Command2.Enabled
Command1.Enabled = Not Command1.Enabled
End Sub

[MaN!FesT]

Listar y matar procesos de Windows

Agregar los siguientes controles:

    *  1 List1 donde se listarán los procesos
    * 1 command1 para ejecutar la Sub Listar
    * 1 command2 para matar el proceso seleccionado

Código:

Dim ListaProcesos As Object
Dim ObjetoWMI As Object
Dim ProcesoACerrar As Object


Private Function MatarProceso(StrNombreProceso As String, Optional DecirSINO As Boolean = True) As Boolean
MatarProceso = False

Set ObjetoWMI = GetObject("winmgmts:")

If IsNull(ObjetoWMI) = False Then

'instanciamos la variable

Set ListaProcesos = ObjetoWMI.InstancesOf("win32_process")

For Each ProcesoACerrar In ListaProcesos
If UCase(ProcesoACerrar.Name) = UCase(StrNombreProceso) Then
If DecirSINO Then

If MsgBox("¿Matar el proceso " & _
ProcesoACerrar.Name & vbNewLine & "...¿Está seguro?", vbYesNo + vbCritical) = vbYes Then

ProcesoACerrar.Terminate (0)

MatarProceso = True

End If

Else

'Matamos el proceso con el método Terminate
ProcesoACerrar.Terminate (0)
MatarProceso = True

End If
End If

Next
End If

Set ListaProcesos = Nothing
Set ObjetoWMI = Nothing
End Function

Private Sub Listar()

Set ObjetoWMI = GetObject("winmgmts:")

If IsNull(ObjetoWMI) = False Then


Set ListaProcesos = ObjetoWMI.InstancesOf("win32_process")

'Recorremos toda las coleccion en lista de procesos y la añadimos al list
For Each ProcesoACerrar In ListaProcesos
List1.AddItem LCase$(ProcesoACerrar.Name)
Next
End If

'Eliminamos las variables de objeto

Set ListaProcesos = Nothing
Set ObjetoWMI = Nothing

End Sub

Private Sub Command1_Click()
'Llamamos a MatarProceso pasandole el nombre
MatarProceso LCase$(List1), True
'Borramos el list
List1.Clear
'Volvemos a listar los procesos
Listar

End Sub

Private Sub Command2_Click()
'Borramos la lista y volvemos a listar los procesos
List1.Clear
Listar

End Sub


 

[MaN!FesT]

Detectar si se hizo Click en cualquier ventana de Windows

En un Formulario poner 1 Timer1 con el interval en 100 o a gusto pero inferior al segundo.

Código:

'Función Api GetWindowText
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'Función Api GetForegroundWindow
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'Función Api GetAsyncKeyState
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Sub Form_Load()

MsgBox "Hacè click en cualquier ventana de Windows"
Me.AutoRedraw = True

End Sub

Private Sub Timer1_Timer() 'probar con distintos intervalos de timer

'El valor que mandamos a la función es para que consulte si se _
ha hecho click, el 1 el botón izq y el 2 el derecho. Si dá verdadero retorna _
32737, y si es así llamamos a la función para capturar el caption de la ventana activa
If GetAsyncKeyState(1) = -32767 Then: retVentanaActiva 'si se ha pulsado el botón izquierdo
If GetAsyncKeyState(2) = -32767 Then: retVentanaActiva 'si se ha pulsado el botón derecho

End Sub

'Procedimiento para capturar el caption de la ventana activa
Private Sub retVentanaActiva()
Dim buffer As String

'recuperamos el Handle de la ventana activa
Handle = GetForegroundWindow

If Handle = 0 Then Exit Sub

buffer = Space(255) 'BUFFER PARA EL CAPTION DE LA VENTANA

GetWindowText Handle, buffer, 255 'RECUPERAMOS EL CAPTION

buffer = Trim$(buffer) 'Le quitamos los espacios
buffer = Left(buffer, Len(buffer) - 1)

'Imprimimos el caption de la ventana en el formulario
Me.Print ">> Se hizo Click en : " & Trim$(buffer)

End Sub

[MaN!FesT]

Detectar el codigo de cada tecla

Colocar un Timer con interval en 100.

Codigo en el formulario:

Código:

'Declaramos el Api GetAsyncKeyState
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Sub Timer1_Timer()

For i = 0 To 255
'Consultamos el valor de la tecla mediante el Api. Si se presionó _
devuelve -32767 y mostramos el valor de i
If GetAsyncKeyState(i) = -32767 Then

MsgBox "Código de la tecla virtual :" & i & vbCrLf & "Tecla " & Chr(i)

End If

Next

End Sub

[MaN!FesT]

Hacer que el mouse se vuelva una mira

Codigo en un Formulario:

Código:

Private Sub Form_Load()
'Ponemos la escala para dibujar en Pixeles
Me.ScaleMode = vbPixels
'Establecemos el ancho de la linea para dibujar en el Form
Me.DrawWidth = 2
'Le ponemos el cursor tipo Mira
Me.MousePointer = 2
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Borramos lo dibujado
Me.Cls
'Dibujamos el circulo con un radio de 25
Me.Circle (X, Y), 25, QBColor(15)
'La linea horizontal
Me.Line (X - 25, Y)-(X + 25, Y)
'La linea vertical
Me.Line (X, Y - 25)-(X, Y + 25)
End Sub

Simple pero efectivo.

[MaN!FesT]

Eliminar el Botón de Inicio de Windows

Colcar 1 Command1 que muestra el Botòn inicio, el Command2 lo oculta o lo elimina

Codigo en un form:

Código:

'Constantes

Const WS_CHILD = &H40000000
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const SW_HIDE = 0
Const SW_NORMAL = 1

'estructura Rect para las coordenadas del botón

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

'Funciones Api

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByValhMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

'Variables varias
Dim tWnd As Long, bWnd As Long, ncWnd As Long

'Boton que reestablece el menu inicio
Private Sub Command1_Click()

'Mostramos el botòn con el Api showWindow
ShowWindow bWnd, SW_NORMAL

'Destruimos el menú
DestroyWindow ncWnd

End Sub

'Boton que oculta el menu inicio

Private Sub Command2_Click()
Dim R As RECT

tWnd = FindWindow("Shell_TrayWnd", vbNullString)
bWnd = FindWindowEx(tWnd, ByVal 0&, "BUTTON", vbNullString)

GetWindowRect bWnd, R

ShowWindow ncWnd, SW_NORMAL

ShowWindow bWnd, SW_HIDE

End Sub

MMM que se podrá hacer......... ..

[MaN!FesT]

Saber el estado de la conexión de red y que tipo de Red estamos usando - Wan, Lan

Colocar 1 Command1:

Código:

Constantes para determinar que tipo de Red estamos conectados

Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2

'Función Api IsNetworkAlive para detectar si estamos conectados y a que tipo de red
Private Declare Function IsNetworkAlive Lib "SENSAPI.DLL" (ByRef lpdwFlags As Long) As Long

Private Sub Command1_Click()
Dim Ret As Long

'Si la Api retorna 0 quiere decir que no hay ningun tipo de conexión de Red
If IsNetworkAlive(Ret) = 0 Then

MsgBox "El sistema no está conectado a una NetWork!"

Else

MsgBox "El sistema está conectado a: " + IIf(Ret = NETWORK_ALIVE_AOL, "AOL", IIf(Ret = NETWORK_ALIVE_LAN, "LAN", "WAN")) + " network!"

End If

End Sub

[MaN!FesT]

Ocultar los iconos del escritorio

Colocar 2 CommandButton. El command1 los oculta el Command2 los muestra.

Código:

'Función Api FindWindowEx
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

'Función Api ShowWindow
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long

'Constantes para ocultar y mostrar los iconos del escritorio
Const SW_SHOW = 5
Const SW_HIDE = 0


'Ocultar los iconos
Private Sub Command1_Click()
Dim Ret As Long

On Error Resume Next
'Obtenemos el Hwnd del escritorio pasandole el nombre de la clase de ventana, en este caso Progman es el escritorio
Ret = FindWindowEx(0&, 0&, "Progman", vbNullString)

'Ocultamos los iconos pasandole a ShowWindow el Hwnd del escritorio
ShowWindow Ret, SW_HIDE
End Sub

'Para Mostrar los iconos
Private Sub Command2_Click()
Dim Ret As Long
On Error Resume Next
'Obtenemos el Hwnd del escritorio
Ret = FindWindowEx(0&, 0&, "Progman", vbNullString)

'Mostramos los iconos pasandole el Hwnd del escritorio
ShowWindow Ret, SW_SHOW
End Sub

.............. ........

[MaN!FesT]

Ponerle contraseña si se intenta abrir el internet Explorer

Colocar un formulario con un Text1, un Timer1 y 1 Command1

Nota: esto también puede sevir para utilizarlo con cualquier tipo de programa o ventana, solo hay que saber el nombre de la clase que se le pasa a la función FindWindow que también se puede obtener mediante el Api GetClassName

Código:

'Declaración del Api FindWindow
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Declaración del Api SendMessage
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'Constantes
Const gcClassnameMSIExplorer = "IEFrame"
Const SC_CLOSE = &HF060&
Const WM_SYSCOMMAND = &H112

Dim cerrar&

Private Sub Command1_Click()
'en este caso la contraseña es administrador

If Not Text1.Text = "administrador" Then
MsgBox "Contraseña Incorrecta", vbCritical, "IEXPLORE"

Else

Form1.Visible = False
Shell "C:\Archivos de programa\Internet Explorer\IEXPLORE.EXE", vbMaximizedFocus
End If

End Sub

Private Sub Form_Load()
On Error Resume Next

'esto hace que la aplicacion si inicie junto con windows
Dim El_Objeto As Object
Set El_Objeto = CreateObject("WScript.Shell")

Resultado = El_Objeto.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Bloqueo")
If Resultado = "" Then
El_Objeto.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Bloqueo", App.Path & "\" & App.EXEName & ".exe"
End If

Text1.PasswordChar = "*"
App.TaskVisible = False
Command1.Default = True
Timer1.Interval = 20

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
'ponle el nombre bloqueo al ejecutable en este caso
Shell App.Path & "/Bloqueo.exe", vbNormalNoFocus
End Sub

Private Sub Timer1_Timer()

cerrar = FindWindow(gcClassnameMSIExplorer, vbNullString)

If cerrar <> 0 Then
If Not Text1.Text = "administrador" Then
Call SendMessage(cerrar, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&)
Form1.Visible = True
End If
End If

If Not cerrar <> 0 And Form1.Visible = False Then
Text1.Text = ""
End If

End Sub

[MaN!FesT]

Reproducir un Gif animado sin utilizar un Ocx y hacerlo mediante código

Bueno este codigo quien sabe donde lo encontre pero muestra como podemos reproducir un Gif animado en un control Image o PictureBox solamente mediante còdigo, es decir leyendo en forma binaria el fichero y obteniendo la secuencia de imagenes.

Colocar un Timer, un Command1 que comienza a reproducir el Gif animado y un control Image con la propiedad Index en 0.

 

Una cosa importante es que no funciona con todos los archivos Gif.

Nota: Colocar el Gif animado dentro de la carpeta del proyecto.

Código:

Option Explicit

Private FrameCount As Long

Private Const LB_DIR As Long = &H18D
Private Const DDL_ARCHIVE As Long = &H20
Private Const DDL_EXCLUSIVE As Long = &H8000
Private Const DDL_FLAGS As Long = DDL_ARCHIVE Or DDL_EXCLUSIVE

Private TotalFrames As Long
Private RepeatTimes As Long

Private Sub Command1_Click()
Dim nFrames As Long
nFrames = LoadGif(App.Path + "\archivoGif.gif", Image1)
If nFrames > 0 Then
FrameCount = 0
Timer1.Interval = CLng(Image1(0).Tag)
Timer1.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
Dim i As Long
If FrameCount < TotalFrames Then

Image1(FrameCount).Visible = False
FrameCount = FrameCount + 1
Else
FrameCount = 0
For i = 1 To Image1.Count - 1
Image1(i).Visible = False
Next i
End If

Image1(FrameCount).Visible = True
Timer1.Interval = CLng(Image1(FrameCount).Tag)
End Sub

Private Function LoadGif(sFile As String, aImg As Variant) As Long


Dim hFile As Long
Dim sImgHeader As String
Dim sFileHeader As String
Dim sBuff As String
Dim sPicsBuff As String
Dim nImgCount As Long
Dim i As Long
Dim j As Long
Dim xOff As Long
Dim yOff As Long
Dim TimeWait As Long
Dim sGifMagic As String

If Dir$(sFile) = "" Or sFile = "" Then
MsgBox "File " & sFile & " not found", vbInformation
Exit Function
End If

sGifMagic = Chr$(0) & Chr$(33) & Chr$(249)

If aImg.Count > 1 Then
For i = 1 To aImg.Count - 1
Unload aImg(i)
Next i
End If

hFile = FreeFile

Open sFile For Binary Access Read As hFile
sBuff = String(LOF(hFile), Chr(0))
Get #hFile, , sBuff
Close #hFile


i = 1
nImgCount = 0
j = InStr(1, sBuff, sGifMagic) + 1
sFileHeader = Left(sBuff, j)

If Left$(sFileHeader, 3) <> "GIF" Then
MsgBox "This file is not a *.gif file", vbInformation
Exit Function
End If

LoadGif = True

i = j + 2

If Len(sFileHeader) >= 127 Then
RepeatTimes& = Asc(Mid(sFileHeader, 126, 1)) + _
(Asc(Mid(sFileHeader, 127, 1)) * 256&)
Else
RepeatTimes = 0
End If

hFile = FreeFile
Open "temp.gif" For Binary As hFile

Do

nImgCount = nImgCount + 1

j = InStr(i, sBuff, sGifMagic) + 3

If j > Len(sGifMagic) Then

sPicsBuff = String(Len(sFileHeader) + j - i, Chr$(0))
sPicsBuff = sFileHeader & Mid(sBuff, i - 1, j - i)
Put #hFile, 1, sPicsBuff

sImgHeader = Left(Mid(sBuff, i - 1, j - i), 16)

TimeWait = ((Asc(Mid(sImgHeader, 4, 1))) + _
(Asc(Mid(sImgHeader, 5, 1)) * 256&)) * 10&

If nImgCount > 1 Then

Load aImg(nImgCount - 1)

xOff = Asc(Mid(sImgHeader, 9, 1)) + _
(Asc(Mid(sImgHeader, 10, 1)) * 256&)

yOff = Asc(Mid(sImgHeader, 11, 1)) + _
(Asc(Mid(sImgHeader, 12, 1)) * 256&)

aImg(nImgCount - 1).Left = aImg(0).Left + _
(xOff * Screen.TwipsPerPixelX)
aImg(nImgCount - 1).Top = aImg(0).Top + _
(yOff * Screen.TwipsPerPixelY)

End If

aImg(nImgCount - 1).Tag = TimeWait
aImg(nImgCount - 1).Picture = LoadPicture("temp.gif")

i = j
End If

Loop Until j = 3

Close #hFile
Kill "temp.gif"

TotalFrames = aImg.Count - 1

LoadGif = TotalFrames
Exit Function

ErrHandler:
MsgBox "Error No. " & Err.Number & " when reading file", vbCritical
LoadGif = False
On Error GoTo 0

End Function

 

[MaN!FesT]

Tomarle una foto a la pantalla y salvarla en C:\

Colocar un Command1

Código:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const KEYEVENTF_KEYUP = 2
'Api para generar una pausa
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Private Sub copiar_Y_Guardar()
On Local Error Resume Next
'Variable para la imagen
Dim imagen As IPictureDisp
keybd_event 44, 0, 0, 0
'mediante Keyevent accionamos la tecla Alt+Printscreen
Set imagen = Clipboard.GetData
DoEvents
'Guardamos la imagen el directorio especificado
SavePicture imagen, "c:\pantalla.bmp"
'eliminamos la imagen de la memoria
Set imagen = Nothing
End Sub

Private Sub Command1_Click()
copiar_Y_Guardar
copiar_Y_Guardar
End Sub