Este sitio utiliza cookies propias y de terceros. Si continúa navegando consideramos que acepta el uso de cookies. OK Más Información.

[VB6] Coleccion de Codigos Utiles

  • 82 Respuestas
  • 55037 Vistas

0 Usuarios y 2 Visitantes están viendo este tema.

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #20 en: Junio 08, 2012, 11:44:07 am »
como Imprimir en tamaño especial en Impresoras Matriciales e
bueno yo tope con lo mismo y pedi soporte a Epson.es y me respondieron esto para las impresoras matriciales en windows XP con tamaño de papel "No", standar.

Para XP.

1. Acceda desde el botón INICIO (CONFIGURACIÓN) carpeta IMPRESORAS (Y
FAXES).

2. Seleccione el icono del driver haciendo un clic con el botón izquierdo
marcando el icono de la impresora EPSON.

3. Busque en el menú ARCHIVO la opción PROPIEDADES DEL SERVIDOR.

4. En la pestaña FORMULARIOS, active la casilla de verificación CREAR UN
NUEVO FORMULARIO.

5. Encontrará un cuadro de texto que dice DESCRIPCIÓN DEL FORMULARIO
(Medidas)

6. En este campo escriba un nombre que identifique su papel por ejemplo
NUEVO_FORMULARIO:

7. En el área MEDIDAS encontrará dos cuadros de valores que corresponderán a
la ANCHURA y ALTURA del formulario
que vaya a utilizar, si tiene seleccionado el botón MÉTRICO introduzca los
valores en centímetros.

8. Una vez introduzca las medidas tanto de altura como de anchura, pulse
sobre el botón GUARDAR FORMULARIO para
grabarlo y a partir de ese momento le aparecerá en la lista de la ventana
superior donde se puede escoger el papel
por defecto para esa impresora.

9. A continuación pulse sobre el botón ACEPTAR y le aparecerá para escoger
el nuevo papel NUEVO_FORMULARIO. En la
carpeta de impresoras, pulse el botón derecho del ratón sobre el icono de su
impresora, entre en 'Configuración predeterminada para este documento' y en
la pestaña de avanzadas, seleccione el tamaño de papel personalizado que
hemos creado.

Recuerde que es muy importante además de crear el formulario, definir en
la propia aplicación desde donde se
desea imprimir, el tamaño físico del formulario que deberá coincidir con las
medidas de NUEVO_FORMULARIO.

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #21 en: Junio 08, 2012, 11:44:24 am »
Solo numeros en un Texbox
Código:
Function SoloNumeros(ByVal KeyAscii As Integer) As Integer
      ' Intercepta un codigo ASCII recibido admitiendo solamente
      ' caracteres numéricos, además:
      ' cambia el punto por una coma
      ' acepta el signo -
     
      ' deja pasar sin afectar si recibe tecla de borrado o return
       If KeyAscii = Asc(".") Then KeyAscii = Asc(",")
       If InStr("0123456789.,-", Chr(KeyAscii)) = 0 Then
          SoloNumeros = 0
         Else
          SoloNumeros = KeyAscii
        End If
        ' teclas especiales permitidas
        If KeyAscii = 8 Then SoloNumeros = KeyAscii  borrado atras
       
    End Function


Private Sub txtvalor_KeyPress(KeyAscii As Integer)
KeyAscii = SoloNumeros(KeyAscii)
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #22 en: Junio 08, 2012, 11:44:44 am »
Otra Forma Para Ingresar Solo Numeros
Código:
Private Sub Text1_LostFocus()
If Not IsNumeric(Me.Text1.Text) Then
MsgBox ("Ingrese solo numeros")
End If
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #23 en: Junio 08, 2012, 11:45:21 am »
Como saber cuantos registros tiene el Recordset
Ustedes diran "¡Qué fácil! Usamos la propiedad RecordCount del Recordset" ..... Si y no. La propiedad RecordCount funciona bien si antes nos movemos hasta el último registro, sino, en algunos casos funciona y en otros no. Pero si nuestro recordset no tiene registros, no puede ejecutar el RS.MoveLast, ya que no tiene registros, y el programa da un error. Entonces podemos hacer lo siguiente:

Código:
If RS.EOF = True And RS.BOF = True Then
MsgBox "Nuestro Recordset no tiene registros"
else
RS.MoveLast
MsgBox "Nuestro Recordset tiene " & CStr(RS.RecordCount) & " registros
End If


Si el Recordset no tiene registros, tanto la propiedad EOF como la BOF tiene valor verdadero.

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #24 en: Junio 08, 2012, 11:45:43 am »
Imprimir un RichTextBox tal y como se ve
Imprimir un RichTextBox con su formato original.

Código:
Private Sub Command1_Click()
On Error GoTo ErrorDeImpresion
Printer.Print ""
RichTextBox1.SelPrint Printer.hDC
Printer.EndDoc
Exit Sub
ErrorDeImpresion:
Exit Sub
End Sub



Otra forma:

En el Formulario [Form1 por defecto] :

Código:
Private Sub Form_Load() Dim LineWidth As Long Me.Caption = "Rich Text Box Ejemplo de Impresion" Command1.Move 10, 10, 600, 380 Command1.Caption = "&Imprimir" RichTextBox1.SelFontName = "Verdana, Tahoma, Arial" RichTextBox1.SelFontSize = 10 LineWidth = WYSIWYG_RTF(RichTextBox1, 1440, 1440) Me.Width = LineWidth + 200End Sub Private Sub Form_Resize() RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600End Sub Private Sub Command1_Click() PrintRTF RichTextBox1, 1440, 1440, 1440, 1440End Sub Crear un módulo y escribir:

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type CharRange
cpMin As Long
cpMax As Long
End Type

Private Type FormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CharRange
End Type

Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As Long, ByVal lpInitData As Long) As Long

Public Function WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, _
RightMarginWidth As Long) As Long
Dim LeftOffset As Long, LeftMargin As Long, RightMargin As Long
Dim LineWidth As Long
Dim PrinterhDC As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
LineWidth = RightMargin - LeftMargin
PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _
ByVal LineWidth)
Printer.KillDoc
WYSIWYG_RTF = LineWidth
End Function

Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _
TopMarginHeight, RightMarginWidth, BottomMarginHeight)
Dim LeftOffset As Long, TopOffset As Long
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin
fr.hdc = Printer.hdc
fr.hdcTarget = Printer.hdc
fr.rc = rcDrawTo
fr.rcPage = rcPage
fr.chrg.cpMin = 0
fr.chrg.cpMax = -1
TextLength = Len(RTF.Text)
Do
NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)
If NextCharPosition >= TextLength Then Exit Do
fr.chrg.cpMin = NextCharPosition
Printer.NewPage
Printer.Print Space(1)
fr.hDC = Printer.hDC
fr.hDCTarget = Printer.hDC
Loop
Printer.EndDoc
r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #25 en: Junio 08, 2012, 11:46:10 am »
Como usar un Array
Un array permite referirse a una serie de elementos del mismo tipo por un mismo nombre y referenciar un único elemento de la serie utilizando un índice. Visual Basic, igual que sus predecesores, permite definir arrays de variables de una o más dimensiones y de cualquier tipo de datos (tipos fundamentales y tipos definidos por el usuario), e introduce una nueva clase de arrays de controles, necesarios para escribir menús, para crear nuevos controles en tiempo de ejecución o para hacer que una serie de controles tengan asociado un mismo procedimiento para cada tipo de suceso.

Arrays de variables

Los arrays discutidos en este apartado permiten referirse a una serie de variables por un mismo nombre y acceder individualmente a cada una de ellas utilizando un índice (variables subindicadas). Este tipo de arrays tiene que declararse en el código y pueden tener una o más dimensiones.

Arrays estáticos

Para declarar un array estático (array con un número fijo de elementos), Visual Basic hace tres consideraciones importantes:

Para declarar un array global, hágalo en la sección de declaraciones de un módulo utilizando la sentencia Public.
Para declarar un array a nivel de un módulo, hágalo en la sección de declaraciones del módulo utilizando la sentencia Public o Dim.
Para declarar un array local a un procedimiento, utilice la sentencia Dim o Static dentro del propio procedimiento.
A diferencia de otras versiones de Basic, Visual Basic no permite declarar implícitamente un array. Un array tiene que ser declarado explícitamente, y los índices del mismo deben estar en el rango (-2.147.483.648 a 2.147.483.647).

A continuación se muestran algunos ejemplos:

Dim Array_A(19) As String

