Programas y Utilidades
para Visual Basic
Actualizado el 03/Nov/2006
Nota:
Esta p�gina est� ya obsoleta... salvo que sigas usando las primeras versiones de Visual Basic (particularmente para 16 bits), por tanto te recomiendo que veas la p�gina de Mis Utilidades para Visual Basic 6.0 y anteriores.
Programas incluidos en esta p�gina desde el ya "remoto" 15/Dic/1997:
Link a la p�gina con la mayor�a de Mis Utilidades...
NOTA del 30/Mar/98:
Te recomiendo que te pases por las p�ginas de Gratisware y Mis Utilidades
ya que en esas p�ginas estar�n los programillas y utilidades, con los listados, que he puesto en mis p�ginas.
As� que seguramente estar�n m�s "actualizados" que esta p�gina.
Programas y utilidades (rutinas y otras cosillas que son algo m�s que un simple truco)
Nuevo contenido con utilidades y otros programas (22/Mar/97)Actualizado el 15-Dic-1997
Actualizado el 04/Jun/2004
Actualizado el 03/Nov/2006
Salva pantallas de Joe LeVasseur. (Protpant.zip 8.667 bytes)
Ejemplo de un salva pantallas (screen saver) de Joe LeVasseur.
En sus p�ginas personales, (ya no existe esa p�gina), podr�s encontrar un salva-pantallas que muestra el icono en la barra de tareas. Joe ha prometido que enviar� el c�digo para mostrar un programa en la barra de tareas. Est�s obligado a hacerlo. 8-)
En el fichero comprimido encontrar�s el c�digo fuente y el ejecutable con la extensi�n .SCR
Copia el fichero Protpant.scr en el directorio System de Windows y podr�s usarlo desde el di�logo de Propiedades de Pantalla, solapa Protector de pantalla.Listados y fichero ejecutable del salva pantallas, nueva versi�n, (Protpan1.zip 8.890 bytes)
Reinicia Windows y muestra los recursos y la memoria disponible. (22/Mar/97)
S�lo para 16 bits.
El listado:
'---------------------------------------------------------- ' gsIniW (Reiniciar Windows) Versi�n 16 bits ' ' (c) Guillermo Som Cerezo (18/May/95) ' ' Utilidad para reiniciar windows. ' Muestra tambi�n la memoria y recursos libres. ( 1/Sep/96) ' ' Este programa es de libre distribuci�n y ' puedes modificarlo, (para eso env�o los listados). ' '---------------------------------------------------------- Option Explicit Declare Function ExitWindows Lib "User" (ByVal ReStartCode As Long, ByVal DosReturnCode As Integer) As Integer 'Obtener la memoria y recursos libres ( 1/Sep/96) Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags As Integer) As Long Declare Function GetFreeSystemResources Lib "User" (ByVal fuSysResource As Integer) As Integer Const GFSR_SYSTEMRESOURCES = &H0 Sub Main() #If Win32 Then MsgBox "Este programa s�lo funciona compilado con 16 bits.", vbInformation #Else Dim Memoria&, m$ Memoria& = GetFreeSpace(0) m$ = "Recursos libres: " & GetFreeSystemResources(GFSR_SYSTEMRESOURCES) & "%" m$ = m$ & " - Memoria libre: " & Format$(Memoria& \ 1024, "###,###,###") & " KB" If MsgBox(m$ & vbCrLf & vbCrLf & "�Quieres reiniciar Windows?", 4 + 16 + 256, "Reiniciar Windows") = 6 Then Memoria& = ExitWindows(66, 0) End If End #End If End Sub
Reinicia Windows (16 y 32 bits) (22/Mar/97)
Esta utilidad reiniciar� Windows. Sirve tanto para 16 como para 32 bits.
Nota:
En la p�gina del API tienes otros ejemplos,
incluso para Windows NT/2000
Reiniciar Windows (listados para 16 y 32
bits)
Reiniciar Windows (2� parte) revisado
para Windows NT
El listado:
Option Explicit '-------------------------------------------------- ' ReIniWin (Reiniciar Windows) ( 8/Nov/95) ' '(c) Guillermo Som '-------------------------------------------------- #If Win32 Then 'Para usar con ExitWindowsEx Public Const EWX_LOGOFF = 0 'Termina la sesi�n actual Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long 'ExitWindows termina la sesi�n actual e inicia una nueva '(es decir reiniciar windows) 'Public Declare Function ExitWindows Lib "user32" (ByVal dwReserved As Long, ByVal uReturnCode As Long) As Long #Else Public Declare Function ExitWindows Lib "user" (ByVal ReStartCode As Long, ByVal DosReturnCode As Integer) As Integer #End If Public Sub Main() Dim msg As String Beep #If Win32 Then msg = "Est�s ejecutando Windows en modo 32bits," & vbCrLf & "(seguramente Windows 95, conectado en red)," & vbCrLf & "y e" #Else msg = "E" #End If msg = msg & "ste programa reiniciar� Windows." If MsgBox(msg & vbCrLf & vbCrLf & "�Seguro que quieres reiniciar Windows?", 4 + 16 + 256, "� ATENCI�N !") = 6 Then 'ReStart Windows #If Win32 Then If ExitWindowsEx(EWX_LOGOFF, 0&) Then #Else If ExitWindows(66, 0) Then #End If End If Else End End If End Sub
Convertir N�meros en Letras (22/Mar/97)
Funci�n para convertir un n�mero en letra.
Por ejemplo: 125 ser�a "ciento veinticinco"
Listado y form de prueba. (gsnum2text.zip 2.98 KB)
Nota:
�chale un vistazo a la p�gina de la clase
cNum2Text.
El listado:
'--------------------------------------------------------------------------- ' gsNumero.BAS M�dulo para procedimientos num�ricos ( 1/Mar/91) ' Versi�n para Windows (25/Oct/96) ' ' (c)Guillermo Som, 1991-97 '--------------------------------------------------------------------------- Option Explicit Option Compare Text Public Function Numero2Letra(ByVal strNum As String, Optional vLo) As String '---------------------------------------------------------- ' Convierte el n�mero strNum en letras (28/Feb/91) ' Versi�n para Windows (25/Oct/96) '---------------------------------------------------------- Dim lngA As Long Dim Negativo As Boolean Dim L As Integer Dim Una As Boolean Dim Millon As Boolean Dim Millones As Boolean Dim vez As Integer Dim MaxVez As Integer Dim k As Integer Dim strQ As String Dim strB As String Dim strU As String Dim strD As String Dim strC As String Dim iA As Integer ' Dim strN() As String Dim lo As Integer ' 'Si no se especifica el ancho... If IsMissing(vLo) Then lo = 255 Else lo = vLo End If Dim unidad(0 To 9) As String Dim decena(0 To 9) As String Dim centena(0 To 9) As String Dim deci(0 To 9) As String Dim otros(0 To 15) As String 'Asignar los valores unidad(1) = "Una" unidad(2) = "dos" unidad(3) = "tres" unidad(4) = "cuatro" unidad(5) = "cinco" unidad(6) = "seis" unidad(7) = "siete" unidad(8) = "ocho" unidad(9) = "nueve" ' decena(1) = "diez" decena(2) = "veinte" decena(3) = "treinta" decena(4) = "cuarenta" decena(5) = "cincuenta" decena(6) = "sesenta" decena(7) = "setenta" decena(8) = "ochenta" decena(9) = "noventa" ' centena(1) = "ciento" centena(2) = "doscientas" centena(3) = "trescientas" centena(4) = "cuatrocientas" centena(5) = "quinientas" centena(6) = "seiscientas" centena(7) = "setecientas" centena(8) = "ochocientas" centena(9) = "novecientas" ' deci(1) = "dieci" deci(2) = "veinti" deci(3) = "treinta y " deci(4) = "cuarenta y " deci(5) = "cincuenta y " deci(6) = "sesenta y " deci(7) = "setenta y " deci(8) = "ochenta y " deci(9) = "noventa y " ' otros(1) = "1" otros(2) = "2" otros(3) = "3" otros(4) = "4" otros(5) = "5" otros(6) = "6" otros(7) = "7" otros(8) = "8" otros(9) = "9" otros(10) = "10" otros(11) = "once" otros(12) = "doce" otros(13) = "trece" otros(14) = "catorce" otros(15) = "quince" ' On Error GoTo 0 lngA = Abs(Val(strNum)) Negativo = (lngA <> Val(strNum)) strNum = LTrim$(RTrim$(Str$(lngA))) L = Len(strNum) If lngA = 0 Then strNum = Left$("cero" & Space$(lo), lo) Exit Function End If ' Una = True Millon = False Millones = False If L < 4 Then Una = False If lngA > 999999 Then Millon = True If lngA > 1999999 Then Millones = True strB = "" strQ = strNum vez = 0 ReDim strN(1 To 4) strQ = Right$(String$(12, "0") & strNum, 12) For k = Len(strQ) To 1 Step -3 vez = vez + 1 strN(vez) = Mid$(strQ, k - 2, 3) Next MaxVez = 4 For k = 4 To 1 Step -1 If strN(k) = "000" Then MaxVez = MaxVez - 1 Else Exit For End If Next For vez = 1 To MaxVez strU = "": strD = "": strC = "" strNum = strN(vez) L = Len(strNum) k = Val(Right$(strNum, 2)) If Right$(strNum, 1) = "0" Then k = k \ 10 strD = decena(k) ElseIf k > 10 And k < 16 Then k = Val(Mid$(strNum, L - 1, 2)) strD = otros(k) Else strU = unidad(Val(Right$(strNum, 1))) If L - 1 > 0 Then k = Val(Mid$(strNum, L - 1, 1)) strD = deci(k) End If End If If L - 2 > 0 Then k = Val(Mid$(strNum, L - 2, 1)) strC = centena(k) & " " End If If strU = "uno" And Left$(strB, 4) = " mil" Then strU = "" strB = strC & strD & strU & " " & strB If (vez = 1 Or vez = 3) And strN(vez + 1) <> "000" Then strB = " mil " & strB If vez = 2 And Millon Then If Millones Then strB = " millones " & strB Else strB = "un mill�n " & strB End If End If Next strB = LTrim$(RTrim$(strB)) If Right$(strB, 3) = "uno" Then strB = Left$(strB, Len(strB) - 1) & "a" Do 'Quitar los espacios que haya por medio iA = InStr(strB, " ") If iA = 0 Then Exit Do strB = Left$(strB, iA - 1) & Mid$(strB, iA + 1) Loop If Left$(strB, 6) = "una un" Then strB = Mid$(strB, 5) If Left$(strB, 7) = "una mil" Then strB = Mid$(strB, 5) If Right$(strB, 16) <> "millones mil una" Then iA = InStr(strB, "millones mil una") If iA Then strB = Left$(strB, iA + 8) & Mid$(strB, iA + 13) End If If Right$(strB, 6) = "ciento" Then strB = Left$(strB, Len(strB) - 2) If Negativo Then strB = "menos " & strB ' strC = Space$(lo) LSet strC = strB Numero2Letra = strC End Function
Aceptar archivos con Drag & Drop (23/Mar/97)
Ejemplo del uso de una clase para aceptar archivos "soltados" en un
formulario.
Aceptar� tanto im�genes BMP, ICO y WMF, as� como archivos de texto. En caso que sea otro
tipo de archivo, si se puede asignar (mostrar) en un textbox, se mostrar�, si no se
producir� un error y el error ser� indicado en el label.
Esta clase est� sacada (sin autorizaci�n) del libro de Francisco Charte:
Programaci�n Profesional con Visual Basic 4.0 de la editorial Anaya Multimedia.
Aunque me expongo a "cualquier cosa" y confiando en que al ser por el tema
divulgativo no haya problemas.
Nota del 15/Dic/97:
Seg�n el autor, Fco. Charte, mientras haga referencia de d�nde est�
sacada, la cosa va bien. Muchas gracias.
Creo que es un ejemplo interesante del modo de realizar esta funci�n que a m�s de
uno, incluido yo, nos gustar�a implementar en sus programas.
Pues ah� queda eso y espero que "le saques provecho"
Baja los listados de la clase y el ejemplo (dragdrop.zip 4.55 KB)
Este es el listado de la clase DragDrop
'---------------------------------------------------------- ' 'cDragDrop.Cls ' ' Esta clase facilitar� la creaci�n de aplicaciones ' que acepten archivos de arrastrar-y-soltar desde ' el Explorador ' 'Clase de ejemplo del Capitulo 8 del libro: 'Programaci�n Profesional con Visual Basic 4.0 'de Francisco Charte (Anaya Multimedia) ' 'Adaptada por Guillermo Som, 23/Mar/97 '---------------------------------------------------------- Option Explicit ' Referencia a la ventana oculta Private MiVentana As frmOculto ' Referencia a la ventana que recibir� los archivos Private VentanaDragDrop As Form Private Termina As Boolean ' indicador interno 'Constantes para las funciones del API 'Const PM_NOREMOVE = &H0 Const PM_REMOVE = &H1 'Const PM_NOYIELD = &H2 Const WM_DROPFILES = &H233 'Declaraciones de las funciones del API Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long 'Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long) Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long) ' Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long Private Declare Function WaitMessage Lib "user32" () As Long 'Tipos de datos para las funciones del API Private Type POINTAPI x As Long y As Long End Type Private Type Msg hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type 'MSG ' Este m�todo activa la recepci�n de archivos ' en la ventana que se pasa como par�metro Public Sub Activa(Ventana As Form) ' Guardamos la referencia a la ventana Set VentanaDragDrop = Ventana ' Activamos la recepci�n de archivos DragAcceptFiles VentanaDragDrop.hwnd, True ' Creamos una ventana oculta Set MiVentana = New frmOculto ' y la asociamos con nosotros mismos Set MiVentana.MiObjeto = Me ' activando el env�o de un mensaje en 500 milisegundos MiVentana.Timer.Enabled = True ' lo cual nos permite devolver el control ' al cliente que nos est� utilizando Termina = False End Sub ' Esta funci�n ser� llamada desde el formulario ' oculto, y se estar� ejecutando mientras Termina ' no tome el valor True Public Sub Proceso() ' Para leer mensajes de la cola Dim Mensaje As Msg, N As Integer ' contador ' Bytes y Cadena para leer nombres de archivo Dim Bytes As Integer, Cadena As String ' Mientras Termina no sea True Do While Not Termina WaitMessage ' esperamos a que llegue un mensaje ' Si ese mensaje es WM_DROPFILES If PeekMessage(Mensaje, VentanaDragDrop.hwnd, WM_DROPFILES, WM_DROPFILES, PM_REMOVE) Then ' lo leemos With Mensaje ' obtenemos el n�mero total de archivos For N = 0 To DragQueryFile(.wParam, -1, Cadena, 0) - 1 ' consultamos la longitud del nombre N Bytes = DragQueryFile(.wParam, N, Cadena, 0) ' asignamos el espacio necesario Cadena = String(Bytes + 1, 0) ' y obtenemos el nombre DragQueryFile .wParam, N, Cadena, Bytes + 1 ' que pasamos al formulario cliente VentanaDragDrop.Archivo Cadena Next DragFinish .wParam ' hemos terminado End With End If DoEvents ' permitimos el trabajo de otros procesos Loop ' y continuamos End Sub ' Este m�todo ser� llamado para desactivar ' el funcionamiento del objeto Public Sub Desactiva() Termina = True ' Provocamos el fin de la ejecuci�n de Proceso ' desactivamos la recepci�n de archivos DragAcceptFiles VentanaDragDrop.hwnd, False Unload MiVentana ' descargamos la ventana oculta Set VentanaDragDrop = Nothing ' y liberamos referencias Set MiVentana = Nothing End Sub ' Al destruir el objeto Private Sub Class_Terminate() ' si no ha sido previamente desactivado If Not Termina Then Desactiva ' lo desactivamos End Sub
El listado del form oculto que usa la clase
' ' frmOculto.frm ' ' Este formulario oculto tiene como �nica finalidad ' enviar un mensaje al objeto asociado una vez ' ha trancurrido un periodo de 500 milisegundos. ' Esto permite que el objeto devuelva el control ' al formulario que ha llamado al m�todo Activa ' Option Explicit ' Referencia al objeto Public MiObjeto As DragDrop ' Al descargar el formulario Private Sub Form_Unload(Cancel As Integer) Set MiObjeto = Nothing ' eliminamos la refrencia End Sub ' Cuando se produzca el evento Private Sub Timer_Timer() Timer.Enabled = False ' desactivamos el timer MiObjeto.Proceso ' y llamamos a Proceso End Sub
Por �ltimo el listado del form de prueba
'------------------------------------------------------------- 'Prueba de Drag & Drop aceptando archivos de texto (23/Mar/97) ' 'Proceso y clase basado en el ejemplo del libro: 'Programaci�n Profesional con Visual Basic 4.0 'de Francisco Charte (Anaya Multimedia) '------------------------------------------------------------- Option Explicit ' Referencia al objeto de arrastrar y soltar Dim MiObjeto As DragDrop ' Este procedimiento p�blico ser� llamado ' por el objeto DragDrop cada vez que se ' reciba un archivo de arrastrar y soltar Public Sub Archivo(Nombre As String) Dim nFic As Integer Desactivar On Local Error Resume Next 'Si es un archivo gr�fico Picture1.Picture = LoadPicture(Nombre) If Err = 0 Then Picture1.Enabled = True Picture1.Visible = True Else Err = 0 'Si no se asigna al text Text1.Enabled = True Text1.Visible = True nFic = FreeFile Open Nombre For Input As nFic Text1 = Input$(LOF(nFic), nFic) Close nFic End If AjustarTama�o Label1 = Nombre If Err Then Label1 = "ERROR: " & Error$ Text1 = "" Err = 0 End If On Local Error GoTo 0 End Sub Private Sub cmdSalir_Click() Unload Me End End Sub Private Sub Form_Load() 'Inicializar ' Creamos el objeto Set MiObjeto = New DragDrop MiObjeto.Activa Me ' lo activamos Desactivar End Sub Private Sub Form_Resize() 'No ajustar las posiciones, si se minimiza el form If WindowState = vbMinimized Then Exit Sub AjustarTama�o End Sub Private Sub Form_Unload(Cancel As Integer) MiObjeto.Desactiva ' desactivamos el objeto Set MiObjeto = Nothing ' y lo liberamos 'Liberar recursos Set Form1 = Nothing End Sub Private Sub AjustarTama�o() Dim alto As Integer cmdSalir.Top = ScaleHeight - 495 cmdSalir.Left = ScaleWidth - 1380 alto = cmdSalir.Top - (Label1.Top + Label1.Height) - 240 If Text1.Enabled Then Text1.Move 90, 480, ScaleWidth - 180, alto End If If Picture1.Enabled Then Picture1.Move 90, 480, ScaleWidth - 180, alto End If End Sub Private Sub Desactivar() Picture1.Enabled = False Picture1.Visible = False Text1.Enabled = False Text1.Visible = False End Sub
Una funci�n para saber si existe un archivo (24/Mar/97)
Esta es una funci�n que me ha enviado mi amigo Joe LeVasseur y es para saber si un archivo existe, aunque sea oculto o del sistema.
Option Explicit ' Ejemplo de probar si existe un archivo sin abrir Private Sub Command1_Click() Dim ValDev As Boolean, UnArchivo As String UnArchivo = "c:\autoexec.bart" ValDev = ExisteArchivo(UnArchivo) MsgBox "ExisteArchivo=" & ValDev & vbCrLf & UnArchivo End Sub Private Sub Command2_Click() Dim ValDev As Boolean, UnArchivo As String UnArchivo = "c:\autoexec.bat" ValDev = ExisteArchivo(UnArchivo) MsgBox "ExisteArchivo=" & ValDev & vbCrLf & UnArchivo End Sub Private Function ExisteArchivo(sNombreArchivo As String) As Boolean Dim AttrDev% On Error Resume Next AttrDev = GetAttr(sNombreArchivo) If Err.Number Then Err.Clear ExisteArchivo = False Else ExisteArchivo = True End If End Function
Hacer Scroll en un Picture y en varios controles (26/Mar/97)
Dos ejemplos para hacer Scroll. Uno es en un Picture con una imagen y el otro usando
varios controles.
Espero que te sirva y lo puedas adaptar para tus necesidades.
En el ejemplo de varios controles tambi�n incluyo como restar horas y adapt�ndolo
puedes usarlo para restar fechas.
En el ejemplo de la imagen, incluyo una funci�n para leer la l�nea de comandos y
quitarle las comillas, si es que se incluyen junto con el nombre del programa.
Baja los ejemplos que est�n en este archivo comprimido: (t_scroll.zip 5.62 KB)
(13/May/97) Los archivos est�n "corregidos" para que no
falle cuando la ventana se reduce "demasiado".
Gracias a "David Sans" [email protected]
por la "aclaraci�n".
Ejecutar archivos con su programa asociado usando DDE (26/Mar/97)
En este ejemplo incluyo un m�dulo que hace tiempo vi por ah�, est� en alem�n, creo,
pero como las instrucciones de VB son "internacionales", por llamarlas de alguna
forma, pues es v�lido.
Para usarlo deber�s tener un control Text o Label para aceptar DDE, en el ejemplo
siguiente es DDESystem
'Ejecutar el archivo o el programa asociado If Exec(DDESystem, AddBSlash(File1.Path) & File1, False) = False Then 'No est� asociado... 'MsgBox "'" & File1 & "' konnte nicht ausgef�hrt werden." 'Si no est� asociado, mostrar la informaci�n... MsgBox "'" & File1 & "' no est� asociado a ning�n programa." End If
Este es el listado completo del archivo: Starter.Bas que es el que tiene las rutinas para ejecutar los programas, as� como otras cosillas interesantes.
Baja los listados del ejemplo original, para VB3. (regdb.zip 9.25 KB)
Option Explicit Global Const MB_RETRYCANCEL = 5 Global Const MB_ICONSTOP = 16 Global Const IDCANCEL = 2 Global Const IDRETRY = 4 'Declaraciones del API de Windows #If Win32 Then Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #Else Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%) Declare Function RegQueryValue& Lib "shell.dll" (ByVal hKey&, ByVal subkey$, ByVal buf$, buflen&) Declare Function FindExecutable% Lib "shell.dll" (ByVal file$, ByVal dr$, ByVal result$) Declare Function GetModuleHandle% Lib "Kernel" (ByVal lpModuleName$) #End If 'A�ade barra de directorio si no la tiene Function AddBSlash(ByVal t As String) As String If Len(t) Then If Right$(t, 1) <> "\" Then AddBSlash = t & "\" Else AddBSlash = t End If Else AddBSlash = "" End If End Function ' Pr�ft, ob eine Anwendung f�r eine DDE-Kommunikation ' angemeldet wurde. Function CanExtDDE(ByVal fext$, ByVal tp$) As Boolean Dim dde$, class$ On Error Resume Next class = QueryRegBase("." & fext) If Len(class) Then dde = QueryRegBase(class & "\shell\" & tp & "\ddeexec") If Len(dde) Then CanExtDDE = True Else CanExtDDE = False End If Else CanExtDDE = False End If End Function Function CountChar%(ByVal t, ByVal z%) Dim g&, zeichen$, n& On Error Resume Next zeichen = Chr$(z) Do g = InStr(g + 1, t, zeichen) n = n + 1 Loop While g CountChar = n - 1 End Function ' Ejecuta el programa o el erchivo con el programa ' asociado Function Exec(c As Control, ByVal fullname$, ByVal t%) As Boolean Dim fpath$, FName$, fbody$, fext$, res%, para$, fn$, tp$ On Error Resume Next If t = 0 Then tp = "open" Else tp = "print" fn = GetAvailPart(fullname, 32, 1) para = Right$(fullname, Len(fullname) - Len(fn) - 1) ' �bergabe in ihre Bestandteile zerlegen. SplitPathname fullname, fpath, FName SplitFilename FName, fbody, fext ' Ist die Datei eventuell ein ausf�hrbares Programm? Die entsprechenden ' Dateiendungen stehen in der WIN.INI. If IsFileOfType(fext, ReadWinIniString("windows", "programs", "")) Then Exec = ExecPrograms(fullname, para) Else ' Unterst�tzt die Anwendung, die zu fext geh�rt, DDE? If CanExtDDE(fext, tp) Then ' mit DDE Kontakt zur Anwendung aufnehmen Exec = ExecDocWithDDE(c, fullname, fpath, fext, tp) Else ' Dokument als Parameter �bergeben Exec = ExecDocWithProgram(fullname, fpath, fext, tp) End If End If End Function ' Steuert den Kontakt mit einer Anwendung via DDE, um ein ' Dokument in diese Anwendung einzulesen. Function ExecDocWithDDE(c As Control, ByVal fullname$, ByVal fpath$, ByVal fext$, ByVal tp$) As Boolean Dim topic$, application$, ddeexec$ Dim ifexec$, cmd$, class$ Dim fpath1$, FName$, fbody$, fext1$ On Error Resume Next ' Die Klasse kann mit Hilfe der Dateierweitung gefunden werden. ' Sie wird f�r alle folgenden Aufrufe ben�tigt. class = QueryRegBase("." & fext) If Len(class) Then ' Lese n�tige Parameter aus der Registrationsdatenbank. cmd = QueryRegBase(class & "\shell\" & tp & "\command") ddeexec = QueryRegBase(class & "\shell\" & tp & "\ddeexec") ifexec = QueryRegBase(class & "\shell\" & tp & "\ddeexec\ifexec") If Len(ifexec) = 0 Then ' Die Angabe von ifexec ist optional. Wird Sie unterlassen, dann ' mu� ddeexec benutzt werden. ifexec = ddeexec End If topic = QueryRegBase(class & "\shell\" & tp & "\ddeexec\topic") If Len(topic) = 0 Then ' Wenn kein Topic angegeben wird, dann wird System als ' Topic vorausgesetzt. topic = "System" End If application = QueryRegBase(class & "\shell\" & tp & "\ddeexec\application") If Len(application) = 0 Then ' Auch der Name der Applikation mu� nicht in der ' Registrationsdatenbank stehen. Leider etwas mehr ' Arbeit f�r den Entwickler, da f�r application ' der Stammteil des Programmnamens benutzt wird. SplitPathname cmd, fpath1, FName SplitFilename FName, fbody, fext1 application = fbody End If ' Ist das Programm vielleicht schon aktiv? If GetModuleHandle(cmd) = 0 Then ' Nein, dann starten If ExecPrograms(cmd, tp) = True Then ' in das ifexec-Kommando mu� nun noch der Dokumentname ' einkopiert werden. Die passende Stelle ist mit ' %1 gekennzeichnet. replacestringpart �bernimmt ' die Zeichenfriemelei. ' Zur Erinnerung: ifexec kann gleich ddeexec sein, ' wenn die Anwendung hier keinen Unterschied macht. ifexec = ReplaceStringPart(ifexec, "%1", fullname) ' Endlich: Das DDE-Kommando in loaddocwithdde wird ' aufgerufen. ExecDocWithDDE = LoadDocWithDDE(c, application, topic, ifexec) Else ExecDocWithDDE = False End If Else ' Das Programm ist aktiv und mu� nicht gestartet werden. ' Ansonsten der gleiche Ablauf wie zuvor, jedoch mit ' ddeexec. ddeexec = ReplaceStringPart(ddeexec, "%1", fullname) ExecDocWithDDE = LoadDocWithDDE(c, application, topic, ddeexec) End If Else ExecDocWithDDE = False End If End Function Function ExecDocWithProgram(ByVal fullname$, ByVal fpath$, ByVal fext$, ByVal tp$) As Boolean Dim res As Long Dim buffer$, class$ On Error Resume Next buffer = Space$(144) class = QueryRegBase("." & fext) If Len(class) Then buffer = QueryRegBase(class & "\shell\" & tp & "\command") If Len(buffer) Then res = Shell(ReplaceStringPart(buffer, "%1", fullname), 1) If Err = 0 Then ExecDocWithProgram = True Else ExecDocWithProgram = False End If Exit Function End If End If ' Sucht das passende Programm zur Anwendung. res = FindExecutable(fullname, CurDir$, buffer) If (res >= 32) Or (res < 0) Then ' Laufwerk und Pfad als aktuell setzen. ChDrive fpath ChDir fpath Err = 0 ' Programm mit commandline-Parameter starten. res = Shell(VBStr(buffer) & " " & fullname, 1) If Err = 0 Then ExecDocWithProgram = True Else ExecDocWithProgram = False End If Else ExecDocWithProgram = False End If End Function ' Inicia un programa Function ExecPrograms(ByVal fullname$, ByVal p$) As Boolean Dim res As Long On Error Resume Next Err = 0 If Len(p) Then fullname = fullname & " " & p res = Shell(fullname, 1) If Err Then ExecPrograms = False Else ExecPrograms = True End If End Function Function GetAvailPart(t, ByVal z%, ByVal nr%) Dim Zaehler% On Error Resume Next Zaehler = CountChar(t, z) + 1 If Zaehler >= nr Then GetAvailPart = GetStringPartX(t, Chr$(z), nr) End Function Function GetStringPartX(ByVal t, ByVal z$, ByVal nr%) Dim i&, p& On Error Resume Next If Len(t) Then t = t & z nr = nr - 1 For i = 1 To nr p = InStr(p + 1, t, z) Next i GetStringPartX = Mid$(t, p + 1, InStr(p + 1, t, z) - p - 1) End If End Function ' Pr�ft, ob eine Dateierweiterung in einer Auswahl von M�glichkeiten vorkommt. ' Die Erweiterungen in extensions m�ssen durch Leerzeichen voneinander ' getrennt sein. Beispiel: "exe com pif bat". Gro�-/Kleinschreibung wird ' ignoriert. Function IsFileOfType(ByVal checkextension$, ByVal extensions$) As Boolean On Error Resume Next If Len(checkextension) Then If InStr(" " & UCase$(extensions) & " ", " " & UCase$(checkextension) & " ") Then IsFileOfType = True Else IsFileOfType = False End If Else IsFileOfType = False End If End Function ' Schickt einen DDE-Befehl an eine Anwendung. Hier speziell zum Laden ' von Dokumenten. Function LoadDocWithDDE(c As Control, ByVal application$, ByVal topic$, ByVal cmd$) As Boolean On Error Resume Next c.LinkMode = 0 c.LinkTimeout = -1 c.LinkTopic = application & "|" & topic c.LinkMode = 2 c.LinkExecute cmd c.LinkMode = 0 If Err = 0 Then LoadDocWithDDE = True Else LoadDocWithDDE = False End If End Function ' Liest einen String aus der Registrationsdatenbank. Um die Verwaltung ' einfach zu halten, beginnt die Suche immer in der ROOT der ' Datenbank. ' Function QueryRegBase(ByVal entry As String) As String Dim buf As String Dim buflen As Long On Error Resume Next buf = Space$(300) buflen = Len(buf) ' 1 = von ROOT aus lesen ' buflen wird von der Funktion ge�ndert, deshalb w�re ' RegQueryValue(1, entry, buf, len(buf)) falsch. 'HKEY_CLASSES_ROOT If RegQueryValue(HKEY_CLASSES_ROOT, entry, buf, buflen) = 0 Then If buflen > 1 Then ' Die R�ckgabe in buflen z�hlt chr$(0) am Ende mit ' Also ein Zeichen abziehen, aber nat�rlich nur dann, ' wenn chr$(0) nicht das einzige Zeichen in der R�ckgabe ist. QueryRegBase = Left$(buf, buflen - 1) Else QueryRegBase = "" End If Else QueryRegBase = "" End If End Function ' Liest einen String aus der WIN.INI Function ReadWinIniString$(ByVal section$, ByVal entry$, ByVal default$) Dim buffer$, l As Long On Error Resume Next buffer = Space$(300) l = GetProfileString(section, entry, default, buffer, Len(buffer)) ReadWinIniString = Left$(buffer, l) End Function ' Einfache Suchen- und Ersetzenfunktion f�r Stringteile. ' Wenn src mehrfach gefunden wird, dann wird es auch mehrfach durch ' rpl ersetzt. Gro�-/Kleinschreibung wird ignoriert, so da� ' sich die Funktion speziell f�r Pfadoperationen und �hnliches anbietet. Function ReplaceStringPart$(ByVal source$, ByVal src$, ByVal rpl$) Dim pos& On Error Resume Next src = UCase$(src) pos = InStr(UCase$(source), src) If src <> UCase$(rpl) Then Do While pos source = Left$(source, pos - 1) & rpl & Right$(source, Len(source) - pos - Len(src) + 1) pos = InStr(pos + Len(rpl), UCase$(source), src) Loop End If ReplaceStringPart = source End Function ' Zerlegt einen Dateinamen ohne Pfad in den Stammteil des Namens ' und die Dateierweiterung. ' F�r kompletten Dateinamen ggf. zuerst splitpathname aufrufen Sub SplitFilename(ByVal FName$, fbody$, fext$) Dim p As Integer On Error Resume Next p = InStr(FName, ".") If p Then fbody = Left$(FName, p - 1) fext = Mid$(FName, p + 1, Len(FName) - p) Else fbody = FName fext = "" End If End Sub ' Zerlegt einen kompletten Dateiname in Pfad und Dateiname ohne Pfad Sub SplitPathname(ByVal fullname$, fpath$, FName$) Dim i%, p% On Error Resume Next Do p = i i = InStr(i + 1, fullname, "\") Loop While i If p Then fpath = Left$(fullname, p) End If FName = Right$(fullname, Len(fullname) - p) End Sub ' Funktion zum Wandeln von ASCIIZ-Strings in VB-Strings. ' Entfernt auch f�hrende und folgende Leerzeichen. Function VBStr$(ByVal c$) Dim pos& pos = InStr(c, Chr$(0)) Select Case pos Case Is > 1 VBStr = Trim$(Left$(c, pos - 1)) Case 1 VBStr = "" Case 0 VBStr = Trim$(c) End Select End Function
Mis Utilidades, bueno no todas... s�lo algunas. (20/Abr)
Estas son algunas de las funciones o procedimientos que,
m�s o menos, incluyo o utilizo en muchos de mis programas.
Las que pongo aqu�, son algunas que no est�n puestas ya, pero que en las consultas que
hac�is, pues lo hab�is preguntado m�s de uno.
El archivo que las contiene est� en este link,
lo he puesto aparte, para que este no sea demasiado largo...
Te indico con un t�tulo, y el link, para que te sea m�s f�cil localizarlas: