Temas

[DoEvents¡!]

Hola, a ver si me podeis ayudar...
Es muy sencillo lo que pido...
Tengo esto:

Código [Seleccionar] Expandir

(hola)
Esto me saca todos los "hola" del texto, pero como seria para que no hiciera distincion entre mayusculas y minusculas?¿
Es decir que me sacara tambien :

Hola
hOla
hoLa
...

Gracias  

Pd: Utilizo VB...

DoEvents¡!

[DoEvents¡!]

Hola, bueno aqui os traigo este buscador de adminpaths, no es que me apasione el tema del Deface y esas cosas, pero en fin...
Aviso de antemano que no tengo ni idea de esto, si veis cualquier cosa decidmela...

Código (vb) [Seleccionar] Expandir


'----------------------------------------------------------------------------------------
' *Module  : mCheckAdminPath.bas
' *Author  : *PsYkE1*
' *Mail    : vbpsyke1@mixmail.com
' *Date    : 28/7/10
' *Purpose : Search admin paths of a Website
' *Greets  : xassiz
' *Web     : http://foro.rthacker.net
' *References : http://xassiz.blogspot.com/2009/12/tool-xassiz-pathfinder-by-xassiz.html
'----------------------------------------------------------------------------------------

Option Explicit

Public Function Check_Admin_Path(ByVal sWebSite As String) As String
   Dim sPosiblePath()          As String
   Dim sPosiblePass()          As String
   Dim sActualPath             As String
   Dim lTotalPosiblePass       As Long
   Dim lTotalPosiblePaths      As Long
   Dim y                       As Long
   Dim x                       As Long
   
   Const Paths As String = "admin/,paneldecontrol/,login/,adm/,cms/,admon/,administrador/,admin/login.php,ADMIN/login.php,admin/home.php,admin/controlpanel.html,admin/controlpanel.php,admin.php,admin.html,admin/cp.php,admin/cp.html,cp.php,cp.html,controlpanel/,panelc/,administrator/index.php,administrator/login.html,administrator/login.php,administrator/account.html," _
& "administrator/account.php,administrator.php,administrator.html,login.php,login.html,modelsearch/login.php,moderator.php,moderator.html,moderator/login.php,moderator/login.html,moderator/admin.php,moderator/admin.html,moderator/,account.php,account.html,controlpanel/," _
& "admin/index.asp,admin/login.asp,admin/home.asp,admin/controlpanel.asp,admin.asp,admin/cp.asp,cp.asp,administrator/index.asp,administrator/login.asp,administrator/account.asp,administrator.asp,login.asp,modelsearch/login.asp,moderator.asp,moderator/login.asp,moderator/admin.asp,account.asp," _
& "controlpanel.asp,admincontrol.asp,adminpanel.asp,fileadmin/,fileadmin.php,fileadmin.asp,fileadmin.html,administration/,administration.php,administration.html,sysadmin.php,sysadmin.html,phpmyadmin/,myadmin/,sysadmin.asp,sysadmin/,ur-admin.asp,ur-admin.php,ur-admin.html,ur-admin/,Server.php,Server.html,Server.asp,Server/,wp-admin/,administr8.php,administr8.html," _
& "administr8/,administr8.asp,webadmin/,webadmin.php,webadmin.asp,webadmin.html,administratie/,admins/,admins.php,admins.asp,admins.html,administrivia/,Database_Administration/,WebAdmin/,sysadmins/,admin1/,system-administration/,administrators/,pgadmin/,directadmin/,staradmin/,ServerAdministrator/,SysAdmin/,administer/,sys-admin/,typo3/," _
& "panel/,cpanel/,cPanel/,cpanel_file/,platz_login/,rcLogin/,blogindex/,formslogin/,autologin/,support_login/,meta_login/,manuallogin/,simpleLogin/,loginflat/,utility_login/,showlogin/,memlogin/,members/,login-redirect/,sub-login/,wp-login/,login1/,dir-login/,login_db/,xlogin/,smblogin/,customer_login/,login-us/,acct_login/,admin_area/,bigadmin/,project-admins/,phppgadmin/,pureadmin/," _
& "sql-admin/,radmind/,openvpnadmin/,wizmysqladmin/,vadmind/,ezsqliteadmin/,pwebjetadmin/,newsadmin/,adminpro/,Lotus_Domino_Admin/,bbadmin/,vmailadmin/,Indy_admin/,ccp14admin/,irc-macadmin/,banneradmin/,sshadmin/,phpldapadmin/,macadmin/,administratoraccounts/,admin4_account/,admin4_colon/,radmind-1/,Super-Admin/,AdminTools/,cmsadmin/,SysAdmin2/,globes_admin/,cadmins/,phpSQLiteAdmin/,navSiteAdmin/,server_admin_small/," _
& "logo_sysadmin/,server/,database_administration/,ADMIN/login.html,system_administration/,ss_vms_admin_sm/"
   
   Const Pass As String = "username/,usuario/,user/,password/,contraseña/,senha/,pass/,pwd/,psswrd/"
   
   If Len(sWebSite) > 0 Then
       If Right$(sWebSite, 1) <> "/" Then sWebSite = sWebSite & "/"
       
       sPosiblePass() = Split(Pass, ",")
       sPosiblePath() = Split(Paths, ",")
       lTotalPosiblePass = UBound(sPosiblePass())
       lTotalPosiblePaths = UBound(sPosiblePath())
       
       If Check_Web_Exists(sWebSite) = True Then
           For x = 0 To lTotalPosiblePaths
               sActualPath = sWebSite & sPosiblePath(x)
               If Check_Web_Exists(sActualPath) = True Then
                   For y = 0 To lTotalPosiblePass
                       sActualPath = sWebSite & sPosiblePath(x) & sPosiblePass(y)
                       If Check_Web_Exists(sActualPath) = True Then
                           Check_Admin_Path = sActualPath
                           Exit Function
                       End If
                   Next
               End If
           Next
       End If
   End If
End Function

Function Check_Web_Exists(ByVal sURL As String) As Boolean
   Dim oXHTTP          As Object
   Set oXHTTP = CreateObject("MSXML2.XMLHTTP")

   If Not UCase$(sURL) Like "HTTP:*" Then sURL = "http://" & sURL
   
   On Error GoTo Error_
   With oXHTTP
       .Open "HEAD", sURL, False
       .Send
       If .Status = 200 Then Check_Web_Exists = True
   End With
   
   Set oXHTTP = Nothing
   Exit Function
Error_:
End Function

Un ejemplo:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim sWeb        As String
   Dim sResult     As String
   
   sWeb = "http://www.xxxxxxxxxxx.net"
   sResult = Check_Admin_Path(sWeb)
   
   If Len(sResult) > 0 Then
       Debug.Print sResult
   Else
       Debug.Print "Not Found... :("
   End If
End Sub

Devuelve por ejemplo:

http://www.xxxxxxxxxxx.net/system-administration/pwd/

DoEvents¡!

[DoEvents¡!]

Código (vb) [Seleccionar] Expandir

'-------------------------------------------------------
' *Module  : mTranslator
' *Author  : *PsYkE1*
' *Mail    : vbpsyke1@mixmail.com
' *Date    : 27/7/10
' *Purpose : Translate any text using Google Translator
' *Web     : http://foro.rthacker.net
'-------------------------------------------------------

Option Explicit

Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Public Const IF_NO_CACHE_WRITE = &H4000000

Public Function Get_Html_Code(sURL As String) As String
    Dim sBuffer         As String * 1000
    Dim lInternet       As Long
    Dim lFile           As Long
    Dim lRead           As Long

    lInternet = InternetOpen(0, 1, vbNullString, vbNullString, 0)
    If lInternet <> 0 Then
        lFile = InternetOpenUrl(lInternet, sURL, vbNullString, 0, IF_NO_CACHE_WRITE, 0)
        If lFile <> 0 Then
            Do
                Call InternetReadFile(lFile, sBuffer, 1000, lRead): DoEvents
                Get_Html_Code = Get_Html_Code & Left$(sBuffer, lRead)
            Loop While lRead <> 0
        End If
        Call InternetCloseHandle(lInternet)
    End If
