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

131	Obtener las BD en un servidor SQL	Como obtener los nombres de las bases de datos en un servidor SQL
132	Poner opcion de boton derecho	Como poner en boton derecho (fuera de VB) un Shortcut
133	Cambiar color de un RichtextBox desde codigo	Cambiar color de un richtextobox desde codigo en VB
134	Crear un DSN desde VB	Como crear un DSN desde Visual Basic
135	Obtener los primeros 'n' registros de un select	Como puede obtener los primeros 'n' registros en una sentencia SQL.
136	Flecha derecha/zquierda en un textbox	Capturar las teclas de desplazamiento en un textbox
137	Cerrar programas desde VB	Como cerrar programas desde VB
138	Nombre de dominio	Como obtener el nombre de dominio en NT
139	Comandos de una a otra ventana	Como ejecutar comandos de otra ventana
140	Busqueda en un combo	Como realizar una busqueda en un Combobox

OBTENER LAS BD DE UN SERVIDOR -SQL-
Private Sub LoadDatabases()
Dim RDOConn As RDO.rdoConnection
Dim rs As rdoResultset
Dim sql As String
On Error GoTo LoadDatabasesError
Set RDOConn = New rdoConnection
With RDOConn
.Connect = "SERVER=" & ServerName & ";UID=" & UserID & ";PWD=" & Password & ";DRIVER={SQL Server};DSN=;"
.LoginTimeout = 5
.EstablishConnection
End With
cboDatabases.Clear
sql = "select * "
sql = sql & "from master.dbo.sysdatabases"
Set rs = RDOConn.OpenResultset(sql)
If rs.EOF Then
cboDatabases.Enabled = False
Else
Do While Not rs.EOF
cboDatabases.AddItem rs.rdoColumns(0).Value
rs.MoveNext
Loop
End If
End Select
If Not rs Is Nothing Then Set rs = Nothing
If Not RDOConn Is Nothing Then Set RDOConn = Nothing
Exit Sub
LoadDatabasesError:
MsgBox Err.Number & ":" & Err.Description, , "Load Databases"
Exit Sub
End Sub

PONER UNA OPCION AL BOTON DERECHO (ESTILO ADD TO ZIP)

Hace algunos días se trato este tema en la lista.... y se soluciono, pero encontré algo que les puede servir a todos...
Se trata de personalizar los menús contextuales cuando hacemos click con el botón derecho sobre algún archivo, como lo hace winzip cuando nos da la opción de "Add to Zip". Lo cual es muy útil para agrégale a nuestra aplicación que funciona con parámetros. Para ello debemos editar la clave del registro (Regedit.exe)
<HKEY_CLASSES_ROOT\FOLDER\SHELL>.
Donde Agregamos una nueva clave con el nombre que queremos que muestre el menú contextual. Por ejemplo "Comprimir".
Luego dentro de la Clave creada agregamos otra clave "Command" y dentro de esta editamos el valor predeterminado asignándole la ruta de nuestra aplicación y los parámetros que necesita. Por ejemplo "C:\COMPRESOR\COMPRIME.EXE ,/idlist,%I,%L".
Luego desde visual basic tomamos los parámetros y listo...

CAMBIAR COLOR DE UN RICHTEXT POR CODIGO
sRTTextBlue = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fnil\fcharset0 Times New Roman;}}" & "{\colortbl ;\red0\green0\blue255;}" & "\uc1\pard\ulnone\f0\fs20 Show \cf1\b " &CurrentCategory & "\cf0\b0 My Name Is \cf1\b " & StartDate & "\cf0 \b0 To:\cf1\b " & Mike & "\cf0\b0\par" & "}"
rtbBox.TextRTF = sRTTextBlue

