de Grenville Tryon Pera

de Grenville Tryon Pera

Aplicaciones	Controles	Trucos	Preguntas	Teoria
Internet	Enlaces	Casos	Surf

Las paginas de Visual Basic

Pagina 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

101	Circulos cuadrados/transparentes para imprimir	Circulos para imprimir sin fondo
102	Buscar y cambiar atributos en un RichTetxBox	Como cambiar atributo en un RichTextBox
103	Abrir y cerrar lector de CD	Como abrir y cerrar el lector del CD
104	Cambiar colores del sistema de Windows	Como desde codigo cambiar los colores del sistema de Windows
105	Obtener los colores del Windows	Como obtener los colores del sistema en Windows
106	Obtener los numeros de linea de un texto multlinea	Como obtener el numero de lineas de un texto a imprimir
107	Llenar un Treeviw con direcotrios	Llenar un Treevie\w con directorios de un disco duro
108	Determinar siguiente unidad de disco	Determinar siguiente unidad disponible
109	Determinar espacio en un Disco Duro	Determinar espacio disponible en un Disco Duro
110	CD a WAV	Pasar un archivo del CD a formato WAV

CIRCULOS/CUADRADOS TRANSPARENTE PARA IMPRIMIR
Para resolver este problema debemos modificar la propiedad FillStyle del objeto Printer antes de emplear los métodos Circle o Line para imprimir objetos transparentes :
Printer.FillStyle = 2
Printer.Print ""
Printer.FillStyle = 1

BUSCAR/CAMBIAR COLOR EN UN RICHTEXT
Private Function HighlightWords(rtb As RichTextBox, sFindString As String, lColor As Long) As Integer
Dim lFoundPos As Long 'Posicion del primer carácter que coincide
Dim lFindLength As Long 'Longitud del string a buscar
Dim lOriginalSelStart As Long
Dim lOriginalSelLength As Long
Dim iMatchCount As Integer 'Número de veces que se encontró
'Guardamos la posición del punto de inserción y la longitud del text seleccionado
lOriginalSelStart = rtb.SelStart
lOriginalSelLength = rtb.SelLength
'Guardamos la longitud del texto a buscar
lFindLength = Len(sFindString)
'Buscamos la primera ocurrencia
lFoundPos = rtb.Find(sFindString, 0, , rtfNoHighlight)
While lFoundPos > 0
iMatchCount = iMatchCount + 1
rtb.SelStart = lFoundPos
'La propiedad SelLength se pone a 0 al cambiar SelStart
rtb.SelLength = lFindLength
rtb.SelColor = lColor
'Buscamos la siguiente ocurrencia
lFoundPos = rtb.Find(sFindString, _
lFoundPos + lFindLength, , rtfNoHighlight)
Wend
'Reponemos la posición y longitud del punto de insercción
rtb.SelStart = lOriginalSelStart
rtb.SelLength = lOriginalSelLength
'Devolvemos el número de ocurrencias encontradas
HighlightWords = iMatchCount
End Function
Y para buscar un texto y señalarlo, por ejemplo en rojo, simplemente :
HighlightWords RichTextBox1, "TextoBuscado", vbRed

ABRIR/CERRAR CD

Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'para abrir la puerta :
dim res as long, returnstring as string*127
res = mcisendstring("set CDAudio door open", returnstring, 127, 0)
'para cerrarla :
dim res as long, returnstring as string*127
res = mcisendstring("set CDAudio door closed", returnstring, 127, 0)

CAMBIAR COLORES DEL SISTEMA DE WINDOWS
Declare Function SetSysColors Lib "user32" Alias "SetSysColors" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
res& = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255,0,0))

