ÍndiceÍndice  PortalPortal  CalendarioCalendario  FAQFAQ  BuscarBuscar  RegistrarseRegistrarse  MiembrosMiembros  Grupos de UsuariosGrupos de Usuarios  Conectarse  

Comparte | 
 

 Trucos VB

Ir abajo 
AutorMensaje
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Trucos VB   Sáb Ago 11, 2007 8:15 am

Como crear un grupo de
programas:



Muy útil para crear instalaciones por ejemplo:



Añadir un textbox y hacerlo oculto.

Una vez oculto, escribir estas líneas sustituyendo "Nombre del
Grupo" por que que se desea crear,

y que lo colocamos en Inicio -> Programas.


Private Sub Command1_Click()
Text1.LinkTopic = "Progman|Progman"
Text1.LinkMode = 2
Text1.LinkExecute "[CreateGroup(" + "Nombre del Grupo" + ")]"
End Sub


Vaciar la carpeta de
Documentos de Windows:





Inicie un nuevo proyecto y añada el siguiente código:

Private Declare Function SHAddToRecentDocs Lib "Shell32"
(ByVal lFlags As Long, ByVal lPv As Long) As Long

Private Sub Form_Load()
SHAddToRecentDocs 0, 0
End Sub


Abrir la ventana de
Propiedades de agregar o quitar aplicaciones:



Añada el siguiente código:



Private Sub Command1_Click()

X = Shell("Rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl
@0")

End Sub



Uso de Random:



La función Rnd o Random posee la virtud de obtener números aleatorios
entre 0 y 1:



El único inconveniente a la hora de usar Rnd, es que hay que inicializarlo,
en otro caso,

el resultado de la función Rnd, será siempre el mismo dentro de un
determinado ordenador.

Por ejemplo, el código:


Private Sub Form_Load()
Dim Num As Double
Num = Rnd
MsgBox Num
End Sub

Nos daría como resultado
siempre el mismo número.



Para solucionar este problema, debemos escribir la sentencia Randomize
antes de llamar

a la función Rnd. De esta manera, la función Rnd actuará correctamente.



El código quedaría así:


Private Sub Form_Load()
Dim Num As Double
Randomize
Num = Rnd
MsgBox Num
End Sub


Calcular la etiqueta o label
de un disco duro:



Hallar la etiqueta o label del mismo disco duro:



Escribir el siguiente código:

Private Declare Function GetVolumeInformation& Lib "kernel32" Alias
"GetVolumeInformationA" (ByVal lpRootPathName As String,
ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long,
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long,
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String,
ByVal nFileSystemNameSize As Long)

Private Sub Form_Load()
Dim cad1 As String * 256
Dim cad2 As String * 256
Dim numSerie As Long
Dim longitud As Long
Dim flag As Long
unidad = "D:\"
Call GetVolumeInformation(unidad, cad1, 256, numSerie, longitud,
flag, cad2, 256)
MsgBox "Label de la unidad " & unidad & " = " & cad1
End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:15 am

Como obtener el directorio
desde donde estamos ejecutando nuestro programa:



Escribir el siguiente código:



Private Sub Form_Load()

Dim Directorio as String

ChDir App.Path

ChDrive App.Path

Directorio = App.Path

If Len(Directorio) > 3 Then

Directorio = Directorio & "\"

End If

End Sub



Determinar si un fichero
existe o no:



Escriba el siguiente código: (una de tanta maneras aparte de Dir$())



Private Sub Form_Load()

On Error GoTo Fallo

x = GetAttr("C:\Autoexec.bat")

MsgBox "El fichero existe."

Exit Sub

Fallo:

MsgBox "El fichero no existe."

End Sub



Capturar la pantalla entera
o la ventana activa:



Añadir dos botones y escribir el siguiente código:


Private Declare Sub keybd_event Lib
"user32" (ByVal bVk As Byte,

ByVal bScan As Byte, ByVal dwFlags As Long,

ByVal dwExtraInfo As Long)



Private Sub Command1_Click()

'Captura la ventana activa

keybd_event 44, 0, 0&, 0&

End Sub



Private Sub Command2_Click()

'Captura toda la pantalla

keybd_event 44, 1, 0&, 0&

End Sub



Salvar
el contenido de un TextBox a un fichero en disco:



Añada el siguiente código:
Private Sub Command1_Click()

Dim canalLibre As Integer

'Obtenemos un canal libre que nos dará

'el sistema oparativo para poder operar

canalLibre = FreeFile

'Abrimos el fichero en el canal dado

Open "C:\fichero.txt" For Output As #canalLibre

'Escribimos el contenido del TextBox al fichero

Print #canalLibre, Text1

Close #canalLibre

End Sub


Nuevo



Para abrir:

Código:

Dim foo As Integer



foo = FreeFile

Open "C:\Archivo.txt" For Input As #foo

Text1.Text = Input(LOF(foo), #foo)

Close #foo
Para guardar:
Código:

Dim foo As Integer



foo = FreeFile

Open "C:\Archivo.txt" For Output As #foo

Print #foo, Text1.Text

Close #foo

dialogos:
Ese es para Abrir
Código:

Dim strOpen As String

CommonDialog1.ShowOpen

strOpen = CommonDialog1.FileName

Text1.LoadFile strOpen

Text1.LoadFile strClose
Ese para guardar
Código:

Dim strNewFile As String

CommonDialog1.ShowSave

strNewFile = CommonDialog1.FileName

Text1.SaveFile strNewFile

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:16 am

Como desplegar la lista de
un ComboBox automáticamente:



Insertar un ComboBox y un Botón en un nuevo proyecto y escribir el
siguiente código:



Private Declare Function SendMessageLong Lib "user32" Alias

"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,

ByVal wParam As Long, ByVal lParam As Long) As Long



Private Sub Form_Load()

Combo1.Clear

Combo1.AddItem "Objeto 1"

Combo1.AddItem "Objeto 2"

Combo1.AddItem "Objeto 3"

Combo1.AddItem "Objeto 4"

Combo1.AddItem "Objeto 5"

Combo1.AddItem "Objeto 6"

Combo1.AddItem "Objeto 7"

Combo1.Text = "Objeto 1"

End Sub



Private Sub Command1_Click()

'ComboBox desplegado

Dim Resp As Long

Resp = SendMessageLong(Combo1.hwnd, &H14F, True, 0)

End Sub


Nota: Resp = SendMessageLong(Combo1.hwnd,
&H14F, False, 0) oculta la lista desplegada

de un ComboBox, aunque esto sucede también cuando cambiamos el focus
a otro control o al formulario.


Selección
y eliminación de todos los elementos de un ListBox:



Insertar un ListBox y dos Botón en un nuevo proyecto. Poner la propiedad
MultiSelect del ListBox

a "1 - Simple" y escriba el siguiente código:



Private Declare Function SendMessageLong Lib "user32" Alias

"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,

ByVal wParam As Long, ByVal lParam As Long) As Long



