Biblioteca de código

[ranefi]

Mostrar palabra que se encuentra debajo del cursor

Agregar 1 control Label y 1 RichTextBox e REPLACEar el siguiente código

Código:

Option Explicit

Private Const EM_CHARFROMPOS& = &HD7
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long


Public Function RichWordOver(rch As RichTextBox, X As Single, Y As Single) As String
    Dim pt As POINTAPI
   
    Dim pos As Integer
    Dim start_pos As Integer
    Dim end_pos As Integer
   
    Dim ch As String
    Dim txt As String
   
    Dim txtlen As Integer


    pt.X = X \ Screen.TwipsPerPixelX
    pt.Y = Y \ Screen.TwipsPerPixelY


    pos = SendMessage(rch.hWnd, EM_CHARFROMPOS, 0&, pt)
    If pos <= 0 Then Exit Function

    txt = rch.Text
    For start_pos = pos To 1 Step -1
        ch = Mid$(rch.Text, start_pos, 1)

        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next start_pos
    start_pos = start_pos + 1


    txtlen = Len(txt)
    For end_pos = pos To txtlen
        ch = Mid$(txt, end_pos, 1)

        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next end_pos
    end_pos = end_pos - 1

    If start_pos <= end_pos Then _
        RichWordOver = Mid$(txt, start_pos, _
            end_pos - start_pos + 1)
End Function

Private Sub Form_Load()
    RichTextBox1.Text = "Que rica esta la manzana, que " & _
        "cuelga de la ramita, se esta cayendo de buena " & _
        vbCrLf & vbCrLf & "porque ya esta madurita.. " & _
            "Jejepa"
End Sub

Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim txt As String

    txt = RichWordOver(RichTextBox1, X, Y)
   
    If Label1.Caption <> txt Then
        Label1.Caption = txt
    End If
End Sub

El control RichTextBox se encuentra en componentes (se abre con CTRL + T) con el nombre de Microsoft RichTextBox.

[ranefi]

Formulario con cara sonriente

Agregar 1 control CommandButton e REPLACEar el siguiente código

En el formulario

Código:

Private Sub Command1_Click()
    SetWindowRgn Me.hwnd, 0, False
   
    DeleteObject leSmiley
   
    End
End Sub

Private Sub Form_Load()
    Smiley Me
End Sub

Private Sub Form_Resize()
    Dim oldSmiley
   
    oldSmiley = leSmiley
   
    Smiley Me
   
    DeleteObject oldSmiley
End Sub

En el módulo

Código:

Option Explicit


Dim leSmiley As Long

Declare Function CreateRectRgn Lib "gdi32" ( _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) _
As Long


Declare Function CreateEllipticRgn Lib "gdi32" ( _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) _
As Long

Declare Function CreatePolygonRgn Lib "gdi32" ( _
lpPoint As POINTAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long _
) As Long

Type POINTAPI
        X As Long
        Y As Long
End Type

Public Const ALTERNATE = 1
Public Const WINDING = 2


Declare Function CombineRgn Lib "gdi32" ( _
ByVal hDestRgn As Long, _
ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As CombineMode _
) As Long


Public Enum CombineMode
    RGN_AND = 1

    RGN_COPY = 5
    RGN_DIFF = 4

    RGN_OR = 2
    RGN_XOR = 3
End Enum

Declare Function SetWindowRgn Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean _
) As Long

Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long _
) As Long

Sub Smiley(obj As Form)
    Dim X As Long, Y As Long

    X = obj.Width / Screen.TwipsPerPixelX
    Y = obj.Height / Screen.TwipsPerPixelY


    Dim Grond As Long
    Dim Gsmile As Long
    Dim Psmile As Long
    Dim Rect As Long
    Dim eyeG As Long
    Dim eyeD As Long

    Dim Bouee As Long
    Dim leSmile As Long
    Dim Yeux As Long
    Dim Tete As Long
    Dim LesPoints(0 To 4) As POINTAPI

    Grond = CreateEllipticRgn(0, 0, X, Y)
    Gsmile = CreateEllipticRgn(Int(X / 10), _
        Int(Y / 10), Int(X * 9 / 10), Int(Y * 9 / 10))
    Psmile = CreateEllipticRgn(Int(X * 2 / 10), _
        Int(Y * 4 / 10), Int(X * 8 / 10), _
        Int(Y * 8 / 10))

    LesPoints(0).X = 0
    LesPoints(0).Y = 0
    LesPoints(1).X = X
    LesPoints(1).Y = 0
    LesPoints(2).X = X
    LesPoints(2).Y = Int(Y * 8 / 10)
    LesPoints(3).X = Int(X / 2)
    LesPoints(3).Y = Int(Y / 2)
    LesPoints(4).X = 0
    LesPoints(4).Y = Int(Y * 8 / 10)
   
    Rect = CreatePolygonRgn(LesPoints(0), 5, 1)
    eyeG = CreateEllipticRgn(Int(X * 2 / 10), _
        Int(Y * 3 / 10), Int(X * 4 / 10), _
        Int(Y * 5 / 10))
    eyeD = CreateEllipticRgn(Int(X * 6 / 10), _
        Int(Y * 3 / 10), Int(X * 8 / 10), _
        Int(Y * 5 / 10))


    Bouee = CreateEllipticRgn(0, 0, X, Y)
    leSmile = CreateEllipticRgn(0, 0, X, Y)
    Yeux = CreateEllipticRgn(0, 0, X, Y)
    Tete = CreateEllipticRgn(0, 0, X, Y)
    leSmiley = CreateEllipticRgn(0, 0, X, Y)

    CombineRgn Bouee, Gsmile, Psmile, RGN_DIFF
    CombineRgn leSmile, Bouee, Rect, RGN_DIFF
    CombineRgn Yeux, eyeG, eyeD, RGN_OR
    CombineRgn Tete, Grond, Yeux, RGN_DIFF
    CombineRgn leSmiley, Tete, leSmile, RGN_DIFF

    DeleteObject Grond
    DeleteObject Gsmile
    DeleteObject Psmile
    DeleteObject Rect
    DeleteObject eyeG
    DeleteObject eyeD
    DeleteObject Bouee
    DeleteObject leSmile
    DeleteObject Yeux
    DeleteObject Tete

    SetWindowRgn obj.hwnd, leSmiley, True
End Sub

Jejejeje, puramente educativo. El autor se llama Thomas Detoux. Nos vemos.

[ranefi]

Formulario que explota e implota (animación de inicio)

Agregar 1 control CommandButton e REPLACEar el siguiente código

En el formulario

Código:

Private Sub Command1_Click()
    Call ImplodeForm(Me, 2, 500, 1)
   
    End
   
    Set Form1 = Nothing
End Sub

Private Sub Form_Load()
    Call ExplodeForm(Me, 500)
    Command1.Caption = "Dame un cochino clic"
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call ImplodeForm(Me, 2, 500, 1)
End Sub

En el módulo

Código:

Option Explicit


#If Win16 Then
    Type RECT
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
    End Type
#Else
    Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
#End If


#If Win16 Then
    Declare Sub GetWindowRect Lib "User" _
        (ByVal hwnd As Integer, lpRect As RECT)
   
    Declare Function GetDC Lib "User" _
        (ByVal hwnd As Integer) As Integer
   
    Declare Function ReleaseDC Lib "User" _
        (ByVal hwnd As Integer, _
        ByVal hdc As Integer) As Integer
   
    Declare Sub SetBkColor Lib "GDI" _
        (ByVal hdc As Integer, ByVal crColor As Long)
   
    Declare Sub Rectangle Lib "GDI" _
        (ByVal hdc As Integer, ByVal X1 As Integer, _
        ByVal Y1 As Integer, ByVal X2 As Integer, _
        ByVal Y2 As Integer)
   
    Declare Function CreateSolidBrush Lib "GDI" _
        (ByVal crColor As Long) As Integer
   
    Declare Function SelectObject Lib "GDI" _
        (ByVal hdc As Integer, _
        ByVal hObject As Integer) As Integer
   
    Declare Sub DeleteObject Lib "GDI" _
        (ByVal hObject As Integer)
#Else
    Declare Function GetWindowRect Lib "user32" _
        (ByVal hwnd As Long, lpRect As RECT) As Long
   
    Declare Function GetDC Lib "user32" _
        (ByVal hwnd As Long) As Long
   
    Declare Function ReleaseDC Lib "user32" _
        (ByVal hwnd As Long, ByVal hdc As Long) As Long
   
    Declare Function SetBkColor Lib "gdi32" _
        (ByVal hdc As Long, ByVal crColor As Long) _
        As Long
   
    Declare Function Rectangle Lib "gdi32" _
        (ByVal hdc As Long, ByVal X1 As Long, _
        ByVal Y1 As Long, ByVal X2 As Long, _
        ByVal Y2 As Long) As Long
   
    Declare Function CreateSolidBrush Lib "gdi32" _
        (ByVal crColor As Long) As Long
   
    Declare Function SelectObject Lib "user32" _
        (ByVal hdc As Long, _
        ByVal hObject As Long) As Long
   
    Declare Function DeleteObject Lib "gdi32" _
        (ByVal hObject As Long) As Long
#End If


Sub ExplodeForm(f As Form, Movement As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
    Dim TheScreen As Long
    Dim Brush As Long
   
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
   
    For i = 1 To Movement
        Cx = formWidth * (i / Movement)
        Cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - Cx) / 2
        Y = myRect.Top + (formHeight - Cy) / 2
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy
    Next i
   
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub


Public Sub ImplodeForm(f As Form, Direction As Integer, Movement As Integer, ModalState As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
    Dim TheScreen As Long
    Dim Brush As Long
   
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
   
        For i = Movement To 1 Step -1
        Cx = formWidth * (i / Movement)
        Cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - Cx) / 2
        Y = myRect.Top + (formHeight - Cy) / 2
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy
    Next i
   
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub

Sirve para darle presentación a nuestras aplicaciones. Nos vemos.

[ranefi]

Uso de la función Left

Agregar 1 control CommandButton y 1 Label e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    Label1.Caption = Left(Label1.Caption, 20)
End Sub

Private Sub Form_Load()
    With Label1
        .Left = 120
        .Top = 600
        .AutoSize = True
        .Caption = "Adoro los tlacuaches de " & _
            "barbacha, mmmmm, muy ricos :p"
    End With
End Sub

Esto puede ser usado para tomar nombres de archivos de izquierda a derecha (el 20 son los carácteres a tomar). Nos vemos.

[ranefi]

Uso de la función Right

Agregar 1 control CommnadButton y 1 Label e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    Label1.Caption = Right(Label1.Caption, 12)
End Sub

Private Sub Form_Load()
    With Label1
        .Left = 120
        .Top = 600
        .AutoSize = True
        .Caption = "Adoro los tlacuaches de " & _
            "barbacha, mmmmm, muy ricos :p"
    End With
End Sub

Esto puede servir para tomar los carácteres de una palabra de derecha a izquierda (los 12 son los carácteres a tomar). Nos vemos.

[ranefi]

Uso de la función Replace

Agregar 1 control CommandButton, 1 Label e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    Label1.Caption = Replace(Label1.Caption, _
        "los tlacuaches de barbacha", "las hamburguesas")
End Sub

Private Sub Form_Load()
    With Label1
        .Left = 120
        .Top = 600
        .AutoSize = True
        .Caption = "Adoro los tlacuaches de " & _
            "barbacha, mmmmm, muy ricos :p"
    End With
End Sub

Lo que hace es buscar la cadena de texto los tlacuaches de barbacha y cambiarla por las hamburguesas. Nos vemos.

[ranefi]

Uso de la función strReverse

Agregar 1 control CommandButton, 1 Label e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    Label1.Caption = StrReverse(Label1.Caption)
End Sub

Private Sub Form_Load()
    With Label1
        .Left = 120
        .Top = 600
        .AutoSize = True
        .Caption = "Adoro los tlacuaches de " & _
            "barbacha, mmmmm, muy ricos :p"
    End With
End Sub

Simplemente pone la cadena de texto al revés. Nos vemos.

[ranefi]

Uso de la función Len

Agregar 1 control CommandButton, 1 Label e REPLACEar el siguiente código

Código:

Private Sub Command1_Click()
    Label1.Caption = "Esta cochinada tiene " & _
        Len(Label1.Caption) & " caracteres"
End Sub

Private Sub Form_Load()
    With Label1
        .Left = 120
        .Top = 600
        .AutoSize = True
        .Caption = "Adoro los tlacuaches de " & _
            "barbacha, mmmmm, muy ricos :p"
    End With
End Sub

Simplemente lee la cantidad de caracteres de una cadena de texto. Nos vemos.

[ranefi]

Encontrar y cerrar ventana

Agregar 1 control CommandButton e REPLACEar el siguiente código

Código:

Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

Private Declare Function PostMessage Lib "user32" _
    Alias "PostMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long

Const SW_SHOWNORMAL = 1
Const WM_CLOSE = &H10

Private Sub Command1_Click()
    Dim WinWnd As Long, Ret As String
   
    Ret = InputBox("Introduce título de ventana a cerrar" _
        + Chr$(13) + Chr$(10) + _
        "Nota: Debe ser el título exacto")
   
    WinWnd = FindWindow(vbNullString, Ret)
   
    If WinWnd = 0 Then
        MsgBox "No se encontró esa cochinada...", _
            vbCritical, "Error"
        Exit Sub
    End If

    PostMessage WinWnd, WM_CLOSE, 0&, 0&
End Sub

    ¿Qué no se puede hacer con esto? Jejejeje. Nos vemos.

[ranefi]

Enviar archivos por FTP con Scripts y Batch

Agregar 5 controles Label, 4 TextBox, 1 CommandButton, 1 DriveListBox, 1 DirListBox, 1 FileListBox e REPLACEar el siguiente código

Código:

Private Declare Function GetShortPathName Lib "kernel32" Alias _
    "GetShortPathNameA" (ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long


Sub Configuraciones()
    Label1.Caption = "Host FTP"
    Label2.Caption = "Usuario"
    Label3.Caption = "Clave"
    Label4.Caption = "Archivo"
    Label5.Caption = "Carpeta FTP"
   
        Command1.Caption = "Enviar"
       
        Text3.PasswordChar = "*"
       
            Text1.TabIndex = 0
            Text2.TabIndex = 1
            Text3.TabIndex = 2
            Text4.TabIndex = 3
       
            Drive1.TabIndex = 4
            Dir1.TabIndex = 5
       
        File1.TabIndex = 6
       
        Command1.TabIndex = 7
   
    Text1.Text = Empty
    Text2.Text = Empty
    Text3.Text = Empty
    Text4.Text = Empty
End Sub

Public Function ObtenRutaCorta(NomArchivo As String) As String
    Dim lngRes As Long, strPath As String
   
    strPath = String$(165, 0)

    lngRes = GetShortPathName(NomArchivo, strPath, 164)

    ObtenRutaCorta = Left$(strPath, lngRes)
End Function

Private Sub Command1_Click()
    Dim Archivo As String, Ruta As String, _
        Corta As String, NombreCorto As String
   
    Dim NumArchivo As Long
   
    Dim Lee As Integer, Resta As Integer
   
       
        Ruta = Drive1.Drive & "\" & Dir1.Path
   
            Lee = Len(Ruta)
            Resta = Lee - 3
   
            Corta = Right$(Ruta, Resta)
       
        Ruta = Corta
       
   
        If Len(Ruta) > 3 Then
            Ruta = Ruta & "\"
            MsgBox "Sí"
        Else
            MsgBox "Sino"
        End If
   
        Archivo = App.Path & "\temp.bat"
        NumArchivo = FreeFile()
       
        NombreCorto = ObtenRutaCorta(Ruta)
               
        Open Archivo For Output As #NumArchivo
            Print #NumArchivo, "@ECHO OFF"
            Print #NumArchivo, ">>SCRIPT.FTP ECHO " & Text2.Text
            Print #NumArchivo, ">>SCRIPT.FTP ECHO " & Text3.Text
            Print #NumArchivo, ">>SCRIPT.FTP ECHO CD " & Text4.Text
            Print #NumArchivo, ">>SCRIPT.FTP ECHO PUT " & NombreCorto & LCase(File1.FileName)
            Print #NumArchivo, ">>SCRIPT.FTP ECHO BYE"
            Print #NumArchivo, "FTP -v -s:SCRIPT.FTP " & Text1.Text
            Print #NumArchivo, "TYPE NULL >SCRIPT.FTP"
            Print #NumArchivo, "DEL SCRIPT.FTP"
            Print #NumArchivo, "EXIT"
        Close #NumArchivo
   
        Shell App.Path & "\temp.bat", vbHide
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
On Error GoTo ups
    Dir1.Path = Drive1.Drive
    Exit Sub
ups:
    MsgBox "La unidad no está lista", vbInformation, "Intente una vez más"
    Drive1.Drive = "C:\"
    Dir1.Path = "C:\"
End Sub

Private Sub Form_Load()
    Configuraciones
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
    Kill App.Path & "\temp.bat"
End Sub

Muy útil, creo que era lo que todos estaban buscando. Sí funciona, lo probé con BraveHost y Yahoo, con éste último fallaba una que otra vez pero aún así funciona.

Nota: En carpeta FTP deben escribir el nombre de la carpeta de su cuenta FTP, un ejemplo, con BraveHost sería: ranefi.braveho st.com.

[ranefi]

Abrir Panel de Control

Agregar 1 control CommandButton e insertar el siguiente código

Código:

Private Sub Command1_Click()
    Shell "rundll32.exe shell32.dll, Control_RunDLL", 5
End Sub

Así de simple. Nos vemos.

[ranefi]

Manipular la tecla Win minimizando todas las ventanas (WIN + M)

Agregar 1 control CommandButton e insertar el siguiente código

En el formulario

Código:

Private Sub Command1_Click()
    Call keybd_event(VK_LWIN, 0, 0, 0)
    Call keybd_event(77, 0, 0, 0)
    Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub

En el módulo

Código:

Public Const VK_LWIN = &H5B
Public Const KEYEVENTF_KEYUP = &H2

Public Declare Sub keybd_event Lib "user32" _
    (ByVal bVk As Byte, ByVal bScan As Byte, _
    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Lo que hace es minimizar todas las ventanas que se encuentren abiertas. Emmmm ¿se imaginan si llegan a poner este código dentro del evento de un Timer? ¿O en un bucle? Jajajajajaja, de risa, jejeje. Nos vemos.

[ranefi]

Abrir menú Inicio (CTRL + ESC)

Agregar 1 control CommandButton e insertar el siguiente código

En el formulario

Código:

Private Sub Command1_Click()
    If Command1.Caption = "Abrir menú Inicio" Then
        Call keybd_event(VK_CONTROL, 0, 0, 0)
        Call keybd_event(VK_ESCAPE, 0, 0, 0)
        Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0)
        Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0)
       
        Command1.Caption = "Cerrar menú Inicio"
    Else
        Call keybd_event(VK_ESCAPE, 0, 0, 0)
        Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0)
       
        Command1.Caption = "Abrir menú Inicio"
    End If