Este ejemplo declara un array de una dimensión, Array_A, con veinte elementos, Array_A(0), Array_A(1),..., Array_A(19), cada uno de los cuales permite almacenar una cadena de caracteres de longitud variable.

Dim Array_B(3, 1 To 6) As Integer

Este ejemplo declara un array de dos dimensiones, Array_B, con 4x6 elementos, Array_B(0,1),..., Array_B(3,6), de tipo entero.

Static Array_C(1 To 5, 1 To 5) As Integer

Este ejemplo declara un array de dos dimensiones, Array_C, con 5x5 elementos, Array_C(1,1),..., Array_C(5,5), de tipo entero.

Public Array_D(1 To 12) As String *60

Este ejemplo declara un array de una dimensión, Array_D, con doce elementos, Array_D(1),..., Array_D(12), cada uno de los cuales permite almacenar una cadena de caracteres de longitud fija (60 caracteres).

Arrays Dinámicos

Cuando las dimensiones de un array no son siempre las mismas, la mejor forma de especificarlas es mediante variables. Un array declarado de esta forma es un array dinámico. El espacio necesario para un array estático se asigna al iniciarse el programa y permanecerá fijo. El espacio para un array dinámico será asignado en cualquier momento durante la ejecución.

Para crear un array dinámico.

Declare el array en la sección de declaraciones de un módulo con una sentencia Public si lo quiere global con Private o Dim si lo quiere s nivel del módulo, o en un procedimiento con Static o Dim si lo quiere local. Para especificar que el array va a ser dinámico deje la lista de dimensiones vacía. Por ejemplo:

Dim Array_A()

Asigne el número actual de elementos con la sentencia ReDim.

ReDim Array_A(N+1)

La sentencia ReDim puede aparecer solamente en un procedimiento y permite cambiar el número de elementos del array, no el número de dimensiones.

Por ejemplo, si declaramos el array_A a nivel de un módulo.

Private Array_A() as Integer

Para asignarle espacio al array utilizamos:

ReDim Array_A(5)

Cada vez que se ejecuta la sentencia ReDim, todos los valores almacenados en el array se pierden. Cuando le interese cambiar el tamaño del array conservando los valores del array, ejecute ReDim con la palabra clave Preserve. Por ejemplo, supongamos un Array_A de dos dimensiones. La sentencia será:

ReDim Preserve Array_A(8)

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #26 en: Junio 08, 2012, 11:46:24 am »
Como restar fechas u Horas
Dos ejemplos de cómo restar fechas y horas.
Para saber los segundos entre dos horas o los días entre dos fechas.

Crea un form con los siguientes controles, dejale los nombre por defecto.
4 TextBox
2 Labels
2 Commands
Distribuyelos para que los dos primeros TextoBoxes estén con el primer label y command, lo mismo con el resto.
Añade lo siguiente al form y pulsa F5

'Ejemplo de prueba para restar fechas y horas

Código:
Option Explicit


Private Sub Command1_Click()
Dim t0 As Variant, t1 As Variant

'Text1 Tendrá una fecha anterior
'Text2 tendrá la nueva fecha
t0 = DateValue(Text1)
t1 = DateValue(Text2)
Label1 = t1 - t0

End Sub


Private Sub Command2_Click()
Dim t0 As Variant, t1 As Variant

'Text3 Tendrá una hora anterior
Text4 = Format(Now, "hh:mm:ss")
t0 = Format(Text3, "hh:mm:ss")
t1 = Format(Text4, "hh:mm:ss")
Label2 = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")

End Sub


Private Sub Form_Load()
'Para probar la diferencia de fechas
Text1 = DateValue(Now)
Text2 = DateValue(Now + 10)
'
'Para probar la diferencia de horas
Text3 = Format(Now, "hh:mm:ss")
Text4 = Format(Now, "hh:mm:ss")

Command1_Click
Command2_Click
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #27 en: Junio 08, 2012, 11:46:57 am »
Ejecutar Cualquier tipo de Archivos
Esta es una función que nos permite ejecutar Cualquier Archivo siempre y cuando existe un programa para abrir dicho archivo.
Ademas ejecuta los .exe y abre directorios o unidades.
Ejemplo
Ponemos Direccion="D:/" ABRIRA UNA BENTANA con el contenido de D
Ponemos Direccion="D:/PEPE" ABRIRA UNA BENTANA con el contenido de pepe
Ponemos Direccion="D:/PEPE/doci.doc" ABRIRA doci.doc sin existe un programa para abrirlo como es elWord.

Escriba este codigo en el formulario en General:

Public Sub EjecutarArchivos(Direccion As String)
On Error GoTo error
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & (Direccion), 1)
Exit Sub
error: MsgBox Err.Description, vbExclamation, "Error de Ejecución"
End Sub

para ejecutar solo tenemos que poner
La función
ejemplo
EjecutarArchivos "c:\nota.txt"

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #28 en: Junio 08, 2012, 11:47:25 am »
Detener Apagado de Windows...
En un módulo:

Código:
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

Type POINTAPI
        x As Long
        y As Long
End Type

Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const GWL_WNDPROC = -4
Public Const WM_QUERYENDSESSION = &H11
Global Const WM_CANCELMODE = &H1F

Public SDAttempted As Long
Global lpPrevWndProc As Long
Global gHW As Long

Public Sub Hook()
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub Unhook()
    Dim temp As Long
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) As _
Long
Dim a As Long
    If uMsg = WM_QUERYENDSESSION Then
            SDAttempted = SDAttempted + 1
            WindowProc = CallWindowProc(lpPrevWndProc, hw, _
            WM_CANCELMODE, wParam, wParam)
             Exit Function
    End If
    WindowProc = CallWindowProc(lpPrevWndProc, hw, _
    uMsg, wParam, lParam)
End Function


En el form Load o Activate:

Código:
SDAttempted = 0
gHW = Me.hwnd
Hook

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #29 en: Junio 08, 2012, 11:47:55 am »
Ordenar Datagrid haciendo click en la cabecera
Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer)
With Adodc1.Recordset
If (.Sort = .Fields(ColIndex).[Nombre] & " Asc") Then
.Sort = .Fields(ColIndex).[Nombre] & " Desc"
Else
.Sort = .Fields(ColIndex).[Nombre] & " Asc"
End If
End With
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #30 en: Junio 08, 2012, 11:48:18 am »
Ejecutar cualquier programa
Código:
Dim ret As String
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & ("ruta archivo"))

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #31 en: Junio 08, 2012, 11:50:50 am »
Ejecutar una direccion url en el navegador
Código:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_NORMAL = 1

Dim X
X = ShellExecute(Me.hwnd, "Open", "http://www.url.com", &O0, &O0, SW_NORMAL)

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #32 en: Junio 08, 2012, 11:51:14 am »
Control total del taskbar
Con esto puedes ocultar y/o mostrar los iconos que se encuentran al aldo del reloj del taskbar.

En un módulo:

Código:
Public isvisible As Integer
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Public Function HideTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarIcons()
    Dim FindClass As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBarClock()
    Dim FindClass As Long, FindParent As Long, Handle As Long
    FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
    FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
    Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0
End Function

Public Function ShowDesktop()
    ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5
End Function

Public Function HideStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = FindWindow("Shell_TrayWnd", "")
    Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Function HideTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 0
End Function

Public Function ShowTaskBar()
    Dim Handle As Long
    Handle& = FindWindow("Shell_TrayWnd", vbNullString)
    ShowWindow Handle&, 1
End Function

Public Sub MakeNormal(hwnd As Long)
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Public Sub MakeTopMost(hwnd As Long)
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub


En el form:

Código:
Dim ico As Integer
Dim clo As Integer
Dim stb As Integer
Dim tsk As Integer
Dim dsk As Integer

Private Sub Command1_Click()
If isvisible = 1 Then
        If ico = 0 Then
        ShowTaskBarIcons
        ico = 1
        ElseIf ico = 1 Then
        HideTaskBarIcons
        ico = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command2_Click()
If isvisible = 1 Then
        If clo = 0 Then
        ShowTaskBarClock
        clo = 1
        ElseIf clo = 1 Then
        HideTaskBarClock
        clo = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command3_Click()
If isvisible = 1 Then
        If stb = 0 Then
        ShowStartButton
        stb = 1
        ElseIf stb = 1 Then
        HideStartButton
        stb = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command4_Click()
 If isvisible = 1 Then
        If tsk = 0 Then
        ShowTaskBar
        tsk = 1
        ElseIf tsk = 1 Then
        HideTaskBar
        tsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command5_Click()
If isvisible = 1 Then
        If dsk = 0 Then
        ShowDesktop
        dsk = 1
        ElseIf dsk = 1 Then
        HideDesktop
        dsk = 0
        End If
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Command6_Click()
   If isvisible = 1 Then
        ShowTaskBarIcons
        ShowTaskBarClock
        ShowDesktop
        ShowStartButton
        ShowTaskBar
        ico = 1
        clo = 1
        stb = 1
        tsk = 1
        dsk = 1
    ElseIf isvisible = 0 Then
    End If
End Sub

Private Sub Form_Load()
MakeTopMost Me.hwnd
isvisible = 1
ico = 1
clo = 1
stb = 1
tsk = 1
dsk = 1
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #33 en: Junio 08, 2012, 11:51:42 am »
Como posicionar el cursor con vb6
Código:
Option Explicit

Private Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long

Private Sub Command1_Click()
Dim a As Long, b As Long, c As Long
SetCursorPos 256, 256
a = 2
b = 5
c = a + b
SetCursorPos 512, 512
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #34 en: Junio 08, 2012, 12:14:27 pm »
Colocar el icono de la aplicacion en el systray
En un modulo:

Código:
Public nid As NOTIFYICONDATA
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public Const WM_CHAR = &H102
Public Const WM_SETTEXT = &HC
Public Const WM_USER = &H400
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_CLOSE = &H10
Public Const WM_COMMAND = &H111
Public Const WM_CLEAR = &H303
Public Const WM_DESTROY = &H2
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Sub InitializeTrayIcon()
With nid
.cbSize = Len(nid)
.hwnd = frmMain.hwnd 'nombre del form que estara minimizado
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = frmMain.Icon 'nombre del formulario que contiene el icono
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub


Y en el Form:

Código:
Private Sub Form_Load()
InitializeTrayIcon
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Result As Long
Dim msg As Long
If Me.ScaleMode = vbPixels Then
msg = X
Else
msg = X / Screen.TwipsPerPixelX
End If
Select Case msg
Case 517
Me.PopupMenu MNU
Case 514
Result = SetForegroundWindow(Me.hwnd)
Me.Show
End Select
End Sub

Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, nid
End Sub

Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nid
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #35 en: Junio 08, 2012, 12:15:06 pm »
Formulario transparente con controles visibles
¡OJO! Este codigo funciona solo si el BorderStyle del form es 0...

En un modulo:

Código:
Option Explicit
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Const RGN_XOR = 3