OBTENER COLORES DEL SISTEMA DE WINDOWS
Declare Function GetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long
Public Const COLOR_3DDKSHADOW = 21 'Sombra oscura de los elementos en 3D
Public Const COLOR_BTNFACE = 15 'Superficie de los botones
Public Const COLOR_3DFACE = COLOR_BTNFACE 'Superficie de los elementos 3D
Public Const COLOR_BTNHIGHLIGHT = 20 'Lado de los botones donde da la luz
Public Const COLOR_BTNHILIGHT = COLOR_BTNHIGHLIGHT
Public Const COLOR_3DHIGHLIGHT = COLOR_BTNHIGHLIGHT 'Lado de los elementos en 3D con luz
Public Const COLOR_3DHILIGHT = COLOR_BTNHIGHLIGHT
Public Const COLOR_3DLIGHT = 22 'Luz de los elementos en 3D
Public Const COLOR_BTNSHADOW = 16 'Sombra para los elementos en 3D
Public Const COLOR_3DSHADOW = COLOR_BTNSHADOW
Public Const COLOR_ACTIVEBORDER = 10 'Borde de las ventanas activas
Public Const COLOR_ACTIVECAPTION = 2 'Barra de título de las ventanas activas
Public Const COLOR_APPWORKSPACE = 12 'Fondo de las ventanas MDI
Public Const COLOR_BACKGROUND = 1 'Escritorio
Public Const COLOR_DESKTOP = COLOR_BACKGROUND
Public Const COLOR_BTNTEXT = 18 'Texto de los botones
Public Const COLOR_CAPTIONTEXT = 9 'Texto en barra de títulos
Public Const COLOR_GRAYTEXT = 17 'Texto desactivado (disabled)
Public Const COLOR_HIGHLIGHT = 13 'Elementos seleccionados en un control
Public Const COLOR_HIGHLIGHTTEXT = 14 'Texto de los elementos seleccionados en un control
Public Const COLOR_INACTIVEBORDER = 11 'Borde de las ventanas no activas
Public Const COLOR_INACTIVECAPTION = 3 'Barra de título de las ventanas no activas
Public Const COLOR_INACTIVECAPTIONTEXT = 19 'Texto de la barra de título de las ventanas no activas
Public Const COLOR_INFOBK = 24 'Fondo de los ToolTipText
Public Const COLOR_INFOTEXT = 23 'Texto de los ToolTipText
Public Const COLOR_MENU = 4 'Fondo del menú
Public Const COLOR_MENUTEXT = 7 'Texto del menú
Public Const COLOR_SCROLLBAR = 0 'Area gris de una scroll bar
Public Const COLOR_WINDOW = 5 'Fondo de la ventana
Public Const COLOR_WINDOWFRAME = 6 'Marco de la ventana
Public Const COLOR_WINDOWTEXT = 8 'Texto de la ventana
Y para obtener el color del elemento deseado, por ejemplo la barra de título de las ventanas activas, empleamos :
dim col as long
col = GetSysColor(COLOR_ACTIVECAPTION)

NUMERO DE LINEAS EN UN TEXT MULTILINE
Private Sub Command8_Click()
Dim sBuffer As String * 80
Dim lRet As Long
Dim lLines As Long
Dim i As Integer
Mid$(sBuffer, 1, 1) = Chr$(79 And &HFF)
Mid$(sBuffer, 2, 1) = Chr$(79 \ &H100)
'Retrieve each line into the buffer & print
'Get the number of lines in the box
lLines = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0)
'Set up the buffer to receive the text
For i = 0 To lLines - 1
lRet = SendMessage(Text1.hwnd, EM_GETLINE, i, ByVal sBuffer)
MsgBox Left$(sBuffer, lRet) ' or put into an array
Next
End Sub

DESCARGANDO UNA PAGINA WEB CON WINSOCK
Winsock1.RemoteHost = "vb.com"
Winsock1.RemotePort = 80
Winsock1.Connect
'En el evento connect del Winsock1
Dim strCommand as String
Dim strWebPage as String
strWebPage = "http://www.vb.com/index.html"
strCommand = "GET " + strWebPage + " HTTP/1.0" + vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept: text/html" + vbCrLf
strCommand = strCommand + vbCrLf
Winsock1.SendData strCommand
Dim webData As String
Winsock1.GetData webData, vbString
TxtWebPage.Text = TxtWebPage.Text + webData

LLENAR UN TREEVIEW CON DIRECTORIOS DE UNIDAD "C"
Option Explicit
Const MAX_PATH = 260
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Type DirInfo
DirName As String
End Type
Sub FindDirs(D$, T As TreeView)
Dim nx As Node, C$
C$ = CurDir$
ChDir D$
If Len(Dir$("*.*", vbDirectory)) Then
On Local Error Resume Next
ChDir ".."
ChDir ".."
Set nx = T.Nodes.Add(CurDir$, 4, C$, LastPath$(C$))
If Err Then
Set nx = T.Nodes.Add(, , C$, C$)
End If
ChDir C$
ChDir D$
'Set nx = T.Nodes.Add(C$, 4, , D$)
Else
Set nx = T.Nodes.Add(C$, 4, , D$)
End If
'T.Nodes(T.Nodes.Count).EnsureVisible
DoEvents
Dim N As Integer, Srch$, i As Integer, NewD$
Srch$ = "*.*"
ReDim Dees(1 To 10) As DirInfo
Call LoadDirs(Dees(), N, Srch$)
If N = 0 Then
ChDir ".."
Exit Sub
End If
For i = 1 To N
NewD$ = RTrim$(Dees(i).DirName)
Call FindDirs(NewD$, T)
Next
ChDir ".."
End Sub
Function LastPath$(P$)
Dim i
For i = Len(P$) To 1 Step -1
If Mid$(P$, i, 1) = "\" Then
LastPath$ = Mid$(P$, i + 1)
Exit For
End If
Next
End Function
Private Sub LoadDirs(D() As DirInfo, N As Integer, Srch$)
Dim a$, Max As Integer, i As Integer, k As Integer, W32 As WIN32_FIND_DATA, fHandle As Long, lResult As Long
Max = UBound(D)
N = 0
fHandle = FindFirstFile(Srch$, W32)
If fHandle Then
Do
a$ = Left$(W32.cFileName, InStr(W32.cFileName, Chr$(0)) - 1)
If a$ <> "." And a$ <> ".." And ((W32.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) > 0) Then
N = N + 1
If Max < N Then
Max = Max + 10
ReDim Preserve D(1 To Max) As DirInfo
End If
D(N).DirName = a$
End If
DoEvents
lResult = FindNextFile(fHandle, W32)
Loop While lResult
lResult = FindClose(fHandle)
End If
For i = 1 To N - 1
For k = i + 1 To N
If D(i).DirName > D(k).DirName Then
a$ = D(k).DirName
D(k).DirName = D(i).DirName
D(i).DirName = a$
End If
Next
Next
End Sub
Private Sub Command1_Click()
Static done
If done Then Exit Sub
done = True
ChDrive "c:\"
ChDir "c:\"
' Dim nx As Node
' Set nx = TV.Nodes.Add(, , CurDir$, CurDir$)
Call FindDirs("c:\", TV)
MsgBox "Done!"
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub

DETERMINAR SIGUIENTE UNIDAD DISPONIBLE &TIPO DE UNIDADES OCUPADAS
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Function FreeDrive() As String
Dim DriveNum As String'To cycle through drive letters in order
Dim DriveType As Long 'To hold the type of drive it is
DriveNum = 64 'Prime the variable to be used in the loop
Do
DriveNum = DriveNum + 1' start at drive zero.
DriveType = GetDriveType(Chr$(DriveNum) & ":\")
' If we are past C: and the drive type is indeterminate, exit the
' Loop
If DriveType = 1 And DriveNum > 67 Then Exit Do
Select Case DriveType
Case 0: MsgBox Chr$(DriveNum) + ": is An Unknown type"
Case 1: MsgBox Chr$(DriveNum) + ": Does Not Exist"
Case 2: MsgBox Chr$(DriveNum) + ": is a Removable Drive"
Case 3: MsgBox Chr$(DriveNum) + ": is a Fixed Drive"
Case 4: MsgBox Chr$(DriveNum) + ": is a Remote Drive"
Case 5: MsgBox Chr$(DriveNum) + ": is a CD-ROM Drive"
Case 6: MsgBox Chr$(DriveNum) + ": is a RAM Drive"
End Select
Loop
FreeDrive = Chr$(DriveNum) + ":" 'Return the next available drive letter
End Function

ESPACIO LIBRE EN DISCO
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA"(ByVal lpRootPathName As String, lpSectorsPerCluster As Long,lpBytesPerSectorAs Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Dim spc As Long
Dim bps As Long
Dim ncl As Long
Dim ntc As Long
Dim Unidad As String
Unidad = "C:/"
GetDiskFreeSpace Unidad, spc, bps, ncl, ntc
debug.print spc & " Sectores por cluster"
debug.print bps & " Bytes por sector"
debug.print ncl & " Número de clusters libres"
debug.print ntc & " Número total de clusters"
debug.print "Espacio total en disco: " & (spc * bps * ntc) & "bytes"
debug.print "Espacio libre en disco: " & (spc * bps * ncl) & "bytes"
Obtener el espacio libre de un disco mayor de 2 Gb
'Para ello usaremos la función GetDiskFreeSpaceEx (válida para NT, pero no para 95, por lo menos para 95 OSR1).
Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long
Private Function EspacioLibreEx(ByVal lpRootPathName As String)
'lpRootPathName= Directorio raiz de la unidad a examinar
Dim ret As Long
Dim lpFreeBytesAvailableToCaller As Currency
Dim lpTotalNumberOfBytes As Currency
Dim lpTotalNumberOfFreeBytes As Currency
Dim TotalBytes As Currency
Dim TotalFreeBytes As Currency
ret = GetDiskFreeSpaceEx(lpRootPathName, lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes)
TotalBytes = lpTotalNumberOfBytes * 10000
TotalFreeBytes = lpTotalNumberOfFreeBytes * 10000
EspacioLibreEx = Format(TotalBytes, "###,###,###") & " / " & Format(TotalFreeBytes, "###,###,###")
End Function

CD A WAV
Public Sub RecordWave(TrackNum As Integer, Filename As String)
On Local Error Resume Next
Dim i As Long, RS As String, cb As Long, t#
RS = Space$(128)
i = mciSendString("stop cdaudio", RS, 128, cb)
i = mciSendString("close cdaudio", RS, 128, cb)
Kill filename
RS = Space$(128)
i = mciSendString("status cdaudio position track " & TrackNum, RS, 128, cb)
i = mciSendString("open cdaudio", RS, 128, cb)
i = mciSendString("set cdaudio time format milliseconds", RS, 128, cb)
i = mciSendString("play cdaudio", RS, 128, cb)
i = mciSendString("open new type waveaudio alias capture", RS, 128, cb)
i = mciSendString("record capture", RS, 128, cb)
t# = Timer + 1: Do Until Timer > t#: DoEvents: Loop
i = mciSendString("save capture " & filename, RS, 128, cb)
i = mciSendString("stop cdaudio", RS, 128, cb)
i = mciSendString("close cdaudio", RS, 128, cb)
End Sub
The method is quite easy:
1) Stop everything in the CD drive
2) Start playing track
3) Record a new wave with the information from the CD (note: it also records MIDI and microphone sounds: in fact anything coming out of the speakers)
4) Save the wave file
5) Stop the CD again