End Sub

Private Sub Form_Load()
    Command1.Height = 600
    Command1.Caption = "Abrir menú Inicio"
End Sub

En el módulo

Código:

Public Const VK_CONTROL = &H11
Public Const VK_ESCAPE = &H1B
Public Const KEYEVENTF_KEYUP = &H2

Public Declare Sub keybd_event Lib "user32" _
    (ByVal bVk As Byte, ByVal bScan As Byte, _
    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Muy interesante pues aprendemos a manipular el teclado. Nos vemos.

[ranefi]

Manipular la tecla Mayúsculas (Bloq Mayús)

Agregar 1 control CommandButton e insertar el siguiente código

En un formulario

Código:

Private Sub Command1_Click()
    Call keybd_event(VK_CAPITAL, 0, 0, 0)
    Call keybd_event(VK_CAPITAL, 0, KEYEVENTF_KEYUP, 0)
End Sub

En un módulo

Código:

Public Const VK_CAPITAL = &H14
Public Const KEYEVENTF_KEYUP = &H2

Public Declare Sub keybd_event Lib "user32" _
    (ByVal bVk As Byte, ByVal bScan As Byte, _
    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Simple pero efectivo. Adiós.

[ranefi]

Obtener nombre corto de carpetas

Agregar 1 control CommandButton e insertar el siguiente código

Código:

Private Declare Function GetShortPathName Lib "kernel32" Alias _
    "GetShortPathNameA" (ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long


Public Function DameRutaCorta(NomArchivo As String) As String
    Dim lngRes As Long, strPath As String
   
    strPath = String$(165, 0)

        lngRes = GetShortPathName(NomArchivo, strPath, 164)

    DameRutaCorta = Left$(strPath, lngRes)
End Function

Private Sub Command1_Click()
    Dim RutaCorta As String
    Dim RutaCarpeta As String
   
    RutaCarpeta = "C:\ranefi quiere tacos de barbacha"
   
        RutaCorta = _
            DameRutaCorta(RutaCarpeta)
   
    Me.Caption = RutaCorta
End Sub

Private Sub Form_Load()
On Error GoTo ups
    MkDir "C:\ranefi quiere tacos de barbacha"
    Exit Sub
ups:
    MsgBox "No bañes bato loco, la carpeta ya está creada, bórrala.", _
        vbCritical, "ranefi te regaña, jajaja :P"
End Sub

Con esto obtienes el nombre en modo MS-DOS de las carpetas de Windows. Au revoir.