Trucos para Visual Basic

[MaN!FesT]

ahora lo lei todo joder esto lo tendrian que poner en el principio de vb es algo que todos tienen ke ver esto es muy bueno ahi kosas k no savia hacer i las e aprendido leyendo en este post  muy muy muy muy muy buen post gracias

Gracias, pero no me gusta pero en fin acá el changarro de Ranefi también es muy bueno, es básico pero bueno para los que empiezan, más bien quedaría en primero y este en segundo, un poco más avanzado.

Salu2

[xXxDarkSystemxXx]

bueno, empeze ayer con el VB y ps el problema es q no se donde ubicar los codigos, no les pido que me digan todos, solo me interesa el keylogger... si no se puede pues ya tratare de aprenderlo,

Saludos y muy buena la recopilacion, te felicito   

[___PELON___]

Este podrian utilizarlo en sus proyectos de VB... Es un reproductor que pueden aplicarlo cuando este funcionando sus proyectos... xD claro tambien podrian utilizarlo parra ocultar un troyano de su verdadera funcion pero eso ya queda en sus conciencias... jehejehejehjeh ejehe
--------------------------------------------------------------------------------------------------------------




Private Sub Combo2_Click()
On Error GoTo Joda
i = Combo2.ListInd ex
Combo1.ListInd ex = i
ComboLista
Joda:
End Sub

Private Sub Command1_Click()
If Frame1.Visible = False Then
   SONIDOS.Height = 5140
   Frame1.Visible = True
   SONIDOS.Width = 10800
   Label1.Width = 10600
   ProgressBar1.W idth = 10600
   Command1.Pictu re = Command1.Disab ledPicture
   Command1.ToolT ipText = "Modo Compacto"
   If Me.Left > 5000 Then
      Me.Left = 1000
   End If
Else
   SONIDOS.Height = 2080
   Frame1.Visible = False
   SONIDOS.Width = 3560
   Label1.Width = 3400
   ProgressBar1.W idth = 3400
   Command1.ToolT ipText = "Modo Completo"
   Command1.Pictu re = Command1.DownP icture
End If
If File1.Enabled = True Then
   File1.SetFocus
End If
End Sub