Public Sub MakeTransparent(TransForm As Form)
Dim ErrorTest As Double
    On Error Resume Next
    Dim Regn As Long
    Dim TmpRegn As Long
    Dim TmpControl As Control
    Dim LinePoints(4) As POINTAPI
    TransForm.ScaleMode = 3
    If TransForm.BorderStyle <> 0 Then MsgBox "Change the borderstyle to 0!", vbCritical, "ACK!": End
    Regn = CreateRectRgn(0, 0, 0, 0)
    For Each TmpControl In TransForm
        If TypeOf TmpControl Is Line Then
            If Abs((TmpControl.Y1 - TmpControl.Y2) / (TmpControl.X1 - TmpControl.X2)) > 1 Then
                LinePoints(0).X = TmpControl.X1 - 1
                LinePoints(0).Y = TmpControl.Y1
                LinePoints(1).X = TmpControl.X2 - 1
                LinePoints(1).Y = TmpControl.Y2
                LinePoints(2).X = TmpControl.X2 + 1
                LinePoints(2).Y = TmpControl.Y2
                LinePoints(3).X = TmpControl.X1 + 1
                LinePoints(3).Y = TmpControl.Y1
            Else
                LinePoints(0).X = TmpControl.X1
                LinePoints(0).Y = TmpControl.Y1 - 1
                LinePoints(1).X = TmpControl.X2
                LinePoints(1).Y = TmpControl.Y2 - 1
                LinePoints(2).X = TmpControl.X2
                LinePoints(2).Y = TmpControl.Y2 + 1
                LinePoints(3).X = TmpControl.X1
                LinePoints(3).Y = TmpControl.Y1 + 1
            End If
            TmpRegn = CreatePolygonRgn(LinePoints(0), 4, 1)
        ElseIf TypeOf TmpControl Is Shape Then
            If TmpControl.Shape = 0 Then
                TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
            ElseIf TmpControl.Shape = 1 Then
                If TmpControl.Width < TmpControl.Height Then
                    TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width)
                Else
                    TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height)
                End If
            ElseIf TmpControl.Shape = 2 Then
                TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
            ElseIf TmpControl.Shape = 3 Then
                If TmpControl.Width < TmpControl.Height Then
                    TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 0.5)
                Else
                    TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
                End If
            ElseIf TmpControl.Shape = 4 Then
                If TmpControl.Width > TmpControl.Height Then
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
                Else
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Width / 4, TmpControl.Width / 4)
                End If
            ElseIf TmpControl.Shape = 5 Then
                If TmpControl.Width > TmpControl.Height Then
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
                Else
                    TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 1, TmpControl.Width / 4, TmpControl.Width / 4)
                End If
            End If
            If TmpControl.BackStyle = 0 Then
                CombineRgn Regn, Regn, TmpRegn, RGN_XOR
                If TmpControl.Shape = 0 Then
                    TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + TmpControl.Height - 1)
                ElseIf TmpControl.Shape = 1 Then
                    If TmpControl.Width < TmpControl.Height Then
                        TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 1)
                    Else
                        TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 1, TmpControl.Top + TmpControl.Height - 1)
                    End If
                ElseIf TmpControl.Shape = 2 Then
                    TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
                ElseIf TmpControl.Shape = 3 Then
                    If TmpControl.Width < TmpControl.Height Then
                        TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 0.5)
                    Else
                        TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
                    End If
                ElseIf TmpControl.Shape = 4 Then
                    If TmpControl.Width > TmpControl.Height Then
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
                    Else
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Width / 4, TmpControl.Width / 4)
                    End If
                ElseIf TmpControl.Shape = 5 Then
                    If TmpControl.Width > TmpControl.Height Then
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
                    Else
                        TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width, TmpControl.Width / 4, TmpControl.Width / 4)
                    End If
                End If
            End If
        Else
               TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
       End If
            ErrorTest = 0
            ErrorTest = TmpControl.Width
            If ErrorTest <> 0 Or TypeOf TmpControl Is Line Then
                CombineRgn Regn, Regn, TmpRegn, RGN_XOR
            End If
    Next TmpControl
    SetWindowRgn TransForm.hwnd, Regn, True
End Sub


En el form:

Código:
Private Declare Function ReleaseCapture Lib "user32" () As Long
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
Private Const WM_SYSCOMMAND = &H112

Private Sub Form_Load()
    MakeTransparent frmTrans
End Sub

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #36 en: Junio 08, 2012, 12:15:24 pm »
Detectar cuando se presiona una tecla o combinación de tecla
Esto es a pura API de Windows usaremos la función GetKeyState de la libreria user32. Si queremos detectar la o las teclas presionadas tenemos que llamar a la función pasándole como parámetro el código ASCII de la o las teclas que queremos analizar. Si la tecla está pulsada, la función devuelve –127 o –128. (Se van alternando los valores a cada pulsación completa.) Cuando no está apretada, la función devuelve 0 o 1. Resumiendo, la tecla está pulsada si la función devuelve un número menor de 0.
Para ver una demostración de esta función, podemos crear un Label y un Timer con el Interval bajo (para que continuamente se produzca el Timer1_Timer). Añadir este código:

Código:
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Sub Timer1_Timer()
If GetKeyState(32) < 0 And GetKeyState(vbKeyUp) < 0 Then
Label1.Caption = "Estás pulsando espacio y arriba a la vez."
Else
Label1.Caption = "No"
End If
End Sub


Al ejecutar el programa, el texto del Label será No; pero al apretar Espacio y Flecha Arriba a la vez, el texto cambiará hasta que dejen de pulsarse estas teclas.

Recuerden poner intervalo al timer y enable=True

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #37 en: Junio 08, 2012, 12:15:48 pm »
Listar los procesos
Colocaremos en el formulario un ListBox de nombre List1.
Y luego copiar este codigo...

Código:
Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVallProcessID As Long) As Long

Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260
End Type


Private Sub Form_Load()
Dim hSnapShot As Long
Dim uProceso As PROCESSENTRY32
Dim res As Long

hSnapShot = CreateToolhelpSnapshot(2&, 0&)
If hSnapShot <> 0 Then
uProceso.dwSize = Len(uProceso)
res = ProcessFirst(hSnapShot, uProceso)
Do While res
List1.AddItem Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1)
res = ProcessNext(hSnapShot, uProceso)
Loop
Call CloseHandle(hSnapShot)
End If
End Sub

_________________

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #38 en: Junio 08, 2012, 12:16:16 pm »

Eso es una Bicoca, Aqui tienen el codigo en una sola linea. Para todos mis amigos programadores de Visual Basic.

Código:
Shell "rundll32.exe user32.dll LockWorkStation"

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #39 en: Junio 08, 2012, 12:16:38 pm »
Abrir la caja de dialogo de Abrir con selección multiple de
Esto es a pura API adios comandialogo. para que control si tenemos la API. ¿Verdad?

En un modulo:

Código:
' Modulo para Abrir la caja de dialogo de Abrir
' archivos donde podra aser selección multiple
'Ejemplo de Yosvanis Cruz Alias VisualGuallabo
'Alguna sugerencia responder
' a [email protected] estare agradesido
'Con este codigo puede aser los cambios que quiera
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Public Const OFN_EXPLORER = &H80000 ' new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules

Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Total_de_Archivos As Integer
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Lista_Archivos(1 To 20000) As String
Function CountFilesInList(ByVal FileList As String) As Integer
' Cuenta archivos. Los regresos resultan como el entero
Dim iCount As Integer
Dim iPos As Integer

iCount = 0
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr$(0) Then iCount = iCount + 1
Next
If iCount = 0 Then iCount = 1
CountFilesInList = iCount
End Function

Function GetFileFromList(ByVal FileList As String, FileNumber As Integer) As String
' Obtiene el nombre de archivo de FileNumber de FileList
Dim iPos As Integer
Dim iCount As Integer
Dim iFileNumberStart As Integer
Dim iFileNumberLen As Integer
Dim sPath As String

If InStr(FileList, Chr(0)) = 0 Then
GetFileFromList = FileList
Else
iCount = 0
sPath = Left(FileList, InStr(FileList, Chr(0)) - 1)
If Right(sPath, 1) <> "\" Then sPath = sPath + "\"
FileList = FileList + Chr(0)
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr(0) Then
iCount = iCount + 1
Select Case iCount
Case FileNumber
iFileNumberStart = iPos + 1
Case FileNumber + 1
iFileNumberLen = iPos - iFileNumberStart
Exit For
End Select
End If
Next
GetFileFromList = sPath + Mid(FileList, iFileNumberStart, iFileNumberLen)
End If
End Function
Function OpenDialog(Filter As String, Title As String, InitDir As String) As String

Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 20000
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST Or OFN_EXPLORER Or OFN_ALLOWMULTISELECT

A = GetOpenFileName(ofn)

' Variable del contador
Dim i As Integer

' Pasa a través de todos los archivos seleccionados
For i = 1 To CountFilesInList(ofn.lpstrFile)
' Compruebe el tamaño del archivo
On Error GoTo cont
Select Case FileLen(GetFileFromList(ofn.lpstrFile, i))
Case Is > 0
' Ahora agréga el archivo a la lista
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
Case Else
' Si el tamaño del archivo es 0 (el cero) - pregunta si desea agregar a la lista
If MsgBox("El Archivo " & GetFileFromList(ofn.lpstrFile, i) & " tiene 0bytes de tamaño" _
& vbCr & "¿Está seguro usted que quiere agregarlo?", vbYesNo, "Alerta") = vbYes Then
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
End If
End Select
Next i
cont:
If (A) Then
If Total_de_Archivos = 0 Then Total_de_Archivos = Total_de_Archivos + 1
Lista_Archivos(i) = ofn.lpstrFile
End If

End Function


******************en el Form ************************


Debera agregar un Listbox de nombre List1

Código:
Private Sub Form_Load()
OpenDialog "*.*", "Abrir Archivo", ""
For A = 1 To Total_de_Archivos
If Lista_Archivos(A) <> "" Then List1.AddItem Lista_Archivos(A)
Next A
me.Caption = Total_de_Archivos
End Sub

 

¿Te gustó el post? COMPARTILO!