Foros del Web - Ver Mensaje Individual

pkj · #4 (**permalink**) 05/10/2009, 09:25

De todas formas como me aburría he creado una sub para hacer iconos transparentes para quien la quiera

Crea un Form con un TextBox y un CommandButton y pega este código en él:

Código Crear icono transparente:

Ver originalOption Explicit
 
Private Sub Form_Load()
  If Right$(App.Path, 1) = "\" Then
    Text1.Text = App.Path & "IconoTransp.ico"
  Else
    Text1.Text = App.Path & "\IconoTransp.ico"
  End If
End Sub
 
Private Sub Command1_Click()
  CreaIcono Text1.Text
End Sub
 
Private Sub CreaIcono(ByVal NombreFichero As String)
 
  Dim F As Long
  Dim NumFichero As Integer
  Dim Cadena As String
  Dim ValorTXT As String
  Dim Contador As Long
  
  On Local Error GoTo ErrorGuardar
  Cadena = "0,0,1,0,1,0,32,32,16,0,0,0,0,0,232,2,0,0,22,0,0,0,40,0,0,0,32,0,0,0,64,0,0,0,1,0,4,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,128,0,0,0,128,128,0,128,0,0,0,128,0,128,0,128,"
  Cadena = Cadena & "128,0,0,192,192,192,0,128,128,128,0,0,0,255,0,0,255,0,0,0,255,255,0,255,0,0,0,255,0,255,0,255,255,0,0"
  Cadena = Cadena & ",255,255,255,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
  Cadena = Cadena & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,"
  Cadena = Cadena & "255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,"
  Cadena = Cadena & "255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,"
  Cadena = Cadena & "255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,"
  Cadena = Cadena & "255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,"
  Cadena = Cadena & "255,255,255,255,255,255,255,255,255,255,255,255,255"
 
  NombreFichero = Text1.Text ' "c:\IconoTransp.ico"
  NumFichero = FreeFile
  
  Open NombreFichero For Binary Access Read Write Lock Read Write As #NumFichero
  For F = 1 To Len(Cadena)
    If Mid$(Cadena, F, 1) <> "," Then
      ValorTXT = ValorTXT & Mid$(Cadena, F, 1)
    Else
      Contador = Contador + 1
      Put #NumFichero, Contador, CByte(Val(ValorTXT))
      ValorTXT = ""
    End If
  Next F
  If ValorTXT <> "" Then
    Contador = Contador + 1
    Put #NumFichero, Contador, CByte(Val(ValorTXT))
    ValorTXT = ""
  End If
  On Local Error GoTo 0
  
ErrorGuardar:
  If Err.Number <> 0 Then MsgBox Err.Description
  Err.Clear
  On Local Error Resume Next
  Close #NumFichero
 
  MsgBox "Trabajo Finalizado"
  On Local Error GoTo 0
 
End Sub

Al pinchar en el botón se creará un fichero .ICO transparente donde marque el TextBox.

Un saludo