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

111	Copiar un archivo que esta en uso	Como copiar un archivo bloqueado por estar en uso
112	Todo lo que hay en un HD	Como obtener la informacion de archivos un disco duro
113	Imprimir en texto	Como imprimir en texto desde VB
114	Lista de contactos en Outlook	Obtener la lista de contactos del MS Outlook
115	Pintar una region delimitada	Como llenar una region delimitada en un picturebox
116	Tooltips en nodos	Como poner un tooltip distinto para cada nodo
117	Funciones internas del SQL para encriptar	Funciones propias del SQL para encriptado
118	Trabajar con folders	Como trabajar con folders
119	Tocar un archivo AU en VB	Como tocar un archivo e tipo *.AU en VB
120	Obtener la relacion de emails de una lista	Como obtener las direcciones de una lista de correos

COPIAR UN ARCHIVO EN USO
Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

TODO LO QUE HAY EN UN HD

Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Integer, nFiles As Integer, lSize As Long
Dim sDir As String, sSrchString As String
sDir = InputBox("Please enter the directory to search", "FileSystemObjects example", "C:\")
sSrchString = InputBox("Please enter the file name to search", "FileSystemObjects example", "vb.ini")
MousePointer = vbHourglass
Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & " directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, nDirs As Integer, nFiles As Integer) As Long
Dim tFld As Folder, tFil As File, FileName As String
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, FileName))
nFiles = nFiles + 1
List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
End Function

IMPRIMIR EN TEXTO
Dim lFile As Long
lFile = FreeFile
Open "LPT1" For Output As #lFile
Print #lFile, Chr$(18); "Esto es modo normal"
Print #lFile, Chr$(15); "Esto es modo condensado"
Print #lFile, Chr$(18); "Esto es modo normal"
Close #lFile

LISTA DE CONTACTOS DEL OUTLOOK
Dim objOutlook As Outlook.Application
Dim m As Outlook.AppointmentItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookMsg As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.Application")
If objOutlook Is Nothing Then
Stop
'lresult = ShellExecute(hwnd, "open", "outlook", ' vbNullString, vbNullString, SW_SHOW)
'Handle it however...
Exit Sub 'Function
End If
Set m = objOutlook.CreateItem(olAppointmentItem)

PINTAR UNA REGION DELIMITADA

Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
'Parámetros :
'hdc : pues eso el hdc del formulario o picture donde está el dibujo
'x : coordenada x de un punto interior a la "región" a rellenar (en pixels)
'y : coordenada y de un punto interior a la "región" a rellenar (en pixels)
'crColor : color que delimita la región a pintar o color a "machacar"
'wFillType : tipo de relleno. 0 para que crColor sea el color del límite.
'Con 1 cambia el color de lo que se encuentre con crColor (para regiones con límites de varios colores)
'Antes de llamarla asegúrate que la propiedad autoredraw está a false y rellena la propiedad FillColor del objeto con el color de relleno

TOOLTIP EN NODOS
Private Sub tvSites_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim tvNode As ComctlLib.Node
On Error Resume Next
Set tvNode = tvSites.HitTest(x, y)
On Error GoTo 0
If Not (tvNode Is Nothing) Then
tvSites.ToolTipText = tvNode.Key
Else
tvSites.ToolTipText = ""
End If
Set tvNode = Nothing
End Sub

FUNCIONES DEL SQL PARA ENCRIPTAR
'If you're using SQL Server, then you can use the (undocumented) SQL Server functions, pwdencrypt and pwdcompare to do your encyption. Supposedly it works for high-ascii values
select pwdencrypt("hello") -- retrns encrypted binary data
select pwdcompare("hello", pwdencrypt("hello")) -- returns 1
select pwdcompare("goodbye", pwdencrypt("hello")) -- returns 0

TRABAJAR CON FOLDERS
Dim fso As FileSystemObject
Dim fold As Folder
Set fso = New FileSystemObject
Set fold = fso.GetFolder("c:\test")
fold.Delete
Set fold = Nothing
Set fso = Nothing

TOCAR UN ARCHIVO .AU DESDE VB
1. Start a new Standard EXE project in Visual Basic. Form1 is created by default.
2. From the Project menu, select References, and add a reference to the DirectShow runtime file, quartz.dll. You may need to Browse for this file in your System directory. After you make a reference to this file, the ActiveMovie Control type library appears in the Available References list box of the References dialog box.
3. Add a CommandButton to Form1.
4. Paste the following code to the Code window of Form1. Change the String
variable MyFile to the path and filename of your AU file:
Option Explicit
Private Sub Command1_Click()
Static PMC As Object
Dim MyFile As String
= "<Path and Filename of the AU file>"
Set PMC = New FilgraphManager
PMC.RenderFile MyFile
PMC.Run
End Sub
5. On the Run menu, select Start, or press the F5 key to start the program.
Click on Command1 and the AU file will start playing.

OBTENER UNA RELACION DE TODOS LOS E-MAILS DE UNA LISTA
Const CdoPR_EMS_AB_HOME_MTA = &H8007001E
Sub GetMailboxList (objSession As MAPI.Session, aMailbox() As String, aServer() As String)
Dim oGAL As AddressList
Dim oAdrEntries As AddressEntries
Dim oAdrEntry As AddressEntry
Dim iCnt As Integer
Dim strRawServerInfo As String
Dim iStartServerName As Integer
Dim iEndServerName As Integer
Dim strHomeServer As String
Dim strMailboxName As String
Dim strFindServer As String
strFindServer = "/cn=Configuration/cn=Servers/cn="
Set oGAL = objSession.AddressLists("Global Address List")
Set oAdrEntries = oGAL.AddressEntries
iCnt = 0
For Each oAdrEntry In oAdrEntries
If oAdrEntry.DisplayType = CdoUser Then
strRawServerInfo = oAdrEntry.Fields(CdoPR_EMS_AB_HOME_MTA)
iStartServerName = InStr(1, strRawServerInfo, strFindServer) + Len(strFindServer)
iEndServerName = InStr(iStartServerName, strRawServerInfo, "/")
strHomeServer = Mid(StrRawServerInfo, iStartServerName, iEndServerName - iStartServerName)
strMailboxName = oAdrEntry.Fields(CdoPR_ACCOUNT).Value
Debug.Print "Server: " & strHomeServer
Debug.Print "Mailbox: " & strMailboxName
iCnt = iCnt + 1
ReDim Preserve aMailbox(iCnt)
ReDim Preserve aServer(iCnt)
aServer(iCnt) = strHomeServer
aMailbox(iCnt) = strMailboxName
End If
Next
Set oAdrEntry = Nothing
Set oAdrEntries = Nothing
Set oGAL = Nothing
End Sub
Private Sub Main()
Dim oSession As MAPI.Session
ReDim aMailboxList(1) As String
ReDim aserverlist(1) As String
Dim iBigLoop As Integer
Dim sServerName As String
Dim sProfileInfo As String
'TO DO: Change "ServerName" to the name of your Exchange Server
sServerName = "ServerName"
'TO DO: Change "MailboxName" to the name of a mailbox on the+
' server specified above
sProfileInfo = sServerName & vbLf & "MailboxName"
Set oSession = CreateObject("MAPI.Session")
oSession.Logon profileinfo:=sProfileInfo
GetMailboxList oSession, aMailboxList, aserverlist
oSession.Logoff
For iBigLoop = 1 To UBound(aMailboxList)
sProfileInfo = aserverlist(iBigLoop) & vbLf & aMailboxList(iBigLoop)
oSession.Logon profileinfo:=sProfileInfo
Debug.Print oSession.CurrentUser.Name
' Do any processing here for each mailbox
oSession.Logoff
Next iBigLoop
Set oSession = Nothing
End Sub