Private Sub Form_Load()

List1.AddItem "Texto 1"

List1.AddItem "Texto 2"

List1.AddItem "Texto 3"

List1.AddItem "Texto 4"

List1.AddItem "Texto 5"

List1.AddItem "Texto 6"

List1.AddItem "Texto 7"

End Sub



Private Sub Command1_Click()

'Seleccion de todo el contenido

Dim Resp As Long

Resp = SendMessageLong(List1.hwnd, &H185&, True, -1)

End Sub



Private Sub Command2_Click()

'Eliminacion de todos los elementos seleccionados

Dim Resp As Long

Resp = SendMessageLong(List1.hwnd, &H185&, False, -1)

End Sub



Calcular el tamaño de
fuentes de letra:



Es útil para utilizar con la propiedad Resize sobre los controles al
cambiar de resolución de pantalla.

Escribir el siguiente código:



Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal

hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd

As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" ()

As Long



Private Sub Form_Load()

Dim ObCaps As Long

Dim ObDC As Long

Dim ObDesktop As Long

Dim Cad As String

ObDesktop = GetDesktopWindow()

ObDC = GetDC(ObDesktop)

ObCaps = GetDeviceCaps(ObDC, 88)

If ObCaps = 96 Then Cad = "Pequeñas

If ObCaps = 120 Then Cad = "Grandes"

MsgBox "Fuentes de letra " & Cad

End Sub


*) Esta función ha sido
corregida por un error en las etiquetas, 96 corresponde a pequeñas

y 120 a Grandes,
agradecimientos a Andrés Moral Gutiérrez por su correción
(01/06/1998)


Provocar la trasparencia de
un formulario:



Escribir el siguiente código:



Private Declare Function SetWindowLong Lib "user32" Alias

"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long,

ByVal dwNewLong As Long) As Long



Private Sub Form_Load()

Dim Resp As Long

Resp = SetWindowLong(Me.hwnd, -20, &H20&)

Form1.Refresh

End Sub



Pasar de un TextBox a otro
al pulsar Enter:



Insertar tres TextBox y escribir el siguiente código:



Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then

SendKeys "{tab}"

KeyAscii = 0

End If

End Sub



Private Sub Text2_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then

SendKeys "{tab}"

KeyAscii = 0

End If

End Sub



Private Sub Text3_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then

SendKeys "{tab}"

KeyAscii = 0

End If

End Sub


otra forma:
Insertar tres TextBox, cambiar la
propiedad KeyPreview del formulario a True y escribir el siguiente código:



Private Sub Form_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then

SendKeys "{tab}"

KeyAscii = 0

End If

End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:16 am

Usar IF THEN ELSE ENDIF en
una misma línea:





Insertar un CommandButton y un TextBox y escribir el siguiente código:


Private Sub Command1_Click()

Dim I As Integer

Dim A As String

I = 3

A = IIf(I <> 1, "True", "False")

Text1.Text = A

End Sub



Convertir un texto a mayúsculas
o minúsculas:



Crear un formulario y situar un TextBox. Escribir:



Private Sub Text1_Change()

Dim I As Integer

Text1.Text = UCase(Text1.Text)

I = Len(Text1.Text)

Text1.SelStart = I

End Sub



Presentar la ventana
AboutBox (Acerca de) por defecto:



Escribir el siguiente código en el formulario:



Private Declare Function ShellAbout Lib "shell32.dll" Alias

"ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String,

ByVal szOtherStuff As String, ByVal hIcon As Long) As Long



Private Sub Command1_Click()