CREAR UN DSN DESDE VB
You can easily create a System DSN by adding a few lines to the ODBC.INI file (usually found in your windows directory).
For example I created a System DSN called "Jerry" so the following lines were added to the INI file:
[ODBC 32 bit Data Sources]
MS Access 97 Database=Microsoft Access Driver (*.mdb) (32 bit)
dBASE Files=Microsoft dBase Driver (*.dbf) (32 bit)
Excel Files=Microsoft Excel Driver (*.xls) (32 bit)
FoxPro Files=Microsoft FoxPro Driver (*.dbf) (32 bit)
Text Files=Microsoft Text Driver (*.txt; *.csv) (32 bit)
Visual FoxPro Tables=Microsoft Visual FoxPro Driver (32 bit)
Visual FoxPro Database=Microsoft Visual FoxPro Driver (32 bit)
Jerry=Microsoft Access Driver (*.mdb) (32 bit) ''''This line was added
[Jerry]
Driver32=C:\WINDOWS\SYSTEM\odbcjt32.dll ''This line was also added
The file odbcjt32.dll is used for Ms Access DSN so you will have to figure what DLL to use if you are using a different Source(i.e.vfpodbc.dll for Visual Foxpro Databases) You can search the archives for the code to modify an INI file.
You also need to add the followoing to the Registry for the method below to work
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\odbc.ini\Jerry]
"Driver"="C:\\WINDOWS\\SYSTEM\\odbcjt32.dll"
"DBQ"="c:\\My Documents\\db3.mdb"
"DriverId"=dword:00000019
"FIL"="MS Access;"
"SafeTransactions"=dword:00000000
"SystemDB"="O:\\CIS\\WORKDIR\\alldept.mda"
"UID"=""
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\odbc.ini\Jerry\Engines]
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\odbc.ini\Jerry\Engines\Jet]
"ImplicitCommitSync"="Yes"
"MaxBufferSize"=dword:00000200
"PageTimeout"=dword:00000005
"Threads"=dword:00000003
"UserCommitSync"="Yes"

OBTENER LOS 'N' PRIMEROS ELEMENTOS DE UN SELECT
En Ado y RDO existe una funcion llamada GetRows ([nRows]) (Vea ejemplo en el DSNL)

FLECHA DERECHA/IZQUIERDA EN UN TEXTBOX
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
' KeyCode 37 y 39
' Shift 0
End Sub

CERRAR UN PROGRAMA DESDE VB
Dim WindowHandle As Long
Dim PostReturnValue As Long
' Returns handle of any top-level window belonging to the "OpusApp" class
WindowHandle = FindWindow("OpusApp", vbNullString)
Do While WindowHandle <> 0
PostReturnValue = SendMessage(WindowHandle, WM_CLOSE, 0, 0&)
WindowHandle = FindWindow("OpusApp", vbNullString)
Loop

NOMBRE DE DOMINIO

Private Const NERR_Success As Long = 0&
Option Explicit
Private Const NullByte As Byte = 0
Type WKSTA_INFO_101_I
wki101_platform_id As Long
wki101_computername As Long
wki101_langroup As Long
wki101_ver_major As Long
wki101_ver_minor As Long
wki101_lanroot As Long
End Type
Type WKSTA_INFO_101_S
wki101_platform_id As Long
wki101_computername As String
wki101_langroup As String
wki101_ver_major As Long
wki101_ver_minor As Long
wki101_lanroot As String
End Type
Private Declare Function NetGetDCName Lib "netapi32" (servername As Byte, domainname As Byte, bufptr As Long) As Long
Private Declare Function NetWkstaGetInfo Lib "netapi32" (servername As Byte, ByVal level As Long, bufptr As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal Buffer As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (sDest As Byte, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Sub Main()
Dim nBuffer As Long
Dim nBufSize As Long
Dim nErr As Long
Dim nPtr As Long
Dim sServer As String
Dim cServer() As Byte
Dim wsiInfoLongs As WKSTA_INFO_101_I
Dim wsiInfoString As WKSTA_INFO_101_S
nErr = NetGetDCName(NullByte, NullByte, nBuffer)
If nErr <> NERR_SUCCESS Then
MsgBox "Error " & nErr & " calling NetGetDCName - See WINERROR.H for definition"
Exit Sub
End If
nBufSize = lstrlen(nBuffer)
ReDim cServer(1 To (nBufSize + 2) * 2)
lstrcpy cServer(1), nBuffer
NetApiBufferFree nBuffer
sServer = cServer
nErr = NetWkstaGetInfo(cServer(1), 101, nBuffer)
If nErr <> NERR_SUCCESS Then
MsgBox "Error " & nErr & " calling NetWkstaGetInfo - See WINERROR.H for definition"
Exit Sub
End If
CopyMemory wsiInfoLongs, nBuffer, LenB(wsiInfoLongs)
wsiInfoString.wki101_platform_id = wsiInfoLongs.wki101_platform_id
wsiInfoString.wki101_computername = GetString(wsiInfoLongs.wki101_computername)
.wki101_langroup = GetString(wsiInfoLongs.wki101_langroup)
wsiInfoString.wki101_ver_major = wsiInfoLongs.wki101_ver_major
wsiInfoString.wki101_ver_minor = wsiInfoLongs.wki101_ver_minor
wsiInfoString.wki101_lanroot = GetString(wsiInfoLongs.wki101_lanroot)
NetApiBufferFree nBuffer
MsgBox "Primary domain controller: " & sServer & vbCrLf & "Domain name: " & wsiInfoString.wki101_langroup
End Sub
Private Function GetString(ByVal nPointer As Long) As String
Dim cBuffer() As Byte
sBuffer As String
Dim nLen As Long
nLen = lstrlen(nPointer)
ReDim cBuffer(1 To (nLen + 2) * 2)
lstrcpy cBuffer(1), nPointer
sBuffer = cBuffer
GetString = sBuffer
End Function

COMANDOS DE UNA A OTRA VENTANA
'Here's a quick and dirty example (the code's kinda messy since I just threwit together):In your form:
Private m_colControlWrappers As Collection
Private Sub Command1_Click()
Dim MyCtrl As CommandButton
Dim oCommandButtonEventHandler As CommandButtonEventHandler
Set MyCtrl = Controls.Add("VB.CommandButton", "cmdTest", Form1)
With MyCtrl
.Caption = "Test Button"
.Top = 50
.Left = 50
.Visible = True
End With
Set oCommandButtonEventHandler = New CommandButtonEventHandler
Set oCommandButtonEventHandler.WrappedControl = MyCtrl
m_colControlWrappers.Add oCommandButtonEventHandler
Set oCommandButtonEventHandler = Nothing
End Sub
Private Sub Form_Load()
Set m_colControlWrappers = New Collection
End Sub
In a class module called CommandButtonEventHandler:
Private WithEvents m_ctlCommandButton As CommandButton
Public Property Set WrappedControl(ctl As CommandButton)
Set m_ctlCommandButton = ctl
End Property
Private Sub m_ctlCommandButton_Click()
MsgBox m_ctlCommandButton.Name & " has been clicked."
End Sub

BUSQUEDA EN COMBO
Hola a todos Esto soluciona lo de las busquedas en los combos y no importa que tantos registros tenga primero declaren esto en algun modulo
' para la autobusqueda en los combos
Public Const CB_ERR = -1
Public Const CB_FINDSTRING = &H14C
Public Const CB_FINDSTRINGEXACT = &H158
Public Const CB_GETITEMDATA = &H150
Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
luego en el modulo hagan esta subrutina:
Public Sub AutoMatch(cbo As ComboBox, KeyAscii As Integer)
Dim sBuffer As String
Dim lRetVal As Long
sBuffer = Left(cbo.Text, cbo.SelStart) & Chr(KeyAscii)
lRetVal = SendMessage((cbo.hWnd), CB_FINDSTRING, -1, ByVal sBuffer)
If lRetVal <> CB_ERR Then
cbo.ListIndex = lRetVal
cbo.Text = cbo.List(lRetVal)
cbo.SelStart = Len(sBuffer)
cbo.SelLength = Len(cbo.Text)
KeyAscii = 0
End If
End Sub
por ultimo en el combo con propiedad Style = 0 para que permita escribir, escriben en el evento keypress lo siguiente:
Private Sub Combo2_KeyPress(KeyAscii As Integer)
AutoMatch Combo2, KeyAscii
End Sub