End Function

Public Function Simplified_Language(ByVal sLenguage As String) As String

    sLenguage = LCase$(sLenguage)

    Select Case sLenguage
        Case "albanian":        Simplified_Language = "sq"
        Case "german":          Simplified_Language = "de"
        Case "armenian":        Simplified_Language = "hy"
        Case "bulgarsk":        Simplified_Language = "bg"
        Case "greek":           Simplified_Language = "el"
        Case "dutch":           Simplified_Language = "nl"
        Case "polish":          Simplified_Language = "pl"
        Case "portuguese":      Simplified_Language = "pt"
        Case "spanish":         Simplified_Language = "es"
        Case "swedish":         Simplified_Language = "sv"
        Case "czech":           Simplified_Language = "cs"
        Case "german":          Simplified_Language = "de"
        Case Else
            Simplified_Language = Left$(sLenguage, 2)
        End Select
End Function

Public Function Text_Between_Words(ByVal sTextToAnalyze As String, ByVal sStartWord As String, ByVal sEndWord As String) As String
    Dim lPosition1             As Double
    Dim lPosition2             As Double
    Dim lStart                 As Double

    lPosition1 = InStr(sTextToAnalyze, sStartWord)
    If lPosition1 <> 0 Then
        lStart = lPosition1 + Len(sStartWord)
        lPosition2 = InStr(lStart, sTextToAnalyze, sEndWord)
    Else
        Exit Function
    End If
    If lPosition2 <> 0 Then Text_Between_Words = Mid$(sTextToAnalyze, lStart, lPosition2 - lStart)
End Function

Public Function Translate_Text(ByVal sTextToTranslate As String, ByVal sActualLenguage As String, ByVal sFutureLenguage As String) As String
    Const sGoogleTransUrl As String = "http://translate.google.com/?js=y&prev=_t&hl=es&ie=UTF-8&layout=1&eotf=1&text="

    '# Delimiters
    Const START_TRANSLATED_TEXT        As String = "onmouseout=""this.style.backgroundColor='#fff'"">"
    Const END_TRANSLATED_TEXT          As String = "<br>"

    Dim sGoogleHtml As String

    If sActualLenguage <> sFutureLenguage Then
        sTextToTranslate = Replace$(sTextToTranslate, Chr$(32), "%20")
        sActualLenguage = Simplified_Language(sActualLenguage)
        sFutureLenguage = Simplified_Language(sFutureLenguage)

        sGoogleHtml = Get_Html_Code(sGoogleTransUrl & sTextToTranslate & "%0D%0A%0D%0A&file=&sl=" & sActualLenguage & "&tl=" & sFutureLenguage & "#submit")

        Translate_Text = RTrim$(Text_Between_Words(sGoogleHtml, START_TRANSLATED_TEXT, END_TRANSLATED_TEXT))
    Else
        Translate_Text = sTextToTranslate
    End If
End Function

An example:

Código (vb) [Seleccionar] Expandir

Debug.Print Translate_Text("Hoy estoy un poco cansado, pero creo que este proyecto sera grande.", "spanish", "english")

It returns:

Today I am a little tired, but I think this project will be great.

DoEvents¡!

[DoEvents¡!]

¿Como hago para poder leer caracteres especiales en un TextBox?
Necesito agregar algo asi por ejemplo:

नमस्ते, आपका नाम क्या है

Muchas gracias

DoEvents¡!

Hola, aver si me podeis ayudar:
Veamos, esta es mi expresion regular para obtener todo aquiello que este entre parentesis:

(\(.*?\))

Como hago para que seleccione todo lo que esta entre parentesis peeeeeero sin el parentesis, me explico?

Gracias¡!

[z]

Hola, aqui os dejo una función para obtener la configuracion electronica de cualquier elemento de la tabla periódica...

Mas info: http://es.wikipedia.org/wiki/Configuraci%C3%B3n_electr%C3%B3nica

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* [vbpsyke1@mixmail.com]                    //
' // *Fecha: 20/7/10                                            //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' //  respete la autoria y se me comuniquen esos cambios.       //
' // *Agradecimientos a raul338                                 //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

Option Explicit

Public Function Get_Electronic_Configuration(ByVal bElementValence As Byte) As Collection

   Const ELECTRONIC_CONF        As String = "1s,2s,2p,3s,3p,4s,3d,4p,5s,4d,5p,6s,4f,5d,6p,7s,5f,6d"
   Const EXCEPTION_VALENCES_A   As String = "24,29"               '# Cr & Cu
   Const EXCEPTION_VALENCES_B   As String = "41,42,44,45,46,47"   '# Zr, Nb, Tc, Ru, Rh, Pd & Ag
   Const EXCEPTION_VALENCES_C   As String = "78,79"               '# Pt & Au
   
   Const LIMIT_SUBLEVEL_S   As Byte = 2
   Const LIMIT_SUBLEVEL_P   As Byte = 6
   Const LIMIT_SUBLEVEL_D   As Byte = 10
   Const LIMIT_SUBLEVEL_F   As Byte = 14
   
   Dim cTemp               As New Collection
   Dim sSubLevel()         As String
   Dim sActualItem         As String * 2
   Dim bInvalidValenceA    As Boolean
   Dim bInvalidValenceB    As Boolean
   Dim bInvalidValenceC    As Boolean
   Dim bElectron           As Byte
   Dim bActualLimit        As Byte
   Dim x                   As Byte
   Dim n                   As Byte
   Dim y                   As Byte
   
   If bElementValence > 0 And bElementValence < 112 Then '# Hasta el elemento Roentgenio [Uuu]
       sSubLevel() = Split(ELECTRONIC_CONF, ",")
           
       '# Compruebo si la valencia introducida es una excepción
       bInvalidValenceA = CBool (InStr(EXCEPTION_VALENCES_A, CStr(bElementValence)))
       bInvalidValenceB = CBool (InStr(EXCEPTION_VALENCES_B, CStr(bElementValence)))
       bInvalidValenceC = CBool (InStr(EXCEPTION_VALENCES_C, CStr(bElementValence)))
       
       For x = 0 To UBound(sSubLevel())
           sActualItem = sSubLevel(x)
           
           '# Reviso el subnivel en el que me encuentro
           Select Case Right$(sActualItem, 1)
               Case "s": bActualLimit = LIMIT_SUBLEVEL_S
               Case "p": bActualLimit = LIMIT_SUBLEVEL_P
               Case "d": bActualLimit = LIMIT_SUBLEVEL_D
               Case "f": bActualLimit = LIMIT_SUBLEVEL_F
           End Select
           
           '# Relleno cada capa de eletrones
           For y = 1 To bActualLimit
               If n <> bElementValence Then n = n + 1 Else Exit For

               '# Hay excepciones: Si la configuración electrónica acaba en d4 o en d9
               '# el subnivel anterior cede un electrón para estabilizarlo (en la mayoria de los casos)
               If (sActualItem = "4s" And bInvalidValenceA = True) Or (sActualItem = "5s" And bInvalidValenceB = True) Or _
               sActualItem = "6s" And bInvalidValenceC = True Then
                   bElectron = 1
                   Exit For
               Else
                   bElectron = bElectron + 1
               End If
           Next y
           
           '# Añado el Item con los electrones que tenga
           cTemp.Add sActualItem & CStr(bElectron)
           
           If n = bElementValence Then Exit For
           bElectron = 0
       Next x
       Set Get_Electronic_Configuration = cTemp
   End If
End Function

Para que veais, un ejemplo:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim sResult        As String
   Dim vItem          As Variant
   Dim z              As Byte
   
   z = 29 '# El Cobre [Cu]
   
   For Each vItem In Get_Electronic_Configuration(z)
       sResult = sResult & vItem & " "
   Next vItem
   
   Debug.Print sResult
End Sub

Me devuelve esto:

1s2 2s2 2p6 3s2 3p6 4s1 3d10

Si en la variable z pongo 97 (Berkelio [Bk]) me da esto:

1s2 2s2 2p6 3s2 3p6 4s2 3d10 4p6 5s2 4d10 5p6 6s2 4f14 5d10 6p6 7s2 5f9

Bueno esto es todo...