Call ShellAbout(Me.hwnd, "Título Programa", "Copyright
1997, Dueño de la aplicación", Me.Icon)

End Sub



Incrementar
un menú en ejecución:



Abrir un proyecto nuevo, y haga doble click sobre el formulario. Meidante
el gestór de menús

escribir lo siguiente:



Caption -> Editor

Name -> MnuEditor

Pulse Insertar y el botón "->"

Caption -> Añadir

Name -> MnuAñadir

Pulse Insertar

Caption -> Quitar

Name -> MnuQuitar

Enabled -> False

Pulse Insertar

Caption -> Salir

Name -> MnuSalir

Pulse Insertar

Caption -> -

Name -> MnuIndex

Index -> 0

Pulse Aceptar



Escribir el siguiente código en el formulario:



Private ultElem As Integer



Private Sub Form_Load()

ultElem = 0

End Sub



Private Sub MnuQuitar_Click()

Unload MnuIndex(ultElem)

ultElem = ultElem - 1

If ultElem = 0 Then

MnuQuitar.Enabled = False

End If

End Sub



Private Sub MnuSalir_Click()

End

End Sub



Private Sub MnuAñadir_Click()

ultElem = ultElem + 1

Load MnuIndex(ultElem)

MnuIndex(ultElem).Caption = "Menu -> " + Str(ultElem)

MnuQuitar.Enabled = True

End Sub



Cambiar el fondo de Windows
desde Visual Basic:



Crear un formulario y escribir:



Private Declare Function SystemParametersInfo Lib "user32"
Alias

"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam
As

Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long



Private Sub Form_Load()

Dim fallo As Integer

fallo = SystemParametersInfo(20, 0, "C:\WINDOWS\FONDO.BMP",
0)

End Sub



Calcular el número de
colores de video del modo actual de Windows:



Crear un formulario y un TextBox y escribir:



Private Declare Function GetDeviceCaps Lib "gdi32"

(ByVal hdc As Long, ByVal nIndex As Long) As Long



Private Sub Form_Load()

i = (2 ^ GetDeviceCaps(Form1.hdc, 12)) ^

GetDeviceCaps(Form1.hdc, 14)

Text1.Text = CStr(i) & " colores."

End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:16 am

Ajustar un Bitmap a la
pantalla:



Crear un formulario con un BitMap cualquiera y una etiqueta o Label
con los atributos que quiera.

Escribir lo siguiente:



Private Sub Form_Paint()

Dim i As Integer

For i = 0 To Form1.ScaleHeight Step Picture1.Height

For j = 0 To Form1.ScaleWidth Step Picture1.Width

PaintPicture Picture1, j, i, Picture1.Width,

Picture1.Height

Next

Next

End Sub



Private Sub Form_Resize()

Picture1.Left = -(Picture1.Width + 200)

Picture1.Top = -(Picture1.Height + 200)

Label1.Top = 100

Label1.Left = 100

End Sub



Detectar la unidad del
CD-ROM:



Si para instalar una aplicación o ejecutar un determinado software
necesitas saber si existe el CD-ROM:.

Crear un formulario con una etiqueta y
escribir lo siguiente:



Option Explicit



Private Declare Function GetDriveType Lib "kernel32" Alias

"GetDriveTypeA" (ByVal nDrive As String) As Long

Private Declare Function GetLogicalDriveStrings Lib
"kernel32" Alias

"GetLogicalDriveStringsA" (ByVal nBufferLength As Long,
ByVal

lpBuffer As String) As Long

Private Const DRIVE_REMOVABLE = 2

Private Const DRIVE_FIXED = 3

Private Const DRIVE_REMOTE = 4

Private Const DRIVE_CDROM = 5

Private Const DRIVE_RAMDISK = 6



Function StripNulls(startStrg$) As String

Dim c%, item$

c% = 1

Do

If Mid$(startStrg$, c%, 1) = Chr$(0) Then

item$ = Mid$(startStrg$, 1, c% - 1)

startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))

StripNulls$ = item$

Exit Function

End If

c% = c% + 1

Loop

End Function



Private Sub Form_Load()

Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&

Dim CDfound As Integer

allDrives$ = Space$(64)

r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)

allDrives$ = Left$(allDrives$, r&)

Do

pos% = InStr(allDrives$, Chr$(0))

If pos% Then

JustOneDrive$ = Left$(allDrives$, pos%)

allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))

DriveType& = GetDriveType(JustOneDrive$)

If DriveType& = DRIVE_CDROM Then

CDfound% = True

Exit Do

End If

End If

Loop Until allDrives$ = "" Or DriveType& = DRIVE_CDROM

If CDfound% Then

label1.Caption = "La unidad de CD-ROM corresponde a la

unidad: " & UCase$(JustOneDrive$)

Else

label1.Caption = "Su sistema no posee CD-ROM o unidad

no encontrada."

End If

End Sub



Calcular la profundidad de
color (bits por pixel) y resolución de Windows:



Crear un formulario y un TextBox y escribir:



Private Declare Function GetDeviceCaps Lib "gdi32"

(ByVal hdc As Long, ByVal nIndex As Long) As Long



Private Sub Form_Load()

Dim col, bit, largo, alto As Integer

col = GetDeviceCaps(Form1.hdc, 12)

If col = 1 Then

bit = GetDeviceCaps(Form1.hdc, 14)

If bit = 1 Then

Text1.Text = "Resolucion de 1 bit / 2 colores"