Private Sub Command1_Mouse Move(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Command10_Clic k()
On Error GoTo Osso
Dim Arch As String
Dim Q As Integer
Dim Sep As String
Sep = " "
CommonDialog1. CancelError = True
CommonDialog1. InitDir = App.Path
CommonDialog1. Filter = "Listas de Reproducción *.Rof|*.Rof"
CommonDialog1. DialogTitle = "Guardar Listas de Reproducción"
CommonDialog1. DefaultExt = "Rof"
CommonDialog1. ShowSave
Arch = CommonDialog1. FileName
Open Arch For Output As 1
For Q = 0 To Combo1.ListCou nt - 1
   Write #1, Combo1.List(Q), Combo2.List(Q)
Next
Close 1
Osso:
End Sub

Private Sub Command11_Clic k()
On Error GoTo Osso
Dim Arch As String
Dim Reg1 As String
Dim Reg2 As String
Dim Sep As String

CommonDialog1. CancelError = True
CommonDialog1. InitDir = App.Path
CommonDialog1. Filter = "Listas de Reproducción *.Rof|*.Rof"
CommonDialog1. DialogTitle = "Abrir Listas de Reproducción"
CommonDialog1. ShowOpen
Arch = CommonDialog1. FileName
Combo2.Visible = True
Sen = True
Open Arch For Input As 1
While Not EOF(1)
  Input #1, Reg1, Reg2
  Combo1.AddItem Reg1
  Combo2.AddItem Reg2
Wend
Close 1
Combo2.ListInd ex = 0
Osso:
End Sub

Private Sub Command12_Clic k()
On Error GoTo Saltito
Dir1.Path = Fav12
File1.Path = Dir1.Path
If Frame1.Visible = False Then ' Activo modo completo
   Command1_Click
End If
Saltito:
End Sub

Private Sub Command12_Mous eDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Saltito
If Button = 2 Then
   Fav = InputBox("Nueva Carpeta de Emule", "Ruta de Descargas del Emule" + Fav12, Dir1.Path)
   If Fav <> "" Then
      ok = MsgBox("Confirma la Nueva Carpeta " + Fav, vbCritical + vbDefaultButto n2 + vbOKCancel)
       If ok = vbOK Then
          Fav12 = Fav
          Open App.Path + "\Favoritos.Txt" For Output As 1
          Write #1, Fav03; Fav12
          Close 1
       End If
    End If
End If
Saltito:
End Sub

Private Sub Command12_Mous eMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Command13_Clic k()
End Sub

Private Sub Command13_Mous eMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Command14_Clic k()
If Text2.Visible = False Then
   Text2.Visible = True
    If Frame1.Visible = False Then ' Activo modo completo
       Command1_Click
    End If
Else
Text2.Visible = False
End If
End Sub

Private Sub Command14_Mous eMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub



Private Sub Command2_Mouse Move(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Command3_Click()
On Error GoTo Saltito
  ' Establece que la carpeta de temas sea la de Música
Dir1.Path = Fav03
File1.Path = Dir1.Path
If Frame1.Visible = False Then ' Activo modo completo
   Command1_Click
End If
Saltito:
End Sub

Private Sub Command3_Mouse Down(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Saltito
If Button = 2 Then
   Fav = InputBox("Nueva Carpeta de Mi Música", "Ruta de Mi Música " + Fav03, Dir1.Path)
   If Fav <> "" Then
      ok = MsgBox("Confirma la Nueva Carpeta " + Fav, vbCritical + vbDefaultButto n2 + vbOKCancel)
      If ok = vbOK Then
         Fav03 = Fav
         Open App.Path + "\Favoritos.Txt" For Output As 1
         Write #1, Fav03; Fav12
         Close 1
      End If
   End If
End If
Saltito:
End Sub

Private Sub Command3_Mouse Move(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Command4_Click()
'On Error GoTo Asco
For i = 0 To File1.ListCoun t - 1
   Combo1.AddItem File1.Path + "\" + File1.List(i)
   Combo2.AddItem File1.List(i)
Next
Combo1.ListInd ex = 0
Combo2.ListInd ex = 0
With MMControl1
.Command = "stop"
.Command = "close"
End With
Combo2.Visible = True
Combo2.ToolTip Text = Str(Combo1.ListCou nt) + " Temas en Lista"
Command10.Enab led = True
Exit Sub
Asco:
Sen = False
End Sub

Private Sub Command5_Click()
If File1.ListInde x >= 0 Then
   Command10.Enab led = True
   Combo1.AddItem File1.Path + "\" + File1.List(File1.ListInde x)
   Combo1.ListInd ex = 0
   Combo2.AddItem File1.List(File1.ListInde x)
   Combo2.ListInd ex = 0
   Combo2.Visible = True
   Combo2.ToolTip Text = Str(Combo1.ListCou nt) + " Temas en Lista"
Else
   Combo2.Visible = False
   Combo2.ToolTip Text = ""
   Command10.Enab led = False
End If
End Sub

Private Sub Command6_Click()
On Error GoTo Qué_Pasó
With MMControl1
CI = Combo1.ListCou nt
If CI < 1 Then
  Exit Sub
End If
Sen = True
SenPlay = True  ' Para prender una luz
File1.Enabled = False
File1.BackColo r = &H8000000F
Command4.Enabl ed = False
Command5.Enabl ed = False
Command7.Enabl ed = False
Command8.Enabl ed = False

Caption = "Reproductor Mp3 (" + Trim(Str(CI)) + " temas) en Lista "

i = 0
f = Combo1.List(i)
l = Len(Combo1.List(i)) - 4   ' Extrae nombre sin extension de archivo
   NN = ""
   For h = l To 1 Step -1
         X = Mid(Combo1.List(i), h, 1)
          If X = "\" Then
            Exit For
      Else
         NN = NN + X
      End If
   Next
     .ToolTipText = StrReverse(NN)
    .Command = "stop"
    .Command = "close"
    Label1.Caption = .ToolTipText
   .FileName = f
   .Command = "open"    ' abre el archivo
   .Command = "play"
   If .Length > 0 Then  ' para lograr los errores que se puedan hacer por Wav cortos
       ProgressBar1.M ax = .Length
  End If
  Label2 = "Dur.: " + Format(.Length / 600, "00:00:00")
  Dim t As Double
  t = FileLen(f) 'Obtengo la long. del archivo en bytes
  Label3 = "Tam.: " + Format(t / 1024, "#,###,##0 ") + "Kb. - " + FormatDateTime(FileDateTime(f))
End With
Combo2.Visible = True

Exit Sub
Qué_Pasó:
MsgBox (Error(Err))
End Sub

Private Sub Command7_Click()
ok = MsgBox("Confirmas?", vbCritical + vbYesNo, "Vaciar la lista")
If ok = vbYes Then
   Combo1.Clear
   Combo2.Clear
   Sen = False
   Combo2.Visible = False
   Combo2.ToolTip Text = ""
End If
End Sub

Private Sub Command8_Click()
Combo1.ListInd ex = Combo2.ListInd ex
Combo1.RemoveI tem (Combo1.ListInd ex)
Combo2.RemoveI tem (Combo2.ListInd ex)
If Combo2.ListCou nt < 1 Then
   Combo2.Visible = False
   Combo2.ToolTip Text = ""
Else
   Combo2.ListInd ex = 0
   Combo2.ToolTip Text = Str(Combo1.ListCou nt) + " Temas en Lista"
End If
End Sub

Private Sub Command9_Click()
If Sen = True Then ' Está reproduciendo lista
 Combo2.Visible = False
 MMControl1.Com mand = "Stop"
 MMControl1.Com mand = "Close"
 Sen = False
 CI = 0
 i = 0
 File1.Enabled = True
 File1.BackColo r = &HC00000
 Command4.Enabl ed = True
 Command5.Enabl ed = True
 Command7.Enabl ed = True
 Command8.Enabl ed = True
End If
End Sub

Private Sub Dir1_Change()
On Error GoTo Qué_Pasó
File1.Path = Dir1.Path
Exit Sub
Qué_Pasó:
MsgBox (Error(Err))
End Sub

Private Sub Dir1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Drive1_Change()
On Error GoTo Qué_Pasó
Dir1.Path = Drive1.Drive
Exit Sub
Qué_Pasó:
MsgBox (Error(Err))
Resume Next
End Sub

Private Sub File1_Click()
On Error GoTo Qué_Pasó
Cl = 0
Picture3.Cls
NI = File1.ListCoun t
Caption = "'Ak puedes colocar la aplicacion en donde quieres que aparezca tu repproductor y el nombre que le des xD  (" + Trim(Str(NI)) + " Tema)"
f = File1.Path + "\" + File1.FileName
l = Len(File1.FileName) - 4             ' Extraigo el nombre sin la extensión
With MMControl1
.ToolTipText = Left(File1.FileName, l)
If UCase(Right(f, 3)) = "CDA" Then  ' Es un tema de CD
      .EjectVisible = True
Else
    .EjectVisible = False
End If
Coef = 600

If UCase(Right(f, 3)) = "AVI" Or UCase(Right(f, 3)) = "MPG" Then  ' Es un Vídeo
  Coef = 6
End If

.Command = "stop"
.Command = "close"
lg = Len(File1.FileName) - 4
Label1.Caption = Left(File1.FileName, lg)
Tit = Label1.Caption
.FileName = f
.Command = "open" ' abre el filename
.Command = "play"
.Command = "prev"
If .Length > 0 Then  ' evito errores en los Wav cortos
     ProgressBar1.M ax = .Length
End If
Label2.Caption = Format(MMControl1.Pos ition / 600, "00:00:00") + Chr(13) + Format(MMControl1.Len gth / 600, "00:00:00")
Dim t As Double
t = FileLen(f) 'Obtengo la long. del archivo en bytes
Label3 = "Tam.: " + Format(t / 1024, "#,###,##0 ") + "Kb. - " + FormatDateTime(FileDateTime(f))
End With
SenPlay = True  ' Para prender una luz
Exit Sub
End Sub

Private Sub File1_MouseMov e(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then End
If KeyCode = 45 Or KeyCode = 43 Then Command1_Click
If KeyCode = 19 Then
   MMControl1.Com mand = "Pause"
   MMControl1_Pau seClick (0)
End If
If Shift = 2 Then
  Text1.SetFocus
  Select Case KeyCode
     Case 37: Me.Left = Me.Left - 100   ' Cur izq
     Case 39: Me.Left = Me.Left + 100  ' Cur der
     Case 38: Me.Top = Me.Top - 100   ' Cur Arriba
     Case 40: Me.Top = Me.Top + 100   ' Cur Abajo
     Case 16: Command6_Click  ' Ctrl P reproducira una lista xD
  End Select
Else
  File1.SetFocus
End If
If Me.Top < 0 Then
   Me.Top = 0
End If

If Me.Top > 10120 Then
   Me.Top = 10120
End If

If Me.Left < 0 Then
   Me.Left = 0
End If

If Me.Left > 12380 Then
   Me.Left = 12380
End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
  Case 27: End
  Case 45, 43: Command1_Click
  Case 37: Me.Left = Me.Left - 100
End Select
End Sub

'Aplica tu Skin pa que se vea mas Bonito Xd jehejehejeheje hejeh
Private Sub Form_Load()
Skin1.LoadSkin App.Path & "\skinXXX.skn"
 Skin1.ApplySki n Me.hwnd
' Los Wma protegidos generalmente no seran reproducidos
On Error GoTo Paso
Label4.Caption = Format(Date, "dddd  mmm yyyy") ' Muestra la fecha en el reloj
Open App.Path + "\Favoritos.Txt" For Input As 1
Input #1, Fav03, Fav12
Close 1
Randomize
MMControl1.Ena bled = True
SONIDOS.MMCont rol1.Wait = True
MMControl1.Com mand = "CLOSE"
MMControl1.Com mand = "open"
lg = Len(MMControl1.Fil eName) - 4
'Label1.Caption = Left(MMControl1.Fil eName, lg)
MMControl1.Com mand = "play"
Frame1.Visible = True
Dir1.Path = App.Path  ' Establezco que la carpeta inicio sea de la aplicación
File1.Path = Dir1.Path

MMControl1.Com mand = "prev"

Label1.Caption = '"Sonido Que deseen ejecutar ak"
MMControl1.Fil eName = App.Path + "\Cuac.Wav"   ' Este Sonido pordria ser el primero que oiras
MMControl1.Com mand = "open" ' abre el filename
MMControl1.Com mand = "play"
MMControl1.Com mand = "prev"
Sen2 = False
Exit Sub
NI = File1.ListCoun t
Caption = "XXXXXXXXXXXXXX XXXXXX (" + Trim(Str(NI)) + " temas)"
Paso:
SenPlay = True
Resume Next
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
Command9_Click

SONIDOS.MMCont rol1.Notify = True
SONIDOS.MMCont rol1.Wait = False
MMControl1.Com mand = "stop"
MMControl1.Com mand = "close"
MMControl1.Ena bled = False
End Sub

Private Sub Image1_Click()

End Sub

Private Sub Image2_Click()

End Sub

Private Sub Label1_MouseMo ve(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Label2_MouseMo ve(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub MMControl1_Don e(NotifyCode As Integer)
If NotifyCode = 1 Then
   Sen2 = False
   If Sen = False Then
       Lista
   Else
      i = i + 1
      If i < CI Then
        Combo1.ListInd ex = i
        Combo2.ListInd ex = i
        ComboLista
      Else
        MMControl1.Com mand = "Stop"
        MMControl1.Com mand = "Close"
        Label1.Caption = "Fin"
        SenPlay = False
        Cl = 0
        Picture3.Cls
        ProgressBar1.V alue = 0
      End If
   End If
End Sub

Sub Lista()
On Error GoTo Cierre
File1.ListInde x = File1.ListInde x + 1
f = File1.Path + "\" + File1.FileName
lg = Len(File1.FileName) - 4
Label1.Caption = Left(File1.FileName, lg)
MMControl1.Fil eName = f
MMControl1.Com mand = "prev"
MMControl1.Com mand = "open" ' abre el filename
MMControl1.Com mand = "prev"
MMControl1.Com mand = "play"
Sen2 = True
Exit Sub
Cierre:
Picture3.Cls
MMControl1.Com mand = "Stop"
MMControl1.Com mand = "Close"
Label1.Caption = "Fin"
SenPlay = False
ProgressBar1.V alue = 0  ' Vacío la barra de progreso
End Sub

Sub ComboLista()
On Error GoTo Cierre
f = Combo1.List(i)
l = Len(Combo1.List(i)) - 4             ' Extraigo el nombre sin la extensión
l = Len(Combo1.List(i)) - 4             ' Extraigo el nombre sin la extensión
NN = ""
For h = l To 1 Step -1
      X = UCase(Mid(Combo1.List(i), h, 1))
      If X = "\" Then
            Exit For
      Else
         NN = NN + X
      End If
Next
MMControl1.Too lTipText = StrReverse(NN)
Label1.Caption = "Track" + Str(i + 1) + " " + MMControl1.Too lTipText
MMControl1.Com mand = "Stop"
MMControl1.Com mand = "Close"
MMControl1.Fil eName = f
MMControl1.Com mand = "prev"
MMControl1.Com mand = "Open" ' abre el filename
MMControl1.Com mand = "prev"
MMControl1.Com mand = "play"
Exit Sub
Cierre:
Picture3.Cls
MMControl1.Com mand = "Stop"
MMControl1.Com mand = "Close"
Label1.Caption = "Fin"
MMControl1.Too lTipText = "Fin"
ProgressBar1.V alue = 0
SenPlay = False
End Sub

Private Sub play_Click()
MMControl1.Com mand = "play"
MMControl1.Com mand = "prev"
End Sub

Private Sub MMControl1_Pau seClick(Cancel As Integer)
'SenPlay = True
Tx = Tit
If Sen2 = False Then
   Label1.Caption = Tx + " (pausa)"
   SenPlay = False
   Sen2 = True
Else
   Label1.Caption = Tx
   SenPlay = True
   Sen2 = False
End If
End Sub

Private Sub MMControl1_Pla yClick(Cancel As Integer)
Label1.Caption = Tit
SenPlay = True
End Sub

Private Sub MMControl1_Pre vClick(Cancel As Integer)
If Sen = False Then
   File1.ListInde x = File1.ListInde x - 1
   If File1.ListInde x < 0 Then
      File1.ListInde x = 0
   End If
Else
   Combo2.ListInd ex = Combo2.ListInd ex - 1
   If Combo2.ListInd ex < 0 Then
      Combo2.ListInd ex = 0
   End If
End If
End Sub

Private Sub MMControl1_Sta tusUpdate()
On Error GoTo Joda
Cl = Cl + 40
Label2.Caption = Format(MMControl1.Pos ition / Coef, "00:00:00") + Chr(13) + Format(MMControl1.Len gth / Coef, "00:00:00")
ProgressBar1.V alue = MMControl1.Pos ition
If MMControl1.Not ify = True Then
   SenPlay = True
End If

End Sub

Private Sub MMControl1_Sto pClick(Cancel As Integer)
Tx = Tit
Label1.Caption = Tx + " (detenido)"
SenPlay = False
Cl = 0
Picture3.Cls
End Sub

Private Sub Picture1_Mouse Move(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Picture3_Mouse Move(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape4.Left = -3000
Efectos = False
End Sub

Private Sub ProgressBar1_M ouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Efectos = True
End Sub

Private Sub Text2_MouseMov e(Button As Integer, Shift As Integer, X As Single, Y As Single)
Text2.Visible = False
End Sub

Private Sub Timer1_Timer()
Label4.Caption = Time
If SenPlay = True Then
  If Frame1.Visible = True Then ' Está en modo completo
    For P = 1 To 400
       X = Int(7600 * Rnd)
       Y = Int(1000 * Rnd)
       Picture3.PSet (X, Y), QBColor(14)
    Next
   
    Shape4.Left = Shape4.Left + 100
    If Shape4.Left > 24000 Then
      Shape4.Left = 0
    End If
    If Efectos = True Then
      For P = 0 To 15000 Step 20
          Picture3.Line (P, 0)-(P + 500, 500), QBColor(9)
          Picture3.Line (P + 500, 0)-(P, 500), QBColor(9)
     Next
      For P = 1 To 2500
        Pico = Int(10000 * Rnd) + 200
        Picture3.Line (Cl, P)-(P + Pico * Sin(Cl), Cl + 200), QBColor(10)
        Pico = Int(900 * Rnd) + 200
        Picture3.Circl e (P + Pico * Cos(Cl) * 7, Cl), Pico * 2, QBColor(12)
        If Cl > 14400 Then
          Cl = 0
          Picture3.Cls
        End If
        Cl = Cl + 24
      Next P
    Else
          Picture3.Cls
    For Q = 1 To 400  ' Estrellas
       X = Int(7600 * Rnd)
       Y = Int(1000 * Rnd)
       Picture3.PSet (X, Y), QBColor(14)
    Next
    End If
  End If
   If Shape1.BackCol or = &H80000001 Then
      Shape1.BackCol or = QBColor(10)
      Shape2.BackCol or = QBColor(14)
      Shape3.BackCol or = QBColor(10)
   Else
      If Shape1.BackCol or = QBColor(10) Then
         Shape1.BackCol or = QBColor(12)
         Shape2.BackCol or = &H80000001
         Shape3.BackCol or = QBColor(12)
      Else
         Shape1.BackCol or = &H80000001
         Shape2.BackCol or = QBColor(11)
         Shape3.BackCol or = &H80000001
      End If
   End If
Else
      Shape1.BackCol or = &H80000001
      Shape2.BackCol or = &H80000001
      Shape3.BackCol or = &H80000001
End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'    Formulario??? Me
End Sub
--------------------------------------------------------------------------------------------------------------
Ak les keda es sencillito pero al menos sirve xD