PD: Saludo a mi profesora de clases Marta Suarez  

DoEvents¡!

Creo que puede ser divertido, empezare yo:

• Escéptico
• Gracioso
• Insistente

SAlu2!

[BlackZer0X]

Hola chicos, esta es mi ultima funcion que sirve para simplificar arrays numéricos.
En realidad es un reto que me puso mi maestro BlackZer0X!

Añadir mi clase cCollectionEx.cls

Código (vb) [Seleccionar] Expandir


'=========================================================
' º Function : Abbreviate_Numeric_Array
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://blog.visual-coders.com.ar/
'       http://InfrAngeluX.Sytes.Net/
'=========================================================
Option Explicit
Option Base 0

Rem Añadir mi clase cCollectionEx.cls

Public Function Abbreviate_Numeric_Array(ByRef vNumberList() As Variant) As cCollectionEx
If (Not vNumberList) = -1 Then Exit Function
Dim cExTemp                                         As New cCollectionEx
Dim lActualNumber                                   As Variant
Dim lToTalNumbers                                   As Long
Dim Q                                               As Long
Dim W                                               As Long
   lToTalNumbers = UBound(vNumberList())
   If lToTalNumbers > 2 Then
       Do While Q <= lToTalNumbers
           lActualNumber = vNumberList(Q)
           W = 0
           If (Q < lToTalNumbers) Then
               Do While (vNumberList(Q) + 1 = vNumberList(Q + 1)) Or _
                        (vNumberList(Q) = vNumberList(Q + 1))
                   Q = Q + 1
                   W = W + 1
               Loop
           End If
           With cExTemp
               If W > 1 Then
                   .Add lActualNumber & "~" & vNumberList(Q)
               Else
                   .Add lActualNumber
               End If
           End With
           If Not (W = 1) Then Q = Q + 1
       Loop
       Set Abbreviate_Numeric_Array = cExTemp
   End If
End Function

Ejemplo:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
Dim Q                                   As Long
Dim dArray()                            As Variant
Dim sResult                             As String

   dArray() = Array(1, 2, 3, 4, 4, 5, 6, 7, 7, 7, 65, 345, 4545, 4546, 4547, 9999999, 9999999999#)
   
   With Abbreviate_Numeric_Array(dArray)
       For Q = 1 To .Count
           sResult = sResult & .Item(Q) & "|"
       Next Q
   End With
   
   Debug.Print sResult
End Sub

Obtengo esto:

1~7|65|345|4545~4547|9999999|9999999999|

Ahora mi funcion para desabreviar...

Código (vb) [Seleccionar] Expandir


'=========================================================
' º Function : DeAbbreviate_Numeric_Array
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://blog.visual-coders.com.ar/
'       http://InfrAngeluX.Sytes.Net/
'=========================================================
Option Explicit
Option Base 0

Public Function DeAbbreviate_Numeric_Array(ByRef sNumbersItems() As String) As cCollectionEx
If (Not sNumbersItems) = -1 Then Exit Function
Dim cExTemp                                         As New cCollectionEx
Dim sActualItem                                     As String
Dim sNumbers()                                      As String
Dim lToTalItems                                     As Long
Dim Q                                               As Long
Dim W                                               As Long
   lToTalItems = UBound(sNumbersItems())
   If lToTalItems > 2 Then
       For Q = 0 To lToTalItems
           sActualItem = sNumbersItems(Q)
           If sActualItem Like "*~*" Then
               sNumbers() = Split(sActualItem, "~")
               For W = CDbl(sNumbers(0)) To CDbl(sNumbers(1))
                   cExTemp.Add W
               Next W
           Else
               cExTemp.Add sActualItem
           End If
       Next Q
       Set DeAbbreviate_Numeric_Array = cExTemp
   End If
End Function

Un ejemplo:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
Dim sArray()                    As String
Dim Q                           As Long

   sArray() = Split("1|2|8|9|34|56~58|9999~10002|", "|")
   With DeAbbreviate_Numeric_Array(sArray())
       For Q = 1 To .Count
           Debug.Print .Item(Q)
       Next Q
   End With
End Sub

Me da esto:

1
2
8
9
34
56
57
58
9999
10000
10001
10002

DoEvents!

Pues eso...
¿Cual es la pero pelicula que has visto en la vida?
A ver si alguien supera a esta:

[youtube=425,350]http://www.youtube.com/watch?v=JQq82cV4aGY&feature=fvst[/youtube]

Salu2!

Hola, se que debo de ser un pesado ya con tanta cadena, pero bueno...
Aqui os dejo esta funcion que acabo de hacer, que igual a alguien le es util...

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

Option Explicit

Public Function Text_Beetwen_Chars(ByVal sStringToAnalyze, ByVal sCharStart, ByVal sCharEnd, _
Optional ByVal bRemoveString As Boolean = True)
   Dim sActualChar          As String * 1
   Dim sPreviousChar        As String * 1
   Dim bFlag                As Boolean
   Dim lToTalLen            As Long
   Dim lToTalChar           As Long
   Dim x                    As Long
   Dim y                    As Long

   lToTalChar = Len(sStringToAnalyze)
   If (lToTalChar > 0) And (sCharStart <> sCharEnd) Then
       For x = 1 To lToTalChar
           If x > 1 Then sPreviousChar = Mid$(sStringToAnalyze, x - 1, 1)
           sActualChar = Mid$(sStringToAnalyze, x, 1)
           lToTalLen = Len(Text_Beetwen_Chars)
           Select Case sActualChar
               Case sCharStart
                   If bFlag = False Then bFlag = True Else y = y + 1
                   If sPreviousChar = Chr$(32) And y = 0 And lToTalLen > 0 Then
                       Text_Beetwen_Chars = Left$(Text_Beetwen_Chars, (lToTalLen - 1))
                   End If
                   If bRemoveString = True Then sActualChar = Chr$(32)
               Case sCharEnd
                   If y = 0 Then bFlag = False Else y = y - 1
                   If bRemoveString = True Then sActualChar = Chr$(32)
           End Select
           If bFlag = bRemoveString And (sActualChar <> sCharStart And sActualChar <> sCharEnd) Then
               Text_Beetwen_Chars = Text_Beetwen_Chars & sActualChar
           End If
       Next x
   End If
End Function

Un ejemplos:

Tengo un texto y quiero omitir todo lo que este entre parentesis...

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Debug.Print Text_Beetwen_Chars("Hola amigos (esto solo es una prueba(jejejeje) ), de este modo veis que funciona...", "(", ")", False)
End Sub

Me devuelve:

Hola amigos, de este modo veis que funciona...

Y ahora el caso contrario, supongamos que necesito SOLO el texto que se encuentra entre parentesis:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Debug.Print Text_Beetwen_Chars("Hola amigos (esto solo es una prueba(jejejeje) ), de este modo veis que funciona...", "(", ")") ' Por defecto bRemoveString es True =)
End Sub

Este es el resultado:

esto solo es una prueba jejejeje

Si me animo un dia de estos la mejorare...
Espero que a alguien le sirva!!

Salu2!

Aqui os dejo esta sencilla función para saber si un caracter es vocal, consonante, numérico o es un símbolo...

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////
Option Explicit

Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long

Public Function Check_Char(ByVal sChar As String) As Integer
   '0 --> Error
   '1 --> Numérico
   '2 --> Vocálico
   '3 --> Consonante
   '4 --> Simbólico
   Const sVowel As String = "aeiou"
   If Len(sChar) = 1 Then
       If IsCharAlphaNumeric(Asc(sChar)) Then
           If IsNumeric(sChar) Then
               Check_Char = 1
           ElseIf InStr(sVowel, sChar) > 0 Then
               Check_Char = 2
           Else
               Check_Char = 3
           End If
       Else
           Check_Char = 4
       End If
   End If
End Function

Un ejemplo:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
   Dim sCharToCheck As String * 1
   sCharToCheck = "/"
   Select Case Check_Char(sCharToCheck)
       Case 1: Debug.Print "El carácter "; sCharToCheck; " es un número"
       Case 2: Debug.Print "El carácter "; sCharToCheck; " es una vocal"
       Case 3: Debug.Print "El carácter "; sCharToCheck; " es una consonante"
       Case 4: Debug.Print "El carácter "; sCharToCheck; " es un símbolo"
       Case Else: Debug.Print "Error al analizar "; sCharToCheck
   End Select
End Sub

Salu2!

Hola a ver si me podeis ayudar:
Estoy conectado por wifi a una red y queria saber si hay alguna forma de ser "invisible", es decir, que si otro usuario de esa red intenta ver que usuarios estan conectados, no me vea... Es posible?
Tengo Win XP y es WPA2...

Gracias!

Holaa todos! 
A ver si me podeis ayudar, mi pregunta es:
¿Como hago para que el titulo de una ventana sea difetente a el titulo de la pestaña de la barra de tareas? 
Es decir, ¿Puedo asignar el nombre a la pestaña de mi programa en la barra de tareas?

Gracias

Hola, me gustaria saber una manera rapida y sencilla de hacer mis propias userbars...

Gracias!

No se que me pasa, llevo 100 visitas seguidas en este video, e incluso me estoy panteando comprarme uno...
¿Por que no puedo parar de verlo?
[youtube=425,350]http://www.youtube.com/watch?v=xXHUdvvHTkw[/youtube]
Gracias por la ayuda

[win XP]

Hola, a ver si me podeis solucionar este problema:
estoy harto de que me suene en tuenti un sonidillo cada vez que alguien me habla por el chat...
Hay alguna forma de silenciar solo la web del tuenti?? 
Tengo win XP y utilizo la ultima version de FireFox...

Gracias 

[cualquier cosa]

Hola chicos!!  
Abro este post pra pediros consejos, sugerencias, mejoras, cualquier cosa que se os ocurra para la futura version de NRC...
Ver post NRC v1.0
Cualquier sugerencia sera bienvenida...  

Gracias

Buf, me parecio muy bueno:

El fútbol es un deporte muy sencillo. Consiste en pegarle patadas a una pelota y meterla entre tres palos. El que más veces la meta, gana. Si no se mete, pues se empata o se pierde, pero siempre queda mal sabor de boca, tal vez porque la clave está en meterla, como en casi todo en la vida.
España inició el mundial como "favorita", eso dicen. Saltó al campo, comenzó a jugar y se olvidó de lo fundamental, o sea, que la clave está en meterla.
Su juego bonito les deslumbró. Se maravillaron y extasiaron de su pase al primer toque, de su mimo al balón. Pero eso sucedía en el centro del campo. Y de ahí hacia atrás.
Si de Luis habían copiado la garra y la mala leche, de Del Bosque copiaron la parsimonia. Y así no se mete.
Yo, que no entiendo de fútbol como los que entienden, digo que el primer tiempo contra Suiza fue un puro bostezo que presagiaba catástrofe. No hay nada peor que auto complacerse, que creerse bueno, listo o genial. Bueno, peor es creerse favorito.
Luis lo dijo al final... "salieron creyéndose los favoritos". Y los comentaristas de la tele se lo creían aún más, lo que les impedía ver la realidad, o sea, lo que pasó.
Decían que Suiza estaba acojonada. En realidad estaba plácidamente tranquila, porque en toda la primera parte España no creó ni una ocasión de peligro.
En el descanso, perdido el lógico respeto que inspiraba España, Suiza se atrevió a más. Y consiguió su fruto. Da igual cómo. Ahora ya da igual, porque el fruto se lo llevaron ellos.
España, y no sólo los jugadores, sino todos los españoles, no se lo creían.
Yo, que no entiendo de fútbol como los que entienden, ya lo había anunciado, dije que pasaría y pasó. No es que sea más listo, simplemente era lógico. Es lo que pasa en casos como el de ayer. Tenemos experiencia en ello.
El fútbol consiste en meter la bola entre los tres palos, pero para eso hay que, al menos, intentarlo. Todo lo demás no es fútbol.
Después del gol España, mientras Del Bosque jugaba con el bigote sin creérselo todavía, España sacó algo de la garra de Luis, pero no lo hizo con cabeza, no lo hizo con fútbol, sino recurriendo al sistema de los impotentes, es decir, colgar balones al área. La fórmula que nunca funciona. El recurso de los torpes.
Los comentaristas de la tele decían que cuando entrara el primero entrarían varios más. Pero no entró el primero. Sí pudo entrar el segundo de Suiza, porque Suiza sabía a qué jugaba. España no.
A pesar de todo, seguíamos oyendo que somos favoritos. Oé, oé, oé...
Yo, que a esas alturas ya había desconectado del partido, pensaba en la paranoia sembrada con el "somos favoritos" y la comparaba con la victoria franquista contra Rusia y el gol de Marcelino. Aquello fue exaltación del Régimen y esto terapia contra la crisis. Con lo cual el fútbol sigue siendo el opio del pueblo, que decía Stalin, sólo que cambiando religión por fútbol. Pero... ¿no es Maradona "Dios"? ¿Alguien oyó a alguien decir que Rouco era "Dios"? ¿O Benedicto, a pesar de su angelical sonrisa? Pues eso.
Pero, volviendo al deporte religión, perdón, al deporte rey, que nadie se suicide ni se deprima. España sigue siendo favorita, oé, oé, oé.
Tocamos el balón como nadie, lo acariciamos, lo movemos, lo sobamos y, como pasó ante Suiza, podemos llegar hasta el orgasmo colectivo y el consiguiente bajón posterior. Pero no la metemos. Corremos, pero sin meterla. ¿Lo pillan?
Otros, más torpes y menos estéticos, van y la meten de un empujón. A lo bruto.
Si yo fuera portería lo tendría claro, me quedaría con el brutote delantero suizo que me la metió con pasión, mejor que con el delicado Iniesta que me acarició pero nunca completó la faena.
Pero, claro, yo no entiendo de fútbol como los que entienden, aunque sigo pensando que el fútbol es meterla. Verán como gana el mundial el que más veces la meta.
Y para finalizar esta irreverente visión de lo que ayer les pasó a nuestros "dioses" balompédicos, pienso que a nuestra selección le falta un toque de erotismo, porque la vida, al fin y al cabo, está impregnada de erotismo, y el fútbol no podía ser menos.
El problema es que no veo yo a Del Bosque impartiendo estrategias eróticas en el vestuario. Posiblemente ya no recuerde que la clave está en meterla.
Pero bueno, lo dicho, somos favoritos, oé, oé, oé.
Eso es lo único importante ¿no?.

Fuente : http://www.revistafusion.com/201006171615/Mira-que-Guay/Mira-que-Guay/somos-favoritos-oe-oe-oe.htm

[say]

Hola a todos estoy buscando la manera de editar config.cfg del counter strike 1.6, y no me funciona el comando echo....
Pongo esto:

Código [Seleccionar] Expandir

bind "g" "drop;echo soltando;"
Lo extraño es que si pongo say en vez de echo me funciona....
Gracias por la ayuda!!

[* ¿Que hace?]

Hola chicos! ¿como os va?
Aqui os presento mi ultimo proyecto :

RTHacker Dictionary Manager

* ¿Que hace?
Crea diccionarios para cracking con palabras aleatorias sin repeticion, algo distinto a los tipicos creadores de diccionarios BruteForze...
Al principio intente hacer eso, pero me di cuenta que cuando pretendia crear un diccionario con todos los caracteres de 9 digitos me creaba un txt de mas de 5GB!!
Entonces se me ocurrio esta solucion e intente hacer el programa lo mas configurable posible  

* Referencias
Todas las funciones y procedimientos son mias menos los controles de usuario, la funcion principal que crea el diccionario nacio de una modificacion a esta que postee hace unos dias: http://foro.elhacker.net/programacion_visual_basic/palabras_aleatorias_sin_repeticion_ayuda-t296715.0.html;msg1470320#new
Se me olvidaba: el programa tambien te habla!  
*Agradezco la ayuda a raul338 y como no a VanHan que fue quien se encargo de la interfaz del proyecto, que me parece que quedo muy profesional...  
*Podeis modificar el code como querais mientras se respete la autoria y se me comuninquen los cambios...  

* Descarga
http://www.mediafire.com/?muzntnmknim

Bueno, espero que os haya gustado, acepto criticas y sugerencias para futuras versiones...  

Salu2!  

[Hacer que tu ordenador te hable]

Hacer que tu ordenador te hable

Bueno investigando por el msdn sobre objetos y demas encontre el ojeto "Sapi.spVoice", el cual nos permite ponerle voz a nuestro ordenador...  
Algo asi como el loquendo, pero en ingles...  
Hice este sencillo procedimiento para que veais un ejemplo:

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Agradecimientos a BlackZeroX                              //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Sub Computer_Talk(ByVal sText As String, Optional ByVal lVelocity As Long = 0)
   If lVelocity < -10 Or lVelocity > 10 Then Exit Sub
   Dim oTalkComputer As Object
   Set oTalkComputer = CreateObject("Sapi.spVoice")
   If oTalkComputer Is Nothing Then Exit Sub
   With oTalkComputer
       .Rate = lVelocity
       .Speak sText
   End With
   Set oTalkComputer = Nothing
End Sub

Lo divertido es que podemos regular laa velocidad a nuestro gusto...
Asi unos ejemplos de llamadas:

Código (vb) [Seleccionar] Expandir


   Call Computer_Talk("hello psyke1") ' Velocidad predeterminada 0

Código (vb) [Seleccionar] Expandir


   Call Computer_Talk("hello psyke1", 5) ' Más rapido(valor maximo 10)

Código (vb) [Seleccionar] Expandir


   Call Computer_Talk("hello psyke1", -7) ' Más lento (valor minimo -10)

Espero que os haya gustado...

Salu2!

Hola!! a ver si me podeiss ayudar, la duda es:
Tengo esto para generar palabras aleatorias:
Pero quiero que esas palabras no se puedan repetir... y ya esta, asi de simple...
(No os asusteis que esta en sucio  )

Código (vb) [Seleccionar] Expandir


Private Sub Aleatory_Comb(ByRef CharList() As String, ByVal iDigits As Integer, ByVal iNumber As Long)
    Dim sWord As String
    Dim x     As Long
    Dim y     As Long
    For y = 1 To iNumber
        For x = 1 To iDigits
            Randomize
            sWord = sWord + CharList((Rnd * (UBound(CharList()) - 1) + 1))
        Next
        MsgBox sWord: sWord = ""
    Next
End Sub

Private Sub Form_Load()
    Dim Matriz() As String
    Matriz = Split("a,b,c,d,e,f,g,h,i,j,k,l,,m,ñ,o,p,q,r,s,t,u,v,w,x,y,z", ",")
    Call Aleatory_Comb(Matriz, 5, 7)
End Sub

Gracias!!

[%]

Hola, a ver si me podeis ayudar, porque sinceramente no se lo que puede pasar...
Tengo esto:

Código (vb) [Seleccionar] Expandir


Option Explicit

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Any, ByVal lParam As Long) As Long

Private Sub Form_Load()
   Timer1.Interval = 1500: Text1 = "HOla amigosssss"
End Sub

Private Sub Timer1_Timer()
   Call SendMessage(Text1.hwnd, &H102, vbKeyLeft, 0&)
End Sub
Entonces se supone que cada 1500 ms la posicion del texto deberia moverse un sitio a la izquierda, ¿no? Pero en el text box me va añadiendo el caracter %...  
Y si pongo vbKeySpace funciona bien, me va añadiendo espacios, pero porque falla con vbKeyLeft???

Gracias!

[Clean_Html_Code]

Hola a todos, aqui mi ultima funcion: Clean_Html_Code
Me llamareis pesao ya con tanta cadena, pero bueno...
Esta funcion lo que hace es limpiar el Html de <strong>, <b>(entre otros)...
De esta forma es mas facil trabajar con la cadena, utilizo este metodo mientras aprendo ExprReg...

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

Option Explicit

Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long

Public Function Clean_Html_Code(ByVal sHtmlCode As String) As String
    Const ValidSymbolChars             As String = ",.?¿!¡=+-*Ç""_:%$·/|\ºª@ "
    Const StartInvalidString           As String = "<{[(&"
    Const StopInvalidString            As String = ">}];"
    Dim sActualChar                    As String * 1
    Dim bIgnoreString                  As Boolean
    Dim lTotalChar                     As Long
    Dim x                              As Long
    Dim y                              As Long
   
    lTotalChar = Len(sHtmlCode)
    If lTotalChar > 0 Then
        For x = 1 To lTotalChar
            sActualChar = Mid$(sHtmlCode, x, 1)
            If InStr(StartInvalidString, sActualChar) <> 0 Then bIgnoreString = True
            If bIgnoreString = False Then
                If IsCharAlphaNumeric(Asc(sActualChar)) Or InStr(ValidSymbolChars, sActualChar) <> 0 Then
                    Clean_Html_Code = Clean_Html_Code & sActualChar
                End If
            End If
            If InStr(StopInvalidString, sActualChar) <> 0 Then bIgnoreString = False
        Next
        Do Until InStr(1, Clean_Html_Code, "  ") = 0
            Clean_Html_Code = Replace$(Clean_Html_Code, "  ", " ")
            DoEvents
        Loop
    End If
End Function
Un ejemplo, tengo esto:

         <table border="0" width="100%" align="center" cellspacing="1" cellpadding="3" class="bordercolor">
            <tr class="titlebg">
               <td>Crear nuevo tema</td>

Hago la llamada asi(suponiendo que sData es el String donde tengo almacenado el codigo Html):

Código (vb) [Seleccionar] Expandir


sData = Clean_Html_Code(sData)
La funcion me devuelve esto:

Crear nuevo tema

Si veis cualquier cosa mal o que se pueda mejorar, decirmela!

Espero que os haya gustado!

Salu2!

[Check_Similar_Words]

Hola a todos, os presento mi utlima funcion : Check_Similar_Words

• ¿Que hace?
  Busca palabras similares en una cadena de texto, obtendrias un resultado similar al tipico de Google : "Quizas quiso decir... "


• ¿Como funciona?
  Lo que hace es alamcenar en un array todas las palabras que encuentre en la cadena a analizar, una vez aqui, descompongo la palabra que se busca en las partes correspondientes a el número de coincidencias que queramos buscar, os voy a poner un ejemplo:
  Supongamos que se desea buscar la palabra "mañana", y indicamos a la funcion que busque palabras similares con 3 coincidencias, entonces se partiria la palabra a buscar de esta manera:
  

mañ
aña
ñan
ana

La formula para sacar el numero de fragmentos es esta:

Código [Seleccionar] Expandir


(x - n) + 1
Donde x es la cantidad de digitos de la palabra y n los digitos en los que se quiere separar esa palabra...

Comprobaria si las palabras de la cadena contienen algunos de estos trozos y las guarda en mi Collection.
Lo divertido es que segun el número de coincidencias que pongamos, la busqueda sera mas o menos estricta.

• Bueno aqui os dejo el codigo:

Código (vb) [Seleccionar] Expandir


'==================================================================================================
' º Function  : Check_Similar_Words
' º Version   : 1.2
' º Author    : Mr.Frog ©
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Recommended Websites :
'       http://visual-coders.com.ar
'       http://InfrAngeluX.Sytes.Net
'==================================================================================================

Option Explicit
Option Base 0

Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Public Function Check_Similar_Words(ByVal sStringToAnalyze As String, ByVal sWord As String, ByVal bvComparationLevel As Byte) As Collection
Const sNullChars                                                            As String = ".,"
Dim cTemp                                                                   As New Collection
Dim sCompareWord()                                                          As String
Dim sTextWord()                                                             As String
Dim sActualWord                                                             As String
Dim lTotalCompWords                                                         As Long
Dim lTotalWords                                                             As Long
Dim lLenWord                                                                As Long
Dim Q                                                                       As Long
Dim G                                                                       As Long
   
   If CBool(bvComparationLevel) Then
       lLenWord = Len(sWord)
       If (lLenWord > 2) And (Len(sStringToAnalyze) > lLenWord) Then
           If (bvComparationLevel < lLenWord) Then
               If Not (InStrB(sWord, vbNewLine)) Then
                   G = 1
                   
                   lTotalCompWords = (lLenWord - bvComparationLevel) + 1
                   ReDim sCompareWord(lTotalCompWords) As String
                   
                   Do Until Q = lTotalCompWords
                       sCompareWord$(Q) = Mid$(sWord, G, bvComparationLevel)
                       G = G + 1
                       Q = Q + 1
                   Loop
                   
                   sStringToAnalyze = Replace$(sStringToAnalyze, vbNewLine, Space$(1))
                   sTextWord() = Split(sStringToAnalyze, Space$(1))
                   
                   lTotalWords = UBound(sTextWord)
                   lTotalCompWords = lTotalCompWords - 1
                   
                   For Q = 0 To lTotalWords
                       sActualWord = sTextWord(Q)
                       If Len(sActualWord) >= bvComparationLevel Then
                           For G = 0 To lTotalCompWords
                              If CBool(lstrcmpi(sWord, sActualWord)) Then
                                   If InStrB(1, sActualWord, sCompareWord(G), vbTextCompare) Then
                                       If InStrB(sNullChars$, Right$(sActualWord, 1)) Then
                                           sActualWord = Left$(sActualWord, Len(sActualWord) - 1)
                                       End If
                                       On Error Resume Next
                                       cTemp.Add sActualWord, sActualWord
                                   End If
                               End If
                           Next G
                       End If
                   Next Q
                   
                   Set Check_Similar_Words = cTemp
               End If
           End If
       End If
   End If
End Function

• Un ejemplo práctico:
  
  Tengo en un TextBox(llamado Text1) esto:
  

  
  La inspiración de Cervantes para componer esta obra vino, al parecer, del llamado Entremés de los romances, que era de fecha anterior (aunque esto es discutido). Su argumento ridiculiza a un labrador que enloquece creyéndose héroe de romances. El labrador abandonó a su mujer, y se echó a los caminos, como hizo Don Quijote. Este entremés posee una doble lectura: también es una crítica a Lope de Vega; quien, después de haber compuesto numerosos romances autobiográficos en los que contaba sus amores, abandonó a su mujer y marchó a la Armada Invencible. Es conocido el interés de Cervantes por el Romancero y su resentimiento por haber sido echado de los teatros por el mayor éxito de Lope de Vega, así como su carácter de gran entremesista. Un argumento a favor de esta hipótesis sería el hecho de que, a pesar de que el narrador nos dice que Don Quijote ha enloquecido a causa de la lectura de libros de caballerías, durante su primera salida recita romances constantemente, sobre todo en los momentos de mayor desvarío. Por todo ello, podría ser una hipótesis verosímil. A este influjo se agregó el de Tirante el Blanco de Joanot Martorell, el del Morgante de Luigi Pulci y el del Orlando Furioso de Ludovico Ariosto.

  
  Para ver un ejemplo:
  

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
   Dim vItem         As Variant

   Debug.Print "--------------->"; Time$
   For Each vItem In Check_Similar_Words(Text1.Text, "argumento", 4)
       Debug.Print vItem
   Next vItem
End Sub

Y obtengo esto:

Entremés
numerosos
resentimiento
entremesista
constantemente
momentos

En cambio si en vez de 3 pongo 4 en la llamada la busqueda de palabras similares se vuelve más extricta y obtendria esto:

resentimiento
constantemente
momentos

Espero que os haya gustado!

Salu2!

[,$%·"!%&/^¨*:]

Hola, necesito saber cual es la forma óptima de quitar los caracteres que no sean ni numeros ni letras (,$%·"!%&/^¨*: ...) en una cadena...  
¿Quizas con Expresiones Regulares?  
Actualmente meto todos los imbolos a mano en un array y utilizo Replace, no creo que sea la mejor forma...

Gracias!

Hola, os cuento:
Me gustaria saber un poco mas de las expresiones regulares, he mirado ejemplos por ahi pero no me acabo de aclarar que digamos... 
Estoy abierto a recomendaciones y me gustaria que me pusierais un ejemplo de como se saca X caracter de una cadena utilizando E.R. 
Son tan complicadas como parecen¿? 

Gracias! 

[ATENCION: SRC CORREGIDO]

ATENCION: SRC CORREGIDO

Hola, aqui os dejo esta funcin que acabo de hacer, no es gran cosa, pero bueno...  

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Agradecimientos a BlackZeroX & Cobein                     //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////
Option Explicit
Public Function Text_Between_Words(ByVal sTextToAnalyze As String, ByVal sStartWord As String, ByVal sEndWord As String) As String
    Dim iPosition1             As Integer
    Dim iPosition2             As Integer
    Dim iStart                 As Integer
   
    iPosition1 = InStr(sTextToAnalyze, sStartWord)
    If iPosition1 <> 0 Then
        iStart = iPosition1 + Len(sStartWord)
        iPosition2 = InStr(iStart, sTextToAnalyze, sEndWord)
    Else
        Exit Function
    End If
    If iPosition2 <> 0 Then
        Text_Between_Words = Mid$(sTextToAnalyze, iStart, iPosition2 - iStart)
    End If
End Function
Un ejemplo seria asi:

Código [Seleccionar] Expandir


El contexto es el ámbito de referencia de un texto. ¿Qué entiendo por ámbito de referencia?.

Código (vb) [Seleccionar] Expandir


   Debug.Print Text_Between_Words(Text1.Text, "referencia", "entiendo")

El resultado seria:

de un texto. ¿Qué

Y si pongo esto:

Código (vb) [Seleccionar] Expandir


   Debug.Print Text_Between_Words(Text1.Text, "referencia", "referencia")

Me sale esto:

de un texto. ¿Qué entiendo por ámbito de

Espero que os haya gustado(mas aun  )...

Salu2!

Hola , os lo voy a poner facil:
Estoy haciendo un programa que lee un archivo de texto, y si detecta la cadena "Siguiente" en una linea cree un archivo de texto que contenga esa linea, actualmente hago esto:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
    Dim archivo As Integer
    Dim linea   As String
    Dim x       As Integer
    archivo = FreeFile
    Open App.Path & "\lista.txt" For Input As archivo
    Do While Not EOF(archivo)
        Line Input #archivo, linea
        If InStr(linea, "siguiente") <> 0 Then
            Open App.Path & "\" & linea & x & ".txt" For Output As #1
                Print #1, "Hola"
            Close #1
            x = x + 1
        End If
    Loop
End Sub
Pero me da error me dice:

El archivo ya está abierto

Y me marca la linea:

Open App.Path & "\" & linea & x & ".txt" For Output As #1

mmmmmm
Porque?¿ 

Hola a todos, a ver os cuento un poco lo que me pasa...
Estoy haciendo un bot utilizando wininet, Lo que necesito es ver el contenido de un label de la web en un label en mi Form, actualmente hago esto:

Código (vb) [Seleccionar] Expandir


Option Explicit

Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Public Function GET_(hURL As String) As String
    Dim hBuffer As String * 1000
    Dim hInternet As Long
    Dim hFile     As Long
    Dim hRead     As Long
    hInternet = InternetOpen(0, 1, vbNullString, vbNullString, 0): DoEvents
    If hInternet <> 0 Then
        hFile = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, &H80000000, ByVal 0&): DoEvents
        If hFile <> 0 Then
            Do
                Call InternetReadFile(hFile, hBuffer, 1000, hRead): DoEvents
                GET_ = GET_ & Left$(hBuffer, hRead)
                If hRead = 0 Then Exit Do: DoEvents
            Loop
        End If
    End If
    If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
    If hFile <> 0 Then Call InternetCloseHandle(hFile)
End Function

Public Function GetUserName(Optional ID As Long) As String
    Dim Buffer   As String
    Dim UserName As String
    If ID > 0 Then
        MyProfileData = GET_(urlotroperfildemipagina & Str(ID))
    Else
        MyProfileData = GET_(urlmiperfil)
    End If
    'Buscamos "Ver perfil de "
    For x = 1 To Len(MyProfileData)
        Buffer = Mid(MyProfileData, x, 14)
        If Buffer = "Ver perfil de " Then Exit For
    Next
    'Buscamos el nombre
    For x = x + 14 To Len(MyProfileData)
        Buffer = Mid(MyProfileData, x, 1)
        If Buffer <> Chr(34) Then UserName = UserName & Buffer Else Exit For
    Next
    GetUserName = UserName
End Function

No estoy seguro de que sea una buena forma de hacerlo, por ello os pido consejo, asi como si en vez de wininet me recomendais otro metodo...

Gracias!

[PsYkE1 Crazy Desktop]

Hola, aqui os dejo mi último proyecto:

PsYkE1 Crazy Desktop

*Podras hacer cosas como estas:

*¿Qué es PCD?
Es un programa con el cual podras pintar circulos de colores aleatorios en tu escritorio.

*¿Cómo funciona?
Descargalo y compruebalo  

*¿Para que sirve?
Echa a volar tu imaginación...

Bueno, espero que seais críticos, y me deis vuestra opinión, cualquier sugerencia sera tomada en cuenta...

Descargalo en http://www.mediafire.com/?xyzyydjyozz

Salu2!

by*PsYkE1*

[C&P]

Hola a todos, tras darle muchas vueltas he conseguido hacer un Triangulo de Pascal desde VB6.
Para que veais que no es un C&P os dire como llegue a la conclusion y os explicare cada paso que doy en los comentarios que aparecen en el code.

Deduccion:

Sabia que habia que resolverlo con una matriz, asi que hice una de 5x5 introduciendo los números que me deberian salir, algo asi:

Código [Seleccionar] Expandir


1 0 0 0 0
1 1 0 0 0
1 2 1 0 0
1 3 3 1 0
1 4 6 4 1

Bien, una vez aqui pense cual era la logica de los numeros una vez dentro de la matriz...
Llegue a la conclusion de que todo elemento viene dado de la suma del que tiene encima con el de la izquierda del que tiene encima (que mal me explico)...
Unos ejemplos:
*El numero 4 sale de la suma del que tiene envima ( el 1) y el de la izquierda al que tiene encima (el 3)
*El numero 2 sale de la suma del que tiene envima ( el 1) y el de la izquierda al que tiene encima (otro 1)

Una vez aqui, os resultara muy facil entender la siguiente formula:

Código [Seleccionar] Expandir


Matriz(x,y) = Matriz(x-1,y) + Martiz(x-1,y-1)

Me dejo de rodeos y os dejo el code:

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

Rem Insertar TextBox con la propiedad Multiline = True y ScrollBars = Both

Option Explicit

Public Sub Generate_Pascal_Triangle(ByVal tTextBox As TextBox, ByVal iPotency As Integer)
    '//Declaro variables
    Dim lNumbersArray()          As Double
    Dim dNumber                  As Double
    Dim x                        As Long
    Dim y                        As Long
   
    '//Si la Potencia es menor a 3 sale del procedimiento
    If iPotency > 2 Then
        '//Redimensiono mi matriz con tantas filas y columnas como me indique la potencia
        ReDim lNumbersArray(iPotency, iPotency)
   
        '//Edito la primera linea de mi matriz puesto que la necesito como base
        lNumbersArray(1, 1) = 1
        For x = 2 To iPotency
            lNumbersArray(x, 1) = 0
        Next
   
        For x = 2 To iPotency
            For y = 1 To iPotency
                '//Si estoy en la primera columna no podria sumar otro elemento de mi matriz que
                'este más a la izquierda, si ocurre eso asigo a mi variable dNumber el valor 0
                If (y - 1) < 1 Then
                    dNumber = 0
                Else
                    dNumber = lNumbersArray(x - 1, y - 1)
                End If
                '//Utilizo la fórmula que puse antes
                lNumbersArray(x, y) = dNumber + lNumbersArray(x - 1, y)
            Next
        Next
   
        With tTextBox
            .Text = vbNullString    '//Limpio el TextBox
            .Alignment = 2          '//Pongo el texto centrado para que se aprecie mejor la piramide
            For x = 1 To iPotency
                For y = 1 To iPotency
                    '//Represento la matriz ya editada prescindiendo de los ceros
                    If lNumbersArray(x, y) <> 0 Then .Text = .Text & lNumbersArray(x, y) & Chr$(32)
                Next
                '//Nueva linea despues de acabar una fila
                .Text = .Text & vbCrLf
            Next
        End With
        '//Borro mi matriz
        Erase lNumbersArray '//Esto es prescindible ;)
    End If
End Sub

Un ejemplito:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
    Call Generate_Pascal_Triangle(Text1, 10)
End Sub

Obtenriamos este resultado en el TextBox:

Código [Seleccionar] Expandir


1
1 1
1 2 1
1 3 3 1
1 4 6 4 1
1 5 10 10 5 1
1 6 15 20 15 6 1
1 7 21 35 35 21 7 1
1 8 28 56 70 56 28 8 1
1 9 36 84 126 126 84 36 9 1

Esto es todo, espero que os sirva... 
Espero el siguiente reto

Salu2! 

Hola, necesito vuestra ayda para una duda muy simple...
Tengo que quitar el caracter "e" de una cadena, para ello actualmente hago esto:

Código (vb) [Seleccionar] Expandir


Dim cadena As String
Cadena = "estoy cansado"
Cadena = Replace(Cadena, "e", "")

Queria saber si hay otra forma de hacerlo...

Gracias!

Hola a todos, os cuento mi problema a ver s sois capaces de ayudarme:
Toco la guitarra y dentro de un mes voy a dar mi primer concierto...
El problema es que tengo pánico escénico, y no se que hacer, porque cuando estoy nervioso toco FATAL...

Gracias!

Hola a todos, os explico y más que nada os pido opinion y consejo...
Haciendo pruebas me di cuenta que no puede haber un archivo y una carpeta con el mismo nombre, a raiz de eso se me ocurrio esto:

Código (vb) [Seleccionar] Expandir



Option Explicit

Dim Rec As String, Aut As String
Dim Aviso As Boolean
Dim Fso As Object

Private Sub Command1_Click()
    On Error Resume Next
    With Fso
        If Not .DriveExists Then MsgBox "La unidad no está disponible", vbCritical, "USB Vaccination": Exit Sub
        Rec = Drive1.Drive & "\RECYCLER"
        Aut = Drive1.Drive & "\autorun.inf"
        If .FileExists(Aut) Then .DeleteFile Aut: MsgBox "Archivo sospechoso : " & Aut, vbCritical, "USB Vaccination"
        If .FolderExists(Rec) Then .DeleteFile Rec: MsgBox "Carpeta sospechosa : " & Rec, vbCritical, "USB Vaccination"
        If Not .FolderExists(Aut) Then
            .CreateFolder Aut: SetAttr Aut, vbHidden: SetAttr Aut, vbReadOnly
            MsgBox "Se creara carpeta " & Aut
        Else
            Aviso = True
        End If
        If Not .FileExists(Rec) Then
            Open Rec For Output As #1: Close: SetAttr Rec, vbHidden: SetAttr Rec, vbReadOnly
            MsgBox "Se creara archivo " & Rec
        Else
            Aviso = True
        End If
    End With
    If Aviso Then
        MsgBox "El USB " & Drive1.Drive & " ya estaba vacunado", vbCritical, "USB Vaccination"
    Else
        MsgBox "El USB " & Drive1.Drive & " se ha vacunado con éxito", vbInformation, "USB Vaccination"
    End If
End Sub

Private Sub Form_Load()
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Me.Caption =  "USB Vaccination"
    Command1.Caption = "Vacunar"
End Sub
No se si es una tonteria y no vale para nada, solo se me ocurrio la idea...
Lo llevo usando un tiempo con mi lapiz metiendolo en ordenadores que se que estan infectados y el resultado ha sido bastante bueno... :smiley

Salu2!

[PD:]

Pues eso:

¿Cuantas horas dormis al dia?

PD: Yo 4...

[.WAV]

Necesito varios sonidos .WAV de cristales rotos...
¿Me podeis ayudar?

Gracias!

Hola, necesito varias imagenes de un cristales rotos pero con el fondo transparente, ¿se entiende?...
He estado buscando y no he encontrado nada, tambien me valdria de unos balazos sobre cristal, tambien con el fondo transparente para poder aplicarlo a cualquier textura... 

PD: Adelanto que no tengo ni idea de retoque fotografico...

Gracias! 

[AMO]

Hola, AMO el ajedrez y llevo años jugando, me gustaria retaros a ver quien es capaz de ganarme...
Vosotros elegis la Web que querais y me retais por MP.

Gracias, os estoy esperando...

[Timer]

Hola buenas, aqui os presento mi ultimo invento :
Hacer garabatos de colores en tu formulario, es simple, pero me gusta el efecto...
Al cabo de unos seg tendriamos algo asi:


o así:


Bueno aqui va el codigo, es la cosa mas estupida que podais imaginar:
Necesitamos añadir:

* Un Timer
* Un ScrollBar
* Tres CommandButton (con una matriz)
* Un Label

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Agradecimientos a BlackZeroX.                             //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

'\\Variables
Dim R1 As Integer, R2 As Integer, R3 As Integer, R4 As Integer
Dim C1 As Integer, C2 As Integer, C3 As Integer
Dim L As Integer
Dim Relleno As Boolean
Dim Que As Variant

Private Sub Form_Load()
   ' Pongo titulo al Form
   Me.Caption = "*PsYkE1* - Garabatos"
   ' Asigno el caption a cada botón
   Command1(0).Caption = "Parar"
   Command1(1).Caption = "Rellenos"
   Command1(2).Caption = "Salir"
End Sub

Private Sub HScroll1_Scroll()
   ' El intervalo del Timer sea igual a el Value del ScrollBar
   Timer1.Interval = HScroll1.Value
   ' El Value del ScrollBar me aparezca en el Label1
   Label1.Caption = HScroll1.Value
End Sub

Private Sub Command1_Click(Index As Integer)
   'Segun el Index asigno unos comandos a cada botón
   Select Case Index
       '\\Parar
       Case 0
           ' Limpio el Form
           Me.Cls
           ' Depende del Caption hace una cosa u otra
           If Command1(0).Caption = "Parar" Then
               MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
               Timer1.Enabled = False
               Command1(0).Caption = "Comenzar"
           Else
               Timer1.Enabled = True
               Command1(0).Caption = "Parar"
           End If
       '\\Rellenos
       Case 1
           ' Limpio el Form
           Me.Cls
           Timer1.Enabled = True
           Command1(0).Caption = "Parar"
           ' Depende del Caption hace una cosa u otra
           If Command1(1).Caption = "Rellenos" Then
               Relleno = True
               MsgBox "Ahora se hará con rectangulos opacos", vbInformation, "*PsYkE1* - Garabatos"
               Command1(1).Caption = "Huecos"
           Else
               Relleno = False
               MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
               Command1(1).Caption = "Rellenos"
           End If
       '\\Salir
       Case 2
           ' Si el Timer esta activado pregunta si quieres salir
           If Timer1.Enabled = True Then
               Que = MsgBox("¿Deseas salir?", vbQuestion + vbYesNo, "*PsYkE1* - Garabatos")
               ' Si dices SI sales del programa
               If Que = vbYes Then End
           End If
       End Select
   
End Sub

Private Sub Timer1_Timer() ' Cada 5 milisegundos

' Etiqueta Rndm
Rndm:

   ' Para que me salgan números aleatorios
   Randomize

   With Me ' Con el formulario actual
       ' Coordenada x del punto de partida
       ' dentro del alto del Form
       R1 = Int(Rnd * .Height)
       ' Coordenada y del punto de partida
       ' dentro del alto del Form
       R2 = Int(Rnd * .Height)
       ' Coordenada x del punto final
       ' dentro del ancho del Form
       R3 = Int(Rnd * .Width)
       ' Coordenada y del punto final
       ' dentro del ancho del Form
       R4 = Int(Rnd * .Width)
   End With

   ' Si las coordenadas de partida coinciden con las finales voy a la etiqueta Rndm
   If R1 = R3 And R2 = R4 Then GoTo Rndm

   ' Tres números aleatorios para definir el color de nuestra futura linea
   C1 = Int(Rnd * 255)
   C2 = Int(Rnd * 255)
   C3 = Int(Rnd * 255)

   If Relleno = False Then
       L = Int(Rnd * 3 + 1)
       If L = 1 Then
           Line (R1, R2)-(R3, R4), RGB(C1, C2, C3) ' Lineas
       ElseIf L = 2 Then
           Circle (R1, R2), (R3), RGB(C1, C2, C3) ' Circulos
       Else
           Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), B ' Rectándulos
       End If
   Else
       Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), BF ' Rectangulos rellenos
   End If

End Sub

Descargalo en http://www.mediafire.com/?yymmaefy1ey

Espero que os haya gustado...  

Salu2!

[Ventajas:]

Mirad lo que he encontrado!!
igual alguno de vosotros ya lo conocia pero creo que merece la pena...
Quizas os suene Spotify, no?¿ Pero si eres de los que han intentado hacerse una cuenta no lo abreis conseguido seguramente...
Pues esta va ha ser tu pagina faborita: http://listen.grooveshark.com/

Ventajas:
+sin registrarse
+muuuuuuuuuuuuuucha musica
+puedes crear listas de reproduccion

Espero que os sirva...

Salu2!!!!1

Hola a todos, he estado trabajando para convertir tus Forms en persianas , si, como oyes, en persianas.
Ahora SI funciona, os lo prometo, sino, os devuelvo el dinero...
IMPORTANTE: DEBEIS PONER LA PROPIEDAD BORDERSTYLE EN NONE
Aqui va el code, (esto deberia estar en módulo):

Código (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Agradecimientos a BlackZeroX.                             //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Persiana(miForm As Form, Vel As Integer, Desplegar As Boolean, Alto As Boolean _
, Acabar As Boolean)
   Dim Largo As Integer
   With miForm
       If Desplegar = True Then
           If Alto = True Then
               Largo = .Height
               .Height = 0
               While Not .Height >= Largo
                   .Height = .Height + 2
                   Sleep Vel
               Wend
           Else
               Largo = .Width
               .Width = 0
               While Not .Width >= Largo
                   .Width = .Width + 2
                   Sleep Vel
               Wend
           End If
       Else
           If Alto = True Then
               While Not .Height <= 10
                   .Height = .Height - 10
                   Sleep Vel
               Wend
           Else
               While Not .Width <= 10
                   .Width = .Width - 2
                   Sleep Vel
               Wend
           End If
       End If
   End With
   If Acabar = True Then End
End Sub

Bien, ahora para llamarlo desde un Form pondríamos esto:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Activate()
   Call Persiana(Me, 5, False, True, True)
End Sub
( esta llamada se ejerceria sobre el Form actual, con una velocidad de 5(si quereis que vaya mas despacio aumentar el valor, no bajarlo ), para que se cierre la persiana, de abajo a arriba y que al completarse se finalice el programa)

Quizas alguien tenga alguna duda preguntar, que es gratis...

Salu2!

[¿Qué es NRC?]

HOla, aqui les dejo uno de mis últimos proyectos a ver si les gusta:

*¿Qué es NRC?
Es un programa diseñado para reducir el recoil (el retroceso del arma) en tus juegos shooter favoritos.

*¿Como funciona?
Cada vez que presionas el mouse el cursor desciende ligeramente hacia abajo
, de este modo, mejora tu precisión a la hora de disparar.

*¿Para qué juego shooter esta pensado?
Principalmente para el Counter Strike, pero incluye la opcion de configurarlo para poder daptarlo a otros juegos.

Bueno, espero que seais críticos, y me deis vuestra opinión, cualquier sugerencia sera tomada en cuenta.

Bueno, aquí os dejo el link:

Código [Seleccionar] Expandir


http://www.mediafire.com/?ciyzn2bnmzx

by*PsYkE1*

HoO0la!! Mirar que facil os lo pongo con una duda tan sencilla , si tengo un textbox con la propiedad multiline, seria posible poner de color rojo(por jemplo) la primera linea??
y una palabra en concreto??

Muchas gracias!!

?¿?
[youtube=425,350]http://www.youtube.com/watch?v=1iVfSgp8XY4[/youtube]