ElseIf bit = 4 Then

Text1.Text = "Resolucion de 4 bits / 16 colores"

End If

ElseIf col = 8 Then

Text1.Text = "Resolucion de 8 bits / 256 colores"

ElseIf col = 16 Then

Text1.Text = "Resolucion de 16 bits / 65000 colores"

Else

Text1.Text = "Resolucion de 16 M colores"

End If

largo = GetDeviceCaps(Form1.hdc, Cool

alto = GetDeviceCaps(Form1.hdc, 10)

Text1.Text = Text1.Text & " " & largo &
"x" & alto & " pixels"

End Sub



Comprobar si el sistema
posee tarjeta de sonido:



Crear un formulario y escribir:



Private Declare Function waveOutGetNumDevs Lib

"winmm.dll" () As Long



Private Sub Form_Load()

Dim inf As Integer

inf = waveOutGetNumDevs()

If inf > 0 Then

MsgBox "Tarjeta de sonido soportada.", vbInformation,

"Informacion: Tarjeta de sonido"

Else

MsgBox "Tarjeta de sonido no soportada.", vbInformation,

"Informacion: Tarjeta de sonido"

End If

End

End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:17 am

Crear una ventana con la
Información del Sistema:



Crear un formulario e insertar un módulo y escribir en el formulario
lo siguiente:



Private Sub Form_Load()

Dim msg As String

MousePointer = 11

Dim verinfo As OSVERSIONINFO

verinfo.dwOSVersionInfoSize = Len(verinfo)

ret% = GetVersionEx(verinfo)

If ret% = 0 Then

MsgBox "Error Obteniendo Information de la Version"

End

End If

Select Case verinfo.dwPlatformId

Case 0

msg = msg + "Windows 32s "

Case 1

msg = msg + "Windows 95 "

Case 2

msg = msg + "Windows NT "

End Select

ver_major$ = verinfo.dwMajorVersion

ver_minor$ = verinfo.dwMinorVersion

build$ = verinfo.dwBuildNumber

msg = msg + ver_major$ + "." + ver_minor$

msg = msg + " (Construido " + build$ + ")" +
vbCrLf + vbCrLf

Dim sysinfo As SYSTEM_INFO

GetSystemInfo sysinfo

msg = msg + "CPU: "

Select Case sysinfo.dwProcessorType

Case PROCESSOR_INTEL_386

msg = msg + "Procesador Intel 386 o compatible." + vbCrLf

Case PROCESSOR_INTEL_486

msg = msg + "Procesador Intel 486 o compatible." + vbCrLf

Case PROCESSOR_INTEL_PENTIUM

msg = msg + "Procesador Intel Pentium o compatible." +
vbCrLf

Case PROCESSOR_MIPS_R4000

msg = msg + "Procesador MIPS R4000." + vbCrLf

Case PROCESSOR_ALPHA_21064

msg = msg + "Procesador DEC Alpha 21064." + vbCrLf

Case Else

msg = msg + "Procesador (desconocido)." + vbCrLf

End Select

msg = msg + vbCrLf

Dim memsts As MEMORYSTATUS

Dim memory&

GlobalMemoryStatus memsts

memory& = memsts.dwTotalPhys

msg = msg + "Memoria Fisica Total: "

msg = msg + Format$(memory& \ 1024, "###,###,###") +
"Kb" + vbCrLf

memory& = memsts.dwAvailPhys

msg = msg + "Memoria Fisica Disponible: "

msg = msg + Format$(memory& \ 1024, "###,###,###") +
"Kb" + vbCrLf

memory& = memsts.dwTotalVirtual

msg = msg + "Memoria Virtual Total: "

msg = msg + Format$(memory& \ 1024, "###,###,###") +
"Kb" + vbCrLf

memory& = memsts.dwAvailVirtual

msg = msg + "Memoria Virtual Disponible: "

msg = msg + Format$(memory& \ 1024, "###,###,###") +
"Kb" + vbCrLf + vbCrLf

MsgBox msg, 0, "Acerca del Sistema"

MousePointer = 0

End

End Sub


Escribir lo siguiente en el módulo:



Type SYSTEM_INFO

dwOemID As Long

dwPageSize As Long

lpMinimumApplicationAddress As Long

lpMaximumApplicationAddress As Long

dwActiveProcessorMask As Long

dwNumberOrfProcessors As Long

dwProcessorType As Long

dwAllocationGranularity As Long

dwReserved As Long

End Type



Type OSVERSIONINFO

dwOSVersionInfoSize As Long

dwMajorVersion As Long

dwMinorVersion As Long

dwBuildNumber As Long

dwPlatformId As Long

szCSDVersion As String * 128

End Type



Type MEMORYSTATUS

dwLength As Long

dwMemoryLoad As Long

dwTotalPhys As Long

dwAvailPhys As Long

dwTotalPageFile As Long

dwAvailPageFile As Long

dwTotalVirtual As Long

dwAvailVirtual As Long

End Type



Declare Function GetVersionEx Lib "kernel32"

Alias "GetVersionExA" (LpVersionInformation

As OSVERSIONINFO) As Long

Declare Sub GlobalMemoryStatus Lib "kernel32"

(lpBuffer As MEMORYSTATUS)

Declare Sub GetSystemInfo Lib "kernel32"

(lpSystemInfo As SYSTEM_INFO)



Public Const PROCESSOR_INTEL_386 = 386

Public Const PROCESSOR_INTEL_486 = 486

Public Const PROCESSOR_INTEL_PENTIUM = 586

Public Const PROCESSOR_MIPS_R4000 = 4000

Public Const PROCESSOR_ALPHA_21064 = 21064

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:17 am

Mostrar un fichero AVI a
pantalla completa:



Crear un formulario y escribir:



Private Declare Function mciSendString Lib

"winmm.dll" Alias "mciSendStringA"

(ByVal lpstrCommand As String,

ByVal lpstrReturnString As Any,

ByVal uReturnLength As Long,

ByVal hwndCallback As Long) As Long



Private Sub Form_Load()

CmdStr$ = "play e:\media\avi\nombre.avi fullscreen"

ReturnVal& = mciSendString(CmdStr$, 0&, 0, 0&)

End Sub


Crear un link con un
programa añadiéndolo al grupo de programas situado en

Inicio -> Programas o
Start -> Programs:



Crear un formulario y escribir:



Private Declare Function fCreateShellLink

Lib "STKIT432.DLL" (ByVal lpstrFolderName

As String, ByVal lpstrLinkName As String,

ByVal lpstrLinkPath As String,

ByVal lpstrLinkArgs As String) As Long



Private Sub Form_Load()

iLong = fCreateShellLink("",

"Visual Basic", "C:\Archivos de
Programa\DevStudio\Vb\vb5.exe", "")

End Sub



Apagar el equipo, reiniciar
Windows, reiniciar el Sistema:



Añadir tres botones a un formulario y escribir lo siguiente en el código
del formulario:



Private Declare Function ExitWindowsEx& Lib "user32"
(ByVal

uFlags&, ByVal dwReserved&)



Private Sub Command1_Click()

Dim i as integer

i = ExitWindowsEx(1, 0&) 'Apaga el equipo

End Sub



Private Sub Command2_Click()

Dim i as integer

i = ExitWindowsEx(0, 0&) 'Reinicia Windows con nuevo usuario

End Sub



Private Sub Command3_Click()

Dim i as integer

i = ExitWindowsEx(2, 0&) 'Reinicia el Sistema

End Sub



Borrar un fichero y enviarlo
a la papelera de reciclaje:



Crear un formulario y escribir el siguiente código:

Private Type SHFILEOPSTRUCT

hWnd As Long

wFunc As Long

pFrom As String

pTo As String

fFlags As Integer

fAnyOperationsAborted As Boolean

hNameMappings As Long

lpszProgressTitle As String

End Type



Private Declare Function SHFileOperation Lib "shell32.dll"
Alias

"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long



Private Const FO_DELETE = &H3

Private Const FOF_ALLOWUNDO = &H40



Public Sub PapeleraDeReciclaje(ByVal Fichero As String)

Dim SHFileOp As SHFILEOPSTRUCT

Dim RetVal As Long

With SHFileOp

.wFunc = FO_DELETE

.pFrom = FileName

.fFlags = FOF_ALLOWUNDO

End With

RetVal = SHFileOperation(SHFileOp)

End Sub



Private Sub Form_Load()

Recycle "c:\a.txt"

End Sub


El programa preguntará
si deseamos o no eliminar el fichero y enviarlo a la papelera de reciclaje.

El parámetro .fFlags
nos permitirá recuperar el fichero de la papelera si lo deseamos

Si eliminamos esta
línea, el fichero no podrá ser recuperado.


Abrir el Acceso telefónico
a Redes de Windows y ejecutar una conexión:



Crear un formulario y escribir el siguiente código:

Private Sub Form_Load()

Dim AbrirConexion As Long

AbrirConexion = Shell("rundll32.exe rnaui.dll,RnaDial "
&

"ConexiónInternet", 1)

SendKeys "{ENTER}"

End Sub

Para Windows 2000/NT
V_ID_CONEXION = Shell
("rasphone.exe -d " & V_NOMBRE_DE_LA_CONEXION_DIAL-UP,
1)

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:17 am

Situar una ScroolBar
horizontal en un ListBox:



Crear un formulario y escribir el siguiente código:

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 Sub Form_Load()

Dim x As Integer, i As Integer

For i = 1 To 20

List1.AddItem "El número final de la selección es el "
& i

Next i

x = SendMessage(List1.hwnd, &H194, 200, ByVal 0&)

End Sub



Obtener el nombre de usuario
y de la compañia de Windows:



Crear un formulario, añadir dos etiquetas o labels y escribir el
siguiente código:


Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String,
ByVal lpReserved As Long, lpType As Long, lpData As Any,
lpcbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String,
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll"
(ByVal hKey As Long) As Long

Private Sub Form_Load()
Dim strUser As String
Dim strOrg As String
Dim lngLen As Long
Dim lngType As Long
Dim hKey As Long
Dim x As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = &H1
x = RegOpenKey(HKEY_LOCAL_MACHINE,
"Software\Microsoft\Windows\CurrentVersion",
hKey) ' open desired key in registry
strUser = Space$(256)
lngLen = Len(strUser)
x = RegQueryValueEx(hKey, "RegisteredOwner",
0, lngType, ByVal strUser, lngLen)
If x = 0 And lngType = REG_SZ And lngLen > 1 Then
strUser = Left$(strUser, lngLen - 1)
Else
strUser = "Unknown"
End If
strOrg = Space$(256)
lngLen = Len(strOrg)
x = RegQueryValueEx(hKey, "RegisteredOrganization", 0, lngType,
ByVal strOrg, lngLen)
If x = 0 And lngType = REG_SZ And lngLen > 1 Then
strOrg = Left$(strOrg, lngLen - 1)
Else
strOrg = "Unknown"
End If
Label1.Caption = "Usuario: " & strUser
Label2.Caption = "Empresa: " & strOrg
x = RegCloseKey(hKey)
End Sub


Forzar a un TextBox para que
admita únicamente números:



Crear un formulario, añadir un TextBox y escribir el siguiente código:


Sub Text1_Keypress(KeyAscii As Integer)
If KeyAscii <> Asc("9") Then
'KeyAscii = 8 es el retroceso o BackSpace
If KeyAscii <> 8 Then
KeyAscii = 0
End If
End If
End Sub

Nuevo:

Private Sub Text1_Keypress(KeyAscii As Integer)
If Not IsNumeric(Chr$(KeyAscii)) And KeyAscii <> 8 Then KeyAscii = 0
End Sub


Forzar a un InputBox para
que admita únicamente números:



Crear un formulario y escribir el siguiente código:


Private Sub Form_Load()
Dim Numero As String
Do
Numero = InputBox("Introduzca un numero:")
Loop Until IsNumeric(Numero)
MsgBox "El numero es el " & Numero
Unload Me
End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:18 am

Hacer Drag & Drop de un
control (ejemplo de un PictureBox):



En un formulario, añadir un PictureBox con una imagen cualquiera y
escribir el siguiente código:


Private DragX As Integer
Private DragY As Integer

Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
Source.Move (X - DragX), (Y - DragY)
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer,
X As Single, Y As Single)
'Si el boton del raton es el derecho, no hacemos nada
If Button = 2 Then Exit Sub
Picture1.Drag 1
DragX = X
DragY = Y
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer,
X As Single, Y As Single)
Picture1.Drag 2
End Sub


Centrar una ventana en
Visual Basic:


Usar:

Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2

En vez de:

Form1.Left = Screen.Width - Width \ 2
Form1.Top = Screen.Height - Height \ 2




Ejecuta pausas durante
un determinado espacio de tiempo en segundos:


Llamada: Espera(5)

Sub Espera(Segundos As Single)
Dim ComienzoSeg As Single
Dim FinSeg As Single
ComienzoSeg = Timer
FinSeg = ComienzoSeg + Segundos
Do While FinSeg > Timer
DoEvents
If ComienzoSeg > Timer Then
FinSeg = FinSeg - 24 * 60 * 60
End If
Loop
End Sub

Llamada: pause segundos

Sub Pause(interval)

Dim atime

atime = Timer

Do While Timer - atime < Val(interval)

DoEvents

Loop

End Sub

Editor de texto:

Seleccionar todo el texto:
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)

Copiar texto:
Clipboard.Clear
Clipboard.SetText Text1.SelText
Text1.SetFocus

Pegar texto:
Text1.SelText = Clipboard.GetText()
Text1.SetFocus

Cortar texto:
Clipboard.SetText Text1.SelText
Text1.SelText = ""
Text1.SetFocus

Deshacer texto: (Nota: esta operación sólo es eficaz con el control Rich TextBox).

En un módulo copie esta línea:

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

Esta es la instrucción de la función deshacer:

UndoResultado = SendMessage(Text1.hwnd, &HC7, 0&, 0&)
If UndoResultado = -1 Then
Beep
MsgBox "Error al intentar recuperar.", 20, "Deshacer texto"
End If


Seleccionar todo el texto:
SendKeys "^A"

Copiar texto:
SendKeys "^C"

Pegar texto:
SendKeys "^V"

Cortar texto:
SendKeys "^X"

Deshacer texto:
SendKeys "^Z"




Obtener el directorio de
Windows y el directorio de Sistema:


En un módulo copiar estas líneas:

Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA"_
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA"_
(ByVal lpBuffer As String, ByVal nSize As Long) As Long

Ponga dos Labels o etiquetas y un botón en el formulario:
Label1, Label2, Command1

Hacer doble click sobre el botón y escribir el código siguiente:

Private Sub Command1_Click()
Dim Car As String * 128
Dim Longitud, Es As Integer
Dim Camino As String

Longitud = 128

Es = GetWindowsDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label1.Caption = Camino

Es = GetSystemDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label2.Caption = Camino

End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:18 am

Ocultar la barra de tareas
en Windows 95 y/o Windows NT:


En un módulo copiar estas líneas:

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName_
As String, ByVal lpWindowName As String) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter
As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long,_
ByVal wFlags As Long) As Long
Global Ventana As Long
Global Const Muestra = &H40
Global Const Oculta = &H80

En un formulario ponga dos botones y escriba el código correspondiente
a cada uno de ellos:

'Oculta la barra de tareas
Private Sub Command1_Click()
Ventana = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Oculta)
End Sub

'Muestra la barra de tareas
Private Sub Command2_Click()
Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Muestra)
End Sub


Imprimir el contenido de un
TextBox en líneas de X caracteres:


Añadir un TextBox con las propiedades "Multiline=True" y "ScrollBars=Vertical",
y un CommandButton. Hacer doble click sobre él y escribir este código:

Private Sub Command1_Click()
'X es 60 en este ejmplo
imprimeLineas Text1, 60
End Sub

En las declaraciones "Generales" del formulario, escribimos:

Public Sub imprimeLineas(Texto As Object, Linea As Integer)
Dim Bloque As String
'Numero de caracteres = NumC
'Numero de Bloques = NumB
Dim NumC, NumB As Integer
NumC = Len(Texto.Text)
If NumC > Linea Then
NumB = NumC \ Linea
For I = 0 To NumB
Texto.SelStart = (Linea * I)
Texto.SelLength = Linea
Bloque = Texto.SelText
Printer.Print Bloque
Next I
Else
Printer.Print Texto.Text
End If
Printer.EndDoc
End Sub




Leer y escribir un
fichero Ini:


Declaraciones generales en un módulo:

Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA"_
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As_
String ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As_
String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias_
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As_
Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Leer en "Ejemplo.Ini":

Private Sub Form_Load()
Dim I As Integer
Dim Est As String
Est = String$(50, " ")
I = GetPrivateProfileString("Ejemplo", "Nombre", "", Est, Len(Est), "Ejemplo.ini")
If I > 0 Then
MsgBox "Tu Nombre es: " & Est
End If
End Sub

Escribir en "Prueba.Ini":

Private Sub Form_Unload(Cancel As Integer)
Dim I As Integer
Dim Est As String
Est = "Ejemplo - Apartado"
I = WritePrivateProfileString("Ejemplo", "Nombre", Est, "Ejemplo.ini")
End Sub

(Nota: si I=0 quiere decir que no existe Información en la línea de fichero Ini a la
que hacemos referencia. El fichero "Ejemplo.Ini" se creará automáticamente).


Crear una barra de estado
sin utilizar controles OCX o VBX:


Crear una PictureBox y una HScrollBar:

Propiedades de la HScrollBar:
Max -> 100
Min -> 0

Propiedades de la PictureBox:
DrawMode -> 14 - Merge Pen Not
FillColor -> &H00C00000&
Font -> Verdana, Tahoma, Arial; Negrita; 10
ForeColor -> &H00000000&
ScaleHeight -> 10
ScaleMode -> 0 - User
ScaleWidth -> 100

Insertar en el formulario o módulo el código de la función:

Sub Barra(Tam As Integer)
If Tam > 100 Or Tam <>

Insertar en el evento Change del control HScrollBar:

Private Sub HScroll1_Change()
Barra (HScroll1.Value)
End Sub

En el evento Paint del formulario, escribir:

Private Sub Form_Paint()
Barra (HScroll1.Value)
End Sub




Calcular el espacio
total y espacio libre de una Unidad de disco:


Crear un módulo y escribir:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA"_
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector_
As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

Crear 7 Labels:

Escribir el código siguiente:

Private Sub Form_Load()
Dim I1 As Long
Dim I2 As Long
Dim I3 As Long
Dim I4 As Long
Dim Unidad As String
Unidad = "C:/"
GetDiskFreeSpace Unidad, I1, I2, I3, I4
Label1.Caption = Unidad
Label2.Caption = I1 & " Sectores por cluster"
Label3.Caption = I2 & " Bytes por sector"
Label4.Caption = I3 & " Número de clusters libres"
Label5.Caption = I4 & " Número total de clusters"
Label6.Caption = "Espacio total en disco: " & (I1 * I2 * I4)
Label7.Caption = "Espacio libre en disco: " & (I1 * I2 * I3)
End Sub




Crear un efecto Shade al
estilo de los programas de instalación:


Crear un proyecto nuevo y escribir el código siguiente:

Private Sub Form_Resize()
Form1.Cls
Form1.AutoRedraw = True
Form1.DrawStyle = 6
Form1.DrawMode = 13
Form1.DrawWidth = 2
Form1.ScaleMode = 3
Form1.ScaleHeight = (256 * 2)
For i = 0 To 255
Form1.Line (0, Y)-(Form1.Width, Y + 2), RGB(0, 0, i), BF
Y = Y + 2
Next i
End Sub


_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:19 am

Situar el cursor encima de
un determinado control (p. ej.: un botón):


Escribir el código siguiente en el módulo:

Declare Sub SetCursorPos Lib "User32" (ByVal X As Integer, ByVal Y As Integer)

Insertar un botón en el formulario y escribir el siguiente código:

Private Sub Form_Load()
X% = (Form1.Left + Command1.Left + Command1.Width / 2 + 60) / Screen.TwipsPerPixelX
Y% = (Form1.Top + Command1.Top + Command1.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos X%, Y%
End Sub



Menú PopUp en un TextBox:

Ejemplo para no visualizar el menú PopUp implícito de Windows:

En el evento MouseDown del control TextBox escriba:

Private Sub Editor1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
Editor1.Enabled = False
PopupMenu MiMenu
Editor1.Enabled = True
Editor1.SetFocus
End If
End Sub




Hacer sonar un fichero
Wav o Midi:


Insertar el siguiente código en un módulo:

Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long

Insertar un botón en el formulario y escribir el siguiente código:

Private Sub Command1_Click()
iResult = mciExecute("Play c:\windows\ringin.wav")
End Sub


Hacer un formulario flotante
al estilo de Visual Basic:


Crear un nuevo proyecto, insertar un botón al formulario que inserte un formulario más y un módulo.
Pegue el siguiente código en el

módulo:

Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Peguar el siguiente código en el formulario principal:

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload Form2
End Sub

Private Sub Command1_Click()
Dim ret As Integer
If doshow = False Then
ret = SetParent(Form2.hWnd, Form1.hWnd)
Form2.Left = 0
Form2.Top = 0
Form2.Show
doshow = True
Else
Form2.Hide
doshow = False
End If
End Sub



Comprobar si el programa ya
está en ejecución:


Crear un nuevo proyecto e insertar el siguiente código:

Private Sub Form_Load()
If App.PrevInstance Then
Msg = App.EXEName & ".EXE" & " ya está en ejecución"
MsgBox Msg, 16, "Aplicación."
End
End If
End Sub


Hallar el nombre del PC en
Windows 95 o Windows NT:


Cree un nuevo proyecto e inserte dos ButtonClick y un Módulo:

Pegue el siguiente código en el formulario:

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nPC as String
Dim buffer As String
Dim estado As Long
buffer = String$(255, " ")
estado = GetComputerName(buffer, 255)
If estado <> 0 Then
nPC = Left(buffer, 255)
End If
MsgBox "Nombre del PC: " & nPC
End Sub

Private Sub Command2_Click()
Unload Form1
End Sub

Pegue el siguiente código en el módulo:

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA"
(ByVal lpBuffer As String, nSize As Long) As Long



Eliminar el sonido
"Beep" cuando pulsamos Enter en un TextBox:


Crear un nuevo proyecto e insertar un TextBox:

Peguar el siguiente código en el formulario:

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then KeyAscii = 0
End Sub



Ocultar y mostrar el puntero
del ratón:


Crear un nuevo proyecto e insertar dos ButtonClick y un Módulo:

Pegue el siguiente código en el formulario:

Private Sub Command1_Click()
result = ShowCursor(False)
End Sub

Private Sub Command2_Click()
result = ShowCursor(True)
End Sub

Usar las teclas alternativas Alt+O para ocultarlo y Alt+M para mostrarlo.

Peguar el siguiente código en el módulo:

Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long


_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Ozzyarg
ADMINISTRADOR
ADMINISTRADOR
avatar

Masculino Cantidad de envíos : 223
Localización : Via lactea, Planeta Tierra, Continente Americano, SudAmerica, Argentina, Buenos Aires, Flores.
Fecha de inscripción : 06/08/2007

MensajeTema: Re: Trucos VB   Sáb Ago 11, 2007 8:19 am

Calcular el número de serie
de un disco:


Crear un nuevo proyecto e insertar el siguiente código en el formulario:

Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA"
(ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize
As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags
As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)

Private Sub Form_Load()
Dim cad1 As String * 256
Dim cad2 As String * 256
Dim numSerie As Long
Dim longitud As Long
Dim flag As Long
unidad = "C:\"
Call GetVolumeInformation(unidad, cad1, 256, numSerie, longitud, flag, cad2, 256)
MsgBox "Numero de Serie de la unidad " & unidad & " = " & numSerie
End Sub




Ejemplo
de un mailer en base64.


Private Sub Base64_Click()
Dim Caracter As String * 1
Dim Trio(3) As Integer
Dim Cont As Integer
Dim ContLinea As Integer
Dim Cuatro(4) As Integer
Dim Base64 As String

Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
ContLinea = 0

MensajeSaliente = ""

MensajeEntrante = ""

If Cfg.FicheroAnexo <> "" Then

Open NFich For Binary As #3 Len = 3

Cont = 0

ContTotal = 0

Progreso.Max = FileLen(NFich)

While Not ContTotal = LOF(3)

ContTotal = ContTotal + 1

Caracter = Input(1, 3)

Cont = Cont + 1

Trio(Cont) = Asc(Caracter)

'MensajeSaliente = MensajeSaliente + Caracter

If Cont = 3 Then

Cuatro(1) = Int(Trio(1) / 4)

Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2)
/ 16)

Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4 + Int(Trio(3)
/ 64)

Cuatro(4) = Trio(3) - Int(Trio(3) / 64) * 64

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(4) + 1, 1)

Cont = 0

ContLinea = ContLinea + 4

If ContLinea = 76 Then

MensajeEntrante = MensajeEntrante + vbCrLf

ContLinea = 0

End If

End If

DoEvents

Wend

Select Case Cont

Case 1

Cuatro(1) = Int(Trio(1) / 4)

Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)
+ "=="

Case 2

Cuatro(1) = Int(Trio(1) / 4)

Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2)
/ 16)

Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)

MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1)
+ "="

End Select

Close #3

End If

End Sub

_________________
.:El hack no se trata de la destruccion, sino de la exploracion:.
Volver arriba Ir abajo
Ver perfil de usuario
Contenido patrocinado




MensajeTema: Re: Trucos VB   

Volver arriba Ir abajo
 
Trucos VB
Volver arriba 
Página 1 de 1.
 Temas similares
-
» mi FERRARI THOR 90
» SIEMBRA GIRASOL
» Partidas ps3 online?

Permisos de este foro:No puedes responder a temas en este foro.
 :: Programacion :: Visual Basic-
Cambiar a: